Index: trunk/omega/share/doc/Makefile.am =================================================================== --- trunk/omega/share/doc/Makefile.am (revision 8919) +++ trunk/omega/share/doc/Makefile.am (revision 8920) @@ -1,270 +1,270 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2024 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. # ######################################################################## ######################################################################## ### TODO: fix weaving of lexers and parsers ######################################################################## include $(top_srcdir)/omega/src/Makefile.sources VPATH = $(srcdir):$(top_builddir)/omega/src:$(srcdir):$(top_srcdir)/omega/src PICTURES_PDF = \ modules.pdf \ omega-paper-1-pics-1.pdf \ omega-paper-1-pics-2.pdf \ omega-paper-1-pics-3.pdf \ omega-paper-1-pics-4.pdf \ omega-paper-1-pics-5.pdf \ omega-paper-1-pics-6.pdf \ omega-paper-1-pics-7.pdf \ omega-paper-1-pics-8.pdf \ omega-paper-1-pics-9.pdf \ omega-paper-1-pics-10.pdf \ bhabha.pdf bhabha0.pdf \ epemudbardubar.pdf epemudbardubar0.pdf \ epemudbarmunumubar.pdf epemudbarmunumubar0.pdf \ sign_ex.pdf fusion_rules.pdf mom_choice.pdf \ mom_flow.pdf LATEX_STYLES = \ flex.cls thophys.sty thohacks.sty \ noweb.sty ocamlweb.sty ytableau.sty \ feynmp.sty feynmp.mp emp.sty TEX_FLAGS = "$(top_srcdir)/omega/share/doc:$$TEXINPUTS" MP_FLAGS = "$(top_srcdir)/omega/share/doc:$$MPINPUTS" if DISTRIBUTION PDFS = omega.pdf omega-paper-1.pdf omega-paper-2.pdf else PDFS = endif ### Files needed to be installed with the O'Mega distribution modelsdir = $(pkgdatadir)/doc if CONTEXT_AVAILABLE dist_doc_DATA = $(PDFS) else dist_doc_DATA = endif EXTRA_DIST = $(PICTURES_PDF) $(LATEX_STYLES) if NOWEB_AVAILABLE pdf-local: $(PDFS) else pdf-local: endif SUFFIXES = .mly .mll .ml .implementation .mli .interface .nw .tex .pdf MPOST_LATEX = TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) MPINPUTS=$(MP_FLAGS) $(MPOST) if DISTRIBUTION if CONTEXT_AVAILABLE if PDFLATEX_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi if MPOST_AVAILABLE @if test -r $*pics.mp; then \ if $(AM_V_P); then MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics; else \ echo " METAPOST " $*pics.mp; MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics > /dev/null; fi; \ fi @if test -r $*.mp; then \ if $(AM_V_P); then $(MPOST_LATEX) $*; else \ echo " METAPOST " $*.mp; $(MPOST_LATEX) $* >/dev/null; fi; \ fi endif MPOST_AVAILABLE $(AM_V_at)echo " PDFLATEX skipping -bibtex $*" @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ if grep -s 'Rerun to get cross-references right.' $*.log; then \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ fi; else \ if grep -s 'Rerun to get cross-references right.' $*.log >/dev/null; then \ echo " PDFLATEX " $< "(for cross-references)"; \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ fi; \ fi endif PDFLATEX_AVAILABLE endif CONTEXT_AVAILABLE endif DISTRIBUTION if DISTRIBUTION if CONTEXT_AVAILABLE if PDFLATEX_AVAILABLE omega-paper-1.pdf: modules.pdf \ omega-paper-1-pics-1.pdf \ omega-paper-1-pics-2.pdf \ omega-paper-1-pics-3.pdf \ omega-paper-1-pics-4.pdf \ omega-paper-1-pics-5.pdf \ omega-paper-1-pics-6.pdf \ omega-paper-1-pics-7.pdf \ omega-paper-1-pics-8.pdf \ omega-paper-1-pics-9.pdf \ omega-paper-1-pics-10.pdf # Dependencies and avoid mpost race condition omega-paper-2.pdf: \ omega-paper-1.pdf sign_ex.pdf fusion_rules.pdf \ mom_choice.pdf mom_flow.pdf endif PDFLATEX_AVAILABLE endif CONTEXT_AVAILABLE endif DISTRIBUTION OMEGA_CORE_INTERFACES = $(OMEGA_CORE_MLI:.mli=.interface) -OMEGA_CORE_IMPLEMENTATIONS = $(OMEGA_CORE_ML:.ml=.implementation) +OMEGA_CORE_IMPLEMENTATIONS = $(OMEGA_INTERFACES_ML:.ml=.implementation) $(OMEGA_CORE_ML:.ml=.implementation) OMEGA_MODELLIB_INTERFACES = $(OMEGA_MODELLIB_MLI:.mli=.interface) OMEGA_MODELLIB_IMPLEMENTATIONS = $(OMEGA_MODELLIB_ML:.ml=.implementation) OMEGA_TARGETLIB_INTERFACES = $(OMEGA_TARGETLIB_MLI:.mli=.interface) OMEGA_TARGETLIB_IMPLEMENTATIONS = $(OMEGA_TARGETLIB_ML:.ml=.implementation) OMEGA_APPLICATIONS_IMPLEMENTATIONS = $(OMEGA_APPLICATIONS_ML:.ml=.implementation) OMEGA_INTERFACES = \ $(OMEGA_CORE_INTERFACES) \ $(OMEGA_MODELLIB_INTERFACES) \ $(OMEGA_TARGETLIB_INTERFACES) OMEGA_IMPLEMENTATIONS = \ $(OMEGA_CORE_IMPLEMENTATIONS) \ $(OMEGA_MODELLIB_IMPLEMENTATIONS) \ $(OMEGA_TARGETLIB_IMPLEMENTATIONS) \ $(OMEGA_APPLICATIONS_IMPLEMENTATIONS) if !NOWEB_AVAILABLE omega.pdf: else NOWEB_AVAILABLE omega.pdf: \ $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) omegalib.tex index.tex \ $(PICTURES_PDF) .nw.tex: @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -delay $< > $@ if DISTRIBUTION if OCAMLWEB_AVAILABLE .mll.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mly.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .ml.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mli.interface: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ index.tex: $(OMEGA_CAML) @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb $^ | \ sed -n '/\\ocwbeginindex{}/,/\\ocwendindex{}/p' >$@ endif OCAMLWEB_AVAILABLE endif DISTRIBUTION endif NOWEB_AVAILABLE ######################################################################## ## Cleanup tasks mostlyclean-latex: -rm -f *.log *.aux *.toc *.mpx *.idx *.out omega*.mp \ omega*pics.t[0-9]* omega*pics.[0-9]* $(PICTURES_PDF) \ omegalib.tex clean-latex: maintainer-clean-latex: -rm $(PDFS) if NOWEB_AVAILABLE mostlyclean-omega: -test "$(srcdir)" != "." && rm -f $(PDFS) maintainer-clean-omega: else mostlyclean-omega: maintainer-clean-omega: endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-omega maintainer-clean-omega if OCAMLWEB_AVAILABLE mostlyclean-caml: -rm -f $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) index.tex else mostlyclean-caml: endif clean-caml: if OCAMLWEB_AVAILABLE maintainer-clean-caml: -rm -f $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) index.tex else maintainer-clean-caml: endif .PHONY: mostlyclean-caml clean-caml maintainer-clean-caml ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-caml mostlyclean-omega clean-local: clean-latex clean-caml maintainer-clean-local: maintainer-clean-latex maintainer-clean-caml \ maintainer-clean-omega maintainer-clean-backup if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 omega.pdf $(DESTDIR)$(datarootdir)/doc/omega -$(INSTALL) -m 644 omega-paper-1.pdf $(DESTDIR)$(datarootdir)/doc/omega -$(INSTALL) -m 644 omega-paper-2.pdf $(DESTDIR)$(datarootdir)/doc/omega uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega-paper-1.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega-paper-2.pdf endif ######################################################################## ## The End. ######################################################################## Index: trunk/omega/tests/UFO/Exotic_Color/vertices.py =================================================================== --- trunk/omega/tests/UFO/Exotic_Color/vertices.py (revision 8919) +++ trunk/omega/tests/UFO/Exotic_Color/vertices.py (revision 8920) @@ -1,61 +1,61 @@ # This is not FeynRules output coresponding to a realistic model. # It's a handcrafted UFO model for testing exotic color representations. # Everything ignored by O'Mega has been stripped. # Don't expect Madgraph to be able to use it. ######################################################################## V_1 = Vertex(name = 'V_1', particles = [ P.g, P.g, P.g ], color = [ 'f(1,2,3)' ], lorentz = [ L.VVV1 ], couplings = {(0,0):C.GC_1}) V_2 = Vertex(name = 'V_2', particles = [ P.g, P.g, P.g, P.g ], color = [ 'f(-1,1,2)*f(3,4,-1)', 'f(-1,1,3)*f(2,4,-1)', 'f(-1,1,4)*f(2,3,-1)' ], lorentz = [ L.VVVV1, L.VVVV3, L.VVVV4 ], couplings = {(1,1):C.GC_2,(0,0):C.GC_2,(2,2):C.GC_2}) V_3 = Vertex(name = 'V_3', particles = [ P.f3__tilde__, P.f3, P.g ], color = [ 'T(3,2,1)' ], lorentz = [ L.FFV1 ], couplings = {(0,0):C.GC_1}) V_4 = Vertex(name = 'V_4', particles = [ P.s3, P.s3, P.s6__tilde__ ], - color = [ 'K6(3,2,1)' ], + color = [ 'K6Bar(3,2,1)' ], lorentz = [ L.SSS1 ], couplings = {(0,0):C.GC_1}) V_5 = Vertex(name = 'V_5', particles = [ P.s3__tilde__, P.s3__tilde__, P.s6 ], - color = [ 'K6Bar(3,2,1)' ], + color = [ 'K6(3,2,1)' ], lorentz = [ L.SSS1 ], couplings = {(0,0):C.GC_1}) V_6 = Vertex(name = 'V_6', particles = [ P.s, P.s, P.ss__tilde__ ], color = [ '1' ], lorentz = [ L.SSS1 ], couplings = {(0,0):C.GC_1}) V_7 = Vertex(name = 'V_7', particles = [ P.s__tilde__, P.s__tilde__, P.ss ], color = [ '1' ], lorentz = [ L.SSS1 ], couplings = {(0,0):C.GC_1}) V_8 = Vertex(name = 'V_8', particles = [ P.g, P.s3__tilde__, P.s3 ], color = [ 'T(1,3,2)' ], lorentz = [ L.VSS1 ], couplings = {(0,0):C.GC_1}) V_9 = Vertex(name = 'V_9', particles = [ P.g, P.s6__tilde__, P.s6 ], color = [ 'T6(1,3,2)' ], lorentz = [ L.VSS1 ], couplings = {(0,0):C.GC_1}) Index: trunk/omega/tests/Makefile.am =================================================================== --- trunk/omega/tests/Makefile.am (revision 8919) +++ trunk/omega/tests/Makefile.am (revision 8920) @@ -1,1113 +1,1120 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2024 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## SUBDIRS = UFO DIST_SUBDIRS = UFO # OMEGA_SPLIT = -target:single_function OMEGA_SPLIT = -target:split_function 10 # OMEGA_SPLIT = -target:split_module 10 # OMEGA_SPLIT = -target:split_file 10 OMEGA_QED = $(top_builddir)/omega/bin/omega_QED$(OCAML_NATIVE_EXT) OMEGA_QED_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QED OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD$(OCAML_NATIVE_EXT) OMEGA_QCD_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QCD OMEGA_SYM = $(top_builddir)/omega/bin/omega_SYM$(OCAML_NATIVE_EXT) OMEGA_SYM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SYM OMEGA_SM = $(top_builddir)/omega/bin/omega_SM$(OCAML_NATIVE_EXT) OMEGA_SM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM OMEGA_SM_CKM = $(top_builddir)/omega/bin/omega_SM_CKM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs = $(top_builddir)/omega/bin/omega_SM_Higgs$(OCAML_NATIVE_EXT) OMEGA_THDM = $(top_builddir)/omega/bin/omega_THDM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM = $(top_builddir)/omega/bin/omega_THDM_CKM$(OCAML_NATIVE_EXT) OMEGA_HSExt = $(top_builddir)/omega/bin/omega_HSExt$(OCAML_NATIVE_EXT) OMEGA_Zprime = $(top_builddir)/omega/bin/omega_Zprime$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom = $(top_builddir)/omega/bin/omega_SM_top_anom$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM_top_anom OMEGA_UFO = $(top_builddir)/omega/bin/omega_UFO$(OCAML_NATIVE_EXT) OMEGA_UFO_MAJORANA = \ $(top_builddir)/omega/bin/omega_UFO_Majorana$(OCAML_NATIVE_EXT) OMEGA_UFO_OPTS = -target:parameter_module parameters_UFO OMEGA_UFO_PATH = $(top_srcdir)/omega/tests/UFO OMEGA_XXX = $(top_builddir)/omega/bin/omega_%%%$(OCAML_NATIVE_EXT) OMEGA_XXX_OPTS = -target:parameter_module parameters_%%% OMEGA_UFO_XXX_OPTS = \ "-model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" OMEGA_XXX_MAJORANA = \ $(top_builddir)/omega/bin/omega_%%%_Majorana$(OCAML_NATIVE_EXT) OMEGA_XXX_MAJORANA_LEGACY = \ $(top_builddir)/omega/bin/omega_%%%_Majorana_legacy$(OCAML_NATIVE_EXT) OMEGA_QED_VM = $(top_builddir)/omega/bin/omega_QED_VM$(OCAML_NATIVE_EXT) OMEGA_QCD_VM = $(top_builddir)/omega/bin/omega_QCD_VM$(OCAML_NATIVE_EXT) OMEGA_SM_VM = $(top_builddir)/omega/bin/omega_SM_VM$(OCAML_NATIVE_EXT) OMEGA_SM_CKM_VM = $(top_builddir)/omega/bin/omega_SM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_VM = $(top_builddir)/omega/bin/omega_THDM_VM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM_VM = $(top_builddir)/omega/bin/omega_THDM_CKM_VM$(OCAML_NATIVE_EXT) OMEGA_HSExt_VM = $(top_builddir)/omega/bin/omega_HSExt_VM$(OCAML_NATIVE_EXT) OMEGA_Zprime_VM = $(top_builddir)/omega/bin/omega_Zprime_VM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs_VM = $(top_builddir)/omega/bin/omega_SM_Higgs_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM = $(top_builddir)/omega/bin/omega_%%%_VM$(OCAML_NATIVE_EXT) OMEGA_XXX_VM_PARAMS_OPTS = -params -target:parameter_module_external \ parameters_%%% -target:wrapper_module %% -target:bytecode_file % AM_FCFLAGS = -I$(top_builddir)/omega/src AM_LDFLAGS = ######################################################################## ## Default Fortran compiler options ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) AM_TESTS_ENVIRONMENT = \ export OMP_NUM_THREADS=1; endif ######################################################################## TESTS = XFAIL_TESTS = EXTRA_PROGRAMS = EXTRA_DIST = ######################################################################## include $(top_srcdir)/omega/src/Makefile.ocaml if OCAML_AVAILABLE OCAMLFLAGS += -I $(top_builddir)/omega/src OMEGA_CORE = $(top_builddir)/omega/src/omega_core.cmxa OMEGA_MODELS = $(top_builddir)/omega/src/omega_models.cmxa TESTS += omega_unit EXTRA_PROGRAMS += omega_unit omega_unit_SOURCES = omega_unit.ml omega_unit: $(OMEGA_CORE) omega_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o omega_unit \ unix.cmxa $(OMEGA_CORE) omega_unit.cmx omega_unit.cmx: omega_unit.ml omega_unit.cmx: $(OMEGA_CORE) endif ######################################################################## KINDS = $(top_builddir)/omega/src/kinds.lo -TESTS += test_omega95 test_omega95_bispinors -EXTRA_PROGRAMS += test_omega95 test_omega95_bispinors +TESTS += test_omega95 test_omega95_bispinors test_omega_api +EXTRA_PROGRAMS += test_omega95 test_omega95_bispinors test_omega_api 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 +test_omega_api.o: $(KINDS) $(top_builddir)/omega/src/libomega_core.la + +test_omega_api_SOURCES = test_omega_api.f90 +test_omega_api_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la 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) $@ +test_omega_api.f90: $(top_srcdir)/omega/src/omegalib.nw + $(NOTANGLE) -R[[$@]] $< | $(CPIF) $@ + endif NOWEB_AVAILABLE ######################################################################## if OCAML_AVAILABLE TESTS += test_qed_eemm EXTRA_PROGRAMS += test_qed_eemm test_qed_eemm_SOURCES = test_qed_eemm.f90 parameters_QED.f90 nodist_test_qed_eemm_SOURCES = amplitude_qed_eemm.f90 test_qed_eemm_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_qed_eemm.f90: $(OMEGA_QED) Makefile $(OMEGA_QED) $(OMEGA_QED_OPTS) -target:module amplitude_qed_eemm \ -scatter "e+ e- -> m+ m-" > $@ test_qed_eemm.o: amplitude_qed_eemm.o test_qed_eemm.o: parameters_QED.o amplitude_qed_eemm.o: parameters_QED.o endif ######################################################################## EXTENDED_COLOR_TESTS = \ $(srcdir)/fc_s.ects \ $(srcdir)/fc_a.ects $(srcdir)/cf_a.ects $(srcdir)/fa_f.ects \ $(srcdir)/ca_c.ects $(srcdir)/af_f.ects $(srcdir)/ac_c.ects \ $(srcdir)/aa_a.ects \ $(srcdir)/fc_fc.ects \ $(srcdir)/aa_s.ects $(srcdir)/as_a.ects $(srcdir)/sa_a.ects TESTS += ects EXTRA_PROGRAMS += ects EXTRA_DIST += ects_driver.sh $(EXTENDED_COLOR_TESTS) # Explicitly state dependence on model files ects.f90: $(OMEGA_QCD) $(OMEGA_SYM) $(OMEGA_SM) ects.f90: ects_driver.sh $(EXTENDED_COLOR_TESTS) @if $(AM_V_P); then :; else echo " ECTS_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ects_driver.sh \ $(OMEGA_XXX) $(EXTENDED_COLOR_TESTS) > $@ ects_SOURCES = color_test_lib.f90 \ parameters_SM.f90 parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 nodist_ects_SOURCES = ects.f90 ects_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ######################################################################## TESTS += exotic_color -# if there is some debugging output ... +# Textual comparisons will fail while we add new features ... # XFAIL_TESTS += exotic_color EXOTIC_COLOR_TESTS = \ sextet-exchange.exotic_color exotic_color: exotic_color_driver.sh Makefile $(OMEGA_UFO) $(SED) -e 's|%%EXOTIC_COLOR_TESTS%%|$(EXOTIC_COLOR_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%OMEGA_UFO%%|$(OMEGA_UFO)|' \ -e 's|%%OMEGA_UFO_MAJORANA%%|$(OMEGA_UFO_MAJORANA)|' \ -e 's|%%EXOTIC_COLOR_UFO_DIR%%|$(OMEGA_UFO_PATH)/Exotic_Color|' $< >$@ chmod +x $@ EXTRA_DIST += exotic_color_driver.sh $(EXOTIC_COLOR_TESTS) ######################################################################## TESTS += cascade # if there is some debugging output ... # XFAIL_TESTS += cascade CASCADE_TESTS = \ bhabha-s-channel.cascade bhabha-t-channel.cascade bhabha-full.cascade \ ww-onlycc.cascade ww-notgc.cascade \ jjj-notgc.cascade \ vbf-noh.cascade cascade: cascade_driver.sh Makefile $(SED) -e 's|%%cascade_tests%%|$(CASCADE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += cascade_driver.sh $(CASCADE_TESTS) ######################################################################## TESTS += phase_space PHASE_SPACE_TESTS = eeee.phs qqggg.phs phase_space: phase_space_driver.sh Makefile $(SED) -e 's|%%phase_space_tests%%|$(PHASE_SPACE_TESTS)|' \ -e 's|%%srcdir%%|$(srcdir)|' \ -e 's|%%SED%%|$(SED)|' \ -e 's|%%top_builddir%%|$(top_builddir)|' \ -e 's|%%OCAML_NATIVE_EXT%%|$(OCAML_NATIVE_EXT)|' $< >$@ chmod +x $@ EXTRA_DIST += phase_space_driver.sh $(PHASE_SPACE_TESTS) ######################################################################## TESTS += fermi # XFAIL_TESTS += fermi EXTRA_PROGRAMS += fermi EXTRA_DIST += fermi_driver.sh EXTRA_DIST += fermi.list FERMI_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_MSSM.f90 parameters_SM_top_anom.f90 FERMI_SUPPORT_O = $(FERMI_SUPPORT_F90:.f90=.o) fermi_lib.o: $(FERMI_SUPPORT_O) FERMI_LIB_F90 = fermi_lib.f90 $(FERMI_SUPPORT_F90) FERMI_LIB_O = $(FERMI_LIB_F90:.f90=.o) run_fermi: fermi ./fermi fermi.f90: fermi_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) fermi.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) fermi.f90: fermi.list @if $(AM_V_P); then :; else echo " FERMI_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ fermi_SOURCES = $(FERMI_LIB_F90) nodist_fermi_SOURCES = fermi.f90 fermi_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi.o: $(FERMI_LIB_O) ######################################################################## TESTS += ward EXTRA_PROGRAMS += ward EXTRA_DIST += ward_driver.sh EXTRA_DIST += ward_identities.list WARD_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \ parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \ parameters_SM.f90 parameters_SM_top_anom.f90 WARD_SUPPORT_O = $(WARD_SUPPORT_F90:.f90=.o) ward_lib.o: $(WARD_SUPPORT_O) WARD_LIB_F90 = ward_lib.f90 $(WARD_SUPPORT_F90) WARD_LIB_O = $(WARD_LIB_F90:.f90=.o) run_ward: ward ./ward ward.f90: ward_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM) ward.f90: $(OMEGA_SM) $(OMEGA_SM_top_anom) ward.f90: ward_identities.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_SOURCES = $(WARD_LIB_F90) nodist_ward_SOURCES = ward.f90 ward_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_long EXTRA_DIST += ward_identities_long.list run_ward_long: ward_long ./ward_long ward_long.f90: ward_driver.sh ward_long.f90: ward_identities_long.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_long_SOURCES = $(WARD_LIB_F90) nodist_ward_long_SOURCES = ward_long.f90 ward_long_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la # ward_long.o: ward_long.f90 # $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_long.o: $(WARD_LIB_O) ######################################################################## EXTRA_PROGRAMS += ward_fail EXTRA_DIST += ward_identities_fail.list run_ward_fail: ward_fail ./ward_fail ward_fail.f90: ward_driver.sh ward_fail.f90: ward_identities_fail.list @if $(AM_V_P); then :; else echo " WARD_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver.sh \ $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@ ward_fail_SOURCES = $(WARD_LIB_F90) nodist_ward_fail_SOURCES = ward_fail.f90 ward_fail_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_fail.o: ward_fail.f90 $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $< ward_fail.o: $(WARD_LIB_O) ######################################################################## TESTS += compare_split_function compare_split_module EXTRA_PROGRAMS += compare_split_function compare_split_module EXTRA_DIST += compare_driver.sh EXTRA_DIST += comparisons.list COMPARE_SUPPORT_F90 = $(WARD_SUPPORT_F90) COMPARE_SUPPORT_O = $(WARD_SUPPORT_O) compare_lib.o: $(COMPARE_SUPPORT_O) COMPARE_LIB_F90 = compare_lib.f90 $(COMPARE_SUPPORT_F90) COMPARE_LIB_O = $(COMPARE_LIB_F90:.f90=.o) run_compare: compare_split_function compare_split_module ./compare_split_function ./compare_split_module compare_split_function.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SF \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_function 10" < $< > $@ compare_split_module.f90: comparisons.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver.sh SM \ "$(OMEGA_XXX) -target:single_function" \ "$(OMEGA_XXX) -target:split_module 10" < $< > $@ compare_split_function_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_function_SOURCES = compare_split_function.f90 compare_split_function_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_module_SOURCES = $(COMPARE_LIB_F90) nodist_compare_split_module_SOURCES = compare_split_module.f90 compare_split_module_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_split_function.o compare_split_module.o: $(COMPARE_LIB_O) ######################################################################## TESTS += compare_orders EXTRA_PROGRAMS += compare_orders EXTRA_DIST += compare_orders_driver.sh EXTRA_DIST += comparisons_orders.list COMPARE_ORDERS_SUPPORT_F90 = $(WARD_SUPPORT_F90) COMPARE_ORDERS_SUPPORT_O = $(WARD_SUPPORT_O) run_compare_orders: compare_orders ./compare_orders compare_orders.f90: comparisons_orders.list compare_orders_driver.sh @if $(AM_V_P); then :; else echo " COMPARE_ORDERS_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_orders_driver.sh "$(OMEGA_SM)" < $< > $@ compare_orders_SOURCES = $(COMPARE_LIB_F90) nodist_compare_orders_SOURCES = compare_orders.f90 compare_orders_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_orders.o: $(COMPARE_LIB_O) ######################################################################## EXTRA_DIST += compare_driver_majorana.sh compare_driver_majorana_UFO.sh EXTRA_DIST += comparisons_majorana.list comparisons_majorana_legacy.list \ comparisons_majorana_UFO.list if OCAML_AVAILABLE TESTS += compare_majorana compare_majorana_legacy compare_majorana_UFO # XFAIL_TESTS += compare_majorana_UFO EXTRA_PROGRAMS += compare_majorana compare_majorana_legacy compare_majorana_UFO compare_majorana.f90: comparisons_majorana.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh Maj \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA)" < $< > $@ compare_majorana_legacy.f90: comparisons_majorana_legacy.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh MajL \ "$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA_LEGACY)" < $< > $@ compare_majorana_UFO.f90: comparisons_majorana_UFO.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana_UFO.sh MajU \ "$(OMEGA_UFO)" "$(OMEGA_UFO_MAJORANA)" "$(OMEGA_UFO_PATH)" < $< > $@ compare_majorana.f90 compare_majorana_legacy.f90 compare_majorana_UFO.f90: \ compare_driver_majorana.sh $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) compare_majorana_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_SOURCES = compare_majorana.f90 compare_majorana_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_legacy_SOURCES = $(COMPARE_LIB_F90) nodist_compare_majorana_legacy_SOURCES = compare_majorana_legacy.f90 compare_majorana_legacy_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana_UFO_SOURCES = $(COMPARE_LIB_F90) parameters_SM_UFO.f90 nodist_compare_majorana_UFO_SOURCES = compare_majorana_UFO.f90 compare_majorana_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_majorana.o compare_majorana_legacy.o compare_majorana_UFO.o: $(COMPARE_LIB_O) compare_majorana_UFO.o: parameters_SM_UFO.o endif ######################################################################## EXTRA_DIST += compare_driver_UFO.sh EXTRA_DIST += comparisons_UFO.list if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += compare_amplitude_UFO # XFAIL_TESTS += compare_amplitude_UFO EXTRA_PROGRAMS += compare_amplitude_UFO compare_amplitude_UFO_SOURCES = \ parameters_SM_from_UFO.f90 compare_lib.f90 \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 compare_amplitude_UFO.f90: comparisons_UFO.list compare_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_UFO"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_UFO.sh UFO \ "$(OMEGA_XXX) -model:constant_width" \ "$(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" \ < $< > $@ # -model:long_flavors nodist_compare_amplitude_UFO_SOURCES = \ compare_amplitude_UFO.f90 parameters_SM_UFO.f90 compare_amplitude_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la parameters_SM_from_UFO.o: parameters_SM_UFO.o compare_amplitude_UFO.o: parameters_SM_UFO.o parameters_SM_from_UFO.o compare_amplitude_UFO.o: $(COMPARE_LIB_O) endif parameters_SM_UFO.f90: $(OMEGA_UFO) $(OMEGA_UFO) \ -model:UFO_dir $(OMEGA_UFO_PATH)/SM/ -model:exec \ -target:parameter_module parameters_sm_ufo -params > $@ endif ######################################################################## EXTRA_DIST += fermi_driver_UFO.sh EXTRA_DIST += fermi_UFO.list if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += fermi_UFO # XFAIL_TESTS += fermi_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += fermi_UFO endif EXTRA_PROGRAMS += fermi_UFO FERMI_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 FERMI_UFO_SUPPORT_O = $(FERMI_UFO_SUPPORT_F90:.f90=.o) fermi_UFO_lib.o: $(FERMI_SUPPORT_O) FERMI_UFO_LIB_F90 = fermi_lib.f90 $(FERMI_UFO_SUPPORT_F90) FERMI_UFO_LIB_O = $(FERMI_UFO_LIB_F90:.f90=.o) run_fermi_UFO: fermi_UFO ./fermi_UFO fermi_UFO.f90: fermi_UFO.list fermi_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " FERMI_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/fermi_driver_UFO.sh \ $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) $(OMEGA_UFO_PATH) \ $(OMEGA_SPLIT) < $< > $@ fermi_UFO_SOURCES = $(FERMI_UFO_LIB_F90) nodist_fermi_UFO_SOURCES = fermi_UFO.f90 parameters_SM_UFO.f90 fermi_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la fermi_UFO.o: $(FERMI_UFO_LIB_O) parameters_SM_UFO.o endif endif ######################################################################## EXTRA_DIST += ward_driver_UFO.sh EXTRA_DIST += ward_identities_UFO.list if OCAML_AVAILABLE # At quadruple or extended precision, these tests take waaaaaayyyy too long! if FC_PREC else TESTS += ward_UFO # We need more work on the parameters to pass the tests # at quadruple or extended precision. if FC_PREC XFAIL_TESTS += ward_UFO endif EXTRA_PROGRAMS += ward_UFO WARD_UFO_SUPPORT_F90 = \ omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 WARD_UFO_SUPPORT_O = $(WARD_UFO_SUPPORT_F90:.f90=.o) ward_UFO_lib.o: $(WARD_SUPPORT_O) WARD_UFO_LIB_F90 = ward_lib.f90 $(WARD_UFO_SUPPORT_F90) WARD_UFO_LIB_O = $(WARD_UFO_LIB_F90:.f90=.o) run_ward_UFO: ward_UFO ./ward_UFO ward_UFO.f90: ward_identities_UFO.list ward_driver_UFO.sh $(OMEGA_UFO) @if $(AM_V_P); then :; else echo " WARD_UFO_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ward_driver_UFO.sh \ $(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ \ $(OMEGA_SPLIT) < $< > $@ ward_UFO_SOURCES = $(WARD_UFO_LIB_F90) nodist_ward_UFO_SOURCES = ward_UFO.f90 parameters_SM_UFO.f90 ward_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ward_UFO.o: $(WARD_UFO_LIB_O) parameters_SM_UFO.o endif endif ######################################################################## TESTS += compare_amplitude_VM EXTRA_PROGRAMS += compare_amplitude_VM EXTRA_DIST += compare_driver_VM.sh compare_driver_VM_wrappers.sh EXTRA_DIST += comparisons_VM.list compare_amplitude_VM.f90: comparisons_VM.list comparisons_VM.wrappers.o @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ comparisons_VM.wrappers.f90: comparisons_VM.list @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM_WRAPPERS"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM_wrappers.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files compare_amplitude_VM.f90: compare_driver_VM.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) \ $(OMEGA_SM_CKM) $(OMEGA_SM_CKM_VM) \ $(OMEGA_SM_Higgs) $(OMEGA_SM_Higgs_VM) \ $(OMEGA_THDM) $(OMEGA_THDM_VM) \ $(OMEGA_THDM_CKM) $(OMEGA_THDM_CKM_VM) \ $(OMEGA_HSExt) $(OMEGA_HSExt_VM) \ $(OMEGA_Zprime) $(OMEGA_Zprime_VM) COMPARE_EXTRA_MODELS = parameters_SM_CKM.f90 parameters_SM_Higgs.f90 \ parameters_THDM.f90 parameters_THDM_CKM.f90 parameters_HSExt.f90 \ parameters_Zprime.f90 compare_amplitude_VM_SOURCES = $(COMPARE_LIB_F90) $(COMPARE_EXTRA_MODELS) nodist_compare_amplitude_VM_SOURCES = compare_amplitude_VM.f90 comparisons_VM.wrappers.f90 compare_amplitude_VM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la compare_amplitude_VM.o: $(COMPARE_LIB_O) ######################################################################## if FC_USE_OPENMP TESTS += test_openmp EXTRA_PROGRAMS += test_openmp TESTOPENMP_SUPPORT_F90 = $(WARD_SUPPORT_F90) TESTOPENMP_SUPPORT_O = $(WARD_SUPPORT_O) test_openmp_SOURCES = test_openmp.f90 $(TESTOPENMP_SUPPORT_F90) nodist_test_openmp_SOURCES = amplitude_openmp.f90 test_openmp_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_openmp.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:openmp \ -target:module amplitude_openmp -scatter "gl gl -> gl gl gl" > $@ test_openmp.o: amplitude_openmp.o test_openmp.o: $(TESTOPENMP_SUPPORT_O) amplitude_openmp.o: parameters_QCD.o endif ######################################################################## EXTRA_PROGRAMS += benchmark_VM_vs_Fortran EXTRA_DIST += benchmark_VM_vs_Fortran_driver.sh benchmark_driver_wrappers.sh EXTRA_DIST += benchmark_processes.list 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) ######################################################################## EXTRA_DIST += benchmark_amp_parallel_driver.sh if FC_USE_OPENMP EXTRA_PROGRAMS += benchmark_amp_parallel benchmark_amp_parallel.f90: benchmark_processes.list benchmark_processes.wrappers.o @if $(AM_V_P); then :; else echo " BENCHMARK_PARALLEL_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/benchmark_amp_parallel_driver.sh \ "$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@ # Explicitly state dependence on model files benchmark_amp_parallel.f90: benchmark_amp_parallel_driver.sh \ $(OMEGA_QED) $(OMEGA_QED_VM) \ $(OMEGA_QCD) $(OMEGA_QCD_VM) \ $(OMEGA_SM) $(OMEGA_SM_VM) benchmark_amp_parallel_SOURCES = $(BENCHMARK_LIB_F90) nodist_benchmark_amp_parallel_SOURCES = benchmark_amp_parallel.f90 benchmark_processes.wrappers.f90 benchmark_amp_parallel_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la benchmark_amp_parallel.o: $(BENCHMARK_LIB_O) endif ######################################################################## EXTRA_PROGRAMS += benchmark run_benchmark: benchmark ./benchmark BENCHMARK_PROCESS = -scatter "gl gl -> gl gl gl" BENCHMARK_SPLIT_SIZE = 10 benchmark_SOURCES = benchmark.f90 parameters_QCD.f90 nodist_benchmark_SOURCES = \ amplitude_benchmark_v1.f90 amplitude_benchmark_v2.f90 \ amplitude_benchmark_v3.f90 # amplitude_benchmark_v4.f90 benchmark_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_v1.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v1 \ $(BENCHMARK_PROCESS) -target:single_function > $@ amplitude_benchmark_v2.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v2 \ $(BENCHMARK_PROCESS) -target:split_function $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v3.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v3 \ $(BENCHMARK_PROCESS) -target:split_module $(BENCHMARK_SPLIT_SIZE) > $@ amplitude_benchmark_v4.f90: $(OMEGA_QCD) Makefile $(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v4 \ $(BENCHMARK_PROCESS) -target:split_file $(BENCHMARK_SPLIT_SIZE) > $@ benchmark.o: \ amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o # amplitude_benchmark_v4.o benchmark.o: parameters_QCD.o amplitude_benchmark_v1.o amplitude_benchmark_v2.o \ amplitude_benchmark_v3.o amplitude_benchmark_v4.o: parameters_QCD.o ######################################################################## EXTRA_PROGRAMS += benchmark_UFO_SM run_benchmark_UFO_SM: benchmark_UFO_SM ./benchmark_UFO_SM # NB: This IS portable ... UFO_SM = $(OMEGA_UFO_PATH)/SM/ BENCHMARK_UFO_SM_PROCESS = -scatter "e+ e- -> W+ W- Z Z" benchmark_UFO_SM_SOURCES = \ benchmark_UFO_SM.f90 parameters_SM_from_UFO.f90 nodist_benchmark_UFO_SM_SOURCES = \ amplitude_benchmark_UFO_SM.f90 \ amplitude_benchmark_UFO_SM_classic.f90 \ parameters_SM_UFO.f90 benchmark_UFO_SM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_UFO_SM_classic.f90: $(OMEGA_SM) Makefile $(OMEGA_SM) -target:module amplitude_benchmark_UFO_SM_classic \ -target:parameter_module parameters_SM_from_UFO \ $(BENCHMARK_UFO_SM_PROCESS) > $@ amplitude_benchmark_UFO_SM.f90: $(OMEGA_UFO) Makefile $(OMEGA_UFO) -model:UFO_dir $(UFO_SM) -model:exec \ -target:module amplitude_benchmark_UFO_SM \ -target:parameter_module parameters_SM_UFO \ $(BENCHMARK_UFO_SM_PROCESS) > $@ benchmark_UFO_SM.o: \ amplitude_benchmark_UFO_SM.o amplitude_benchmark_UFO_SM_classic.o benchmark_UFO_SM.o: parameters_SM_UFO.o parameters_SM_from_UFO.o amplitude_benchmark_UFO_SM_classic.o: parameters_SM_from_UFO.o amplitude_benchmark_UFO_SM.o: parameters_SM_UFO.o ######################################################################## EXTRA_PROGRAMS += benchmark_UFO_SMEFT run_benchmark_UFO_SMEFT: benchmark_UFO_SMEFT ./benchmark_UFO_SMEFT # NB: This is NOT portable ... UFO_SMEFT = /home/ohl/physics/SMEFT_mW_UFO/ BENCHMARK_UFO_SMEFT_PROCESS = -scatter "e+ e- -> W+ W- Z" benchmark_UFO_SMEFT_SOURCES = benchmark_UFO_SMEFT.f90 nodist_benchmark_UFO_SMEFT_SOURCES = \ amplitude_benchmark_UFO_SMEFT.f90 \ amplitude_benchmark_UFO_SMEFT_opt.f90 \ parameters_UFO_SMEFT.f90 benchmark_UFO_SMEFT_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la amplitude_benchmark_UFO_SMEFT.f90: $(OMEGA_UFO) Makefile $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:module amplitude_benchmark_UFO_SMEFT \ -target:parameter_module parameters_UFO_SMEFT \ $(BENCHMARK_UFO_SMEFT_PROCESS) | $(SED) 's/g == 0/.false./' > $@ amplitude_benchmark_UFO_SMEFT_opt.f90: $(OMEGA_UFO) Makefile $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:module amplitude_benchmark_UFO_SMEFT_opt \ -target:parameter_module parameters_UFO_SMEFT \ $(BENCHMARK_UFO_SMEFT_PROCESS) > $@ benchmark_UFO_SMEFT.o: \ amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o benchmark_UFO_SMEFT.o: parameters_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o: \ parameters_UFO_SMEFT.o parameters_UFO_SMEFT.f90: $(OMEGA_UFO) $(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \ -target:parameter_module parameters_UFO_SMEFT -params > $@ ######################################################################## if OCAML_AVAILABLE TESTS += vertex_unit EXTRA_PROGRAMS += vertex_unit vertex_unit_SOURCES = vertex_unit.ml vertex_unit: $(OMEGA_CORE) vertex_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o vertex_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) vertex_unit.cmx vertex_unit.cmx: vertex_unit.ml vertex_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += ufo_unit EXTRA_PROGRAMS += ufo_unit ufo_unit_SOURCES = ufo_unit.ml ufo_unit: $(OMEGA_CORE) ufo_unit.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o ufo_unit \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) ufo_unit.cmx ufo_unit.cmx: ufo_unit.ml ufo_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) endif ######################################################################## if OCAML_AVAILABLE TESTS += keystones_omegalib keystones_UFO TESTS += keystones_omegalib_bispinors keystones_UFO_bispinors # XFAIL_TESTS += keystones_UFO # XFAIL_TESTS += keystones_UFO_bispinors EXTRA_PROGRAMS += keystones_omegalib keystones_UFO EXTRA_PROGRAMS += keystones_omegalib_bispinors keystones_UFO_bispinors keystones_omegalib_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_SOURCES = keystones_omegalib.f90 keystones_omegalib_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_SOURCES = keystones_UFO.f90 keystones_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_omegalib_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_omegalib_bispinors_SOURCES = keystones_omegalib_bispinors.f90 keystones_omegalib_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la keystones_UFO_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90 nodist_keystones_UFO_bispinors_SOURCES = keystones_UFO_bispinors.f90 keystones_UFO_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la EXTRA_PROGRAMS += keystones_omegalib_generate keystones_UFO_generate EXTRA_PROGRAMS += keystones_omegalib_bispinors_generate keystones_UFO_bispinors_generate keystones_omegalib_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_generate.ml keystones_UFO_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_generate.ml keystones_omegalib_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_omegalib_bispinors_generate.ml keystones_UFO_bispinors_generate_SOURCES = \ keystones.ml keystones.mli keystones_UFO_bispinors_generate.ml keystones_omegalib.f90: keystones_omegalib_generate ./keystones_omegalib_generate -cat > $@ keystones_UFO.f90: keystones_UFO_generate ./keystones_UFO_generate -cat > $@ keystones_omegalib_bispinors.f90: keystones_omegalib_bispinors_generate ./keystones_omegalib_bispinors_generate -cat > $@ keystones_UFO_bispinors.f90: keystones_UFO_bispinors_generate ./keystones_UFO_bispinors_generate -cat > $@ keystones_omegalib_generate: $(OMEGA_CORE) keystones_omegalib_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_generate.cmx keystones_UFO_generate: $(OMEGA_CORE) keystones_UFO_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_generate.cmx keystones_omegalib_bispinors_generate: $(OMEGA_CORE) keystones_omegalib_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_omegalib_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_omegalib_bispinors_generate.cmx keystones_UFO_bispinors_generate: $(OMEGA_CORE) keystones_UFO_bispinors_generate.cmx @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \ -o keystones_UFO_bispinors_generate \ unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \ keystones.cmx keystones_UFO_bispinors_generate.cmx keystones_omegalib_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_generate.ml keystones_omegalib_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_generate.ml keystones_UFO_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_omegalib_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_omegalib_bispinors_generate.ml keystones_omegalib_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones_UFO_bispinors_generate.cmx: \ keystones.cmi keystones.cmx keystones_UFO_bispinors_generate.ml keystones_UFO_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmx: keystones.ml keystones.cmi keystones.cmx: $(OMEGA_CORE) $(OMEGA_MODELS) keystones.cmi: keystones.mli $(OMEGA_CORE) endif ######################################################################## EXTRA_DIST += comparisons_recola.list EXTRA_DIST += compare_driver_recola.sh if RECOLA_AVAILABLE TESTS += compare_amplitude_recola # We need more work on the parameters to pass the tests # at quadruple or extended precision if FC_PREC XFAIL_TESTS += compare_amplitude_recola endif EXTRA_PROGRAMS += compare_amplitude_recola AM_FCFLAGS += $(RECOLA_INCLUDES) compare_amplitude_recola_SOURCES = \ parameters_SM_Higgs_recola.f90 \ omega_interface.f90 compare_lib.f90 compare_lib_recola.f90 \ omega_testtools.f90 tao_random_numbers.f90 nodist_compare_amplitude_recola_SOURCES = compare_amplitude_recola.f90 compare_amplitude_recola.f90: comparisons_recola.list compare_driver_recola.sh @if $(AM_V_P); then :; else echo " COMPARE_DRIVER_RECOLA"; fi $(AM_V_at)$(SHELL) $(srcdir)/compare_driver_recola.sh \ "$(OMEGA_XXX) -model:constant_width" < $< > $@ compare_amplitude_recola.o: \ omega_testtools.f90 compare_lib.o compare_lib_recola.o \ tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_lib_recola.o: \ omega_testtools.f90 compare_lib.o tao_random_numbers.o \ parameters_SM_Higgs_recola.o compare_amplitude_recola_LDADD = \ $(LDFLAGS_RECOLA) \ $(KINDS) $(top_builddir)/omega/src/libomega_core.la run_compare_recola: compare_amplitude_recola ./compare_amplitude_recola endif ######################################################################## installcheck-local: PATH=$(DESTDIR)$(bindir):$$PATH; export PATH; \ LD_LIBRARY_PATH=$(DESTDIR)$(libdir):$(DESTDIR)$(pkglibdir):$$LD_LIBRARY_PATH; \ export LD_LIBRARY_PATH; \ omega_QED.opt $(OMEGA_QED_OPTS) -scatter "e+ e- -> m+ m-" \ -target:module amplitude_qed_eemm > amplitude_qed_eemm.f90; \ $(FC) $(AM_FCFLAGS) $(FCFLAGS) -I$(pkgincludedir) \ -L$(DESTDIR)$(libdir) -L$(DESTDIR)$(pkglibdir) \ $(srcdir)/parameters_QED.f90 amplitude_qed_eemm.f90 \ $(srcdir)/test_qed_eemm.f90 -lomega_core; \ ./a.out ######################################################################## ### Remove DWARF debug information on MAC OS X clean-macosx: -rm -rf a.out.dSYM -rm -rf compare_amplitude_UFO.dSYM -rm -rf compare_amplitude_VM.dSYM -rm -rf compare_split_function.dSYM -rm -rf compare_split_module.dSYM -rm -rf ects.dSYM -rm -rf test_omega95.dSYM -rm -rf test_omega95_bispinors.dSYM -rm -rf test_qed_eemm.dSYM -rm -rf ward.dSYM .PHONY: clean-macosx clean-local: clean-macosx rm -f a.out gmon.out *.$(FCMOD) \ *.o *.cmi *.cmo *.cmx amplitude_*.f90 \ $(EXTRA_PROGRAMS) ects.f90 ward.f90 ward_UFO.f90 \ fermi.f90 fermi_UFO.f90 compare_*.f90 \ parameters_SM_UFO.f90 keystones_omegalib.f90 keystones_UFO.f90 \ keystones_UFO_bispinors.f90 keystones_omegalib_bispinors.f90 \ omega_testtools.f90 test_omega95*.f90 benchmark*.f90 \ parameters_UFO_SMEFT.f90 \ *.hbc *wrappers.f90 cascade exotic_color phase_space \ output.rcl recola.log \ *.exotic_color.expected *.exotic_color.result rm -fr output_cll if FC_SUBMODULES -rm -f *.smod endif ######################################################################## ## The End. ######################################################################## Index: trunk/omega/tests/sextet-exchange.exotic_color =================================================================== --- trunk/omega/tests/sextet-exchange.exotic_color (revision 8919) +++ trunk/omega/tests/sextet-exchange.exotic_color (revision 8920) @@ -1,319 +1,396 @@ # sextet-exchange.exotic_color -- ######################################################################## # process s3 s3 -> s3 s3 # cascade 3 + 4 ######################################################################## ! flavor combinations: ! ! 1: s3 s3 -> s3 s3 ! ! color flows: ! ! 1: ( 1, 0) ( 2, 0) -> ( 1, 0) ( 2, 0) ! 2: ( 2, 0) ( 1, 0) -> ( 1, 0) ( 2, 0) ! ! NB: i.g. not all color flows contribute to all flavor ! combinations. Consult the array FLV_COL_IS_ALLOWED ! below for the allowed combinations. ! ! Color Factors: ! ! ( 1, 1): + N^2 ! ( 2, 1): + N ! ( 2, 2): + N^2 ! ! vanishing or redundant flavor combinations: ! ! ! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!): ! ! 3+4 ~ ? grouping {{3,4}} ! ! -module omega_amplitude +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Amplitude computation module +! NOT to be USEd by application programs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module omega_amplitude_computation use kinds use omega95 use omega_color, OCF => omega_color_factor use omega_amplitude_ufo implicit none private public :: number_particles_in, number_particles_out, number_color_indices, & reset_helicity_selection, new_event, is_allowed, get_amplitude, & - color_sum, external_masses, openmp_supported, number_spin_states, & - spin_states, number_flavor_states, flavor_states, number_color_flows, & - color_flows, number_color_factors, color_factors - + color_sum, external_masses, openmp_supported, table_coupling_orders, & + table_coupling_powers, amp_by_orders, table_spin_states, & + table_flavor_states, number_spin_states, spin_states, & + number_flavor_states, flavor_states, number_color_flows, color_flows, & + number_color_factors, color_factors ! DON'T EVEN THINK of removing the following! ! If the compiler complains about undeclared ! or undefined variables, you are compiling ! against an incompatible omega95 module! integer, dimension(7), parameter, private :: require = & (/ omega_spinors_2010_01_A, omega_spinor_cpls_2010_01_A, & omega_vectors_2010_01_A, omega_polarizations_2010_01_A, & omega_couplings_2010_01_A, omega_color_2010_01_A, & omega_utils_2010_01_A /) integer, parameter :: n_prt = 4 integer, parameter :: n_in = 2 integer, parameter :: n_out = 2 integer, parameter :: n_cflow = 2 integer, parameter :: n_cindex = 2 integer, parameter :: n_flv = 1 integer, parameter :: n_hel = 1 integer, parameter :: n_co = 0 - integer, parameter :: n_cop = 0 + integer, parameter :: n_co_len = 0 + integer, parameter :: n_cp = 1 ! NB: you MUST NOT change the value of N_ here!!! ! It is defined here for convenience only and must be ! compatible with hardcoded values in the amplitude! real(kind=default), parameter :: N_ = 3 logical, parameter :: F = .false. logical, parameter :: T = .true. - integer, dimension(n_co,n_cop), save, protected :: table_coupling_orders + character(len=0), dimension(n_co), save, protected :: table_coupling_orders + + integer, dimension(n_co,n_cp), save, protected :: table_coupling_powers integer, dimension(n_prt,n_hel), save, protected :: table_spin_states data table_spin_states(:, 1) / 0, 0, 0, 0 / integer, dimension(n_prt,n_flv), save, protected :: table_flavor_states data table_flavor_states(:, 1) / 3, 3, 3, 3 / ! s3 s3 s3 s3 integer, dimension(n_cindex,n_prt,n_cflow), save, protected :: table_color_flows data table_color_flows(:,:, 1) / 1,0, 2,0, 1,0, 2,0 / data table_color_flows(:,:, 2) / 2,0, 1,0, 1,0, 2,0 / logical, dimension(n_prt,n_cflow), save, protected :: table_ghost_flags data table_ghost_flags(:, 1) / F, F, F, F / data table_ghost_flags(:, 2) / F, F, F, F / integer, parameter :: n_cfactors = 4 type(OCF), dimension(n_cfactors), save, protected :: table_color_factors real(kind=default), parameter, private :: color_factor_000001 = +N_**2 data table_color_factors( 1) / OCF(1,1,color_factor_000001) / real(kind=default), parameter, private :: color_factor_000002 = +N_ data table_color_factors( 2) / OCF(1,2,color_factor_000002) / real(kind=default), parameter, private :: color_factor_000003 = +N_ data table_color_factors( 3) / OCF(2,1,color_factor_000003) / real(kind=default), parameter, private :: color_factor_000004 = +N_**2 data table_color_factors( 4) / OCF(2,2,color_factor_000004) / - logical, dimension(n_flv, n_cflow), save, protected :: flv_col_is_allowed + logical, dimension(n_flv,n_cflow), save, protected :: flv_col_is_allowed data flv_col_is_allowed(:, 1) / T / data flv_col_is_allowed(:, 2) / T / - complex(kind=default), dimension(n_flv, n_cflow, n_hel), save :: amp + logical, dimension(n_cp,n_flv,n_cflow), save, protected :: & + co_flv_col_is_allowed + data co_flv_col_is_allowed(:, 1, 1) / T / + data co_flv_col_is_allowed(:, 1, 2) / T / + + complex(kind=default), dimension(n_flv,n_cflow,n_hel), save :: amp_all_orders + complex(kind=default), dimension(n_cp,n_flv,n_cflow,n_hel), save :: amp_by_orders logical, dimension(n_hel), save :: hel_is_allowed = T real(kind=default), dimension(n_hel), save :: hel_max_abs = 0 real(kind=default), save :: hel_sum_abs = 0, hel_threshold = 1E10_default integer, save :: hel_count = 0, hel_cutoff = 100 integer :: i integer, save, dimension(n_hel) :: hel_map = (/(i, i = 1, n_hel)/) integer, save :: hel_finite = n_hel type(momentum) :: p1, p2, p3, p4 type(momentum) :: p12 complex(kind=default) :: owf_f5_o2_p4, owf_f5_o1_p3, owf_f6_i2_p2, & owf_f6_i2_p1, owf_f6_i1_p2, owf_f6_i1_p1 complex(kind=default) :: owf_f4_i21_p12_X1, owf_f4_i21_p12_X2, & owf_f4_i12_p12_X1, owf_f4_i12_p12_X2 complex(kind=default) :: oks_f6_i2_f6_i1_f6_i1_f6_i2, & oks_f6_i1_f6_i2_f6_i1_f6_i2 contains pure function number_particles_in () result (n) integer :: n n = n_in end function number_particles_in pure function number_particles_out () result (n) integer :: n n = n_out end function number_particles_out pure function number_spin_states () result (n) integer :: n n = size (table_spin_states, dim=2) end function number_spin_states pure subroutine spin_states (a) integer, dimension(:,:), intent(out) :: a a = table_spin_states end subroutine spin_states pure function number_flavor_states () result (n) integer :: n n = size (table_flavor_states, dim=2) end function number_flavor_states pure subroutine flavor_states (a) integer, dimension(:,:), intent(out) :: a a = table_flavor_states end subroutine flavor_states pure subroutine external_masses (m, flv) real(kind=default), dimension(:), intent(out) :: m integer, intent(in) :: flv select case (flv) case ( 1) m( 1) = ZERO m( 2) = ZERO m( 3) = ZERO m( 4) = ZERO end select end subroutine external_masses pure function openmp_supported () result (status) logical :: status status = .false. end function openmp_supported pure function number_color_indices () result (n) integer :: n n = size (table_color_flows, dim=1) end function number_color_indices pure function number_color_flows () result (n) integer :: n n = size (table_color_flows, dim=3) end function number_color_flows pure subroutine color_flows (a, g) integer, dimension(:,:,:), intent(out) :: a logical, dimension(:,:), intent(out) :: g a = table_color_flows g = table_ghost_flags end subroutine color_flows pure function number_color_factors () result (n) integer :: n n = size (table_color_factors) end function number_color_factors pure subroutine color_factors (cf) type(OCF), dimension(:), intent(out) :: cf cf = table_color_factors end subroutine color_factors function color_sum (flv, hel) result (amp2) integer, intent(in) :: flv, hel real(kind=default) :: amp2 - amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors)) + amp2 = real (omega_color_sum (flv, hel, amp_all_orders, table_color_factors)) end function color_sum subroutine new_event (p) real(kind=default), dimension(0:3,*), intent(in) :: p logical :: mask_dirty integer :: hel - call calculate_amplitudes (amp, p, hel_is_allowed) + call calculate_amplitudes (amp_by_orders, p, hel_is_allowed) + amp_all_orders = sum (amp_by_orders, dim=1) if ((hel_threshold .gt. 0) .and. (hel_count .le. hel_cutoff)) then - call omega_update_helicity_selection (hel_count, amp, hel_max_abs, & - hel_sum_abs, hel_is_allowed, hel_threshold, hel_cutoff, & - mask_dirty) + call omega_update_helicity_selection (hel_count, amp_all_orders, & + hel_max_abs, hel_sum_abs, hel_is_allowed, hel_threshold, & + hel_cutoff, mask_dirty) if (mask_dirty) then hel_finite = 0 do hel = 1, n_hel if (hel_is_allowed(hel)) then hel_finite = hel_finite + 1 hel_map(hel_finite) = hel end if end do end if end if end subroutine new_event subroutine reset_helicity_selection (threshold, cutoff) real(kind=default), intent(in) :: threshold integer, intent(in) :: cutoff integer :: i hel_is_allowed = T hel_max_abs = 0 hel_sum_abs = 0 hel_count = 0 hel_threshold = threshold hel_cutoff = cutoff hel_map = (/(i, i = 1, n_hel)/) hel_finite = n_hel end subroutine reset_helicity_selection pure function is_allowed (flv, hel, col) result (yorn) logical :: yorn integer, intent(in) :: flv, hel, col yorn = hel_is_allowed(hel) .and. flv_col_is_allowed(flv,col) end function is_allowed - pure function get_amplitude (flv, hel, col) result (amp_result) - complex(kind=default) :: amp_result + pure function get_amplitude (flv, hel, col) result (amp) + complex(kind=default) :: amp integer, intent(in) :: flv, hel, col - amp_result = amp(flv, col, hel) + amp = amp_all_orders(flv, col, hel) end function get_amplitude subroutine calculate_amplitudes (amp, k, mask) - complex(kind=default), dimension(:,:,:), intent(out) :: amp + complex(kind=default), dimension(:,:,:,:), intent(out) :: amp real(kind=default), dimension(0:3,*), intent(in) :: k logical, dimension(:), intent(in) :: mask integer, dimension(n_prt) :: s integer :: h, hi p1 = - k(:,1) ! incoming p2 = - k(:,2) ! incoming p3 = k(:,3) ! outgoing p4 = k(:,4) ! outgoing p12 = p1 + p2 amp = 0 if (hel_finite == 0) return do hi = 1, hel_finite h = hel_map(hi) s = table_spin_states(:,h) owf_f6_i2_p1 = 1 owf_f6_i1_p2 = 1 owf_f5_o1_p3 = 1 owf_f5_o2_p4 = 1 owf_f6_i1_p1 = 1 owf_f6_i2_p2 = 1 call compute_fusions_0001 () call compute_brakets_0001 () - amp(1,1,h) = oks_f6_i1_f6_i2_f6_i1_f6_i2 - amp(1,2,h) = oks_f6_i2_f6_i1_f6_i1_f6_i2 + amp(1,1,1,h) = oks_f6_i1_f6_i2_f6_i1_f6_i2 + amp(1,1,2,h) = oks_f6_i2_f6_i1_f6_i1_f6_i2 end do end subroutine calculate_amplitudes subroutine compute_fusions_0001 () owf_f4_i12_p12_X2 = pr_phi(p12,ZERO,ZERO, & - + SSS1_p201(+ GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1)) owf_f4_i21_p12_X2 = pr_phi(p12,ZERO,ZERO, & - + SSS1_p201(+ GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1)) owf_f4_i12_p12_X1 = pr_phi(p12,ZERO,ZERO, & - + SSS1_p201(+ GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1)) owf_f4_i21_p12_X1 = pr_phi(p12,ZERO,ZERO, & - + SSS1_p201(+ GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1)) end subroutine compute_fusions_0001 subroutine compute_brakets_0001 () oks_f6_i2_f6_i1_f6_i1_f6_i2 = 0 oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 & + owf_f4_i12_p12_X2*( & - + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 & + owf_f4_i21_p12_X2*( & - + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) oks_f6_i2_f6_i1_f6_i1_f6_i2 = & - oks_f6_i2_f6_i1_f6_i1_f6_i2 ! 2 vertices, 1 propagators oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 & / sqrt(2.0_default) ! symmetry factor oks_f6_i1_f6_i2_f6_i1_f6_i2 = 0 oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 & + owf_f4_i12_p12_X1*( & - + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 & + owf_f4_i21_p12_X1*( & - + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) + + SSS1_p201(+ 1.0_default/2*GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3)) oks_f6_i1_f6_i2_f6_i1_f6_i2 = & - oks_f6_i1_f6_i2_f6_i1_f6_i2 ! 2 vertices, 1 propagators oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 & / sqrt(2.0_default) ! symmetry factor end subroutine compute_brakets_0001 +end module omega_amplitude_computation +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! O'Mega API Version 1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module omega_amplitude_api_v1 + use omega_amplitude_computation, only: number_particles_in, & + number_particles_out, number_color_indices, reset_helicity_selection, & + new_event, is_allowed, get_amplitude, color_sum, external_masses, & + openmp_supported, table_coupling_orders, table_coupling_powers, & + amp_by_orders, table_spin_states, table_flavor_states, & + number_spin_states, spin_states, number_flavor_states, flavor_states, & + number_color_flows, color_flows, number_color_factors, color_factors + implicit none + public +end module omega_amplitude_api_v1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Backward compatible alias for O'Mega API Version 1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module omega_amplitude + use omega_amplitude_api_v1 + implicit none + public end module omega_amplitude +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! O'Mega API Version 3 +! WORK IN PROCESS !!!! +! NOT FOR PRODUCTION ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module omega_amplitude_api_v3 + use omega_birdtracks + use omega_api_v3 + use omega_amplitude_computation + implicit none + private + public :: load_amplidude +! DUMMY DECLARATIONS FOR TESTING! + integer, parameter, public :: n_incoming = 2 + integer, parameter, public :: n_outgoing = 2 + integer, parameter, public :: n_particles = 4 + integer, parameter, public :: n_colorflows = 2 + integer, parameter :: max_rank_inflowing = 1 + integer, parameter :: max_rank_outflowing = 1 + integer, parameter :: max_n_eps = 0 + integer, parameter :: max_n_eps_bar = 0 + integer, dimension(n_particles,n_colorflows), save :: rank_inflowing, rank_outflowing + integer, dimension(n_colorflows), save :: n_eps, n_eps_bar + integer, dimension(max_rank_inflowing,n_particles,n_colorflows), save :: inflowing, outflowing + logical, dimension(n_particles,n_colorflows), save :: is_ghost + integer, dimension(3,max_n_eps,n_colorflows), save :: eps + integer, dimension(3,max_n_eps_bar,n_colorflows), save :: eps_bar + +contains + + pure subroutine load_amplidude (a) + type(amplitude), intent(inout) :: a + call copy_amplitude & + (a, n_incoming, table_flavor_states, table_spin_states, & + rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar, & + table_coupling_orders, table_coupling_powers, amp_by_orders) + end subroutine load_amplidude + +end module omega_amplitude_api_v3 Index: trunk/omega/src/model.mli =================================================================== --- trunk/omega/src/model.mli (revision 8919) +++ trunk/omega/src/model.mli (revision 8920) @@ -1,322 +0,0 @@ -(* model.mli -- - - Copyright (C) 1999-2024 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{General Quantum Field Theories} *) - -module type T = - sig - -(* [flavor] abstractly encodes all quantum numbers. *) - type flavor - -(* [Color.t] encodes the ($\textrm{SU}(N)$) color representation. *) - val color : flavor -> Color.t - val nc : unit -> int - -(* The set of conserved charges. *) - module Ch : Charges.T - val charges : flavor -> Ch.t - -(* The PDG particle code for interfacing with Monte Carlos. *) - val pdg : flavor -> int - -(* The Lorentz representation of the particle. *) - val lorentz : flavor -> Coupling.lorentz - -(* The propagator for the particle, which \emph{can} depend - on a gauge parameter. *) - type gauge - val propagator : flavor -> gauge Coupling.propagator - -(* \emph{Not} the symbol for the numerical value, but the - scheme or strategy. *) - val width : flavor -> Coupling.width - -(* Charge conjugation, with and without color. *) - val conjugate : flavor -> flavor - -(* Returns $1$ for fermions, $-1$ for anti-fermions, $2$ for Majoranas - and $0$ otherwise. *) - val fermion : flavor -> int - -(* The Feynman rules. [vertices] and [(fuse2, fuse3, fusen)] are - redundant, of course. However, [vertices] is required for building - functors for models and [vertices] can be recovered from - [(fuse2, fuse3, fusen)] only at great cost. *) - -(* \begin{dubious} - Nevertheless: [vertices] is a candidate for removal, b/c we can - build a smarter [Colorize] functor acting on [(fuse2, fuse3, fusen)]. - It can support an arbitrary numer of color lines. But we have to test - whether it is efficient enough. And we have to make sure that this - wouldn't break the UFO interface. - \end{dubious} *) - type constant - - val max_degree : unit -> int - val vertices : unit -> - ((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list) - * (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list) - * (((flavor list) * constant Coupling.vertexn * constant) list)) - val fuse2 : flavor -> flavor -> (flavor * constant Coupling.t) list - val fuse3 : flavor -> flavor -> flavor -> (flavor * constant Coupling.t) list - val fuse : flavor list -> (flavor * constant Coupling.t) list - -(* For counting coupling orders. *) - type coupling_order - val all_coupling_orders : unit -> coupling_order list - val coupling_order_to_string : coupling_order -> string - val coupling_orders : constant -> (coupling_order * int) list - -(* The list of all known flavors. *) - val flavors : unit -> flavor list - -(* The flavors that can appear in incoming or outgoing states, grouped - in a way that is useful for user interfaces. *) - val external_flavors : unit -> (string * flavor list) list - -(* The Goldstone bosons corresponding to a gauge field, if any. *) - val goldstone : flavor -> (flavor * constant Coupling.expr) option - -(* The dependent parameters. *) - val parameters : unit -> constant Coupling.parameters - -(* Translate from and to convenient textual representations of flavors. *) - val flavor_of_string : string -> flavor - val flavor_to_string : flavor -> string - -(* \TeX{} and \LaTeX{} *) - val flavor_to_TeX : flavor -> string - -(* The following must return unique symbols that are acceptable as - symbols in all programming languages under consideration as targets. - Strings of alphanumeric characters (starting with a letter) should - be safe. Underscores are also usable, but would violate strict - Fortran77. *) - val flavor_symbol : flavor -> string - val gauge_symbol : gauge -> string - val mass_symbol : flavor -> string - val width_symbol : flavor -> string - val constant_symbol : constant -> string - -(* Model specific options. *) - val options : Options.t - -(* \textit{Not ready for prime time} or other warnings to - be written to the source files for the amplitudes. *) - - val caveats : unit -> string list - - end - -(* In addition to hardcoded models, we can have models that are - initialized at run time. *) - -(* \thocwmodulesection{Mutable Quantum Field Theories} *) - -module type Mutable = - sig - include T - -(* Pass initialization data to the model. Typically, - this is the name of a UFO directory and we can specialize - [Mutable with type init = string] *) - type init - val init : init -> unit - val write_whizard : out_channel -> unit - -(* Export only one big initialization function to discourage - partial initializations. Labels make this usable. *) - - val setup : - color:(flavor -> Color.t) -> - nc:(unit -> int) -> - pdg:(flavor -> int) -> - lorentz:(flavor -> Coupling.lorentz) -> - propagator:(flavor -> gauge Coupling.propagator) -> - width:(flavor -> Coupling.width) -> - goldstone:(flavor -> (flavor * constant Coupling.expr) option) -> - conjugate:(flavor -> flavor) -> - fermion:(flavor -> int) -> - vertices: - (unit -> - ((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list) - * (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list) - * (((flavor list) * constant Coupling.vertexn * constant) list))) -> - flavors:((string * flavor list) list) -> - parameters:(unit -> constant Coupling.parameters) -> - flavor_of_string:(string -> flavor) -> - flavor_to_string:(flavor -> string) -> - flavor_to_TeX:(flavor -> string) -> - flavor_symbol:(flavor -> string) -> - gauge_symbol:(gauge -> string) -> - mass_symbol:(flavor -> string) -> - width_symbol:(flavor -> string) -> - constant_symbol:(constant -> string) -> - all_coupling_orders:(unit -> coupling_order list) -> - coupling_order_to_string:(coupling_order -> string) -> - coupling_orders:(constant -> (coupling_order * int) list) -> - unit - end - -(* \thocwmodulesection{Gauge Field Theories} *) - -(* The following signatures are used only for model building. The diagrammatics - and numerics is supposed to be completely ignorant about the detail of the - models and expected to rely on the interface [T] exclusively. - \begin{dubious} - In the end, we might have functors [(M : T) -> Gauge], but we will - need to add the quantum numbers to [T]. - \end{dubious} *) - -module type Gauge = - sig - include T - -(* Matter field carry conserved quantum numbers and can be replicated - in generations without changing the gauge sector. *) - type matter_field - -(* Gauge bosons proper. *) - type gauge_boson - -(* Higgses, Goldstones and all the rest: *) - type other - -(* We can query the kind of field *) - type field = - | Matter of matter_field - | Gauge of gauge_boson - | Other of other - val field : flavor -> field - -(* and we can build new fields of a given kind: *) - val matter_field : matter_field -> flavor - val gauge_boson : gauge_boson -> flavor - val other : other -> flavor - end - -(* \thocwmodulesection{Gauge Field Theories with Broken Gauge Symmetries} *) - -(* Both are carefully crafted as subtypes of [Gauge] so that - they can be used in place of [Gauge] and [T] everywhere: *) - -module type Broken_Gauge = - sig - include Gauge - - type massless - type massive - type goldstone - - type kind = - | Massless of massless - | Massive of massive - | Goldstone of goldstone - val kind : gauge_boson -> kind - - val massless : massive -> gauge_boson - val massive : massive -> gauge_boson - val goldstone : goldstone -> gauge_boson - - end - -module type Unitarity_Gauge = - sig - include Gauge - - type massless - type massive - - type kind = - | Massless of massless - | Massive of massive - val kind : gauge_boson -> kind - - val massless : massive -> gauge_boson - val massive : massive -> gauge_boson - - end - -module type Colorized = - sig - - include T - - type flavor_sans_color - val flavor_sans_color : flavor -> flavor_sans_color - val conjugate_sans_color : flavor_sans_color -> flavor_sans_color - -(* [amplitude] does \emph{not} compute the amplitude, but - returns all possible color combinations for the given flavor. - These will be used by the functions in [Fusion]. *) - - val amplitude : flavor_sans_color list -> flavor_sans_color list -> - (flavor list * flavor list) list - val flow : flavor list -> flavor list -> Color.Flow.t - - val flavor_equal : flavor -> flavor -> bool - - end - -module type Colorized_Gauge = - sig - - include Gauge - - type flavor_sans_color - val flavor_sans_color : flavor -> flavor_sans_color - val conjugate_sans_color : flavor_sans_color -> flavor_sans_color - - val amplitude : flavor_sans_color list -> flavor_sans_color list -> - (flavor list * flavor list) list - val flow : flavor list -> flavor list -> Color.Flow.t - - val flavor_equal : flavor -> flavor -> bool - - end - -module type Sliced_by_Orders = - sig - - include Colorized - - type flavor_all_orders - val flavor_all_orders : flavor -> flavor_all_orders - val conjugate_all_orders : flavor_all_orders -> flavor_all_orders - - type orders - val orders : flavor -> orders - val add_orders : orders -> orders -> orders - val incr_orders : orders -> orders -> orders - val orders_to_string : orders -> string - val orders_symbol : orders -> string - - val trivial : flavor_all_orders -> flavor - - val amplitude : orders -> flavor_all_orders list -> flavor_all_orders list -> - flavor list * flavor list - val flow : flavor list -> flavor list -> Color.Flow.t - - end Index: trunk/omega/src/coupling.mli =================================================================== --- trunk/omega/src/coupling.mli (revision 8919) +++ trunk/omega/src/coupling.mli (revision 8920) @@ -1,2898 +0,0 @@ -(* coupling.mli -- - - Copyright (C) 1999-2024 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 - -type fermion_lines = (int * int) 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 - | Prop_UFO of string - -(* \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 = - | 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 = - | 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 = - | UFO of Algebra.QC.t * string * lorentzn * fermion_lines * Color.Vertex.t - -(* 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 - | Integer of int - | Float of float - | 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 - | Asin of 'a expr - | Acos of 'a expr - | Atan of 'a expr - | Atan2 of 'a expr * 'a expr - | Sinh of 'a expr - | Cosh of 'a expr - | Tanh of 'a expr - | Exp of 'a expr - | Log of 'a expr - | Log10 of 'a expr - | Conj of 'a expr - | Abs 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/target.mli =================================================================== --- trunk/omega/src/target.mli (revision 8919) +++ trunk/omega/src/target.mli (revision 8920) @@ -1,51 +0,0 @@ -(* target.mli -- - - Copyright (C) 1999-2024 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 amplitudes - - val options : Options.t - type diagnostic = All | Arguments | Momenta | Gauge - -(* Format the amplitudes as a sequence of strings. *) - val amplitudes_to_channel : string -> out_channel -> - (diagnostic * bool) list -> amplitudes -> unit - - val parameters_to_channel : out_channel -> unit - - end - -module type Maker = - functor (F : Fusion.Maker) -> - functor (P : Momentum.T) -> functor (M : Model.T) -> - T with type amplitudes = Fusion.Multi(F)(P)(M).amplitudes - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/PArray.ml =================================================================== --- trunk/omega/src/PArray.ml (revision 8919) +++ trunk/omega/src/PArray.ml (revision 8920) @@ -1,259 +1,259 @@ (* PArray.ml -- Copyright (C) 2022-2024 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. *) (* \begin{dubious} The [Map] based implementation has the drawback that the polymorphic [compare] and [(=)] will occasionally report two [PArray.t] as different even if they describe the same array. Options \begin{enumerate} \item Replace [compare] by specific functions everywhere. This is the preferred approach, but can become very tedious. \item Replace [Map] by sorted association lists. \end{enumerate} \end{dubious} *) (* \thocwmodulesection{Maps} *) module Maps = struct module IMap = Map.Make(Int) type 'a t = 'a IMap.t - let empty = IMap.empty + let _empty = IMap.empty let is_empty = IMap.is_empty - let map = IMap.map - let add = IMap.add + let _map = IMap.map + let _add = IMap.add let remove = IMap.remove let get_opt = IMap.find_opt let min_key map = fst (IMap.min_binding map) let max_key map = fst (IMap.max_binding map) let index_base = 0 let to_option_list map = if IMap.is_empty map then [] else if min_key map < index_base then invalid_arg "PArray.Maps.to_option_list" else let rec to_option_list' acc n = if n < index_base then acc else to_option_list' (get_opt n map :: acc) (pred n) in to_option_list' [] (max_key map) - let to_string a2s map = + let _to_string a2s map = match to_option_list map with | [] -> "[]" | [None] -> "?" | [Some a] -> a2s a | pairs -> ThoList.to_string (function None -> "?" | Some a -> a2s a) pairs - let of_pairs pairs = + let _of_pairs pairs = List.fold_right (fun (k, v) map -> if k < index_base then invalid_arg "PArray.Maps.of_pairs" else IMap.add k v map) pairs IMap.empty - let to_pairs = IMap.bindings + let _to_pairs = IMap.bindings - let compare = IMap.compare - let equal = IMap.equal + let _compare = IMap.compare + let _equal = IMap.equal type ('a, 'b) taken = | Nothing of 'b t | Single of int * 'a * 'b t | Multiple of int * 'a * 'a t - let take_one project_opt parray = + let _take_one project_opt parray = let select k v = match project_opt k v with | Some _ -> false | None -> true and project k v = match project_opt k v with | Some v' -> v' | None -> failwith "PArray.Maps.take_one: impossible" in let matches, other = IMap.partition select parray in match IMap.choose_opt matches with | None -> Nothing (IMap.mapi project parray) | Some (k, v) -> let more_matches = remove k matches in if is_empty more_matches then Single (k, v, IMap.mapi project other) else Multiple (k, v, IMap.fold IMap.add more_matches other) end (* \thocwmodulesection{Association Lists} *) (* We assume that the lists are short and use non tail recursive implementations if they are faster. *) module Alists = struct type 'a t = (int * 'a) list let empty = [] let is_empty = function | [] -> true | _ -> false let map f parray = List.map (fun (i, a) -> (i, f a)) parray let rec add i a = function | [] -> [(i, a)] - | (i', a' as ia') :: tail as alist -> + | (i', _ as ia') :: tail as alist -> if i' = i then (i, a) :: tail else if i' > i then (i, a) :: alist else ia' :: add i a tail let rec remove i = function | [] -> [] | (i', _ as ia') :: tail as alist -> if i' = i then tail else if i' > i then alist else ia' :: remove i tail let rec get_opt i = function | [] -> None | (i', a') :: tail -> if i' = i then Some a' else get_opt i tail - let min_key = function + let _min_key = function | [] -> invalid_arg "PArray.Alists.min_key" | (i, _) :: _ -> i - let rec max_key = function + let rec _max_key = function | [] -> invalid_arg "PArray.Alists.max_key" | [(i, _)] -> i - | _ :: tail -> max_key tail + | _ :: tail -> _max_key tail let index_base = 0 let to_option_list parray = let rec to_option_list' i = function | [] -> [] | (i', a') :: tail -> (if i' = i then Some a' else None) :: to_option_list' (succ i) tail in to_option_list' index_base parray let to_string a2s map = match to_option_list map with | [] -> "[]" | [None] -> "?" | [Some a] -> a2s a | pairs -> ThoList.to_string (function None -> "?" | Some a -> a2s a) pairs let of_pairs pairs = List.fold_right (fun (i, a) acc -> if i < index_base then invalid_arg "PArray.Alists.of_pairs" else add i a acc) pairs empty let to_pairs parray = parray let compare _ = compare let equal _ = (=) type ('a, 'b) taken = | Nothing of 'b t | Single of int * 'a * 'b t | Multiple of int * 'a * 'a t let take_one project_opt parray = let select (k, v) = match project_opt k v with | Some _ -> false | None -> true and project (k, v) = match project_opt k v with | Some v' -> (k, v') | None -> failwith "PArray.Alists.take_one: impossible" in match List.partition select parray with | [], other -> Nothing (List.map project other) | [(k, v)], other -> Single (k, v, List.map project other) | (k, v) :: _, _ -> Multiple (k, v, remove k parray) end include Alists module Test = struct open OUnit let project_single _ = function | [v] -> Some v | _ -> None let suite_take_one = "take_one" >::: [ "Nothing" >:: (fun () -> assert_equal (Nothing (of_pairs [(1, "1"); (3, "3")])) (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"])]))); "Single" >:: (fun () -> assert_equal (Single (2, ["2"; "2"], of_pairs [(1, "1"); (3, "3")])) (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"]); (2, ["2"; "2"])]))); "Multiple" >:: (fun () -> assert_equal (Multiple (2, ["2"; "2"], of_pairs [(1, ["1"]); (3, ["3"]); (4, [])])) (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"]); (2, ["2"; "2"]); (4, [])]))) ] let suite = "PArray" >::: [ suite_take_one ] end Index: trunk/omega/src/OUnit.ml =================================================================== --- trunk/omega/src/OUnit.ml (revision 8919) +++ trunk/omega/src/OUnit.ml (revision 8920) @@ -1,779 +1,779 @@ (* oUnit.ml -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) open Format (* TODO: really use Format in printf call. Most of the time, not * cuts/spaces/boxes are used *) let global_verbose = ref false let buff_printf f = let buff = Buffer.create 13 in let fmt = formatter_of_buffer buff in f fmt; pp_print_flush fmt (); Buffer.contents buff let bracket set_up f tear_down () = let fixture = set_up () in let () = try let () = f fixture in tear_down fixture with e -> let () = tear_down fixture in raise e in () let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f = bracket (fun () -> Filename.open_temp_file ?mode prefix suffix) f (fun (fn, chn) -> begin try close_out chn with _ -> () end; begin try Sys.remove fn with _ -> () end) exception Skip of string let skip_if b msg = if b then raise (Skip msg) exception Todo of string let todo msg = raise (Todo msg) let assert_failure msg = failwith ("OUnit: " ^ msg) let assert_bool msg b = if not b then assert_failure msg let assert_string str = if not (str = "") then assert_failure str let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = let get_error_string () = (* let max_len = pp_get_margin fmt () in *) (* let ellipsis_text = "[...]" in *) let print_ellipsis p fmt s = (* TODO: find a way to do this let res = p s in let len = String.length res in if diff <> None && len > max_len then begin let len_with_ellipsis = (max_len - (String.length ellipsis_text)) / 2 in (* TODO: we should use %a here to print values *) fprintf fmt "@[%s[...]%s@]" (String.sub res 0 len_with_ellipsis) (String.sub res (len - len_with_ellipsis) len_with_ellipsis) end else begin (* TODO: we should use %a here to print values *) fprintf fmt "@[%s@]" res end *) pp_print_string fmt (p s) in let res = buff_printf (fun fmt -> pp_open_vbox fmt 0; begin match msg with | Some s -> pp_open_box fmt 0; pp_print_string fmt s; pp_close_box fmt (); pp_print_cut fmt () | None -> () end; begin match printer with | Some p -> let p_ellipsis = print_ellipsis p in fprintf fmt "@[expected: @[%a@]@ but got: @[%a@]@]@," p_ellipsis expected p_ellipsis actual | None -> fprintf fmt "@[not equal@]@," end; begin match pp_diff with | Some d -> fprintf fmt "@[differences: %a@]@," d (expected, actual) | None -> () end; pp_close_box fmt ()) in let len = String.length res in if len > 0 && res.[len - 1] = '\n' then String.sub res 0 (len - 1) else res in if not (cmp expected actual) then assert_failure (get_error_string ()) let assert_command ?(exit_code=Unix.WEXITED 0) ?(use_stderr=true) ?env ?verbose prg args = let verbose = match verbose with | Some v -> v | None -> !global_verbose in bracket_tmpfile (fun (fn_out, chn_out) -> let cmd_print fmt = let () = match env with | Some e -> begin pp_print_string fmt "env"; Array.iter (fprintf fmt "@ %s") e; pp_print_space fmt () end | None -> () in pp_print_string fmt prg; List.iter (fprintf fmt "@ %s") args in (* Start the process *) let in_write = Unix.dup (Unix.descr_of_out_channel chn_out) in let (out_read, out_write) = Unix.pipe () in let err = if use_stderr then in_write else Unix.stderr in let args = Array.of_list (prg :: args) in let pid = Unix.set_close_on_exec out_write; if verbose then printf "@[Starting command '%t'@]\n" cmd_print; match env with | Some e -> Unix.create_process_env prg args e out_read in_write err | None -> Unix.create_process prg args out_read in_write err in let () = Unix.close out_read; Unix.close in_write in let _, real_exit_code = let rec wait_intr () = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> wait_intr () in wait_intr () in let exit_code_printer = function | Unix.WEXITED n -> Printf.sprintf "exit code %d" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %d" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %d" n in (* Dump process output to stderr *) if verbose then begin let chn = open_in fn_out in let buff = Bytes.make 4096 'X' in let len = ref (-1) in while !len <> 0 do len := input chn buff 0 (Bytes.length buff); printf "%s" (Bytes.sub_string buff 0 !len); done; printf "@?"; close_in chn end; (* Check process status *) assert_equal ~msg:(buff_printf (fun fmt -> fprintf fmt "@[Exit status of command '%t'@]" cmd_print)) ~printer:exit_code_printer exit_code real_exit_code) () let raises f = try - f (); + ignore (f ()); None with e -> Some e let assert_raises ?msg exn (f: unit -> 'a) = let pexn = Printexc.to_string in let get_error_string () = let str = Format.sprintf "expected exception %s, but no exception was raised." (pexn exn) in match msg with | None -> assert_failure str | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) in match raises f with | None -> assert_failure (get_error_string ()) | Some e -> assert_equal ?msg ~printer:pexn exn e (* Compare floats up to a given relative error *) let cmp_float ?(epsilon = 0.00001) a b = abs_float (a -. b) <= epsilon *. (abs_float a) || abs_float (a -. b) <= epsilon *. (abs_float b) (* Now some handy shorthands *) let (@?) = assert_bool (* The type of test function *) type test_fun = unit -> unit (* The type of tests *) type test = | TestCase of test_fun | TestList of test list | TestLabel of string * test (* Some shorthands which allows easy test construction *) let (>:) s t = TestLabel(s, t) (* infix *) let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = function | TestCase f -> TestCase (g f) | TestList tst_lst -> TestList (List.map (test_decorate g) tst_lst) | TestLabel (str, tst) -> TestLabel (str, test_decorate g tst) (* Return the number of available tests *) let rec test_case_count = function | TestCase _ -> 1 | TestLabel (_, t) -> test_case_count t | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l type node = | ListItem of int | Label of string type path = node list let string_of_node = function | ListItem n -> string_of_int n | Label s -> s let string_of_path path = String.concat ":" (List.rev_map string_of_node path) (* Some helper function, they are generally applicable *) (* Applies function f in turn to each element in list. Function f takes one element, and integer indicating its location in the list *) let mapi f l = let rec rmapi cnt l = match l with | [] -> [] | h :: t -> (f h cnt) :: (rmapi (cnt + 1) t) in rmapi 0 l let fold_lefti f accu l = let rec rfold_lefti cnt accup l = match l with | [] -> accup | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l (* Returns all possible paths in the test. The order is from test case to root *) let test_case_paths test = let rec tcps path test = match test with | TestCase _ -> [path] | TestList tests -> List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) | TestLabel (l, t) -> tcps ((Label l)::path) t in tcps [] test (* Test filtering with their path *) module SetTestPath = Set.Make(String) let test_filter ?(skip=false) only test = let set_test = List.fold_left (fun st str -> SetTestPath.add str st) SetTestPath.empty only in let rec filter_test path tst = if SetTestPath.mem (string_of_path path) set_test then begin Some tst end else begin match tst with | TestCase f -> begin if skip then Some (TestCase (fun () -> skip_if true "Test disabled"; f ())) else None end | TestList tst_lst -> begin let ntst_lst = fold_lefti (fun ntst_lst tst i -> let nntst_lst = match filter_test ((ListItem i) :: path) tst with | Some tst -> tst :: ntst_lst | None -> ntst_lst in nntst_lst) [] tst_lst in if not skip && ntst_lst = [] then None else Some (TestList (List.rev ntst_lst)) end | TestLabel (lbl, tst) -> begin let ntst_opt = filter_test ((Label lbl) :: path) tst in match ntst_opt with | Some ntst -> Some (TestLabel (lbl, ntst)) | None -> if skip then Some (TestLabel (lbl, tst)) else None end end in filter_test [] test (* The possible test results *) type test_result = | RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string -let is_success = +let _is_success = function | RSuccess _ -> true | RFailure _ | RError _ | RSkip _ | RTodo _ -> false let is_failure = function | RFailure _ -> true | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false let is_error = function | RError _ -> true | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false let is_skip = function | RSkip _ -> true | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false let is_todo = function | RTodo _ -> true | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false let result_flavour = function | RError _ -> "Error" | RFailure _ -> "Failure" | RSuccess _ -> "Success" | RSkip _ -> "Skip" | RTodo _ -> "Todo" let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg (* Returns true if the result list contains successes only *) let rec was_successful = function | [] -> true | RSuccess _::t | RSkip _::t -> was_successful t | RFailure _::_ | RError _::_ | RTodo _::_ -> false (* Events which can happen during testing *) type test_event = | EStart of path | EEnd of path | EResult of test_result let maybe_backtrace () = if Printexc.backtrace_status () then "\n" ^ Printexc.get_backtrace () else "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = let run_test_case f path = try f (); RSuccess path with - | Failure s -> + | Stdlib.Failure s -> RFailure (path, s ^ maybe_backtrace ()) | Skip s -> RSkip (path, s) | Todo s -> RTodo (path, s) | s -> RError (path, Printexc.to_string s ^ maybe_backtrace ()) in let rec run_test path results = function | TestCase(f) -> begin let result = - report (EStart path); - run_test_case f path + report (EStart path) |> ignore; + run_test_case f path in - report (EResult result); - report (EEnd path); + report (EResult result) |> ignore; + report (EEnd path) |> ignore; result::results end | TestList (tests) -> begin fold_lefti (fun results t cnt -> run_test ((ListItem cnt)::path) results t) results tests end | TestLabel (label, t) -> begin run_test ((Label label)::path) results t end in run_test [] [] test (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in (Unix.gettimeofday () -. begin_time, f x y) (* A simple (currently too simple) text based test runner *) let run_test_tt ?verbose test = let verbose = match verbose with | Some v -> v | None -> !global_verbose in let printf = Format.printf in let separator1 = String.make (get_margin ()) '=' in let separator2 = String.make (get_margin ()) '-' in let string_of_result = function | RSuccess _ -> if verbose then "ok\n" else "." | RFailure (_, _) -> if verbose then "FAIL\n" else "F" | RError (_, _) -> if verbose then "ERROR\n" else "E" | RSkip (_, _) -> if verbose then "SKIP\n" else "S" | RTodo (_, _) -> if verbose then "TODO\n" else "T" in let report_event = function | EStart p -> if verbose then printf "%s ...\n" (string_of_path p) | EEnd _ -> () | EResult result -> printf "%s@?" (string_of_result result) in let print_result_list results = List.iter (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" separator1 (result_flavour result) (string_of_path (result_path result)) (result_msg result) separator2) results in (* Now start the test *) let running_time, results = time_fun perform_test report_event test in let errors = List.filter is_error results in let failures = List.filter is_failure results in let skips = List.filter is_skip results in let todos = List.filter is_todo results in if not verbose then printf "\n"; (* Print test report *) print_result_list errors; print_result_list failures; printf "Ran: %d tests in: %.2f seconds.\n" (List.length results) running_time; (* Print final verdict *) if was_successful results then ( if skips = [] then printf "OK" else printf "OK: Cases: %d Skip: %d\n" (test_case_count test) (List.length skips) ) else printf "FAILED: Cases: %d Tried: %d Errors: %d \ Failures: %d Skip:%d Todo:%d\n" (test_case_count test) (List.length results) (List.length errors) (List.length failures) (List.length skips) (List.length todos); (* Return the results possibly for further processing *) results (* Call this one from you test suites *) let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = let only_test = ref [] in let () = Arg.parse (Arg.align [ "-verbose", Arg.Set global_verbose, " Run the test in verbose mode."; "-only-test", Arg.String (fun str -> only_test := str :: !only_test), "path Run only the selected test"; "-list-test", Arg.Unit (fun () -> List.iter (fun pth -> print_endline (string_of_path pth)) (test_case_paths suite); exit 0), " List tests"; ] @ arg_specs ) (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*") in let nsuite = if !only_test = [] then suite else begin match test_filter ~skip:true !only_test suite with | Some test -> test | None -> failwith ("Filtering test "^ (String.concat ", " !only_test)^ " lead to no test") end in let result = set_verbose !global_verbose; run_test_tt ~verbose:!global_verbose nsuite in if not (was_successful result) then exit 1 else result Index: trunk/omega/src/momentum.ml =================================================================== --- trunk/omega/src/momentum.ml (revision 8919) +++ trunk/omega/src/momentum.ml (revision 8920) @@ -1,732 +1,724 @@ (* momentum.ml -- Copyright (C) 1999-2024 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 t val of_ints : int -> int list -> t exception Duplicate of int exception Range of int exception Mismatch of string * t * t exception Negative val to_ints : t -> int list val dim : t -> int val rank : t -> int val singleton : int -> int -> t val zero : int -> t val compare : t -> t -> int val neg : t -> t val abs : t -> t val add : t -> t -> t val sub : t -> t -> t val try_add : t -> t -> t option val try_sub : t -> t -> t option val less : t -> t -> bool val lesseq : t -> t -> bool val try_fusion : t -> t -> t -> (bool * bool) option val to_string : t -> string val split : int -> int -> t -> t module Scattering : sig val incoming : t -> bool val outgoing : t -> bool val timelike : t -> bool val spacelike : t -> bool val s_channel_in : t -> bool val s_channel_out : t -> bool val s_channel : t -> bool val flip_s_channel_in : t -> t end module Decay : sig val incoming : t -> bool val outgoing : t -> bool val timelike : t -> bool val spacelike : t -> bool end end (* \thocwmodulesection{Lists of Integers} *) (* The first implementation (as part of [Fusion]) was based on sorted lists, because I did not want to preclude the use of more general indices that integers. However, there's probably not much use for this generality (the indices are typically generated automatically and integer are the most natural choice) and it is no longer supported. by the current signature. Thus one can also use the more efficient implementation based on bitvectors below. *) module Lists = struct type t = { d : int; r : int; p : int list } exception Range of int exception Duplicate of int let rec check d = function | p1 :: p2 :: _ when p2 <= p1 -> raise (Duplicate p1) - | p1 :: (p2 :: _ as rest) -> check d rest + | _ :: (_ :: _ as rest) -> check d rest | [p] when p < 1 || p > d -> raise (Range p) - | [p] -> () + | [_] -> () | [] -> () let of_ints d p = let p' = List.sort compare p in check d p'; { d = d; r = List.length p; p = p' } let to_ints p = p.p let dim p = p.d let rank p = p.r let zero d = { d = d; r = 0; p = [] } let singleton d p = { d = d; r = 1; p = [p] } let to_string p = "[" ^ String.concat "," (List.map string_of_int p.p) ^ "/" ^ string_of_int p.r ^ "/" ^ string_of_int p.d ^ "]" exception Mismatch of string * t * t let mismatch s p1 p2 = raise (Mismatch (s, p1, p2)) - let matching f s p1 p2 = + let _matching f s p1 p2 = if p1.d = p2.d then f p1 p2 else mismatch s p1 p2 let compare p1 p2 = if p1.d = p2.d then begin let c = compare p1.r p2.r in if c <> 0 then c else compare p1.p p2.p end else mismatch "compare" p1 p2 let rec neg' d i = function | [] -> if i <= d then i :: neg' d (succ i) [] else [] | i' :: rest as p -> if i' > d then failwith "Integer_List.neg: internal error" else if i' = i then neg' d (succ i) rest else i :: neg' d (succ i) p let neg p = { d = p.d; r = p.d - p.r; p = neg' p.d 1 p.p } let abs p = if 2 * p.r > p.d then neg p else p let rec add' p1 p2 = match p1, p2 with | [], p -> p | p, [] -> p | x1 :: p1', x2 :: p2' -> if x1 < x2 then x1 :: add' p1' p2 else if x2 < x1 then x2 :: add' p1 p2' else raise (Duplicate x1) let add p1 p2 = if p1.d = p2.d then { d = p1.d; r = p1.r + p2.r; p = add' p1.p p2.p } else mismatch "add" p1 p2 let rec try_add' d r acc p1 p2 = match p1, p2 with | [], p -> Some ({ d = d; r = r; p = List.rev_append acc p }) | p, [] -> Some ({ d = d; r = r; p = List.rev_append acc p }) | x1 :: p1', x2 :: p2' -> if x1 < x2 then try_add' d r (x1 :: acc) p1' p2 else if x2 < x1 then try_add' d r (x2 :: acc) p1 p2' else None let try_add p1 p2 = if p1.d = p2.d then try_add' p1.d (p1.r + p2.r) [] p1.p p2.p else mismatch "try_add" p1 p2 exception Negative let rec sub' p1 p2 = match p1, p2 with | p, [] -> p | [], _ -> raise Negative | x1 :: p1', x2 :: p2' -> if x1 < x2 then x1 :: sub' p1' p2 else if x1 = x2 then sub' p1' p2' else raise Negative let rec sub p1 p2 = if p1.d = p2.d then begin if p1.r >= p2.r then { d = p1.d; r = p1.r - p2.r; p = sub' p1.p p2.p } else neg (sub p2 p1) end else mismatch "sub" p1 p2 let rec try_sub' d r acc p1 p2 = match p1, p2 with | p, [] -> Some ({ d = d; r = r; p = List.rev_append acc p }) | [], _ -> None | x1 :: p1', x2 :: p2' -> if x1 < x2 then try_sub' d r (x1 :: acc) p1' p2 else if x1 = x2 then try_sub' d r acc p1' p2' else None let try_sub p1 p2 = if p1.d = p2.d then begin if p1.r >= p2.r then try_sub' p1.d (p1.r - p2.r) [] p1.p p2.p else match try_sub' p1.d (p2.r - p1.r) [] p2.p p1.p with | None -> None | Some p -> Some (neg p) end else mismatch "try_sub" p1 p2 let rec less' equal p1 p2 = match p1, p2 with | [], [] -> not equal | [], _ -> true - | x1 :: _ , [] -> false + | _ :: _ , [] -> false | x1 :: p1', x2 :: p2' when x1 = x2 -> less' equal p1' p2' - | x1 :: p1', x2 :: p2' -> less' false p1 p2' + | _ :: _, _ :: p2' -> less' false p1 p2' let less p1 p2 = if p1.d = p2.d then less' true p1.p p2.p else mismatch "sub" p1 p2 let rec lesseq' p1 p2 = match p1, p2 with | [], _ -> true - | x1 :: _ , [] -> false + | _ :: _ , [] -> false | x1 :: p1', x2 :: p2' when x1 = x2 -> lesseq' p1' p2' - | x1 :: p1', x2 :: p2' -> lesseq' p1 p2' + | _ :: _, _ :: p2' -> lesseq' p1 p2' let lesseq p1 p2 = if p1.d = p2.d then lesseq' p1.p p2.p else mismatch "lesseq" p1 p2 module Scattering = struct let incoming p = if p.r = 1 then match p.p with | [1] | [2] -> true | _ -> false else false let outgoing p = if p.r = 1 then match p.p with | [1] | [2] -> false | _ -> true else false let s_channel_in p = match p.p with | [1; 2] -> true | _ -> false let rec s_channel_out' d i = function | [] -> i = succ d | i' :: p when i' = i -> s_channel_out' d (succ i) p | _ -> false let s_channel_out p = match p.p with | 3 :: p' -> s_channel_out' p.d 4 p' | _ -> false let s_channel p = s_channel_in p || s_channel_out p let timelike p = match p.p with | p1 :: p2 :: _ -> p1 > 2 || (p1 = 1 && p2 = 2) | p1 :: _ -> p1 > 2 | [] -> false let spacelike p = not (timelike p) let flip_s_channel_in p = if s_channel_in p then neg (of_ints p.d [1;2]) else p end module Decay = struct let incoming p = if p.r = 1 then match p.p with | [1] -> true | _ -> false else false let outgoing p = if p.r = 1 then match p.p with | [1] -> false | _ -> true else false let timelike p = match p.p with | [1] -> true | p1 :: _ -> p1 > 1 | [] -> false let spacelike p = not (timelike p) end let test_sum p inv1 p1 inv2 p2 = if p.d = p1.d then begin if p.d = p2.d then begin match (if inv1 then try_add else try_sub) p p1 with | None -> false | Some p' -> begin match (if inv2 then try_add else try_sub) p' p2 with | None -> false | Some p'' -> p''.r = 0 || p''.r = p.d end end else mismatch "test_sum" p p2 end else mismatch "test_sum" p p1 let try_fusion p p1 p2 = if test_sum p false p1 false p2 then Some (false, false) else if test_sum p true p1 false p2 then Some (true, false) else if test_sum p false p1 true p2 then Some (false, true) else if test_sum p true p1 true p2 then Some (true, true) else None let split i n p = let n' = n - 1 in let rec split' head = function | [] -> (p.r, List.rev head) | i1 :: ilist -> if i1 < i then split' (i1 :: head) ilist else if i1 > i then (p.r, List.rev_append head (List.map ((+) n') (i1 :: ilist))) else (p.r + n', List.rev_append head ((ThoList.range i1 (i1 + n')) @ (List.map ((+) n') ilist))) in let r', p' = split' [] p.p in { d = p.d + n'; r = r'; p = p' } end (* \thocwmodulesection{Bit Fiddlings} *) (* Bit vectors are popular in Fortran based implementations~\cite{ALPHA:1997,HELAC:2000,Kilian:WHIZARD} and can be more efficient. In particular, when all infomation is packed into a single integer, much of the memory overhead is reduced. *) module Bits = struct type t = int (* Bits $1\ldots21$ are used as a bitvector, indicating whether a particular momentum is included. Bits $22\ldots26$ represent the numbers of bits set in bits $1\ldots21$ and bits $27\ldots31$ denote the maximum number of momenta. *) let mask n = (1 lsl n) - 1 - let mask2 = mask 2 + let _mask2 = mask 2 let mask5 = mask 5 let mask21 = mask 21 let maskd = mask5 lsl 26 let maskr = mask5 lsl 21 let maskb = mask21 let dim0 p = p land maskd let rank0 p = p land maskr let bits0 p = p land maskb let dim p = (dim0 p) lsr 26 let rank p = (rank0 p) lsr 21 let bits p = bits0 p let drb0 d r b = d lor r lor b let drb d r b = d lsl 26 lor r lsl 21 lor b (* For a 64-bit architecture, the corresponding sizes could be increased to $1\ldots51$, $52\ldots57$, and $58\ldots63$. However, the combinatorical complexity will have killed us long before we can reach these values. *) exception Range of int exception Duplicate of int exception Mismatch of string * t * t let mismatch s p1 p2 = raise (Mismatch (s, p1, p2)) let of_ints d p = let r = List.length p in if d <= 21 && r <= 21 then begin List.fold_left (fun b p' -> if p' <= d then b lor (1 lsl (pred p')) else raise (Range p')) (drb d r 0) p end else raise (Range r) let zero d = drb d 0 0 let singleton d p = drb d 1 (1 lsl (pred p)) let rec to_ints' acc p b = if b = 0 then List.rev acc else if (b land 1) = 1 then to_ints' (p :: acc) (succ p) (b lsr 1) else to_ints' acc (succ p) (b lsr 1) let to_ints p = to_ints' [] 1 (bits p) let to_string p = "[" ^ String.concat "," (List.map string_of_int (to_ints p)) ^ "/" ^ string_of_int (rank p) ^ "/" ^ string_of_int (dim p) ^ "]" let compare p1 p2 = if dim0 p1 = dim0 p2 then begin let c = compare (rank0 p1) (rank0 p2) in if c <> 0 then c else compare (bits p1) (bits p2) end else mismatch "compare" p1 p2 let neg p = let d = dim p and r = rank p in drb d (d - r) ((mask d) land (lnot p)) let abs p = if 2 * (rank p) > dim p then neg p else p let add p1 p2 = let d1 = dim0 p1 and d2 = dim0 p2 in if d1 = d2 then begin let b1 = bits p1 and b2 = bits p2 in if b1 land b2 = 0 then drb0 d1 (rank0 p1 + rank0 p2) (b1 lor b2) else raise (Duplicate 0) end else mismatch "add" p1 p2 exception Negative let rec sub p1 p2 = let d1 = dim0 p1 and d2 = dim0 p2 in if d1 = d2 then begin let r1 = rank0 p1 and r2 = rank0 p2 in if r1 >= r2 then begin let b1 = bits p1 and b2 = bits p2 in if b1 lor b2 = b1 then drb0 d1 (r1 - r2) (b1 lxor b2) else raise Negative end else neg (sub p2 p1) end else mismatch "sub" p1 p2 let try_add p1 p2 = let d1 = dim0 p1 and d2 = dim0 p2 in if d1 = d2 then begin let b1 = bits p1 and b2 = bits p2 in if b1 land b2 = 0 then Some (drb0 d1 (rank0 p1 + rank0 p2) (b1 lor b2)) else None end else mismatch "try_add" p1 p2 let rec try_sub p1 p2 = let d1 = dim0 p1 and d2 = dim0 p2 in if d1 = d2 then begin let r1 = rank0 p1 and r2 = rank0 p2 in if r1 >= r2 then begin let b1 = bits p1 and b2 = bits p2 in if b1 lor b2 = b1 then Some (drb0 d1 (r1 - r2) (b1 lxor b2)) else None end else begin match try_sub p2 p1 with | Some p -> Some (neg p) | None -> None end end else mismatch "sub" p1 p2 let lesseq p1 p2 = let d1 = dim0 p1 and d2 = dim0 p2 in if d1 = d2 then begin let r1 = rank0 p1 and r2 = rank0 p2 in if r1 <= r2 then begin let b1 = bits p1 and b2 = bits p2 in b1 lor b2 = b2 end else false end else mismatch "less" p1 p2 let less p1 p2 = p1 <> p2 && lesseq p1 p2 let mask_in1 = 1 let mask_in2 = 2 let mask_in = mask_in1 lor mask_in2 module Scattering = struct let incoming p = rank p = 1 && (mask_in land p <> 0) let outgoing p = rank p = 1 && (mask_in land p = 0) let timelike p = (rank p > 0 && (mask_in land p = 0)) || (bits p = mask_in) let spacelike p = (rank p > 0) && not (timelike p) let s_channel_in p = bits p = mask_in let s_channel_out p = rank p > 0 && (mask_in lxor p = 0) let s_channel p = s_channel_in p || s_channel_out p let flip_s_channel_in p = if s_channel_in p then neg p else p end module Decay = struct let incoming p = rank p = 1 && (mask_in1 land p = mask_in1) let outgoing p = rank p = 1 && (mask_in1 land p = 0) let timelike p = incoming p || (rank p > 0 && mask_in1 land p = 0) let spacelike p = not (timelike p) end let test_sum p inv1 p1 inv2 p2 = let d = dim p in if d = dim p1 then begin if d = dim p2 then begin match (if inv1 then try_add else try_sub) p p1 with | None -> false | Some p' -> begin match (if inv2 then try_add else try_sub) p' p2 with | None -> false | Some p'' -> let r = rank p'' in r = 0 || r = d end end else mismatch "test_sum" p p2 end else mismatch "test_sum" p p1 let try_fusion p p1 p2 = if test_sum p false p1 false p2 then Some (false, false) else if test_sum p true p1 false p2 then Some (true, false) else if test_sum p false p1 true p2 then Some (false, true) else if test_sum p true p1 true p2 then Some (true, true) else None (* First create a gap of size~$n-1$ and subsequently fill it if and only if the bit~$i$ was set. *) let split i n p = let delta_d = n - 1 and b = bits p in let mask_low = mask (pred i) and mask_i = 1 lsl (pred i) and mask_high = lnot (mask i) in let b_low = mask_low land b and b_med, delta_r = if mask_i land b <> 0 then ((mask n) lsl (pred i), delta_d) else (0, 0) and b_high = if delta_d > 0 then (mask_high land b) lsl delta_d else if delta_d = 0 then mask_high land b else (mask_high land b) lsr (-delta_d) in drb (dim p + delta_d) (rank p + delta_r) (b_low lor b_med lor b_high) end (* \thocwmodulesection{Whizard} *) module type Whizard = sig type t val of_momentum : t -> int val to_momentum : int -> int -> t end module BitsW = struct type t = Bits.t open Bits (* NB: this includes the internal functions not in [T]! *) let of_momentum p = let d = dim p in let bit_in1 = 1 land p and bit_in2 = 1 land (p lsr 1) and bits_out = ((mask d) land p) lsr 2 in bits_out lor (bit_in1 lsl (d - 1)) lor (bit_in2 lsl (d - 2)) let rec count_non_zero' acc i last b = if i > last then acc else if (1 lsl (pred i)) land b = 0 then count_non_zero' acc (succ i) last b else count_non_zero' (succ acc) (succ i) last b let count_non_zero first last b = count_non_zero' 0 first last b let to_momentum d w = let bit_in1 = 1 land (w lsr (d - 1)) and bit_in2 = 1 land (w lsr (d - 2)) and bits_out = (mask (d - 2)) land w in let b = (bits_out lsl 2) lor bit_in1 lor (bit_in2 lsl 1) in drb d (count_non_zero 1 d b) b end (* The following would be a tad more efficient, if coded directly, but there's no point in wasting effort on this. *) module ListsW = struct type t = Lists.t let of_momentum p = BitsW.of_momentum (Bits.of_ints p.Lists.d p.Lists.p) let to_momentum d w = Lists.of_ints d (Bits.to_ints (BitsW.to_momentum d w)) end (* \thocwmodulesection{Suggesting a Default Implementation} *) (* [Lists] is better tested, but the more recent [Bits] appears to work as well and is \emph{much} more efficient, resulting in a relative factor of better than 2. This performance ratio is larger than I had expected and we are not likely to reach its limit of 21 independent vectors anyway. *) module Default = Bits module DefaultW = BitsW - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/tuple.mli =================================================================== --- trunk/omega/src/tuple.mli (revision 8919) +++ trunk/omega/src/tuple.mli (revision 8920) @@ -1,223 +1,215 @@ (* tuple.mli -- Copyright (C) 1999-2024 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 [Tuple.Poly] interface abstracts the notion of tuples with variable arity. Simple cases are binary polytuples, which are simply pairs and indefinite polytuples, which are nothing but lists. Another example is the union of pairs and triples. The interface is very similar to [List] from the O'Caml standard library, but the [Tuple.Poly] signature allows a more fine grained control of arities. The latter provides typesafe linking of models, targets and topologies. *) module type Mono = sig type 'a t (* The size of the tuple, i.\,e.~[arity (a1,a2,a3) = 3]. *) val arity : 'a t -> int (* The maximum size of tuples supported by the module. A negative value means that there is no limit. In this case the functions [power] and [power_fold] may raise the exception [No_termination]. *) val max_arity : unit -> int val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val for_all : ('a -> bool) -> 'a t -> bool val map : ('a -> 'b) -> 'a t -> 'b t val iter : ('a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (* We have applications, where no sensible intial value can be defined: *) val fold_left_internal : ('a -> 'a -> 'a) -> 'a t -> 'a val fold_right_internal : ('a -> 'a -> 'a) -> 'a t -> 'a val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val split : ('a * 'b) t -> 'a t * 'b t (* The distributive tensor product expands a tuple of lists into list of tuples, e.\,g.~for binary tuples: \begin{equation} \ocwlowerid{product}\, (\lbrack x_1;x_2\rbrack,\lbrack y_1;y_2\rbrack) = \lbrack (x_1,y_1);(x_1,y_2);(x_2,y_1);(x_2,y_2)\rbrack \end{equation} NB: [product_fold] is usually much more memory efficient than the combination of [product] and [List.fold_right] for large sets. *) val product : 'a list t -> 'a t list val product_fold : ('a t -> 'b -> 'b) -> 'a list t -> 'b -> 'b (* For homogeneous tuples the [power] function could trivially be built from [product], e.\,g.: \begin{equation} \ocwlowerid{power}\,\lbrack x_1;x_2\rbrack = \ocwlowerid{product}\,(\lbrack x_1;x_2\rbrack,\lbrack x_1;x_2\rbrack) = \lbrack (x_1,x_1);(x_1,x_2);(x_2,x_1);(x_2,x_2)\rbrack \end{equation} but it is also well defined for polytuples, e.\,g.~for pairs and triples \begin{equation} \ocwlowerid{power}\,\lbrack x_1;x_2\rbrack = \ocwlowerid{product}\,(\lbrack x_1;x_2\rbrack,\lbrack x_1;x_2\rbrack) \cup \ocwlowerid{product}\, (\lbrack x_1;x_2\rbrack,\lbrack x_1;x_2\rbrack,\lbrack x_1;x_2\rbrack) \end{equation} For tuples and polytuples with bounded arity, the [power] and [power_fold] functions terminate. In polytuples with unbounded arity, the the [power] function raises [No_termination] unless a limit is given by [?truncate]. [power_fold] also raises [No_termination], but could be changed to run until the argument function raises an exception. However, if we need this behaviour, we should probably implement [power_iter] instead. *) val power : ?truncate:int -> 'a list -> 'a t list val power_fold : ?truncate:int -> ('a t -> 'b -> 'b) -> 'a list -> 'b -> 'b (* We can also identify all (poly)tuples with permuted elements and return only one representative, e.\,g.: \begin{equation} \ocwlowerid{sym\_power}\,\lbrack x_1;x_2\rbrack = \lbrack (x_1,x_1);(x_1,x_2);(x_2,x_2)\rbrack \end{equation} NB: this function has not yet been implemented, because O'Mega only needs the more efficient special case [graded_sym_power]. *) (* If a set $X$ is graded (i.\,e.~there is a map $\phi:X\to\mathbf{N}$, called [rank] below), the results of [power] or [sym_power] can canonically be filtered by requiring that the sum of the ranks in each (poly)tuple has one chosen value. Implementing such a function directly is much more efficient than constructing and subsequently disregarding many (poly)tuples. The elements of rank $n$ are at offset $(n-1)$ in the array. The array is assumed to be \emph{immutable}, even if O'Caml doesn't support immutable arrays. NB: [graded_power] has not yet been implemented, because O'Mega only needs [graded_sym_power]. *) type 'a graded = 'a list array val graded_sym_power : int -> 'a graded -> 'a t list val graded_sym_power_fold : int -> ('a t -> 'b -> 'b) -> 'a graded -> 'b -> 'b (* \begin{dubious} We hope to be able to avoid the next one in the long run, because it mildly breaks typesafety for arities. Unfortunately, we're still working on it \ldots \end{dubious} *) val to_list : 'a t -> 'a list (* \begin{dubious} The next one is only used for Fermi statistics in the obsolescent [Fusion_vintage] module below, but can not be implemented if there are no binary tuples. It must be retired as soon as possible. \end{dubious} *) val of2_kludge : 'a -> 'a -> 'a t end module type Poly = sig include Mono exception Mismatched_arity exception No_termination end module type Binary = sig include Poly (* should become [Mono]! *) val of2 : 'a -> 'a -> 'a t end module Binary : Binary module type Ternary = sig include Mono val of3 : 'a -> 'a -> 'a -> 'a t end module Ternary : Ternary type 'a pair_or_triple = T2 of 'a * 'a | T3 of 'a * 'a *'a module type Mixed23 = sig include Poly val of2 : 'a -> 'a -> 'a t val of3 : 'a -> 'a -> 'a -> 'a t end module Mixed23 : Mixed23 module type Nary = sig include Poly val of2 : 'a -> 'a -> 'a t val of3 : 'a -> 'a -> 'a -> 'a t val of_list : 'a list -> 'a t end module Unbounded_Nary : Nary (* \begin{dubious} It seemed like a good idea, but hardcoding [max_arity] here prevents optimizations for processes with fewer external particles than [max_arity]. For [max_arity >= 8] things become bad! Need to implement a truncating version of [power] and [power_fold]. \end{dubious} *) module type Bound = sig val max_arity : unit -> int end module Nary (B: Bound) : Nary (* \begin{dubious} For compleneteness sake, we could add most of the [List] signature \begin{itemize} \item{} [val length : 'a t -> int] \item{} [val hd : 'a t -> 'a] \item{} [val nth : 'a t -> int -> 'a] \item{} [val rev : 'a t -> 'a t] \item{} [val rev_map : ('a -> 'b) -> 'a t -> 'b t] \item{} [val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit] \item{} [val rev_map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t] \item{} [val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b t -> 'c t -> 'a] \item{} [val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a t -> 'b t -> 'c -> 'c] \item{} [val exists : ('a -> bool) -> 'a t -> bool] \item{} [val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool] \item{} [val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool] \item{} [val mem : 'a -> 'a t -> bool] \item{} [val memq : 'a -> 'a t -> bool] \item{} [val find : ('a -> bool) -> 'a t -> 'a] \item{} [val find_all : ('a -> bool) -> 'a t -> 'a list] \item{} [val assoc : 'a -> ('a * 'b) t -> 'b] \item{} [val assq : 'a -> ('a * 'b) t -> 'b] \item{} [val mem_assoc : 'a -> ('a * 'b) t -> bool] \item{} [val mem_assq : 'a -> ('a * 'b) t -> bool] \item{} [val combine : 'a t -> 'b t -> ('a * 'b) t] \item{} [val sort : ('a -> 'a -> int) -> 'a t -> 'a t] \item{} [val stable_sort : ('a -> 'a -> int) -> 'a t -> 'a t] \end{itemize} \end{dubious} but only if we ever have too much time on our hand \ldots *) - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/Makefile.am =================================================================== --- trunk/omega/src/Makefile.am (revision 8919) +++ trunk/omega/src/Makefile.am (revision 8920) @@ -1,217 +1,216 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2024 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. # ######################################################################## # Build the O'Mega Fortran library using libtool # (?use pkglib_ instead of lib_ to make the -rpath and *.lai business work ...) lib_LTLIBRARIES = libomega_core.la execmoddir = $(fmoddir)/omega nodist_execmod_HEADERS = $(OMEGALIB_MOD) libomega_core_la_SOURCES = $(OMEGALIB_F90) EXTRA_DIST = \ $(OMEGA_CONFIG_MLI) $(OMEGA_CAML) \ omegalib.nw $(OMEGALIB_F90) OMEGA_CMXA = omega_core.cmxa omega_targets.cmxa omega_models.cmxa OMEGA_CMA = $(OMEGA_CMXA:.cmxa=.cma) if OCAML_AVAILABLE all-local: $(OMEGA_CMXA) $(OMEGA_APPLICATIONS_CMX) bytecode: $(OMEGA_CMA) $(OMEGA_APPLICATIONS_CMO) else all-local: bytecode: endif # Compiled interfaces and libraries for out-of-tree compilation of models if OCAML_AVAILABLE camllibdir = $(libdir)/omega/caml nodist_camllib_DATA = \ - omega.cmi fusion.cmi targets.cmi coupling.cmi modeltools.cmi color.cmi \ - options.cmi model.cmi \ + omega.cmi fusion.cmi targets.cmi modeltools.cmi color.cmi options.cmi \ omega_core.cmxa omega_core.a omega_targets.cmxa omega_targets.a \ charges.cmi endif ######################################################################## include $(top_srcdir)/omega/src/Makefile.ocaml include $(top_srcdir)/omega/src/Makefile.sources if OCAML_AVAILABLE config.cmo config.cmx: config.cmi omega_core.a: omega_core.cmxa omega_core.cmxa: $(OMEGA_CORE_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_core.cma: $(OMEGA_CORE_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ omega_targets.a: omega_targets.cmxa omega_targets.cmxa: $(OMEGA_TARGETS_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_targets.cma: $(OMEGA_TARGETS_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ omega_models.cmxa: $(OMEGA_MODELS_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_models.cma: $(OMEGA_MODELS_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ orders_lexer.mli: orders_lexer.ml orders_parser.cmi $(OCAMLC) -i $< | $(GREP) 'val token' >$@ cascade_lexer.mli: cascade_lexer.ml cascade_parser.cmi $(OCAMLC) -i $< | $(GREP) 'val token' >$@ vertex_lexer.mli: vertex_lexer.ml vertex_parser.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ UFO_lexer.mli: UFO_lexer.ml UFO_parser.cmi UFO_tools.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ UFOx_lexer.mli: UFOx_lexer.ml UFOx_parser.cmi UFO_tools.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ endif MYPRECIOUS = $(OMEGA_DERIVED_CAML) SUFFIXES += .lo .$(FCMOD) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ ######################################################################## DISTCLEANFILES = kinds.f90 if NOWEB_AVAILABLE omegalib.stamp: $(srcdir)/omegalib.nw @rm -f omegalib.tmp @touch omegalib.tmp for src in $(OMEGALIB_DERIVED_F90); do \ $(NOTANGLE) -R[[$$src]] $< | $(CPIF) $$src; \ done @mv -f omegalib.tmp omegalib.stamp $(OMEGALIB_DERIVED_F90): omegalib.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f omegalib.stamp; \ $(MAKE) $(AM_MAKEFLAGS) omegalib.stamp; \ fi DISTCLEANFILES += $(OMEGALIB_DERIVED_F90) endif NOWEB_AVAILABLE MYPRECIOUS += $(OMEGALIB_DERIVED_F90) ######################################################################## # The following line just says # include Makefile.depend_fortran # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE ######################################################################## @am__include@ @am__quote@Makefile.depend_fortran@am__quote@ Makefile.depend_fortran: kinds.f90 $(libomega_core_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -e 's/, *only:.*//' \ -e 's/, *&//' \ -e 's/, *.*=>.*//' \ -e 's/ *$$/.lo/' ; \ done > $@ DISTCLEANFILES += Makefile.depend_fortran if OCAML_AVAILABLE @am__include@ @am__quote@Makefile.depend_ocaml@am__quote@ PARSERS = orders cascade vertex UFO UFOx Makefile.depend_ocaml: $(OMEGA_CAML_PRIMARY) @if $(AM_V_P); then :; else echo " OCAMLDEP " $@; fi @rm -f $@ $(AM_V_at)$(OCAMLDEP) -I $(srcdir) $^ $(OMEGA_DERIVED_CAML) \ | sed 's,[^ ]*/,,g' > $@ $(AM_V_at)for parser in $(PARSERS); do \ echo $${parser}.cmi: $${parser}_lexer.cmi; \ echo $${parser}_lexer.cmi: $${parser}_parser.cmi; \ echo $${parser}_parser.cmi: $${parser}_syntax.cmi; \ echo $${parser}_parser.mli: $${parser}_parser.ml; \ echo $${parser}.cmo: $${parser}.cmi; \ echo $${parser}.cmx: $${parser}.cmi $${parser}_lexer.cmx; \ echo $${parser}_lexer.cmo: $${parser}_lexer.cmi; \ echo $${parser}_lexer.cmx: $${parser}_lexer.cmi $${parser}_parser.cmx; \ echo $${parser}_parser.cmo: $${parser}_parser.cmi $${parser}_syntax.cmi; \ echo $${parser}_parser.cmx: $${parser}_parser.cmi \ $${parser}_syntax.cmi $${parser}_syntax.cmx; \ done >>$@ DISTCLEANFILES += Makefile.depend_ocaml endif OCAML_AVAILABLE ######################################################################## # Don't trigger remakes by deleting intermediate files. .PRECIOUS = $(MYPRECIOUS) clean-local: rm -f *.cm[aiox] *.cmxa *.[ao] *.l[oa] *.$(FCMOD) \ $(OMEGA_DERIVED_CAML) omegalib.stamp if FC_SUBMODULES -rm -f *.smod endif distclean-local: -test "$(srcdir)" != "." && rm -f config.mli ######################################################################## ## The End. ######################################################################## Index: trunk/omega/src/permutation.ml =================================================================== --- trunk/omega/src/permutation.ml (revision 8919) +++ trunk/omega/src/permutation.ml (revision 8920) @@ -1,378 +1,378 @@ (* permutation.ml -- Copyright (C) 1999-2024 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 of_lists : 'a list -> 'a list -> t val inverse : t -> t val compose : t -> t -> t val compose_inv : t -> t -> t val list : t -> 'a list -> 'a list val array : t -> 'a array -> 'a array val all : int -> t list val even : int -> t list val odd : int -> t list val cyclic : int -> t list val signed : int -> (int * t) list val to_string : t -> string end let same_elements l1 l2 = List.sort compare l1 = List.sort compare l2 module PM = Pmap.Tree let offset_map l = let _, offsets = List.fold_left (fun (i, map) a -> (succ i, PM.add compare a i map)) (0, PM.empty) l in offsets (* TODO: this algorithm fails if the lists contain duplicate elements. *) let of_lists_list l l' = if same_elements l l' then let offsets' = offset_map l' in let _, p_rev = List.fold_left (fun (i, acc) a -> (succ i, PM.find compare a offsets' :: acc)) (0, []) l in List.rev p_rev else invalid_arg "Permutation.of_lists: incompatible lists" module Using_Lists : T = struct type t = int list let of_list p = if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then invalid_arg "Permutation.of_list" else p let of_array p = try of_list (Array.to_list p) with | Invalid_argument s -> if s = "Permutation.of_list" then invalid_arg "Permutation.of_array" else failwith ("Permutation.of_array: unexpected Invalid_argument(" ^ s ^ ")") let of_lists = of_lists_list let inverse p = snd (ThoList.ariadne_sort p) let list p l = List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) (try List.rev_map2 (fun i x -> (i, x)) p l with | Invalid_argument s -> if s = "List.rev_map2" then invalid_arg "Permutation.list: length mismatch" else failwith ("Permutation.list: unexpected Invalid_argument(" ^ s ^ ")"))) let array p a = try Array.of_list (list p (Array.to_list a)) with | Invalid_argument s -> if s = "Permutation.list: length mismatch" then invalid_arg "Permutation.array: length mismatch" else failwith ("Permutation.array: unexpected Invalid_argument(" ^ s ^ ")") let compose_inv p q = list q p (* Probably not optimal (or really inefficient), but correct by associativity. *) let compose p q = list (inverse q) p let all n = List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n))) let even n = List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n))) let odd n = List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n))) let cyclic n = List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n))) let signed n = List.map (fun (eps, l) -> (eps, of_list l)) (Combinatorics.permute_signed (ThoList.range 0 (pred n))) let to_string p = String.concat "" (List.map string_of_int p) end module Using_Arrays : T = struct type t = int array let of_list p = if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then invalid_arg "Permutation.of_list" else Array.of_list p let of_array p = try of_list (Array.to_list p) with | Invalid_argument s -> if s = "Permutation.of_list" then invalid_arg "Permutation.of_array" else failwith ("Permutation.of_array: unexpected Invalid_argument(" ^ s ^ ")") let of_lists l l' = Array.of_list (of_lists_list l l') let inverse p = let len_p = Array.length p in let p' = Array.make len_p p.(0) in for i = 0 to pred len_p do p'.(p.(i)) <- i done; p' let array p a = let len_a = Array.length a and len_p = Array.length p in if len_a <> len_p then invalid_arg "Permutation.array: length mismatch"; let a' = Array.make len_a a.(0) in for i = 0 to pred len_a do a'.(p.(i)) <- a.(i) done; a' let list p l = try Array.to_list (array p (Array.of_list l)) with | Invalid_argument s -> if s = "Permutation.array: length mismatch" then invalid_arg "Permutation.list: length mismatch" else failwith ("Permutation.list: unexpected Invalid_argument(" ^ s ^ ")") let compose_inv p q = array q p let compose p q = array (inverse q) p let all n = List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n))) let even n = List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n))) let odd n = List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n))) let cyclic n = List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n))) let signed n = List.map (fun (eps, l) -> (eps, of_list l)) (Combinatorics.permute_signed (ThoList.range 0 (pred n))) let to_string p = String.concat "" (List.map string_of_int (Array.to_list p)) end module Default = Using_Arrays let shuffle l = let a = Array.of_list l in ThoArray.shuffle a; Array.to_list a let time f x = let start = Sys.time () in let f_x = f x in let stop = Sys.time () in (f_x, stop -. start) let print_time msg f x = let f_x, seconds = time f x in Printf.printf "%s took %10.2f ms\n" msg (seconds *. 1000.); f_x let random_int_list imax n = let imax_plus = succ imax in Array.to_list (Array.init n (fun _ -> Random.int imax_plus)) module Test (P : T) : sig val suite : OUnit.test val time : unit -> unit end = struct open OUnit open P let of_list_overlap = "overlap" >:: (fun () -> assert_raises (Invalid_argument "Permutation.of_list") (fun () -> of_list [0;1;2;2])) let of_list_gap = "gap" >:: (fun () -> assert_raises (Invalid_argument "Permutation.of_list") (fun () -> of_list [0;1;2;4;5])) let of_list_ok = "ok" >:: (fun () -> let l = ThoList.range 0 10 in assert_equal (of_list l) (of_list l)) let suite_of_list = "of_list" >::: [of_list_overlap; of_list_gap; of_list_ok] let suite_of_lists = "of_lists" >::: [ "ok" >:: (fun () -> - for i = 1 to 10 do + for _ = 1 to 10 do let l = random_int_list 1000000 100 in let l' = shuffle l in assert_equal ~printer:(ThoList.to_string string_of_int) l' (list (of_lists l l') l) done) ] let apply_invalid_lengths = "invalid/lengths" >:: (fun () -> assert_raises (Invalid_argument "Permutation.list: length mismatch") (fun () -> list (of_list [0;1;2;3;4]) [0;1;2;3])) let apply_ok = "ok" >:: (fun () -> assert_equal [2;0;1;3;5;4] (list (of_list [1;2;0;3;5;4]) [0;1;2;3;4;5])) let suite_apply = "apply" >::: [apply_invalid_lengths; apply_ok] let inverse_ok = "ok" >:: (fun () -> let l = shuffle (ThoList.range 0 1000) in let p = of_list (shuffle l) in assert_equal l (list (inverse p) (list p l))) let suite_inverse = "inverse" >::: [inverse_ok] let compose_ok = "ok" >:: (fun () -> let id = ThoList.range 0 1000 in let p = of_list (shuffle id) and q = of_list (shuffle id) and l = id in assert_equal (list p (list q l)) (list (compose p q) l)) let compose_inverse_ok = "inverse/ok" >:: (fun () -> let id = ThoList.range 0 1000 in let p = of_list (shuffle id) and q = of_list (shuffle id) in assert_equal (compose (inverse p) (inverse q)) (inverse (compose q p))) let suite_compose = "compose" >::: [compose_ok; compose_inverse_ok] let suite = "Permutations" >::: [suite_of_list; suite_of_lists; suite_apply; suite_inverse; suite_compose] let repeat repetitions size = let id = ThoList.range 0 size in let p = of_list (shuffle id) and l = shuffle (List.map string_of_int id) in print_time (Printf.sprintf "reps=%d, len=%d" repetitions size) (fun () -> - for i = 1 to repetitions do + for _ = 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 8919) +++ trunk/omega/src/process.ml (revision 8920) @@ -1,401 +1,392 @@ (* process.ml -- Copyright (C) 1999-2024 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 + List.for_all (function [_] -> true | _ -> false) f_bags - let unique_final_state = function + 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' + | _ -> 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 = + 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 []) let integer_range n1 n2 = let rec integer_range' acc n' = if n' < n1 then acc else 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 = 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) + module IPowSet = PowSet.Make (Int) 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/UFOx.ml =================================================================== --- trunk/omega/src/UFOx.ml (revision 8919) +++ trunk/omega/src/UFOx.ml (revision 8920) @@ -1,1879 +1,1880 @@ (* vertex.ml -- Copyright (C) 1999-2024 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 = +let _error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) module SMap = Map.Make(String) module Expr = struct type t = UFOx_syntax.expr let of_string text = try UFOx_parser.input UFOx_lexer.token (UFOx_lexer.init_position "" (Lexing.from_string text)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | UFOx_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let of_strings = function | [] -> UFOx_syntax.integer 0 | string :: strings -> List.fold_right (fun s acc -> UFOx_syntax.add (of_string s) acc) strings (of_string string) open UFOx_syntax let rec map f = function | Integer _ | Float _ | Quoted _ | Young_Tableau _ as e -> e | Variable s as e -> begin match f s with | Some value -> value | None -> e end | Sum (e1, e2) -> Sum (map f e1, map f e2) | Difference (e1, e2) -> Difference (map f e1, map f e2) | Product (e1, e2) -> Product (map f e1, map f e2) | Quotient (e1, e2) -> Quotient (map f e1, map f e2) | Power (e1, e2) -> Power (map f e1, map f e2) | Application (s, el) -> Application (s, List.map (map f) el) let substitute name value expr = map (fun s -> if s = name then Some value else None) expr let rename1 name_map name = try Some (Variable (SMap.find name name_map)) with Not_found -> None let rename alist_names value = let name_map = List.fold_left (fun acc (name, name') -> SMap.add name name' acc) SMap.empty alist_names in map (rename1 name_map) value - let map_name1 f name = + let _map_name1 f name = Some (Variable (f name)) let map_names f value = map (fun name -> Some (Variable (f name))) value let half name = Quotient (Variable name, Integer 2) let variables = UFOx_syntax.variables let functions = UFOx_syntax.functions end (* It might seem to be a hack to base the decision of whether a sign or parentheses are required on the textual representation of a term. However we control the textual representation, it's efficient and we can avoid duplicating quite a bit of code testing for terms that might produce minus signs. *) let starts_with_a_sign s = String.length s > 0 && let c = s.[0] in c = '-' || c = '+' let starts_with_a_plus s = String.length s > 0 && s.[0] = '+' let starts_with_a_minus s = String.length s > 0 && s.[0] = '-' let prepend_binary_plus s = if starts_with_a_sign s then s else "+" ^ s (* The safe version that might produce terms like $-(-a)$. *) let prepend_binary_minus s = if starts_with_a_sign s then "-(" ^ s ^ ")" else "-" ^ s (* The version that produces fewer parentheses, but must assume that a leading minus sign always applies to the \emph{whole} term! *) -let prepend_binary_minus s = +let _prepend_binary_minus s = if starts_with_a_plus s then "-" ^ String.sub s 1 (String.length s - 1) else if starts_with_a_minus s then "+" ^ String.sub s 1 (String.length s - 1) else "-" ^ s module Value = struct module S = UFOx_syntax module Q = Algebra.Q type builtin = | Sqrt | Exp | Log | Log10 | Sin | Asin | Cos | Acos | Tan | Atan | Sinh | Asinh | Cosh | Acosh | Tanh | Atanh | Sec | Asec | Csc | Acsc | Conj | Abs let builtin_to_string = function | Sqrt -> "sqrt" | Exp -> "exp" | Log -> "log" | Log10 -> "log10" | Sin -> "sin" | Cos -> "cos" | Tan -> "tan" | Asin -> "asin" | Acos -> "acos" | Atan -> "atan" | Sinh -> "sinh" | Cosh -> "cosh" | Tanh -> "tanh" | Asinh -> "asinh" | Acosh -> "acosh" | Atanh -> "atanh" | Sec -> "sec" | Csc -> "csc" | Asec -> "asec" | Acsc -> "acsc" | Conj -> "conjg" | Abs -> "abs" let builtin_of_string = function | "cmath.sqrt" -> Sqrt | "cmath.exp" -> Exp | "cmath.log" -> Log | "cmath.log10" -> Log10 | "cmath.sin" -> Sin | "cmath.cos" -> Cos | "cmath.tan" -> Tan | "cmath.asin" -> Asin | "cmath.acos" -> Acos | "cmath.atan" -> Atan | "cmath.sinh" -> Sinh | "cmath.cosh" -> Cosh | "cmath.tanh" -> Tanh | "cmath.asinh" -> Asinh | "cmath.acosh" -> Acosh | "cmath.atanh" -> Atanh | "sec" -> Sec | "csc" -> Csc | "asec" -> Asec | "acsc" -> Acsc | "complexconjugate" -> Conj | "abs" -> Abs | name -> failwith ("UFOx.Value: unsupported function: " ^ name) type t = | Integer of int | Rational of Q.t | Real of float | Complex of float * float | Variable of string | Sum of t list | Difference of t * t | Product of t list | Quotient of t * t | Power of t * t | Application of builtin * t list (* At first sight, unparsing appears to be simpler than parsing. Nevertheless, it can become tricky and error prone if one wants to produce readable output that is not cluttered by too many parentheses. *) - let signed_string_of_float x = + let _signed_string_of_float x = (if x < 0.0 then "-" else "+") ^ string_of_float (abs_float x) (* Collect the numerical factors in a [Product] in order to reduce the number of parentheses required. \begin{dubious} We could include [Rational], but is it worth it? \end{dubious} *) let collect_factors elist = let rec collect_factors' factor elist_rev elist = match factor, elist with | (Integer 1| Real 1.), [] -> List.rev elist_rev | _, [] -> factor :: List.rev elist_rev | Integer i1, Integer i2 :: elist' -> collect_factors' (Integer (i1 * i2)) elist_rev elist' | Integer i, Real x :: elist' | Real x, Integer i :: elist' -> collect_factors' (Real (float i *. x)) elist_rev elist' | Real x1, Real x2 :: elist' -> collect_factors' (Real (x1 *. x2)) elist_rev elist' | _, e :: elist' -> collect_factors' factor (e :: elist_rev) elist' in collect_factors' (Integer 1) [] elist let rec to_string = function | Integer i -> string_of_int i | Rational q -> Q.to_string q | Real x -> string_of_float x | Complex (0.0, 1.0) -> "I" | Complex (0.0, i) -> group_product (Product [Real i; Complex (0.0, 1.0)]) | Complex (r, 0.0) -> to_string (Real r) | Complex (r, i) -> group_sum (Sum [Real r; Product [Real i; Complex (0.0, 1.0)]]) | Variable s -> s | Sum [] -> "0" | Sum [e] -> to_string e | Sum (e::es) -> to_string e ^ String.concat "" (List.map with_binary_plus es) | Difference (e1, e2) -> to_string e1 ^ prepend_binary_minus (group_sum e2) | Product [] -> "1" | Product es -> begin match collect_factors es with | (Integer (-1) | Real (-1.)) :: es -> "-" ^ to_string (Product es) | es -> String.concat "*" (List.map group_sum es) end | Quotient (e1, e2) -> group_numerator e1 ^ "/" ^ group_denominator e2 | Power ((Power (_, _) as e1, (Power (_, _) as e2))) -> "(" ^ group_product e1 ^ ")^(" ^ to_string e2 ^ ")" | Power ((Power (_, _) as e1, e2)) -> "(" ^ group_product e1 ^ ")^" ^ to_string e2 | Power (e1, (Power (_, _) as e2)) -> group_product e1 ^ "^(" ^ to_string e2 ^ ")" | Power ((Integer i as e), Integer p) -> if p < 0 then group_product (Real (float_of_int i)) ^ "^(" ^ string_of_int p ^ ")" else if p = 0 then "1" else if p <= 4 then group_product e ^ "^" ^ string_of_int p else group_product (Real (float_of_int i)) ^ "^" ^ string_of_int p | Power (e1, e2) -> group_product e1 ^ "^" ^ group_product e2 | Application (f, [Integer i]) -> to_string (Application (f, [Real (float i)])) | Application (f, es) -> builtin_to_string f ^ "(" ^ String.concat "," (List.map to_string es) ^ ")" (* Expressions that appear as arguments of [Power]s must be enclosed in parentheses, unless they are singletons. In a denominator, we don't have to put function applications in parentheses. \begin{dubious} Check this with \texttt{Whizard}'s parser, since this is the main (only?) consumer of our output. \end{dubious} *) and group_product = function | Application (_, _) as e -> "(" ^ to_string e ^ ")" | e -> group_denominator e (* In numerators, we must be careful not to leave an unprotected minus sign, since they can appear inside products. *) and group_numerator = function | Product (_ :: _ as es) -> begin match collect_factors es with | (Integer (-1) | Real (-1.)) :: es -> "(-" ^ to_string (Product es) ^ ")" | es -> String.concat "*" (List.map group_sum es) end | e -> group_denominator e and group_denominator = function | Sum [e] | Product [e] -> group_product e | Sum ( _ :: _) | Difference (_, _) | Product ( _ :: _) | Quotient (_, _) as e -> "(" ^ to_string e ^ ")" | e -> to_string e (* [Sum]s that appear in [Product]s must be enclosed in parentheses, unless they are singletons. *) and group_sum = function | Sum [e] | Product [e] -> group_sum e | Sum ( _ :: _) | Difference (_, _) as e -> "(" ^ to_string e ^ ")" | e -> to_string e (* Add a ['+'] at the front of a term iff if has no sign. *) and with_binary_plus e = prepend_binary_plus (to_string e) let rec to_coupling atom = function | Integer i -> Coupling.Integer i | Rational q -> let n, d = Q.to_ratio q in Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Real x -> Coupling.Float x | Product es -> Coupling.Prod (List.map (to_coupling atom) es) | Variable s -> Coupling.Atom (atom s) | Complex (r, 0.0) -> Coupling.Float r | Complex (0.0, 1.0) -> Coupling.I | Complex (0.0, -1.0) -> Coupling.Prod [Coupling.I; Coupling.Integer (-1)] | Complex (0.0, i) -> Coupling.Prod [Coupling.I; Coupling.Float i] | Complex (r, 1.0) -> Coupling.Sum [Coupling.Float r; Coupling.I] | Complex (r, -1.0) -> Coupling.Diff (Coupling.Float r, Coupling.I) | Complex (r, i) -> Coupling.Sum [Coupling.Float r; Coupling.Prod [Coupling.I; Coupling.Float i]] | Sum es -> Coupling.Sum (List.map (to_coupling atom) es) | Difference (e1, e2) -> Coupling.Diff (to_coupling atom e1, to_coupling atom e2) | Quotient (e1, e2) -> Coupling.Quot (to_coupling atom e1, to_coupling atom e2) | Power (e1, Integer e2) -> Coupling.Pow (to_coupling atom e1, e2) | Power (e1, e2) -> Coupling.PowX (to_coupling atom e1, to_coupling atom e2) | Application (f, [e]) -> apply1 (to_coupling atom e) f | Application (f, []) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": empty argument list") | Application (f, _::_::_) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": more than one argument in list") and apply1 e = function | Sqrt -> Coupling.Sqrt e | Exp -> Coupling.Exp e | Log -> Coupling.Log e | Log10 -> Coupling.Log10 e | Sin -> Coupling.Sin e | Cos -> Coupling.Cos e | Tan -> Coupling.Tan e | Asin -> Coupling.Asin e | Acos -> Coupling.Acos e | Atan -> Coupling.Atan e | Sinh -> Coupling.Sinh e | Cosh -> Coupling.Cosh e | Tanh -> Coupling.Tanh e | Sec -> Coupling.Quot (Coupling.Integer 1, Coupling.Cos e) | Csc -> Coupling.Quot (Coupling.Integer 1, Coupling.Sin e) | Asec -> Coupling.Acos (Coupling.Quot (Coupling.Integer 1, e)) | Acsc -> Coupling.Asin (Coupling.Quot (Coupling.Integer 1, e)) | Conj -> Coupling.Conj e | Abs -> Coupling.Abs e | (Asinh | Acosh | Atanh as f) -> failwith ("UFOx.Value.to_coupling: function `" ^ builtin_to_string f ^ "' not supported yet!") (* \begin{dubious} The constant propagation here is incomplete. [S.Quotient] and [S.Power] are not yet handled and in [S.Sum] and [S.Product] only adjacent constants are combined. \end{dubious} \begin{dubious} We could include [Rational], but is it worth it? \end{dubious} *) let compress terms = terms let rec of_expr e = compress (of_expr' e) and of_expr' = function | S.Integer i -> Integer i | S.Float x -> Real x | S.Variable "cmath.pi" -> Variable "pi" | S.Quoted name -> invalid_arg ("UFOx.Value.of_expr: unexpected quoted variable '" ^ name ^ "'") | S.Young_Tableau y -> invalid_arg ("UFOx.Value.of_expr: unexpected Young tableau '" ^ Young.tableau_to_string string_of_int y ^ "'") | S.Variable name -> Variable name | S.Sum (e1, e2) -> begin match of_expr e1, of_expr e2 with | Integer i1, Integer i2 -> Integer (i1 + i2) | Integer i, Real x | Real x, Integer i -> Real (float_of_int i +. x) | Real x1, Real x2 -> Real (x1 +. x2) | (Integer 0 | Real 0.), e -> e | e, (Integer 0 | Real 0.) -> e | Sum e1, Sum e2 -> Sum (e1 @ e2) | e1, Sum e2 -> Sum (e1 :: e2) | Sum e1, e2 -> Sum (e1 @ [e2]) | e1, e2 -> Sum [e1; e2] end | S.Difference (e1, e2) -> begin match of_expr e1, of_expr e2 with | Integer i1, Integer i2 -> Integer (i1 - i2) | Integer i, Real x -> Real (float_of_int i -. x) | Real x, Integer i -> Real (x -. float_of_int i) | Real x1, Real x2 -> Real (x1 -. x2) | e1, (Integer 0 | Real 0.) -> e1 | e1, e2 -> Difference (e1, e2) end | S.Product (e1, e2) -> begin match of_expr e1, of_expr e2 with | Integer i1, Integer i2 -> Integer (i1 * i2) | Integer i, Real x | Real x, Integer i -> Real (float_of_int i *. x) | Real x1, Real x2 -> Real (x1 *. x2) | (Integer 0 | Real 0.), _ -> Integer 0 | _, (Integer 0 | Real 0.) -> Integer 0 | (Integer 1 | Real 1.), e -> e | e, (Integer 1 | Real 1.) -> e | Product e1, Product e2 -> Product (e1 @ e2) | e1, Product e2 -> Product (e1 :: e2) | Product e1, e2 -> Product (e1 @ [e2]) | e1, e2 -> Product [e1; e2] end | S.Quotient (e1, e2) -> begin match of_expr e1, of_expr e2 with - | e1, (Integer 0 | Real 0.) -> + | _, (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: divide by 0" | e1, (Integer 1 | Real 1.) -> e1 | Integer i1, Integer i2 -> Rational (Q.make i1 i2) | Real x, Integer i -> Real (x /. float i) | Integer i, Real x -> Real (float i /. x) | Real x1, Real x2 -> Real (x1 /. x2) | e1, e2 -> Quotient (e1, e2) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | (Integer 0 | Real 0.), (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: 0^0" | _, (Integer 0 | Real 0.) -> Integer 1 | e, (Integer 1 | Real 1.) -> e | Integer e, Integer p -> if p < 0 then Power (Real (float_of_int e), Integer p) else if p = 0 then Integer 1 else if p <= 4 then Power (Integer e, Integer p) else Power (Real (float_of_int e), Integer p) | e, p -> Power (e, p) end | S.Application ("complex", [r; i]) -> begin match of_expr r, of_expr i with | r, (Integer 0 | Real 0.0) -> r | Real r, Real i -> Complex (r, i) | Integer r, Real i -> Complex (float_of_int r, i) | Real r, Integer i -> Complex (r, float_of_int i) | Integer r, Integer i -> Complex (float_of_int r, float_of_int i) | _ -> invalid_arg "UFOx.Value: complex expects two numeric arguments" end | S.Application ("complex", _) -> invalid_arg "UFOx.Value: complex expects two arguments" | S.Application ("complexconjugate", [e]) -> Application (Conj, [of_expr e]) | S.Application ("complexconjugate", _) -> invalid_arg "UFOx.Value: complexconjugate expects single argument" | S.Application ("cmath.sqrt", [e]) -> Application (Sqrt, [of_expr e]) | S.Application ("cmath.sqrt", _) -> invalid_arg "UFOx.Value: sqrt expects single argument" | S.Application (name, args) -> Application (builtin_of_string name, List.map of_expr args) end let positive integers = List.filter (fun (i, _) -> i > 0) integers let not_positive integers = List.filter (fun (i, _) -> i <= 0) integers module type Index = sig type t = int val position : t -> int val factor : t -> int val unpack : t -> int * int val pack : int -> int -> t val map_position : (int -> int) -> t -> t val to_string : t -> string val list_to_string : t list -> string val free : (t * 'r) list -> (t * 'r) list val summation : (t * 'r) list -> (t * 'r) list val classes_to_string : ('r -> string) -> (t * 'r) list -> string val fresh_summation : unit -> t val named_summation : string -> unit -> t end module Index : Index = struct type t = int let free i = positive i let summation i = not_positive i let position i = if i > 0 then i mod 1000 else i let factor i = if i > 0 then i / 1000 else invalid_arg "UFOx.Index.factor: argument not positive" let unpack i = if i > 0 then (position i, factor i) else (i, 0) let pack i j = if j > 0 then if i > 0 then 1000 * j + i else invalid_arg "UFOx.Index.pack: position not positive" else if j = 0 then i else invalid_arg "UFOx.Index.pack: factor negative" let map_position f i = let pos, fac = unpack i in pack (f pos) fac let to_string i = let pos, fac = unpack i in if fac = 0 then Printf.sprintf "%d" pos else Printf.sprintf "%d.%d" pos fac - let to_string' = string_of_int + let _to_string = string_of_int let list_to_string is = "[" ^ String.concat ", " (List.map to_string is) ^ "]" let classes_to_string rep_to_string index_classes = let reps = ThoList.uniq (List.sort compare (List.map snd index_classes)) in "[" ^ String.concat ", " (List.map (fun r -> (rep_to_string r) ^ "=" ^ (list_to_string (List.map fst (List.filter (fun (_, r') -> r = r') index_classes)))) reps) ^ "]" type factory = { mutable named : int SMap.t; mutable used : Sets.Int.t } let factory = { named = SMap.empty; used = Sets.Int.empty } let first_anonymous = -1001 let fresh_summation () = let next_anonymous = try pred (Sets.Int.min_elt factory.used) with | Not_found -> first_anonymous in factory.used <- Sets.Int.add next_anonymous factory.used; next_anonymous let named_summation name () = try SMap.find name factory.named with | Not_found -> begin let next_named = fresh_summation () in factory.named <- SMap.add name next_named factory.named; next_named end end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val contract_pair : t -> t -> t option val variable : t -> string option val scalar : t -> bool val is_unit : t -> bool val invertible : t -> bool val invert : t -> t val of_expr : string -> UFOx_syntax.expr list -> t list val to_string : t -> string type r val classify_indices : t list -> (Index.t * r) list val disambiguate_indices : t list -> t list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Tensor = sig type atom type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list val map_atoms : (atom -> atom) -> t -> t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t val contract_pairs : t -> t val variables : t -> string list val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string type r val classify_indices : t -> (Index.t * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module Tensor (A : Atom) : Tensor with type atom = A.t and type r = A.r and type r_omega = A.r_omega = struct module S = UFOx_syntax (* TODO: we have to switch to [Algebra.QC] to support complex coefficients, as used in custom propagators. *) module Q = Algebra.Q module QC = Algebra.QC type atom = A.t type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list let term_to_string (tensors, c) = if QC.is_null c then "" else match tensors with | [] -> QC.to_string c | tensors -> String.concat "*" ((if QC.is_unit c then [] else [QC.to_string c]) @ List.map A.to_string tensors) let linear_to_string = function | [] -> "" | term :: terms -> term_to_string term ^ String.concat "" (List.map (fun t -> prepend_binary_plus (term_to_string t)) terms) let to_string = function | Linear terms -> linear_to_string terms | Ratios ratios -> String.concat " + " (List.map (fun (n, d) -> Printf.sprintf "(%s)/(%s)" (linear_to_string n) (linear_to_string d)) ratios) let variables_of_atoms atoms = List.fold_left (fun acc a -> match A.variable a with | None -> acc | Some name -> Sets.String.add name acc) Sets.String.empty atoms let variables_of_linear linear = List.fold_left (fun acc (atoms, _) -> Sets.String.union (variables_of_atoms atoms) acc) Sets.String.empty linear let variables_set = function | Linear linear -> variables_of_linear linear | Ratios ratios -> List.fold_left (fun acc (numerator, denominator) -> Sets.String.union (variables_of_linear numerator) (Sets.String.union (variables_of_linear denominator) acc)) Sets.String.empty ratios let variables t = Sets.String.elements (variables_set t) let map_ratios f = function | Linear n -> Linear (f n) | Ratios ratios -> Ratios (List.map (fun (n, d) -> (f n, f d)) ratios) let map_summands f t = map_ratios (List.map f) t let map_numerators f = function | Linear n -> Linear (List.map f n) | Ratios ratios -> Ratios (List.map (fun (n, d) -> (List.map f n, d)) ratios) let map_atoms f t = map_summands (fun (atoms, q) -> (List.map f atoms, q)) t let map_indices f t = map_atoms (A.map_indices f) t let rename_indices f t = map_atoms (A.rename_indices f) t let map_coeff f t = map_numerators (fun (atoms, q) -> (atoms, f q)) t type result = | Matched of atom list | Unmatched of atom list (* [contract_pair a rev_prefix suffix] returns [Unmatched (a :: List.rev_append rev_prefix suffix] if there is no match (as defined by [A.contract_pair]) and [Matched] with the reduced list otherwise. *) let rec contract_pair a rev_prefix = function | [] -> Unmatched (a :: List.rev rev_prefix) | a' :: suffix -> begin match A.contract_pair a a' with | None -> contract_pair a (a' :: rev_prefix) suffix | Some a'' -> if A.is_unit a'' then Matched (List.rev_append rev_prefix suffix) else Matched (List.rev_append rev_prefix (a'' :: suffix)) end (* Use [contract_pair] to find all pairs that match according to [A.contract_pair]. *) let rec contract_pairs1 = function | ([] | [_] as t) -> t | a :: t -> begin match contract_pair a [] t with | Unmatched ([]) -> [] | Unmatched (a' :: t') -> a' :: contract_pairs1 t' | Matched t' -> contract_pairs1 t' end let contract_pairs t = map_summands (fun (t', c) -> (contract_pairs1 t', c)) t let add t1 t2 = match t1, t2 with | Linear l1, Linear l2 -> Linear (l1 @ l2) | Ratios r, Linear l | Linear l, Ratios r -> Ratios ((l, [([], QC.unit)]) :: r) | Ratios r1, Ratios r2 -> Ratios (r1 @ r2) let multiply1 (t1, c1) (t2, c2) = (List.sort compare (t1 @ t2), QC.mul c1 c2) let multiply2 t1 t2 = Product.list2 multiply1 t1 t2 let multiply t1 t2 = match t1, t2 with | Linear l1, Linear l2 -> Linear (multiply2 l1 l2) | Ratios r, Linear l | Linear l, Ratios r -> Ratios (List.map (fun (n, d) -> (multiply2 l n, d)) r) | Ratios r1, Ratios r2 -> Ratios (Product.list2 (fun (n1, d1) (n2, d2) -> (multiply2 n1 n2, multiply2 d1 d2)) r1 r2) let rec power n t = if n < 0 then invalid_arg "UFOx.Tensor.power: n < 0" else if n = 0 then Linear [([], QC.unit)] else if n = 1 then t else multiply t (power (pred n) t) let compress ratios = map_ratios (fun terms -> List.map (fun (t, cs) -> (t, QC.sum cs)) (ThoList.factorize terms)) ratios let rec of_expr e = contract_pairs (compress (of_expr' e)) and of_expr' = function | S.Integer i -> Linear [([], QC.make (Q.make i 1) Q.null)] | S.Float _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected float" | S.Quoted name -> invalid_arg ("UFOx.Tensor.of_expr: unexpected quoted variable '" ^ name ^ "'") | S.Young_Tableau y -> invalid_arg ("UFOx.Tensor.of_expr: unexpected top level Young tableau '" ^ Young.tableau_to_string string_of_int y ^ "'") | S.Variable name -> (* There should be a gatekeeper here or in [A.of_expr]: *) Linear [(A.of_expr name [], QC.unit)] | S.Application ("complex", [re; im]) -> begin match of_expr re, of_expr im with | Linear [([], re)], Linear [([], im)] -> if QC.is_real re && QC.is_real im then Linear [([], QC.make (QC.re re) (QC.re im))] else invalid_arg ("UFOx.Tensor.of_expr: argument of complex is complex") | _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected argument of complex" end | S.Application (name, args) -> Linear [(A.of_expr name args, QC.unit)] | S.Sum (e1, e2) -> add (of_expr e1) (of_expr e2) | S.Difference (e1, e2) -> add (of_expr e1) (of_expr (S.Product (S.Integer (-1), e2))) | S.Product (e1, e2) -> multiply (of_expr e1) (of_expr e2) | S.Quotient (n, d) -> begin match of_expr n, of_expr d with - | n, Linear [] -> + | _, Linear [] -> invalid_arg "UFOx.Tensor.of_expr: zero denominator" | n, Linear [([], q)] -> map_coeff (fun c -> QC.div c q) n | n, Linear ([(invertibles, q)] as d) -> if List.for_all A.invertible invertibles then let inverses = List.map A.invert invertibles in multiply (Linear [(inverses, QC.inv q)]) n else multiply (Ratios [[([], QC.unit)], d]) n | n, (Linear d as d')-> if List.for_all (fun (t, _) -> List.for_all A.scalar t) d then multiply (Ratios [[([], QC.unit)], d]) n else invalid_arg ("UFOx.Tensor.of_expr: non scalar denominator: " ^ to_string d') - | n, (Ratios _ as d) -> + | _, (Ratios _ as d) -> invalid_arg ("UFOx.Tensor.of_expr: illegal denominator: " ^ to_string d) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | Linear [([], q)], Linear [([], p)] -> if QC.is_real p then let re_p = QC.re p in if Q.is_integer re_p then Linear [([], QC.pow q (Q.to_integer re_p))] else invalid_arg "UFOx.Tensor.of_expr: rational power of number" else invalid_arg "UFOx.Tensor.of_expr: complex power of number" - | Linear [([], q)], _ -> + | Linear [([], _)], _ -> invalid_arg "UFOx.Tensor.of_expr: non-numeric power of number" | t, Linear [([], p)] -> if QC.is_integer p then power (Q.to_integer (QC.re p)) t else invalid_arg "UFOx.Tensor.of_expr: non integer power of tensor" | _ -> invalid_arg "UFOx.Tensor.of_expr: non numeric power of tensor" end type r = A.r let rep_to_string = A.rep_to_string let rep_to_string_whizard = A.rep_to_string_whizard let rep_of_int = A.rep_of_int let rep_of_int_or_young_tableau = A.rep_of_int_or_young_tableau let rep_conjugate = A.rep_conjugate let rep_trivial = A.rep_trivial let numerators = function | Linear tensors -> tensors | Ratios ratios -> ThoList.flatmap fst ratios let classify_indices' filter tensors = ThoList.uniq (List.sort compare (List.map - (fun (t, c) -> filter (A.classify_indices t)) + (fun (t, _) -> filter (A.classify_indices t)) (numerators tensors))) (* NB: the number of summation indices is not guarateed to be the same! Therefore it was foolish to try to check for uniqueness \ldots *) let classify_indices tensors = match classify_indices' Index.free tensors with | [] -> (* There's always at least an empty list! *) failwith "UFOx.Tensor.classify_indices: can't happen!" | [f] -> f | _ -> invalid_arg "UFOx.Tensor.classify_indices: incompatible free indices!" let disambiguate_indices1 (atoms, q) = (A.disambiguate_indices atoms, q) let disambiguate_indices tensors = map_ratios (List.map disambiguate_indices1) tensors let check_indices t = ignore (classify_indices t) let of_expr e = let t = disambiguate_indices (of_expr e) in check_indices t; t let of_string s = of_expr (Expr.of_string s) let of_strings s = of_expr (Expr.of_strings s) type r_omega = A.r_omega let omega = A.omega end module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = (* private *) | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = (* private *) | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar val map_indices_scalar : (int -> int) -> scalar -> scalar val map_indices_vector : (int -> int) -> vector -> vector val rename_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom = struct type dirac = | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar let map_indices_scalar f = function | Mass i -> Mass (f i) | Width i -> Width (f i) | P2 i -> P2 (f i) | P12 (i, j) -> P12 (f i, f j) | (Variable _ | Coeff _ as s) -> s let map_indices_vector f = function | Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la) | Metric (mu, nu) -> Metric (f mu, f nu) | P (mu, n) -> P (f mu, f n) let rename_indices_vector f = function | Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la) | Metric (mu, nu) -> Metric (f mu, f nu) | P (mu, n) -> P (f mu, n) end module Lorentz_Atom' : Atom with type t = Lorentz_Atom.t and type r_omega = Coupling.lorentz = struct type t = Lorentz_Atom.t open Lorentz_Atom let map_indices_dirac f = function | C (i, j) -> C (f i, f j) | Gamma (mu, i, j) -> Gamma (f mu, f i, f j) | Gamma5 (i, j) -> Gamma5 (f i, f j) | Identity (i, j) -> Identity (f i, f j) | ProjP (i, j) -> ProjP (f i, f j) | ProjM (i, j) -> ProjM (f i, f j) | Sigma (mu, nu, i, j) -> Sigma (f mu, f nu, f i, f j) let rename_indices_dirac = map_indices_dirac let map_indices_scalar f = function | Mass i -> Mass (f i) | Width i -> Width (f i) | P2 i -> P2 (f i) | P12 (i, j) -> P12 (f i, f j) | Variable s -> Variable s | Coeff c -> Coeff c let map_indices f = function | Dirac d -> Dirac (map_indices_dirac f d) | Vector v -> Vector (map_indices_vector f v) | Scalar s -> Scalar (map_indices_scalar f s) | Inverse s -> Inverse (map_indices_scalar f s) let rename_indices2 fd fv = function | Dirac d -> Dirac (rename_indices_dirac fd d) | Vector v -> Vector (rename_indices_vector fv v) | Scalar s -> Scalar s | Inverse s -> Inverse s let rename_indices f atom = rename_indices2 f f atom let contract_pair a1 a2 = match a1, a2 with | Vector (P (mu1, i1)), Vector (P (mu2, i2)) -> if mu1 <= 0 && mu1 = mu2 then if i1 = i2 then Some (Scalar (P2 i1)) else Some (Scalar (P12 (i1, i2))) else None | Scalar s, Inverse s' | Inverse s, Scalar s' -> if s = s' then Some (Scalar (Coeff (Value.Integer 1))) else None | _ -> None let variable = function | Scalar (Variable s) | Inverse (Variable s) -> Some s | _ -> None let scalar = function | Dirac _ | Vector _ -> false | Scalar _ | Inverse _ -> true let is_unit = function | Scalar (Coeff c) | Inverse (Coeff c) -> begin match c with | Value.Integer 1 -> true | Value.Rational q -> Algebra.Q.is_unit q | _ -> false end | _ -> false let invertible = scalar let invert = function | Dirac _ -> invalid_arg "UFOx.Lorentz_Atom.invert Dirac" | Vector _ -> invalid_arg "UFOx.Lorentz_Atom.invert Vector" | Scalar s -> Inverse s | Inverse s -> Scalar s let i2s = Index.to_string let dirac_to_string = function | C (i, j) -> Printf.sprintf "C(%s,%s)" (i2s i) (i2s j) | Gamma (mu, i, j) -> Printf.sprintf "Gamma(%s,%s,%s)" (i2s mu) (i2s i) (i2s j) | Gamma5 (i, j) -> Printf.sprintf "Gamma5(%s,%s)" (i2s i) (i2s j) | Identity (i, j) -> Printf.sprintf "Identity(%s,%s)" (i2s i) (i2s j) | ProjP (i, j) -> Printf.sprintf "ProjP(%s,%s)" (i2s i) (i2s j) | ProjM (i, j) -> Printf.sprintf "ProjM(%s,%s)" (i2s i) (i2s j) | Sigma (mu, nu, i, j) -> Printf.sprintf "Sigma(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s i) (i2s j) let vector_to_string = function | Epsilon (mu, nu, ka, la) -> Printf.sprintf "Epsilon(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s ka) (i2s la) | Metric (mu, nu) -> Printf.sprintf "Metric(%s,%s)" (i2s mu) (i2s nu) | P (mu, n) -> Printf.sprintf "P(%s,%d)" (i2s mu) n let scalar_to_string = function | Mass id -> Printf.sprintf "Mass(%d)" id | Width id -> Printf.sprintf "Width(%d)" id | P2 id -> Printf.sprintf "P(%d)**2" id | P12 (id1, id2) -> Printf.sprintf "P(%d)*P(%d)" id1 id2 | Variable s -> s | Coeff c -> Value.to_string c let to_string = function | Dirac d -> dirac_to_string d | Vector v -> vector_to_string v | Scalar s -> scalar_to_string s | Inverse s -> "1/" ^ scalar_to_string s module S = UFOx_syntax (* \begin{dubious} Here we handle some special cases in order to be able to parse propagators. This needs to be made more general, but unfortunately the syntax for the propagator extension is not well documented and appears to be a bit chaotic! \end{dubious} *) let quoted_index s = Index.named_summation s () let integer_or_id = function | S.Integer n -> n | S.Variable "id" -> 1 | _ -> failwith "UFOx.Lorentz_Atom.integer_or_id: impossible" let vector_index = function | S.Integer n -> n | S.Quoted mu -> quoted_index mu | S.Variable id -> let l = String.length id in if l > 1 then if id.[0] = 'l' then int_of_string (String.sub id 1 (pred l)) else invalid_arg ("UFOx.Lorentz_Atom.vector_index: " ^ id) else invalid_arg "UFOx.Lorentz_Atom.vector_index: empty variable" | _ -> invalid_arg "UFOx.Lorentz_Atom.vector_index" let spinor_index = function | S.Integer n -> n | S.Variable id -> let l = String.length id in if l > 1 then if id.[0] = 's' then int_of_string (String.sub id 1 (pred l)) else invalid_arg ("UFOx.Lorentz_Atom.spinor_index: " ^ id) else invalid_arg "UFOx.Lorentz_Atom.spinor_index: empty variable" | _ -> invalid_arg "UFOx.Lorentz_Atom.spinor_index" let of_expr name args = match name, args with | "C", [i; j] -> [Dirac (C (spinor_index i, spinor_index j))] | "C", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to C()" | "Epsilon", [mu; nu; ka; la] -> [Vector (Epsilon (vector_index mu, vector_index nu, vector_index ka, vector_index la))] | "Epsilon", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Epsilon()" | "Gamma", [mu; i; j] -> [Dirac (Gamma (vector_index mu, spinor_index i, spinor_index j))] | "Gamma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma()" | "Gamma5", [i; j] -> [Dirac (Gamma5 (spinor_index i, spinor_index j))] | "Gamma5", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma5()" | "Identity", [i; j] -> [Dirac (Identity (spinor_index i, spinor_index j))] | "Identity", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Identity()" | "Metric", [mu; nu] -> [Vector (Metric (vector_index mu, vector_index nu))] | "Metric", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Metric()" | "P", [mu; id] -> [Vector (P (vector_index mu, integer_or_id id))] | "P", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to P()" | "ProjP", [i; j] -> [Dirac (ProjP (spinor_index i, spinor_index j))] | "ProjP", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjP()" | "ProjM", [i; j] -> [Dirac (ProjM (spinor_index i, spinor_index j))] | "ProjM", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjM()" | "Sigma", [mu; nu; i; j] -> if mu <> nu then [Dirac (Sigma (vector_index mu, vector_index nu, spinor_index i, spinor_index j))] else invalid_arg "UFOx.Lorentz.of_expr: implausible arguments to Sigma()" | "Sigma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Sigma()" | "PSlash", [i; j; id] -> let mu = Index.fresh_summation () in [Dirac (Gamma (mu, spinor_index i, spinor_index j)); Vector (P (mu, integer_or_id id))] | "PSlash", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to PSlash()" | "Mass", [id] -> [Scalar (Mass (integer_or_id id))] | "Mass", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Mass()" | "Width", [id] -> [Scalar (Width (integer_or_id id))] | "Width", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Width()" | name, [] -> [Scalar (Variable name)] | name, _ -> invalid_arg ("UFOx.Lorentz.of_expr: invalid tensor '" ^ name ^ "'") type r = S | V | T | Sp | CSp | Maj | VSp | CVSp | VMaj | Ghost let rep_trivial = function | S | Ghost -> true | V | T | Sp | CSp | Maj | VSp | CVSp | VMaj -> false let rep_to_string = function | S -> "0" | V -> "1" | T -> "2" | Sp -> "1/2" | CSp-> "1/2bar" | Maj -> "1/2M" | VSp -> "3/2" | CVSp -> "3/2bar" | VMaj -> "3/2M" | Ghost -> "Ghost" let rep_to_string_whizard = function | S -> "0" | V -> "1" | T -> "2" | Sp | CSp | Maj -> "1/2" | VSp | CVSp | VMaj -> "3/2" | Ghost -> "Ghost" let rep_of_int neutral = function | -1 -> Ghost | 1 -> S | 2 -> if neutral then Maj else Sp | -2 -> if neutral then Maj else CSp (* used by [UFO.Particle.force_conjspinor] *) | 3 -> V | 4 -> if neutral then VMaj else VSp | -4 -> if neutral then VMaj else CVSp (* used by [UFO.Particle.force_conjspinor] *) | 5 -> T | s when s > 0 -> failwith "UFOx.Lorentz: spin > 2 not supported!" | _ -> invalid_arg "UFOx.Lorentz: invalid non-positive spin value" let rep_of_int_or_young_tableau neutral i yt = match i, yt with | Some i, None -> rep_of_int neutral i | None, None -> S | _, Some _ -> invalid_arg "UFOx.Lorentz: Young tableau not supported" let rep_conjugate = function | S -> S | V -> V | T -> T | Sp -> CSp (* ??? *) | CSp -> Sp (* ??? *) | Maj -> Maj | VSp -> CVSp | CVSp -> VSp | VMaj -> VMaj | Ghost -> Ghost let classify_vector_indices1 = function | Epsilon (mu, nu, ka, la) -> [(mu, V); (nu, V); (ka, V); (la, V)] | Metric (mu, nu) -> [(mu, V); (nu, V)] - | P (mu, n) -> [(mu, V)] + | P (mu, _) -> [(mu, V)] let classify_dirac_indices1 = function | C (i, j) -> [(i, CSp); (j, Sp)] (* ??? *) | Gamma5 (i, j) | Identity (i, j) | ProjP (i, j) | ProjM (i, j) -> [(i, CSp); (j, Sp)] | Gamma (mu, i, j) -> [(mu, V); (i, CSp); (j, Sp)] | Sigma (mu, nu, i, j) -> [(mu, V); (nu, V); (i, CSp); (j, Sp)] let classify_indices1 = function | Dirac d -> classify_dirac_indices1 d | Vector v -> classify_vector_indices1 v | Scalar _ | Inverse _ -> [] module IMap = Map.Make(Int) exception Incompatible_factors of r * r let product rep1 rep2 = match rep1, rep2 with | V, V -> T | V, Sp -> VSp | V, CSp -> CVSp | V, Maj -> VMaj | Sp, V -> VSp | CSp, V -> CVSp | Maj, V -> VMaj | _, _ -> raise (Incompatible_factors (rep1, rep2)) let combine_or_add_index (i, rep) map = let pos, fac = Index.unpack i in try let fac', rep' = IMap.find pos map in if pos < 0 then IMap.add pos (fac, rep) map else if fac <> fac' then IMap.add pos (0, product rep rep') map else if rep <> rep' then (* Can be disambiguated! *) IMap.add pos (0, product rep rep') map else invalid_arg (Printf.sprintf "UFO: duplicate subindex %d" pos) with | Not_found -> IMap.add pos (fac, rep) map | Incompatible_factors (rep1, rep2) -> invalid_arg (Printf.sprintf "UFO: incompatible factors (%s,%s) at %d" (rep_to_string rep1) (rep_to_string rep2) pos) let combine_or_add_indices atom map = List.fold_right combine_or_add_index (classify_indices1 atom) map let project_factors (pos, (fac, rep)) = if fac = 0 then (pos, rep) else invalid_arg (Printf.sprintf "UFO: leftover subindex %d.%d" pos fac) let classify_indices atoms = List.map project_factors (IMap.bindings (List.fold_right combine_or_add_indices atoms IMap.empty)) let add_factor fac indices pos = if pos > 0 then if Sets.Int.mem pos indices then Index.pack pos fac else pos else pos let disambiguate_indices1 indices atom = rename_indices2 (add_factor 1 indices) (add_factor 2 indices) atom let vectorspinors atoms = List.fold_left (fun acc (i, r) -> match r with | S | V | T | Sp | CSp | Maj | Ghost -> acc | VSp | CVSp | VMaj -> Sets.Int.add i acc) Sets.Int.empty (classify_indices atoms) let disambiguate_indices atoms = let vectorspinor_indices = vectorspinors atoms in List.map (disambiguate_indices1 vectorspinor_indices) atoms type r_omega = Coupling.lorentz let omega = function | S -> Coupling.Scalar | V -> Coupling.Vector | T -> Coupling.Tensor_2 | Sp -> Coupling.Spinor | CSp -> Coupling.ConjSpinor | Maj -> Coupling.Majorana | VSp -> Coupling.Vectorspinor | CVSp -> Coupling.Vectorspinor (* TODO: not really! *) | VMaj -> Coupling.Vectorspinor (* TODO: not really! *) | Ghost -> Coupling.Scalar end module Lorentz = Tensor(Lorentz_Atom') module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | Delta of int Young.tableau * int * int | T of int * int * int | TY of int Young.tableau * int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom = struct type t = | Identity of int * int | Identity8 of int * int | Delta of int Young.tableau * int * int | T of int * int * int | TY of int Young.tableau * int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom' : Atom with type t = Color_Atom.t and type r_omega = Color.t = struct type t = Color_Atom.t module S = UFOx_syntax open Color_Atom let map_indices f = function | Identity (i, j) -> Identity (f i, f j) | Identity8 (a, b) -> Identity8 (f a, f b) | Delta (y, a, b) -> Delta (y, f a, f b) | T (a, i, j) -> T (f a, f i, f j) | TY (y, a, i, j) -> TY (y, f a, f i, f j) | F (a, i, j) -> F (f a, f i, f j) | D (a, i, j) -> D (f a, f i, f j) | Epsilon (i, j, k) -> Epsilon (f i, f j, f k) | EpsilonBar (i, j, k) -> EpsilonBar (f i, f j, f k) | T6 (a, i', j') -> T6 (f a, f i', f j') | K6 (i', j, k) -> K6 (f i', f j, f k) | K6Bar (i', j, k) -> K6Bar (f i', f j, f k) let rename_indices = map_indices let contract_pair _ _ = None let variable _ = None let scalar _ = false let invertible _ = false let is_unit _ = false let invert _ = invalid_arg "UFOx.Color_Atom.invert" let young_tableau_valid_particle y = Young.standard_tableau ~offset:1 y let of_expr1 name args = match name, args with | "Identity", [S.Integer i; S.Integer j] -> Identity (i, j) | "Identity", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()" | "Delta", [S.Young_Tableau y; S.Integer i; S.Integer j] -> if young_tableau_valid_particle y then Delta (y, i, j) else invalid_arg ("UFOx.Color.of_expr: invalid Young tableau in Delta: " ^ Young.tableau_to_string string_of_int y) | "Delta", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()" | "T", [S.Integer a; S.Integer i; S.Integer j] -> T (a, i, j) | "T", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T()" | "TY", [S.Young_Tableau y; S.Integer a; S.Integer i; S.Integer j] -> if young_tableau_valid_particle y then TY (y, a, i, j) else invalid_arg ("UFOx.Color.of_expr: invalid Young tableau in TY: " ^ Young.tableau_to_string string_of_int y) | "TY", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to TY()" | "f", [S.Integer a; S.Integer b; S.Integer c] -> F (a, b, c) | "f", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to f()" | "d", [S.Integer a; S.Integer b; S.Integer c] -> D (a, b, c) | "d", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to d()" | "Epsilon", [S.Integer i; S.Integer j; S.Integer k] -> Epsilon (i, j, k) | "Epsilon", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Epsilon()" | "EpsilonBar", [S.Integer i; S.Integer j; S.Integer k] -> EpsilonBar (i, j, k) | "EpsilonBar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to EpsilonBar()" | "T6", [S.Integer a; S.Integer i'; S.Integer j'] -> T6 (a, i', j') | "T6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T6()" | "K6", [S.Integer i'; S.Integer j; S.Integer k] -> K6 (i', j, k) | "K6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6()" | "K6Bar", [S.Integer i'; S.Integer j; S.Integer k] -> K6Bar (i', j, k) | "K6Bar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6Bar()" | name, _ -> invalid_arg ("UFOx.Color.of_expr: invalid tensor '" ^ name ^ "'") let of_expr name args = [of_expr1 name args] let to_string = function | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j | Identity8 (a, b) -> Printf.sprintf "Identity8(%d,%d)" a b | Delta (y, a, b) -> Printf.sprintf "Delta(%s,%d,%d)" (Young.tableau_to_string string_of_int y) a b | T (a, i, j) -> Printf.sprintf "T(%d,%d,%d)" a i j | TY (y, a, i, j) -> Printf.sprintf "TY(%s,%d,%d,%d)" (Young.tableau_to_string string_of_int y) a i j | F (a, b, c) -> Printf.sprintf "f(%d,%d,%d)" a b c | D (a, b, c) -> Printf.sprintf "d(%d,%d,%d)" a b c | Epsilon (i, j, k) -> Printf.sprintf "Epsilon(%d,%d,%d)" i j k | EpsilonBar (i, j, k) -> Printf.sprintf "EpsilonBar(%d,%d,%d)" i j k | T6 (a, i', j') -> Printf.sprintf "T6(%d,%d,%d)" a i' j' | K6 (i', j, k) -> Printf.sprintf "K6(%d,%d,%d)" i' j k | K6Bar (i', j, k) -> Printf.sprintf "K6Bar(%d,%d,%d)" i' j k type r = S | F | C | A | YT of int Young.tableau let conjugate_tableau y = Young.map (~-) y let young_tableau_valid_UFO y = young_tableau_valid_particle y || young_tableau_valid_particle (conjugate_tableau y) let young_to_string y = ThoList.to_string (ThoList.to_string string_of_int) y let rep_trivial = function | S | YT [] | YT [[]] -> true | F | C | A | YT _ -> false let rep_to_string = function | S -> "1" | F -> "3" | C -> "3bar" | A -> "8" | YT y -> young_to_string y let rep_to_string_whizard = function | S -> "1" | F -> "3" | C -> "-3" | A -> "8" | YT y -> young_to_string y - let rep_of_int neutral = function + let rep_of_int _neutral = function | 1 -> S | 3 -> F | -3 -> C | 8 -> A | 6 -> YT [[1;2]] | -6 -> YT [[-1;-2]] | 10 -> YT [[1;2;3]] | -10 -> YT [[-1;-2;-3]] | n -> invalid_arg (Printf.sprintf "UFOx.Color: impossible representation color = %d!" n) let simplify_young_tableau = function | [] | [[]] -> S | [[i]] -> if i < 0 then C else F | y -> YT y let rep_of_int_or_young_tableau neutral i = function | None -> begin match i with | Some i -> rep_of_int neutral i | None -> Printf.eprintf "UFO: warning: missing required attribute color!\n"; S end | Some y -> if young_tableau_valid_UFO y then begin match i with | None | Some 0 -> YT y | Some i -> let ri = rep_of_int neutral i in if ri = simplify_young_tableau y then ri else invalid_arg (Printf.sprintf "UFOx.Color.rep_of_int_or_young_tableau: color = %d != color_young = %s" i (young_to_string y)) end else invalid_arg ("UFOx.Color.rep_of_int_or_young_tableau: not a standard tableau: " ^ young_to_string y) let rep_conjugate = function | S -> S | C -> F | F -> C | A -> A | YT y -> YT (conjugate_tableau y) (* \begin{dubious} Check the particle/anti-particle assignments for - the sextets! + the sextets with the table on page~\pageref{pg:UFO-Color}! + \label{pg:classify-indices} \end{dubious} *) let classify_indices1 = function | Identity (i, j) -> [(i, C); (j, F)] | Identity8 (a, b) -> [(a, A); (b, A)] | Delta (y, a, b) -> [(a, YT (conjugate_tableau y)); (b, YT y)] | T (a, i, j) -> [(i, F); (j, C); (a, A)] | TY (y, a, i, j) -> [(i, YT y); (j, YT (conjugate_tableau y)); (a, A)] | Color_Atom.F (a, b, c) | D (a, b, c) -> [(a, A); (b, A); (c, A)] | Epsilon (i, j, k) -> [(i, F); (j, F); (k, F)] | EpsilonBar (i, j, k) -> [(i, C); (j, C); (k, C)] | T6 (a, i, j) -> [(a, A); (i, YT [[1;2]]); (j, YT [[-1;-2]])] - | K6 (i, j, k) -> [(i, YT [[-1;-2]]); (j, F); (k, F)] - | K6Bar (i, j, k) -> [(i, YT [[1;2]]); (j, C); (k, C)] + | K6Bar (i, j, k) -> [(i, YT [[-1;-2]]); (j, F); (k, F)] + | K6 (i, j, k) -> [(i, YT [[1;2]]); (j, C); (k, C)] let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) let disambiguate_indices atoms = atoms type r_omega = Color.t (* Our encoding of charge conjugation only works if the indices start from 1. In [SU3], we use tableau with indices that start from 0. *) (* FIXME: $N_C=3$ should not be hardcoded! *) let omega = function | S -> Color.Singlet | F -> Color.SUN (3) | C -> Color.SUN (-3) | A -> Color.AdjSUN (3) | YT [] | YT [[]] -> Color.Singlet | YT ([] :: _ as y) -> failwith ("UFOx.Color.omega: invalid tableau: " ^ young_to_string y) | YT ((i0 :: _) :: _ as y) -> let y = Young.map (fun i -> abs i - 1) y in if i0 < 0 then Color.YTC y else Color.YT y end module Color = Tensor(Color_Atom') module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let parse_unparse s = Value.to_string (Value.of_expr (Expr.of_string s)) let apup unparsed expr = assert_equal ~printer:(fun s -> s) unparsed (parse_unparse expr) let apup_id expr = apup expr expr let suite_arithmetic = "arithmetic" >::: [ "1 + 2" >:: (fun () -> apup "3" "1+2"); "1 - 2" >:: (fun () -> apup "-1" "1-2"); "3 * 2" >:: (fun () -> apup "6" "3*2"); "3 * (-2)" >:: (fun () -> apup "-6" "3*(-2)"); "3 / 2" >:: (fun () -> apup "(3/2)" "3/2"); "4 / 12" >:: (fun () -> apup "(1/3)" "4/12"); "4 / (-6)" >:: (fun () -> apup "(-2/3)" "4/(-6)"); "3 * (6 / 12)" >:: (fun () -> apup "3*(1/2)" "3*(6/12)"); "(3 * 6) / 12)" >:: (fun () -> apup "(3/2)" "(3*6)/12") ] let suite_complex = "complex" >::: [ "1+I" >:: (fun () -> apup "1+I" "1+complex(0,1)"); "1-I" >:: (fun () -> apup "1-I" "1-complex(0,1)"); "1-I'" >:: (fun () -> apup "1+(-I)" "1+complex(0,-1)"); "1+I'" >:: (fun () -> apup "1-(-I)" "1-complex(0,-1)"); "1+1.+I" >:: (fun () -> apup "1+(1.+I)" "1+complex(1,1)"); "1+1.-I" >:: (fun () -> apup "1+(1.-I)" "1+complex(1,-1)"); "1-1.-I" >:: (fun () -> apup "1-(1.+I)" "1-complex(1,1)"); "1-1.+I" >:: (fun () -> apup "1-(1.-I)" "1-complex(1,-1)"); "2-I" >:: (fun () -> apup "1-(1.+I)" "1-complex(1,1)"); "-I+1" >:: (fun () -> apup "-I+1" "-complex(0,1)+1"); "1.-I+1" >:: (fun () -> apup "(1.-I)+1" "complex(1,-1)+1"); "1/I" >:: (fun () -> apup "1/I" "1/complex(0,1)"); "1/1" >:: (fun () -> apup "1" "1/complex(1,0)"); "1/(-1)" >:: (fun () -> apup "-1" "1/complex(-1,0)"); "1/(-I)" >:: (fun () -> apup "1/(-I)" "1/complex(0,-1)"); "1/(2*I)" >:: (fun () -> apup "1/(2.*I)" "1/complex(0,2)"); "1/(1+I)" >:: (fun () -> apup "1/(1.+I)" "1/complex(1,1)"); "1/(1-I)" >:: (fun () -> apup "1/(1.-I)" "1/complex(1,-1)"); "I/2" >:: (fun () -> apup "I/2" "complex(0,1)/2"); "1/2" >:: (fun () -> apup "(1/2)" "complex(1,0)/2"); "-1/2" >:: (fun () -> apup "(-1/2)" "complex(-1,0)/2"); "-I/2" >:: (fun () -> apup "(-I)/2" "complex(0,-1)/2"); "(2 * I) / 2" >:: (fun () -> apup "(2.*I)/2" "complex(0,2)/2"); "(1 + I) / 2" >:: (fun () -> apup "(1.+I)/2" "complex(1,1)/2"); "(1 - I) / 2" >:: (fun () -> apup "(1.-I)/2" "complex(1,-1)/2") ] let suite_product = "product" >::: [ "(-a) * (-b)" >:: (fun () -> apup "a*b" "(-a)*(-b)"); "a * (-2*b)" >:: (fun () -> apup "-2*a*b" "a*(-2*b)"); "a * (-2/3*b)" >:: (fun () -> apup "a*(-2/3)*b" "a*(-2/3*b)"); "(-2*a) * (-2*b)" >:: (fun () -> apup "4*a*b" "(-2*a)*(-2*b)") ] let suite_power = "power" >::: [ "a^b^c^d" >:: (fun () -> apup "a^(b^(c^d))" "a**b**c**d"); "(a^b)^c^d" >:: (fun () -> apup "(a^b)^(c^d)" "(a**b)**c**d"); "(a^b)^(c^d)" >:: (fun () -> apup "(a^b)^(c^d)" "(a**b)**(c**d)"); "((a^b)^c)^d" >:: (fun () -> apup "((a^b)^c)^d" "((a**b)**c)**d") ] let suite_apply = "apply" >::: [ "sin(x) * cos(x)**2" >:: (fun () -> apup "sin(x)*(cos(x))^2" "cmath.sin(x)*cmath.cos(x)**2"); "sin(x) / cos(x)**2" >:: (fun () -> apup "sin(x)/(cos(x))^2" "cmath.sin(x)/cmath.cos(x)**2"); "(sin(x) / cos(x))**2" >:: (fun () -> apup "(sin(x)/cos(x))^2" "(cmath.sin(x)/cmath.cos(x))**2") ] let suite_expr = "unparse/parse" >::: [ "a + b" >:: (fun () -> apup_id "a+b"); "a - b" >:: (fun () -> apup_id "a-b"); "a + b - c" >:: (fun () -> apup_id "a+b-c"); "a - b - c" >:: (fun () -> apup_id "a-b-c"); "-a + b - c" >:: (fun () -> apup_id "-a+b-c"); "-a - b - c" >:: (fun () -> apup_id "-a-b-c"); "(a - b) / c" >:: (fun () -> apup_id "(a-b)/c"); "(a - b) / (c + d)" >:: (fun () -> apup_id "(a-b)/(c+d)"); "(a + b - c) / d" >:: (fun () -> apup_id "(a+b-c)/d"); "a^b / c" >:: (fun () -> apup "a^b/c" "a**b/c"); "(a * b)^c / d" >:: (fun () -> apup "(a*b)^c/d" "(a*b)**c/d"); "(a * b)^(c/d)" >:: (fun () -> apup "(a*b)^(c/d)" "(a*b)**(c/d)"); "(a / b)^c / d" >:: (fun () -> apup "(a/b)^c/d" "(a/b)**c/d"); "(a + b)^c / d" >:: (fun () -> apup "(a+b)^c/d" "(a+b)**c/d"); "(a - b)^c / d" >:: (fun () -> apup "(a-b)^c/d" "(a-b)**c/d"); "-a^2" >:: (fun () -> apup "-a^2" "-a**2"); "(-a)^2" >:: (fun () -> apup "(-a)^2" "(-a)**2"); "a-b^2" >:: (fun () -> apup "a-b^2" "a-b**2"); "-a^2 + b + c" >:: (fun () -> apup "-a^2+b+c" "-a**2+b+c"); "a - b^2 + c" >:: (fun () -> apup "a-b^2+c" "a-b**2+c") ] let suite_bugreports = "bug reports" >::: [ "S2HDMIV:lam1" >:: (fun () -> apup "(Mh1^2*RA1x1^2+Mh2^2*RA2x1^2+Mh3^2*RA3x1^2-musq*SB^2)/(CB^2*vH^2)" "(Mh1**2*RA1x1**2 + Mh2**2*RA2x1**2 + Mh3**2*RA3x1**2 - musq*SB**2)/(CB**2*vH**2)"); "loop_sm:AxialZUp" >:: (fun () -> apup "(3/2)*(-ee*sw)/(6*cw)-(1/2)*cw*ee/(2*sw)" "(3.0/2.0)*(-(ee*sw)/(6.*cw))-(1.0/2.0)*((cw*ee)/(2.*sw))"); "loop_sm:AxialZUp'" >:: (fun () -> apup "(3/2)*(-ee*sw)/(6*cw)" "(3.0/2.0)*(-(ee*sw)/(6.*cw))"); "loop_sm:AxialZUp''" >:: (fun () -> apup "(3/2)*(-ee)/2" "(3.0/2.0)*(-ee/2)") ] let suite = "UFOx" >::: [suite_arithmetic; suite_complex; suite_product; suite_power; suite_apply; suite_expr; suite_bugreports] end Index: trunk/omega/src/thoList.ml =================================================================== --- trunk/omega/src/thoList.ml (revision 8919) +++ trunk/omega/src/thoList.ml (revision 8920) @@ -1,742 +1,742 @@ (* thoList.ml -- Copyright (C) 1999-2024 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 let split_last l = match List.rev l with | [] -> invalid_arg "ThoList.split_last []" | ln :: l12_rev -> (List.rev l12_rev, ln) (* This is [splitn'] all over again, but without the exception. *) let rec chopn'' n l1_rev l2 = if n <= 0 then (List.rev l1_rev, l2) else match l2 with | x :: l2' -> chopn'' (pred n) (x :: l1_rev) l2' | [] -> (List.rev l1_rev, []) let rec chopn' n ll_rev = function | [] -> List.rev ll_rev | l -> begin match chopn'' n [] l with | [], [] -> List.rev ll_rev | l1, [] -> List.rev (l1 :: ll_rev) | l1, l2 -> chopn' n (l1 :: ll_rev) l2 end let chopn n l = if n <= 0 then invalid_arg "ThoList.chopn n <= 0" else chopn' n [] l (* Find a member [a] in the list [l] and return the cyclically permuted list with [a] as head. *) let cycle_until a l = let rec cycle_until' acc = function | [] -> raise Not_found | a' :: l' as al' -> if a' = a then al' @ List.rev acc else cycle_until' (a' :: acc) l' in cycle_until' [] l let rec cycle' i acc l = if i <= 0 then l @ List.rev acc else match l with | [] -> invalid_arg "ThoList.cycle" | a' :: l' -> cycle' (pred i) (a' :: acc) l' let cycle n l = if n < 0 then invalid_arg "ThoList.cycle" else cycle' n [] l let of_subarray n1 n2 a = let rec of_subarray' n1 n2 = if n1 > n2 then [] else a.(n1) :: of_subarray' (succ n1) n2 in of_subarray' (max 0 n1) (min n2 (pred (Array.length a))) let range ?(stride=1) n1 n2 = if stride <= 0 then invalid_arg "ThoList.range: stride <= 0" else let rec range' n = if n > n2 then [] else n :: range' (n + stride) in range' n1 (* Tail recursive: *) let enumerate ?(stride=1) n l = let _, l_rev = List.fold_left (fun (i, acc) a -> (i + stride, (i, a) :: acc)) (n, []) l in List.rev l_rev (* Take the elements of [list] that satisfy [predicate] and form a list of pairs of an offset into the original list and the element with the offsets starting from [offset]. NB: the order of the returned alist is not specified! *) let alist_of_list ?(predicate=(fun _ -> true)) ?(offset=0) list = let _, alist = List.fold_left (fun (n, acc) x -> (succ n, if predicate x then (n, x) :: acc else acc)) (offset, []) list in alist (* This is \emph{not} tail recursive! *) let rec flatmap f = function | [] -> [] | x :: rest -> f x @ flatmap f rest (* This is! *) let rev_flatmap f l = let rec rev_flatmap' acc f = function | [] -> acc | x :: rest -> rev_flatmap' (List.rev_append (f x) acc) f rest in rev_flatmap' [] f l let rec power = function | [] -> [[]] | a :: a_list -> let power_a_list = power a_list in power_a_list @ List.map (fun a_list -> a :: a_list) power_a_list let rec fold_left_opt f acc = function | [] -> Some acc | a :: rest -> begin match f acc a with | None -> None | Some acc -> fold_left_opt f acc rest end let fold_left2 f acc lists = List.fold_left (List.fold_left f) acc lists let fold_right2 f lists acc = List.fold_right (List.fold_right f) lists acc let iteri f start list = ignore (List.fold_left (fun i a -> f i a; succ i) start list) let iteri2 f start_outer star_inner lists = iteri (fun j -> iteri (f j) star_inner) start_outer lists let mapi f start list = - let next, list' = + let _, list' = List.fold_left (fun (i, acc) a -> (succ i, f i a :: acc)) (start, []) list in List.rev list' let rec map3 f l1 l2 l3 = match l1, l2, l3 with | [], [], [] -> [] | a1 :: l1, a2 :: l2, a3 :: l3 -> let fa123 = f a1 a2 a3 in fa123 :: map3 f l1 l2 l3 | _, _, _ -> invalid_arg "ThoList.map3" (* Is there a more efficient implementation? *) let transpose lists = let rec transpose' rest = if List.for_all ((=) []) rest then [] else List.map List.hd rest :: transpose' (List.map List.tl rest) in try transpose' lists with | Failure s -> if s = "tl" then invalid_arg "ThoList.transpose: not rectangular" else failwith ("ThoList.transpose: unexpected Failure(" ^ s ^ ")") let compare ?(cmp=Stdlib.compare) l1 l2 = let rec compare' l1' l2' = match l1', l2' with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | n1 :: r1, n2 :: r2 -> let c = cmp n1 n2 in if c <> 0 then c else compare' r1 r2 in compare' l1 l2 let rec uniq' x = function | [] -> [] | x' :: rest -> if x' = x then uniq' x rest else x' :: uniq' x' rest let uniq = function | [] -> [] | x :: rest -> x :: uniq' x rest let rec homogeneous = function | [] | [_] -> true | a1 :: (a2 :: _ as rest) -> if a1 <> a2 then false else homogeneous rest let rec pairs' acc = function | [] -> acc - | [x] -> invalid_arg "pairs: odd number of elements" + | [_] -> 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 Stdlib.compare l) (* If we needed it, we could use a polymorphic version of [Set] to speed things up from~$O(n^2)$ to~$O(n\ln n)$. But not before it matters somewhere \ldots *) let classify l = let rec add_to_class a = function | [] -> [1, a] | (n, a') :: rest -> if a = a' then (succ n, a) :: rest else (n, a') :: add_to_class a rest in let rec classify' cl = function | [] -> cl | a :: rest -> classify' (add_to_class a cl) rest in classify' [] l -let rec factorize l = +let factorize l = let rec add_to_class x y = function | [] -> [(x, [y])] | (x', ys) :: rest -> if x = x' then (x, y :: ys) :: rest else (x', ys) :: add_to_class x y rest in let rec factorize' fl = function | [] -> fl | (x, y) :: rest -> factorize' (add_to_class x y fl) rest in List.map (fun (x, ys) -> (x, List.rev ys)) (factorize' [] l) let factorize_fold f acc l = List.map (fun (key, values) -> (key, List.fold_left f acc values)) (factorize l) let rec clone x n = if n < 0 then invalid_arg "ThoList.clone" else if n = 0 then [] else x :: clone x (pred n) let interleave f list = let rec interleave' rev_head tail = let rev_head' = List.rev_append (f rev_head tail) rev_head in match tail with | [] -> List.rev rev_head' | x :: tail' -> interleave' (x :: rev_head') tail' in interleave' [] list let interleave_nearest f list = interleave (fun head tail -> match head, tail with | h :: _, t :: _ -> f h t | _ -> []) list let rec rev_multiply n rl l = if n < 0 then invalid_arg "ThoList.multiply" else if n = 0 then [] else List.rev_append rl (rev_multiply (pred n) rl l) let multiply n l = rev_multiply n (List.rev l) l let filtermap f l = let rec rev_filtermap acc = function | [] -> List.rev acc | a :: a_list -> match f a with | None -> rev_filtermap acc a_list | Some fa -> rev_filtermap (fa :: acc) a_list in rev_filtermap [] l exception Overlapping_indices exception Out_of_bounds let iset_list_union list = List.fold_right Sets.Int.union list Sets.Int.empty let complement_index_sets n index_set_lists = let index_sets = List.map Sets.Int.of_list index_set_lists in let index_set = iset_list_union index_sets in let size_index_sets = List.fold_left (fun acc s -> Sets.Int.cardinal s + acc) 0 index_sets in if size_index_sets <> Sets.Int.cardinal index_set then raise Overlapping_indices else if Sets.Int.exists (fun i -> i < 0 || i >= n) index_set then raise Overlapping_indices else match Sets.Int.elements (Sets.Int.diff (Sets.Int.of_list (range 0 (pred n))) index_set) with | [] -> index_set_lists | complement -> complement :: index_set_lists let sort_section cmp array index_set = List.iter2 (Array.set array) index_set (List.sort cmp (List.map (Array.get array) index_set)) let partitioned_sort cmp index_sets list = let array = Array.of_list list in List.fold_left (fun () -> sort_section cmp array) () (complement_index_sets (List.length list) index_sets); Array.to_list array let ariadne_sort ?(cmp=Stdlib.compare) list = let sorted = - List.sort (fun (n1, a1) (n2, a2) -> cmp a1 a2) (enumerate 0 list) in + List.sort (fun (_, a1) (_, 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) -> Stdlib.compare n1 n2) + (fun (n1, _) (n2, _) -> Stdlib.compare n1 n2) (List.map2 (fun n a -> (n, a)) indices sorted)) let lexicographic ?(cmp=Stdlib.compare) l1 l2 = let rec lexicographic' = function | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | x1 :: rest1, x2 :: rest2 -> let res = cmp x1 x2 in if res <> 0 then res else lexicographic' (rest1, rest2) in lexicographic' (l1, l2) (* If there was a polymorphic [Set], we could also say [Set.elements (Set.union (Set.of_list l1) (Set.of_list l2))]. *) let common l1 l2 = List.fold_left (fun acc x1 -> if List.mem x1 l2 then x1 :: acc else acc) [] l1 let complement l1 = function | [] -> l1 | l2 -> if List.for_all (fun x -> List.mem x l1) l2 then List.filter (fun x -> not (List.mem x l2)) l1 else invalid_arg "ThoList.complement" let split_first_opt predicate list = let rec split_first_opt' rev_head = function | [] -> None | a :: tail -> if predicate a then Some (List.rev rev_head, a, tail) else split_first_opt' (a :: rev_head) tail in split_first_opt' [] list let take_first_even_opt predicate list = match split_first_opt predicate list with | None -> None | Some ([], i, []) -> Some (i, []) | Some ([_], _, []) -> invalid_arg "ThoList.take_first_even_opt: pair" | Some ([], i, tail) -> Some (i, tail) | Some (i1 :: i2 :: head, i, []) -> (* [ [i; i1; i2] ] is an even permutaion of [ [i1; i2; i] ] *) Some (i, i1 :: head @ [i2]) | Some (i1 :: head, i, i2 :: tail) -> (* [ [i; i2; i1] ] is an even permutaion of [ [i1; i; i2] ] *) Some (i, head @ (i2 :: i1 :: tail)) let to_string a2s alist = "[" ^ String.concat "; " (List.map a2s alist) ^ "]" let merge_sorted_alist op f1 f2 l1 l2 = let rec merge_sorted_alist' acc l1 l2 = match l1, l2 with | [], [] -> List.rev acc | tl1, [] -> List.rev_append acc (List.map (fun (k, v) -> (k, f1 v)) tl1) | [], tl2 -> List.rev_append acc (List.map (fun (k, v) -> (k, f2 v)) tl2) | (k1, v1) :: tl1, (k2, v2) :: tl2 -> let c = Stdlib.compare k1 k2 in if c = 0 then merge_sorted_alist' ((k1, op v1 v2) :: acc) tl1 tl2 else if c < 0 then merge_sorted_alist' ((k1, f1 v1) :: acc) tl1 l2 else merge_sorted_alist' ((k2, f2 v2) :: acc) l1 tl2 in merge_sorted_alist' [] l1 l2 let merge_alist op f1 f2 l1 l2 = merge_sorted_alist op f1 f2 (List.sort (fun (k1, _) (k2, _) -> Stdlib.compare k1 k2) l1) (List.sort (fun (k1, _) (k2, _) -> Stdlib.compare k1 k2) l2) let random_int_list imax n = let imax_plus = succ imax in Array.to_list (Array.init n (fun _ -> Random.int imax_plus)) module Test = struct let id x = x let int_list2_to_string l2 = to_string (to_string string_of_int) l2 (* Inefficient, must only be used for unit tests. *) let compare_lists_by_size l1 l2 = let lengths = Stdlib.compare (List.length l1) (List.length l2) in if lengths = 0 then Stdlib.compare l1 l2 else lengths open OUnit let suite_filtermap = "filtermap" >::: [ "filtermap Some []" >:: (fun () -> assert_equal ~printer:(to_string string_of_int) [] (filtermap (fun x -> Some x) [])); "filtermap None []" >:: (fun () -> assert_equal ~printer:(to_string string_of_int) - [] (filtermap (fun x -> None) [])); + [] (filtermap (fun _ -> None) [])); "filtermap even_neg []" >:: (fun () -> assert_equal ~printer:(to_string string_of_int) [0; -2; -4] (filtermap (fun n -> if n mod 2 = 0 then Some (-n) else None) (range 0 5))); "filtermap odd_neg []" >:: (fun () -> assert_equal ~printer:(to_string string_of_int) [-1; -3; -5] (filtermap (fun n -> if n mod 2 <> 0 then Some (-n) else None) (range 0 5))) ] let assert_power power_a_list a_list = assert_equal ~printer:int_list2_to_string power_a_list (List.sort compare_lists_by_size (power a_list)) let suite_power = "power" >::: [ "power []" >:: (fun () -> assert_power [[]] []); "power [1]" >:: (fun () -> assert_power [[]; [1]] [1]); "power [1;2]" >:: (fun () -> assert_power [[]; [1]; [2]; [1;2]] [1;2]); "power [1;2;3]" >:: (fun () -> assert_power [[]; [1]; [2]; [3]; [1;2]; [1;3]; [2;3]; [1;2;3]] [1;2;3]); "power [1;2;3;4]" >:: (fun () -> assert_power [[]; [1]; [2]; [3]; [4]; [1;2]; [1;3]; [1;4]; [2;3]; [2;4]; [3;4]; [1;2;3]; [1;2;4]; [1;3;4]; [2;3;4]; [1;2;3;4]] [1;2;3;4]) ] let suite_split = "split*" >::: [ "split_last []" >:: (fun () -> assert_raises (Invalid_argument "ThoList.split_last []") (fun () -> split_last [])); "split_last [1]" >:: (fun () -> assert_equal ([], 1) (split_last [1])); "split_last [2;3;1;4]" >:: (fun () -> assert_equal ([2;3;1], 4) (split_last [2;3;1;4])) ] let test_list = random_int_list 1000 100 let assert_equal_int_list = assert_equal ~printer:(to_string string_of_int) let suite_cycle = "cycle_until" >::: [ "cycle (-1) [1;2;3]" >:: (fun () -> assert_raises (Invalid_argument "ThoList.cycle") (fun () -> cycle 4 [1;2;3])); "cycle 4 [1;2;3]" >:: (fun () -> assert_raises (Invalid_argument "ThoList.cycle") (fun () -> cycle 4 [1;2;3])); "cycle 42 [...]" >:: (fun () -> let n = 42 in assert_equal_int_list (tln n test_list @ hdn n test_list) (cycle n test_list)); "cycle_until 1 []" >:: (fun () -> assert_raises (Not_found) (fun () -> cycle_until 1 [])); "cycle_until 1 [2;3;4]" >:: (fun () -> assert_raises (Not_found) (fun () -> cycle_until 1 [2;3;4])); "cycle_until 1 [1;2;3;4]" >:: (fun () -> assert_equal [1;2;3;4] (cycle_until 1 [1;2;3;4])); "cycle_until 3 [1;2;3;4]" >:: (fun () -> assert_equal [3;4;1;2] (cycle_until 3 [3;4;1;2])); "cycle_until 4 [1;2;3;4]" >:: (fun () -> assert_equal [4;1;2;3] (cycle_until 4 [4;1;2;3])) ] let suite_alist_of_list = "alist_of_list" >::: [ "simple" >:: (fun () -> assert_equal [(46, 4); (44, 2); (42, 0)] (alist_of_list ~predicate:(fun n -> n mod 2 = 0) ~offset:42 [0;1;2;3;4;5])) ] let suite_factorize_fold = "factorize_fold" >::: [ "simple" >:: (fun () -> assert_equal [(1, 21); (2, 41)] (factorize_fold (+) 0 [(1, 10); (2, 20); (2, 21); (1, 11)])) ] let suite_complement = "complement" >::: [ "simple" >:: (fun () -> assert_equal [2;4] (complement [1;2;3;4] [1; 3])); "empty" >:: (fun () -> assert_equal [1;2;3;4] (complement [1;2;3;4] [])); "failure" >:: (fun () -> assert_raises (Invalid_argument ("ThoList.complement")) (fun () -> complement (complement [1;2;3;4] [5]))) ] let suite_merge_alist = "merge_alist" >::: [ "[] []" >:: (fun () -> assert_equal [] (merge_alist (+) id id [] [])); "[] [(a, 1); (b, 2)]" >:: (fun () -> assert_equal [("a", 1); ("b", 2)] (merge_alist (+) id id [] [("a", 1); ("b", 2)])); "[(a, 1); (b, 2)] []" >:: (fun () -> assert_equal [("a", 1); ("b", 2)] (merge_alist (+) id id [("a", 1); ("b", 2)] [])); "[(a, 1); (b, 2)] [(c, 3); (b, 2)]" >:: (fun () -> assert_equal [("a", 1); ("b", 4); ("c", 3)] (merge_alist (+) id id [("a", 1); ("b", 2)] [("c", 3); ("b", 2)])) ] let suite_take_first_even_opt = "take_first_even_opt" >::: [ "empty" >:: (fun () -> assert_equal None (take_first_even_opt ((=) 1) [])); "not found" >:: (fun () -> assert_equal None (take_first_even_opt ((=) 0) [1;2;3])); "1 [1;2;3]" >:: (fun () -> assert_equal (Some (1, [2;3])) (take_first_even_opt ((=) 1) [1;2;3])); "2 [1;2;3]" >:: (fun () -> assert_equal (Some (2, [3;1])) (take_first_even_opt ((=) 2) [1;2;3])); "3 [1;2;3]" >:: (fun () -> assert_equal (Some (3, [1;2])) (take_first_even_opt ((=) 3) [1;2;3])); "1 [1;2;3;4]" >:: (fun () -> assert_equal (Some (1, [2;3;4])) (take_first_even_opt ((=) 1) [1;2;3;4])); "2 [1;2;3;4]" >:: (fun () -> assert_equal (Some (2, [3;1;4])) (take_first_even_opt ((=) 2) [1;2;3;4])); "3 [1;2;3;4]" >:: (fun () -> assert_equal (Some (3, [2;4;1])) (take_first_even_opt ((=) 3) [1;2;3;4])); "4 [1;2;3;4]" >:: (fun () -> assert_equal (Some (4, [1;3;2])) (take_first_even_opt ((=) 4) [1;2;3;4])); "pair" >:: (fun () -> assert_raises (Invalid_argument ("ThoList.take_first_even_opt: pair")) (fun () -> take_first_even_opt ((=) 2) [1;2])) ] let suite = "ThoList" >::: [suite_filtermap; suite_power; suite_split; suite_cycle; suite_alist_of_list; suite_factorize_fold; suite_complement; suite_merge_alist; suite_take_first_even_opt] end Index: trunk/omega/src/dune-project =================================================================== --- trunk/omega/src/dune-project (revision 0) +++ trunk/omega/src/dune-project (revision 8920) @@ -0,0 +1,3 @@ +(lang dune 2.9) +(package (name omega)) +(cram enable) Index: trunk/omega/src/thoString.mli =================================================================== --- trunk/omega/src/thoString.mli (revision 8919) +++ trunk/omega/src/thoString.mli (revision 8920) @@ -1,71 +1,74 @@ (* thoString.mli -- Copyright (C) 1999-2024 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 is a very simple library if string manipulation functions missing in O'Caml's standard library. *) +(* Length of the longest string in the list. *) +val max_length : string list -> int + (* [strip_prefix prefix string] returns [string] with 0 or 1 occurences of a leading [prefix] removed. *) val strip_prefix : string -> string -> string (* [strip_prefix_star prefix string] returns [string] with any number of leading occurences of [prefix] removed. *) val strip_prefix_star : char -> string -> string (* [strip_prefix prefix string] returns [string] with a leading [prefix] removed, raises [Invalid_argument] if there's no match. *) val strip_required_prefix : string -> string -> string (* [strip_from_first c s] returns [s] with everything starting from the first [c] removed. [strip_from_last c s] returns [s] with everything starting from the last [c] removed. *) val strip_from_first : char -> string -> string val strip_from_last : char -> string -> string (* [index_string pattern string] returns the index of the first occurence of [pattern] in [string], if any. Raises [Not_found], if [pattern] is not in [string]. *) val index_string : string -> string -> int (* This silently fails if the argument contains both single and double quotes! *) val quote : string -> string (* The corresponding functions from [String] have become obsolescent with O'Caml~4.0.3. Quanrantine them here. *) val uppercase : string -> string val lowercase : string -> string (* Ignore the case in comparisons. *) val compare_caseless : string -> string -> int (* Match the regular expression \texttt{\lbrack A-Za-z\rbrack\lbrack A-Za-z0-9\_\rbrack*} *) val valid_fortran_id : string -> bool (* Replace any invalid character by ['_'] and prepend ["N_"] iff the string doesn't start with a letter. *) val sanitize_fortran_id : string -> string module Test : sig val suite : OUnit.test end Index: trunk/omega/src/UFO_Lorentz.ml =================================================================== --- trunk/omega/src/UFO_Lorentz.ml (revision 8919) +++ trunk/omega/src/UFO_Lorentz.ml (revision 8920) @@ -1,1020 +1,1020 @@ (* UFO_Lorentz.ml -- Copyright (C) 1999-2017 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Processed UFO Lorentz Structures} *) module Q = Algebra.Q module QC = Algebra.QC module A = UFOx.Lorentz_Atom module D = Dirac.Chiral (* Take a [A.t list] and return the corresponding pair [A.dirac list * A.vector list * A.scalar list * A.scalar list], without preserving the order (currently, the order is reversed). *) let split_atoms atoms = List.fold_left (fun (d, v, s, i) -> function | A.Vector v' -> (d, v' :: v, s, i) | A.Dirac d' -> (d' :: d, v, s, i) | A.Scalar s' -> (d, v, s' :: s, i) | A.Inverse i' -> (d, v, s, i' :: i)) ([], [], [], []) atoms (* Just like [UFOx.Lorentz_Atom.dirac], but without the Dirac matrix indices. *) type dirac = | Gamma5 | ProjM | ProjP | Gamma of int | Sigma of int * int | C | Minus let map_indices_gamma f = function | (Gamma5 | ProjM | ProjP | C | Minus as g) -> g | Gamma mu -> Gamma (f mu) | Sigma (mu, nu) -> Sigma (f mu, f nu) (* A sandwich of a string of $\gamma$-matrices. [bra] and [ket] are positions of fields in the vertex. *) type dirac_string = { bra : int; ket : int; conjugated : bool; gammas : dirac list } let map_indices_dirac f d = { bra = f d.bra; ket = f d.ket; conjugated = d.conjugated; gammas = List.map (map_indices_gamma f) d.gammas } let toggle_conjugated ds = { ds with conjugated = not ds.conjugated } -let flip_bra_ket ds = +let _flip_bra_ket ds = { ds with bra = ds.ket; ket = ds.bra } (* The implementation of couplings for Dirac spinors in \texttt{omega\_spinors} uses \texttt{conjspinor\_spinor} which is a straightforward positive inner product \begin{equation} \text{\texttt{psibar0 * psi1}} = \bar\psi_0\psi_1 = \sum_\alpha \bar\psi_{0,\alpha} \psi_{1,\alpha}\,. \end{equation} Note that~the row spinor~$\bar\psi_0$ is the actual argument, it is \emph{not} conjugated and multplied by~$\gamma_0$! In contrast, JRR's implementation of couplings for Majorana spinors uses \texttt{spinor\_product} in \texttt{omega\_bispinors} \begin{equation} \text{\texttt{chi0 * chi1}} = \chi_0^T C\chi_1 \end{equation} with a charge antisymmetric and unitary conjugation matrix: $C^{-1}=C^\dagger$ and~$C^T=-C$. This product is obviously antisymmetric: \begin{equation} \text{\texttt{chi0 * chi1}} = \chi_0^T C\chi_1 = \chi_1^T C^T\chi_0 = - \chi_1^T C\chi_0 = \text{\texttt{- chi1 * chi0}}\,. \end{equation} *) (*i \begin{subequations} \begin{align} \tilde\chi &= C\bar\chi^T \\ \bar{\tilde\chi} &= -\chi^T C^{-1} \,. \end{align} \end{subequations} So we write in JRR's implementation \begin{equation} \bar\chi_0 \Gamma \chi_1\phi = \bar\chi_0 C^T C\Gamma \chi_1\phi = (C\bar\chi_0^T)^T C\Gamma \chi_1\phi = \tilde\chi_0^T C\Gamma \chi_1\phi \end{equation} using~$C^{-1}=C^\dagger$, $C^T=-C$ and the representation dependent~$C^2=-\mathbf{1}$ that holds in all our representation(s). Analogously \begin{multline} \bar\chi_0 \Gamma \chi_1\phi = \left(\bar\chi_0 \Gamma \chi_1\right)^T \phi = - \chi_1^T \Gamma^T \bar\chi_0^T \phi = \bar{\tilde\chi}_1 C \Gamma^T C^{-1}\tilde\chi_0 \phi = - \chi_1^T C^{-1} C \Gamma^T C^{-1}\tilde\chi_0 \phi \\ = - \chi_1^T \Gamma^T C^{-1}\tilde\chi_0 \phi = - \chi_1^T \Gamma^T C^T \tilde\chi_0 \phi = - \chi_1^T (C\Gamma)^T \tilde\chi_0 \phi \end{multline} i*) (* In the following, we assume to be in a realization with~$C^{-1}=-C$, i.\,e.~$C^2=-\mathbf{1}$: *) let inv_C = [Minus; C] (* In JRR's implementation of Majorana fermions (see page~\pageref{pg:JRR-Fusions}), \emph{all} fermion-boson fusions are realized with the \texttt{f\_}$\phi$\texttt{f(g,phi,chi)} functions, where $\phi\in\{\text{\texttt{v}},\text{\texttt{a}},\ldots\}$. This is different from the original Dirac implementation, where \emph{both} \texttt{f\_}$\phi$\texttt{f(g,phi,psi)} and \texttt{f\_f}$\phi$\texttt{(g,psibar,phi)} are used. However, the latter plays nicer with the permutations in the UFO version of [fuse]. Therefore, we can attempt to automatically map \texttt{f\_}$\phi$\texttt{f(g,phi,chi)} to \texttt{f\_f}$\phi$\texttt{(g,chi,phi)} by an appropriate transformation of the $\gamma$-matrices involved. *) (* Starting from \begin{equation} \text{\texttt{f\_}$\phi$\texttt{f(g,phi,chi)}} = \Gamma_\phi^\mu\chi \end{equation} where~$\Gamma_\phi$ is the contraction of the bosonic field~$\phi$ with the appropriate product of $\gamma$-matrices, we obtain a condition on the corresponding matrix~$\tilde\Gamma_\phi$ that appears in~\texttt{f\_f}$\phi$: \begin{equation} \label{eq:Gamma-tilde} \text{\texttt{f\_f}$\phi$\texttt{(g,chi,phi)}} = \chi^T\tilde\Gamma_\phi^\mu = \left((\tilde\Gamma_\phi)^T \chi\right)^T \stackrel{!}{=} \left(\Gamma_\phi\chi\right)^T\,. \end{equation} This amounts to requiring $\tilde\Gamma=\Gamma^T$, as one might have expected. Below we will see that this is \emph{not} the correct approach. *) (* In any case, we can use the standard charge conjugation matrix relations \begin{subequations} \label{eq:transpose-gamma} \begin{align} \mathbf{1}^T &= \mathbf{1} \\ \gamma_\mu^T &= - C\gamma_\mu C^{-1} \\ \sigma_{\mu\nu}^T &= C\sigma_{\nu\mu} C^{-1} = - C\sigma_{\mu\nu} C^{-1} \\ (\gamma_5\gamma_\mu)^T &= \gamma_\mu^T \gamma_5^T = - C\gamma_\mu\gamma_5 C^{-1} = C\gamma_5\gamma_\mu C^{-1} \\ \gamma_5^T &= C\gamma_5 C^{-1} \end{align} \end{subequations} to perform the transpositions symbolically. For the chiral projectors \begin{equation} \gamma_\pm = \mathbf{1}\pm\gamma_5 \end{equation} this means\footnote{The final two equations are two different ways to obtain the same result, of course.} \begin{subequations} \label{eq:transpose-gamma'} \begin{align} \gamma_\pm^T &= (\mathbf{1}\pm\gamma_5)^T = C(\mathbf{1}\pm\gamma_5) C^{-1} = C\gamma_\pm C^{-1} \\ (\gamma_\mu\gamma_\pm)^T &= \gamma_\pm^T \gamma_\mu^T = - C\gamma_\pm \gamma_\mu C^{-1} = - C\gamma_\mu\gamma_\mp C^{-1} \\ (\gamma_\mu\pm\gamma_\mu\gamma_5)^T &= - C(\gamma_\mu\mp\gamma_\mu\gamma_5) C^{-1} \end{align} \end{subequations} and of course \begin{equation} C^T = - C\,. \end{equation} *) (* The implementation starts from transposing a single factor using~\eqref{eq:transpose-gamma} and~\eqref{eq:transpose-gamma'}: *) let transpose1 = function | (Gamma5 | ProjM | ProjP as g) -> [C; g] @ inv_C | (Gamma _ | Sigma (_, _) as g) -> [Minus] @ [C; g] @ inv_C | C -> [Minus; C] | Minus -> [Minus] (* In general, this will leave more than one [Minus] in the result and we can pull these out: *) let rec collect_signs_rev (negative, acc) = function | [] -> (negative, acc) | Minus :: g_list -> collect_signs_rev (not negative, acc) g_list | g :: g_list -> collect_signs_rev (negative, g :: acc) g_list (* Also, there will be products~$CC$ inside the result, these can be canceled, since we assume~$C^2=-\mathbf{1}$: *) let rec compress_ccs_rev (negative, acc) = function | [] -> (negative, acc) | C :: C :: g_list -> compress_ccs_rev (not negative, acc) g_list | g :: g_list -> compress_ccs_rev (negative, g :: acc) g_list (* Compose [collect_signs_rev] and [compress_ccs_rev]. The two list reversals will cancel. *) let compress_signs g_list = let negative, g_list_rev = collect_signs_rev (false, []) g_list in match compress_ccs_rev (negative, []) g_list_rev with | true, g_list -> Minus :: g_list | false, g_list -> g_list (* Transpose all factors in reverse order and clean up: *) let transpose d = { d with gammas = compress_signs (ThoList.rev_flatmap transpose1 d.gammas) } (* We can also easily flip the sign: *) let minus d = { d with gammas = compress_signs (Minus :: d.gammas) } (*i \footnote{In components: \begin{subequations} \begin{align} \text{\texttt{chi0 * f\_}$\phi$\texttt{f(g,phi1,chi2)}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'}\chi_{0,\alpha'} \Gamma^\mu_{\alpha\beta}\chi_{2,\beta} = \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\alpha'} C^T_{\alpha'\alpha} \Gamma^\mu_{\alpha\beta}\chi_{2,\beta} \\ \text{\texttt{f\_f}$\phi$\texttt{(g,chi0,phi1) * chi2}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'}\chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha'} \chi_{2,\alpha} =\sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha'} C^T_{\alpha'\alpha}\chi_{2,\alpha} \\ \text{\texttt{chi2 * f\_f}$\phi$\texttt{(g,chi0,phi1)}} &\cong \sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} C_{\alpha\alpha'} \chi_{2,\alpha'} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha} =\sum_{\mu,\alpha,\alpha',\beta} \phi_{1,\mu} \chi_{0,\beta} \tilde\Gamma^\mu_{\beta\alpha} C_{\alpha\alpha'} \chi_{2,\alpha'} \end{align} \end{subequations}} i*) (* Also in \texttt{omega\_spinors} \begin{equation} \text{$\phi$\texttt{\_ff(g,psibar1,psi2)}} = \bar\psi_1 \Gamma_\phi\psi_2\,, \end{equation} while in \texttt{omega\_bispinors} \begin{equation} \text{$\phi$\texttt{\_ff(g,chi1,chi2)}} = \chi_1^T C\Gamma_\phi\chi_2\,. \end{equation} The latter has mixed symmetry, depending on the $\gamma$-matrices in~$\Gamma_\phi$ according to~\eqref{eq:transpose-gamma} and~\eqref{eq:transpose-gamma'} \begin{equation} \text{$\phi$\texttt{\_ff(g,chi2,chi1)}} = \chi_2^T C\Gamma_{\phi}\chi_1 = \chi_1^T \Gamma^T_{\phi} C^T\chi_2 = - \chi_1^T \Gamma^T_{\phi} C\chi_2 = \pm \chi_1^T C \Gamma_{\phi} C^{-1} C\chi_2 = \pm \chi_1^T C \Gamma_{\phi} \chi_2\,. \end{equation} *) (* \thocwmodulesection{Testing for Self-Consistency Numerically} *) (* In the tests \texttt{keystones\_omegalib} and \texttt{keystones\_UFO}, we check that the vertex~$\bar\psi_0\Gamma_{\phi_1}\psi_2$ can be expressed in three ways, which must all agree. In the case of \texttt{keystones\_omegalib}, the equivalences are \begin{subequations} \begin{align} \text{\texttt{psibar0 * f\_$\phi$f(g,phi1,psi2)}} &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ \text{\texttt{f\_f$\phi$(g,psibar0,phi1) * psi2}} &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ \text{\texttt{phi1 * $\phi$\_ff(g,psibar0,psi2)}} &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \,. \end{align} \end{subequations} In the case of \texttt{keystones\_UFO}, we use cyclic permutations to match the use in [UFO_targets], as described in the table following~\eqref{eq:cyclic-UFO-fusions} \begin{subequations} \begin{align} \text{\texttt{psibar0 * f$\phi$f\_p012(g,phi1,psi2)}} &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ \text{\texttt{f$\phi$f\_p201(g,psibar0,phi1) * psi2}} &= \bar\psi_0 \Gamma_{\phi_1} \psi_2 \\ \text{\texttt{phi1 * f$\phi$f\_p120(g,psi2,psibar0)}} &= \tr \left( \Gamma_{\phi_1} \psi_2\otimes\bar\psi_0 \right) = \bar\psi_0 \Gamma_{\phi_1} \psi_2 \,. \end{align} \end{subequations} In both cases, there is no ambiguity regarding the position of spinors and conjugate spinors, since the inner product \texttt{conjspinor\_spinor} is not symmetrical. Note that, from the point of view of permutations, the notation $\tr(\Gamma \psi'\otimes\bar\psi)$ is more natural than the equivalent $\bar\psi\Gamma\psi'$ that inspired the $\phi{\texttt{\_ff}}$ functions in the \texttt{omegalib} more than 20 years ago. *) (* We would like to perform the same tests in \texttt{keystones\_omegalib\_bispinors} and \texttt{keystones\_UFO\_bispinors}, but now we have to be more careful in positioning the Majorana spinors, because we can not rely on the Fortran type system to catch cofusions of \texttt{spinor} and \texttt{conjspinor} fields. In addition, we must make sure to insert charge conjugation matrices in the proper places~\cite{Denner:Majorana}. Regarding the tests in \texttt{keystones\_omegalib\_bispinors}, we observe \begin{subequations} \begin{align} \text{\texttt{chi0 * f\_}$\phi$\texttt{f(g,phi1,chi2)}} &= \chi_0^T C \Gamma_{\phi_1} \chi_2 \\ \text{\texttt{phi1 * $\phi$\texttt{\_ff}(g,chi0,chi2)}} &= \chi_0^T C \Gamma_{\phi_1} \chi_2 \end{align} \end{subequations} and \begin{subequations} \begin{align} \text{\texttt{chi2 * f\_f}$\phi$\texttt{(g,chi0,phi1)}} &= \chi_2^T C (\chi_0^T\tilde\Gamma_{\phi_1}^\mu)^T = \chi_2^T C (\tilde\Gamma_{\phi_1}^\mu)^T \chi_0 = \chi_2^T C \Gamma_{\phi_1} \chi_0 \\ \text{\texttt{phi1 * $\phi$\texttt{\_ff}(g,chi2,chi0)}} &= \chi_2^T C \Gamma_{\phi_1} \chi_0\,, \end{align} \end{subequations} while \begin{align} \text{\texttt{f\_f}$\phi$\texttt{(g,chi0,phi1) * chi2}} &= \chi_0^T\tilde\Gamma_{\phi_1} C\chi_2 = \chi_0^T\Gamma_{\phi_1}^T C\chi_2 = (\Gamma_{\phi_1}\chi_0)^T C\chi_2 \end{align} is different. JRR solved this problem by abandoning \texttt{f\_f$\phi$} altogether and using \texttt{$\phi$\_ff} only in the form \texttt{$\phi$\_ff(g,chi0,chi2)}. Turning to the tests in \texttt{keystones\_UFO\_bispinors}, it would be convenient to be able to use \begin{subequations} \begin{align} \text{\texttt{chi0 * f$\phi$f\_p012(g,phi1,chi2)}} &= \chi_0^T C \Gamma_{\phi_1}^{012} \chi_2 \\ \text{\texttt{f$\phi$f\_p201(g,chi0,phi1) * chi2}} &= \chi_0^T \Gamma_{\phi_1}^{201} C \chi_2 \\ \text{\texttt{phi1 * f$\phi$f\_p120(g,chi2,chi0)}} &= \tr \left( \Gamma_{\phi_1}^{120} \chi_2 \otimes \chi_0^T \right) = \chi_0^T \Gamma_{\phi_1}^{120} \chi_2 = \chi_2^T (\Gamma_{\phi_1}^{120})^T \chi_0 \,, \end{align} \end{subequations} where~$\Gamma^{012}=\Gamma$ is the string of $\gamma$-matrices as written in the Lagrangian. Obviously, we should require \begin{equation} \Gamma^{120} = C \Gamma^{012} = C \Gamma \end{equation} as expected from \texttt{omega\_bispinors}. *) let cc_times d = { d with gammas = compress_signs (C :: d.gammas) } (* For~$\Gamma^{201}$ we must require\footnote{% Note that we don't get anything new, if we reverse the scalar product \begin{equation*} \text{\texttt{chi2 * f$\phi$f\_p201(g,chi0,phi1)}} = \chi_2^T C (\chi_0^T \Gamma_{\phi_1}^{201})^T = \chi_0^T \Gamma_{\phi_1}^{201} C^T \chi_2\,. \end{equation*} We would find the condition \begin{equation*} - \Gamma^{201} C = \Gamma^{201} C^T = C \Gamma \end{equation*} i.\,e.~only a sign \begin{equation*} \Gamma^{201} = - C \Gamma C^{-1} \not= \Gamma^T \,, \end{equation*} as was to be expected from the antisymmetry of \texttt{spinor\_product}, of course.} \begin{equation} \Gamma^{201} C = C \Gamma^{012} = C \Gamma \end{equation} i.\,e. \begin{equation} \Gamma^{201} = C \Gamma C^{-1} \not= \Gamma^T \,. \end{equation} *) let conjugate d = { d with gammas = compress_signs (C :: d.gammas @ inv_C) } let conjugate_transpose d = conjugate (transpose d) let times_minus_cc d = { d with gammas = compress_signs (d.gammas @ [Minus; C]) } (* \thocwmodulesection{From Dirac Strings to $4\times4$ Matrices} *) (* [dirac_string bind ds] applies the mapping [bind] to the indices of $\gamma_\mu$ and~$\sigma_{\mu\nu}$ and multiplies the resulting matrices in order using complex rational arithmetic. *) module type To_Matrix = sig val dirac_string : (int -> int) -> dirac_string -> D.t end module To_Matrix : To_Matrix = struct let half = QC.make (Q.make 1 2) Q.null let half_i = QC.make Q.null (Q.make 1 2) let gamma_L = D.times half (D.sub D.unit D.gamma5) let gamma_R = D.times half (D.add D.unit D.gamma5) let sigma = Array.make_matrix 4 4 D.null let () = for mu = 0 to 3 do for nu = 0 to 3 do sigma.(mu).(nu) <- D.times half_i (D.sub (D.mul D.gamma.(mu) D.gamma.(nu)) (D.mul D.gamma.(nu) D.gamma.(mu))) done done let dirac bind_indices = function | Gamma5 -> D.gamma5 | ProjM -> gamma_L | ProjP -> gamma_R | Gamma (mu) -> D.gamma.(bind_indices mu) | Sigma (mu, nu) -> sigma.(bind_indices mu).(bind_indices nu) | C -> D.cc | Minus -> D.neg D.unit let dirac_string bind_indices ds = D.product (List.map (dirac bind_indices) ds.gammas) end let dirac_string_to_matrix = To_Matrix.dirac_string (* The Lorentz indices appearing in a term are either negative internal summation indices or positive external polarization indices. Note that the external indices are not really indices, but denote the position of the particle in the vertex. *) type 'a term = { indices : int list; atom : 'a } let map_atom f term = { term with atom = f term.atom } let map_term f_index f_atom term = { indices = List.map f_index term.indices; atom = f_atom term.atom } (* Return a pair of lists: first the (negative) summation indices, second the (positive) external indices. *) let classify_indices ilist = List.partition (fun i -> if i < 0 then true else if i > 0 then false else invalid_arg "classify_indices") ilist (* Recursions on this type only stop when we come across an empty [denominator]. In practice, this is no problem (we never construct values that recurse more than once), but it would be cleaner to use polymorphic variants as suggested for [UFOx.Tensor.t]. *) type contraction = { coeff : QC.t; dirac : dirac_string term list; vector : A.vector term list; scalar : A.scalar list; inverse : A.scalar list; denominator : contraction list } let fermion_lines_of_contraction contraction = List.sort compare (List.map (fun term -> (term.atom.ket, term.atom.bra)) contraction.dirac) let rec map_indices_contraction f c = { coeff = c.coeff; dirac = List.map (map_term f (map_indices_dirac f)) c.dirac; vector = List.map (map_term f (A.map_indices_vector f)) c.vector; scalar = List.map (A.map_indices_scalar f) c.scalar; inverse = List.map (A.map_indices_scalar f) c.inverse; denominator = List.map (map_indices_contraction f) c.denominator } type t = contraction list let dummy = [] let rec charge_conjugate_dirac (ket, bra as fermion_line) = function | [] -> [] | dirac :: dirac_list -> if dirac.atom.bra = bra && dirac.atom.ket = ket then map_atom toggle_conjugated dirac :: dirac_list else dirac :: charge_conjugate_dirac fermion_line dirac_list let charge_conjugate_contraction fermion_line c = { c with dirac = charge_conjugate_dirac fermion_line c.dirac } let charge_conjugate fermion_line l = List.map (charge_conjugate_contraction fermion_line) l let fermion_lines contractions = let pairs = List.map fermion_lines_of_contraction contractions in match ThoList.uniq (List.sort compare pairs) with | [] -> invalid_arg "UFO_Lorentz.fermion_lines: impossible" | [pairs] -> pairs | _ -> invalid_arg "UFO_Lorentz.fermion_lines: ambiguous" let map_indices f contractions = List.map (map_indices_contraction f) contractions let map_fermion_lines f pairs = List.map (fun (i, j) -> (f i, f j)) pairs let dirac_of_atom = function | A.Identity (_, _) -> [] | A.C (_, _) -> [C] | A.Gamma5 (_, _) -> [Gamma5] | A.ProjP (_, _) -> [ProjP] | A.ProjM (_, _) -> [ProjM] | A.Gamma (mu, _, _) -> [Gamma mu] | A.Sigma (mu, nu, _, _) -> [Sigma (mu, nu)] let dirac_indices = function | A.Identity (i, j) | A.C (i, j) | A.Gamma5 (i, j) | A.ProjP (i, j) | A.ProjM (i, j) | A.Gamma (_, i, j) | A.Sigma (_, _, i, j) -> (i, j) let rec scan_for_dirac_string stack = function | [] -> (* We're done with this pass. There must be no leftover atoms on the [stack] of spinor atoms, but we'll check this in the calling function. *) (None, List.rev stack) | atom :: atoms -> let i, j = dirac_indices atom in if i > 0 then if j > 0 then (* That's an atomic Dirac string. Collect all atoms for further processing. *) (Some { bra = i; ket = j; conjugated = false; gammas = dirac_of_atom atom }, List.rev_append stack atoms) else (* That's the start of a new Dirac string. Search for the remaining elements, not forgetting matrices that we might pushed on the [stack] earlier. *) collect_dirac_string i j (dirac_of_atom atom) [] (List.rev_append stack atoms) else (* The interior of a Dirac string. Push it on the stack until we find the start. *) scan_for_dirac_string (atom :: stack) atoms (* Complete the string starting with [i] and the current summation index [j]. *) and collect_dirac_string i j rev_ds stack = function | [] -> (* We have consumed all atoms without finding the end of the string. *) invalid_arg "collect_dirac_string: open string" | atom :: atoms -> let i', j' = dirac_indices atom in if i' = j then if j' > 0 then (* Found the conclusion. Collect all atoms on the [stack] for further processing. *) (Some { bra = i; ket = j'; conjugated = false; gammas = List.rev_append rev_ds (dirac_of_atom atom)}, List.rev_append stack atoms) else (* Found the continuation. Pop the stack of open indices, since we're looking for a new one. *) collect_dirac_string i j' (dirac_of_atom atom @ rev_ds) [] (List.rev_append stack atoms) else (* Either the start of another Dirac string or a non-matching continuation. Push it on the stack until we're done with the current one. *) collect_dirac_string i j rev_ds (atom :: stack) atoms let dirac_string_of_dirac_atoms atoms = scan_for_dirac_string [] atoms let rec dirac_strings_of_dirac_atoms' rev_ds atoms = match dirac_string_of_dirac_atoms atoms with | (None, []) -> List.rev rev_ds | (None, _) -> invalid_arg "dirac_string_of_dirac_atoms: leftover atoms" | (Some ds, atoms) -> dirac_strings_of_dirac_atoms' (ds :: rev_ds) atoms let dirac_strings_of_dirac_atoms atoms = dirac_strings_of_dirac_atoms' [] atoms let indices_of_vector = function | A.Epsilon (mu1, mu2, mu3, mu4) -> [mu1; mu2; mu3; mu4] | A.Metric (mu1, mu2) -> [mu1; mu2] | A.P (mu, n) -> if n > 0 then [mu] else invalid_arg "indices_of_vector: invalid momentum" let classify_vector atom = { indices = indices_of_vector atom; atom } let indices_of_dirac = function | Gamma5 | ProjM | ProjP | C | Minus -> [] | Gamma (mu) -> [mu] | Sigma (mu, nu) -> [mu; nu] let indices_of_dirac_string ds = ThoList.flatmap indices_of_dirac ds.gammas let classify_dirac atom = { indices = indices_of_dirac_string atom; atom } let contraction_of_lorentz_atoms denominator (atoms, coeff) = let dirac_atoms, vector_atoms, scalar, inverse = split_atoms atoms in let dirac = List.map classify_dirac (dirac_strings_of_dirac_atoms dirac_atoms) and vector = List.map classify_vector vector_atoms in { coeff; dirac; vector; scalar; inverse; denominator } type redundancy = | Trace of int | Replace of int * int let rec redundant_metric' rev_atoms = function | [] -> (None, List.rev rev_atoms) - | { atom = A.Metric (mu, nu) } as atom :: atoms -> + | { 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 -> + | { 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 = +let _remove a alist = List.filter ((<>) a) alist let substitute_index1 mu nu mu1 = if mu = mu1 then nu else mu1 let substitute_index mu nu indices = List.map (substitute_index1 mu nu) indices (* This assumes that [mu] is a summation index and [nu] is a polarization index. *) let substitute_index_vector mu nu vectors = List.map (fun v -> { indices = substitute_index mu nu v.indices; atom = substitute_index_vector1 mu nu v.atom }) vectors (* Substitude any occurance of the index [mu] by the index [nu]: *) let substitute_index_dirac1 mu nu = function | (Gamma5 | ProjM | ProjP | C | Minus) as g -> g | Gamma (mu1) as g -> if mu = mu1 then Gamma (nu) else g | Sigma (mu1, mu2) as g -> if mu = mu1 then Sigma (nu, mu2) else if mu = mu2 then Sigma (mu1, nu) else g (* This assumes that [mu] is a summation index and [nu] is a polarization index. *) let substitute_index_dirac mu nu dirac_strings = List.map (fun ds -> { indices = substitute_index mu nu ds.indices; atom = { ds.atom with gammas = List.map (substitute_index_dirac1 mu nu) ds.atom.gammas } } ) dirac_strings let trace_metric = QC.make (Q.make 4 1) Q.null (* FIXME: can this be made typesafe by mapping to a type that \emph{only} contains [P] and [Epsilon]? *) let rec compress_metrics c = match redundant_metric c.vector with | None, _ -> c - | Some (Trace mu), vector' -> + | Some (Trace _mu), vector' -> compress_metrics { coeff = QC.mul trace_metric c.coeff; dirac = c.dirac; vector = vector'; scalar = c.scalar; inverse = c.inverse; denominator = c.denominator } | Some (Replace (mu, nu)), vector' -> compress_metrics { coeff = c.coeff; dirac = substitute_index_dirac mu nu c.dirac; vector = substitute_index_vector mu nu vector'; scalar = c.scalar; inverse = c.inverse; denominator = c.denominator } let compress_denominator = function | [([], q)] as denominator -> if QC.is_unit q then [] else denominator | denominator -> denominator -let parse1 spins denominator atom = +let parse1 _spins denominator atom = compress_metrics (contraction_of_lorentz_atoms denominator atom) let parse ?(allow_denominator=false) spins = function | UFOx.Lorentz.Linear l -> List.map (parse1 spins []) l | UFOx.Lorentz.Ratios r -> ThoList.flatmap (fun (numerator, denominator) -> match compress_denominator denominator with | [] -> List.map (parse1 spins []) numerator | d -> if allow_denominator then let parsed_denominator = List.map (parse1 [Coupling.Scalar; Coupling.Scalar] []) denominator in List.map (parse1 spins parsed_denominator) numerator else invalid_arg (Printf.sprintf "UFO_Lorentz.parse: denominator %s in %s not allowed here!" (UFOx.Lorentz.to_string (UFOx.Lorentz.Linear d)) (UFOx.Lorentz.to_string (UFOx.Lorentz.Ratios r)))) r let i2s = UFOx.Index.to_string let vector_to_string = function | A.Epsilon (mu, nu, ka, la) -> Printf.sprintf "Epsilon(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s ka) (i2s la) | A.Metric (mu, nu) -> Printf.sprintf "Metric(%s,%s)" (i2s mu) (i2s nu) | A.P (mu, n) -> Printf.sprintf "P(%s,%d)" (i2s mu) n let dirac_to_string = function | Gamma5 -> "g5" | ProjM -> "(1-g5)/2" | ProjP -> "(1+g5)/2" | Gamma (mu) -> Printf.sprintf "g(%s)" (i2s mu) | Sigma (mu, nu) -> Printf.sprintf "s(%s,%s)" (i2s mu) (i2s nu) | C -> "C" | Minus -> "-1" let dirac_string_to_string ds = match ds.gammas with | [] -> Printf.sprintf "<%s|%s>" (i2s ds.bra) (i2s ds.ket) | gammas -> Printf.sprintf "<%s|%s|%s>" (i2s ds.bra) (String.concat "*" (List.map dirac_to_string gammas)) (i2s ds.ket) let scalar_to_string = function | A.Mass _ -> "m" | A.Width _ -> "w" | A.P2 i -> Printf.sprintf "p%d**2" i | A.P12 (i, j) -> Printf.sprintf "p%d*p%d" i j | A.Variable s -> s | A.Coeff c -> UFOx.Value.to_string c let rec contraction_to_string c = String.concat " * " (List.concat [if QC.is_unit c.coeff then [] else [QC.to_string c.coeff]; List.map (fun ds -> dirac_string_to_string ds.atom) c.dirac; List.map (fun v -> vector_to_string v.atom) c.vector; List.map scalar_to_string c.scalar]) ^ (match c.inverse with | [] -> "" | inverse -> " / (" ^ String.concat "*" (List.map scalar_to_string inverse) ^ ")") ^ (match c.denominator with | [] -> "" | denominator -> " / (" ^ to_string denominator ^ ")") and to_string contractions = String.concat " + " (List.map contraction_to_string contractions) let fermion_lines_to_string fermion_lines = ThoList.to_string (fun (ket, bra) -> Printf.sprintf "%s->%s" (i2s ket) (i2s bra)) fermion_lines module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let braket gammas = { bra = 11; ket = 22; conjugated = false; gammas } let assert_transpose gt g = assert_equal ~printer:dirac_string_to_string (braket gt) (transpose (braket g)) let assert_conjugate_transpose gct g = assert_equal ~printer:dirac_string_to_string (braket gct) (conjugate_transpose (braket g)) let suite_transpose = "transpose" >::: [ "identity" >:: (fun () -> assert_transpose [] []); "gamma_mu" >:: (fun () -> assert_transpose [C; Gamma 1; C] [Gamma 1]); "sigma_munu" >:: (fun () -> assert_transpose [C; Sigma (1, 2); C] [Sigma (1, 2)]); "gamma_5*gamma_mu" >:: (fun () -> assert_transpose [C; Gamma 1; Gamma5; C] [Gamma5; Gamma 1]); "gamma5" >:: (fun () -> assert_transpose [Minus; C; Gamma5; C] [Gamma5]); "gamma+" >:: (fun () -> assert_transpose [Minus; C; ProjP; C] [ProjP]); "gamma-" >:: (fun () -> assert_transpose [Minus; C; ProjM; C] [ProjM]); "gamma_mu*gamma_nu" >:: (fun () -> assert_transpose [Minus; C; Gamma 2; Gamma 1; C] [Gamma 1; Gamma 2]); "gamma_mu*gamma_nu*gamma_la" >:: (fun () -> assert_transpose [C; Gamma 3; Gamma 2; Gamma 1; C] [Gamma 1; Gamma 2; Gamma 3]); "gamma_mu*gamma+" >:: (fun () -> assert_transpose [C; ProjP; Gamma 1; C] [Gamma 1; ProjP]); "gamma_mu*gamma-" >:: (fun () -> assert_transpose [C; ProjM; Gamma 1; C] [Gamma 1; ProjM]) ] let suite_conjugate_transpose = "conjugate_transpose" >::: [ "identity" >:: (fun () -> assert_conjugate_transpose [] []); "gamma_mu" >:: (fun () -> assert_conjugate_transpose [Minus; Gamma 1] [Gamma 1]); "sigma_munu" >:: (fun () -> assert_conjugate_transpose [Minus; Sigma (1, 2)] [Sigma (1,2)]); "gamma_mu*gamma5" >:: (fun () -> assert_conjugate_transpose [Minus; Gamma5; Gamma 1] [Gamma 1; Gamma5]); "gamma5" >:: (fun () -> assert_conjugate_transpose [Gamma5] [Gamma5]) ] let suite = "UFO_Lorentz" >::: [suite_transpose; suite_conjugate_transpose] end Index: trunk/omega/src/color.ml =================================================================== --- trunk/omega/src/color.ml (revision 8919) +++ trunk/omega/src/color.ml (revision 8920) @@ -1,800 +1,800 @@ (* color.ml -- Copyright (C) 1999-2024 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 suite : OUnit.test val suite_long : OUnit.test end (* \thocwmodulesection{Quantum Numbers} *) type t = | Singlet | SUN of int | AdjSUN of int | YT of int Young.tableau | YTC of int Young.tableau let conjugate = function | Singlet -> Singlet | SUN n -> SUN (-n) | AdjSUN n -> AdjSUN n | YT y -> YTC y | YTC y -> YT y let compare c1 c2 = match c1, c2 with | Singlet, Singlet -> 0 | Singlet, _ -> -1 | _, Singlet -> 1 | SUN n, SUN n' -> compare n n' | SUN _, AdjSUN _ -> -1 | AdjSUN _, SUN _ -> 1 | AdjSUN n, AdjSUN n' -> compare n n' | YT y, YT y' -> compare y y' | YT _, YTC _ -> -1 | YTC _, YT _ -> 1 | YTC y, YTC y' -> compare y y' | _, (YT _ | YTC _) -> -1 | (YT _ | YTC _) , _ -> 1 (* \thocwmodulesection{Color Flows} *) module type Flow = sig type color type t = color list * color list val rank : t -> int val of_list : int list -> color val ghost : unit -> color val to_lists : t -> int list list val in_to_lists : t -> int list list val out_to_lists : t -> int list list val ghost_flags : t -> bool list val in_ghost_flags : t -> bool list val out_ghost_flags : t -> bool list type power = { num : int; den : int; power : int } type factor = power list val factor : t -> t -> factor val zero : factor val factor_table : t list -> factor array array module Test : Test end module Flow : Flow = struct (* All [int]s are non-zero! *) type color = | Flow of Color_Propagator.flow | Ghost let to_cp = function | Flow cf -> Color_Propagator.Flow cf | Ghost -> Color_Propagator.Ghost - let color_to_string c = + let _color_to_string c = Color_Propagator.to_string (to_cp c) (* Incoming and outgoing, since we need to cross the incoming states. *) type t = color list * color list - let rank cflow = + let rank _cflow = 2 (* \thocwmodulesubsection{Constructors} *) let ghost () = Ghost let of_list = function | [0; 0] -> Flow (PArray.empty, PArray.empty) | [c; 0] -> Flow (PArray.of_pairs [(1, c)], PArray.empty) | [0; c] -> Flow (PArray.empty, PArray.of_pairs [(1, -c)]) | [c1; c2] -> Flow (PArray.of_pairs [(1, c1)], PArray.of_pairs [(1, -c2)]) | _ -> invalid_arg "Color.Flow.of_list: num_lines != 2" let to_list = function | Ghost -> [0; 0] | Flow (cfi, cfo) -> begin match PArray.to_pairs cfi, PArray.to_pairs cfo with | [], [] -> [0; 0] | [(1, c)], [] -> [c; 0] | [], [(1, c)] -> [0; -c] | [(1, c1)], [(1, c2)] -> [c1; -c2] | _, _ -> failwith "Color.Flow.to_list: incomplete" end let to_lists (cfin, cfout) = (List.map to_list cfin) @ (List.map to_list cfout) let in_to_lists (cfin, _) = List.map to_list cfin let out_to_lists (_, cfout) = List.map to_list cfout let ghost_flag = function | Flow _ -> false | Ghost -> true let ghost_flags (cfin, cfout) = (List.map ghost_flag cfin) @ (List.map ghost_flag cfout) let in_ghost_flags (cfin, _) = List.map ghost_flag cfin let out_ghost_flags (_, cfout) = List.map ghost_flag cfout (* \thocwmodulesubsection{Evaluation} *) type power = { num : int; den : int; power : int } type factor = power list let zero = [] - let factor_to_string = function + let _factor_to_string = function | [] -> "0" | factor -> String.concat "+" (List.map (fun p -> Printf.sprintf "%d%s%s" p.num (if p.den <> 1 then "/" ^ string_of_int p.den else "") (match p.power with | 0 -> "" | 1 -> "*N" | n -> "*N^" ^ string_of_int n)) factor) let conjugate = function | Flow (cfi, cfo) -> Flow (cfo, cfi) | Ghost -> Ghost - let cross_in (cin, cout) = + let _cross_in (cin, cout) = cin @ (List.map conjugate cout) let cross_out (cin, cout) = (List.map conjugate cin) @ cout (* \thocwmodulesubsection{Handling $\tr(F_{\mu\nu}F^{\mu\nu})$ couplings, a.k.a.~$Hgg$} If the model contains couplings of the form $\tr(F_{\mu\nu}F^{\mu\nu})$, e.\,g.~the effective $Hgg$ couplings, the color flow rules and the evaluation of color weights require special care. These couplings are problematic in our recursive construction, since fusing a colorless state with a $\mathrm{U}(1)$ ghost produces a trace gluon in addition to a $\mathrm{U}(1)$ ghost. But for this fresh trace gluon, no canonical color flow index is available! \begin{dubious} A possible solution could be the introduction of ``wild card'' color flow that are replaced be concrete color flows only at the matching of the brakets. This is worth investigating, but can be postponed in favor of the well tested pragmatic approach. \end{dubious} *) (* There are three different cases to consider: \begin{enumerate} \item First consider the case that neither gluon is directly connected by a string of such couplings to the external states. In this case, the gluons must be connected to matter, since the gluon self couplings contain no ghost terms. Fortunately, if suffices to ajust the ghost-ghost coupling to account for the missing ghost-trace couplings. The prototypical example is Higgs production in $q\bar q$ scattering via the effective $Hgg$ coupling expanded as in~\cite{Kilian:2012pz}: \newcommand{\setupFiveAmp}{% \fmfleft{i1,i2} \fmfright{o1,o2} \fmftop{H} \fmf{phantom}{i1,v1,i2} \fmf{phantom}{o2,v2,o1} \fmf{phantom}{v1,vH,v2} \fmffreeze} \begin{subequations} \label{eq:qqqqH} \begin{multline} \label{eq:qqqqH-full} \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmflabel{$H$}{H} \fmflabel{$q$}{i2} \fmflabel{$q$}{i1} \fmflabel{$\bar q$}{o1} \fmflabel{$\bar q$}{o2} \fmf{fermion}{i1,v1,i2} \fmf{fermion}{o2,v2,o1} \fmf{gluon}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} = \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (vpath (__vH, __v2) sideways -thick) join vpath (__v2, __o1)} \fmfi{plain}{vpath (__o2, __v2) join (reverse vpath (__vH, __v2) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \fmf{plain}{H,vH} \end{fmfgraph*}}} + \left(-\frac{1}{N_C}\right) \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join vpath (__v2, __o1)} \fmf{dots}{vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \\ + \left(-\frac{1}{N_C}\right) \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join (reverse vpath (__vH, __v2) sideways -thick) join (vpath (__vH, __v2) sideways -thick) join vpath (__v2, __o1)} \fmf{dots}{v1,vH} \fmf{plain}{vH,H} \end{fmfgraph*}}} + N_C \left(-\frac{1}{N_C}\right)^2 \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join vpath (__v2, __o1)} \fmf{dots}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \end{multline} the sum of which corresponds to the same simple color flows as gluon exchange \begin{equation} \parbox{28\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(20,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (vpath (__vH, __v2) sideways -thick) join vpath (__v2, __o1)} \fmfi{plain}{vpath (__o2, __v2) join (reverse vpath (__vH, __v2) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \end{fmfgraph*}}} - \frac{1}{N_C} \parbox{28\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(20,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join vpath (__v2, __o1)} \end{fmfgraph*}}}\,. \end{equation} Squaring and summing these produces the correct result \begin{equation} N_C^2 + N_C \left(-\frac{1}{N_C}\right) + N_C \left(-\frac{1}{N_C}\right) + N_C^2 \left(-\frac{1}{N_C}\right)^2 = N_C^2 - 1\,. \end{equation} \end{subequations} This result can be reproduced without coupling of trace gluons to ghosts by simply replacing the ghost-ghost coupling~$N_C$ by $-N_C$ in order to cancel the minus sign from the additional ghost propagator\footnote{% For comparison, naively leaving out the coupling of ghosts to traces results in different color flows \begin{equation*} \parbox{28\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(20,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (vpath (__vH, __v2) sideways -thick) join vpath (__v2, __o1)} \fmfi{plain}{vpath (__o2, __v2) join (reverse vpath (__vH, __v2) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \end{fmfgraph*}}} + \frac{1}{N_C} \parbox{28\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(20,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join vpath (__v2, __o1)} \end{fmfgraph*}}} \end{equation*} Squaring and summing these would produce the incorrect result \begin{equation*} N_C^2 + N_C \frac{1}{N_C} + N_C \frac{1}{N_C} + N_C^2 \left(\frac{1}{N_C}\right)^2 = N_C^2 + 3\,. \end{equation*}}. \item In the second case of one gluon connected to matter and the other to an external state, no special treatment is required. The prototypical example is $q\bar q\to Hg$ \begin{multline} \label{eq:qqHg-full} \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmflabel{$H$}{H} \fmflabel{$q$}{i2} \fmflabel{$q$}{i1} \fmf{fermion}{i1,v1,i2} \fmf{phantom}{o2,v2,o1} \fmf{gluon}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} = \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (vpath (__vH, __v2) sideways -thick)} \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \fmf{plain}{H,vH} \end{fmfgraph*}}} + \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __vH) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick) join vpath (__v1, __i2)} \fmf{dots}{vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \\ + \left(-\frac{1}{N_C}\right) \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join (vpath (__vH, __v2) sideways -thick)} \fmf{dots}{v1,vH} \fmf{plain}{vH,H} \end{fmfgraph*}}} + N_C \left(-\frac{1}{N_C}\right) \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmf{dots}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \end{multline} The correct result for the summed square is again $N_C^2-1$, where the two color flow diagrams with an external ghost cancel. In the simplified rules, the $\mathrm{U}(N_C)$ gluons contribute $N_C^2$ and the ghost $-1$. \item In the third and final case of both gluons connected to external states, we have to apply a fudge factor replacing $N_C^2$ by $N_C^2-2$ for each cycle of color disconnected gluons. The calculation is straightforward, since there is no interference of external ghosts and $\mathrm{U}(N_C)$ gluons in the sum of squares. \begin{multline} \label{eq:gHg-full} \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmflabel{$H$}{H} \fmf{phantom}{i1,v1,i2} \fmf{phantom}{o2,v2,o1} \fmf{gluon}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} = \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{plain}{(vpath (__v1, __vH) sideways -thick) join (vpath (__vH, __v2) sideways -thick)} \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick)} \fmf{plain}{H,vH} \end{fmfgraph*}}} + \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick} \fmfi{plain}{(vpath (__v1, __vH) sideways -thick) join (reverse vpath (__v1, __vH) sideways -thick)} \fmf{dots}{vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \\ + \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick} \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick} \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join (vpath (__vH, __v2) sideways -thick)} \fmf{dots}{v1,vH} \fmf{plain}{vH,H} \end{fmfgraph*}}} + N_C \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFiveAmp \fmf{dots}{v1,vH,v2} \fmf{plain}{vH,H} \end{fmfgraph*}}} \end{multline} The latter contributes a factor of~$N_C^2$ (two loops) and the former a factor of~$(-N_C)^2(-1/N_C)^2=1$ (one $-N_C$ fom each vertex and one $-1/N_C$ from each line across the cut). Therefore the sum would be $N_C^2+1$ in contrast to the correct result~$N_C^2-1$. The correct result is then obtained by multiplying the gluon term~$N_C^2$ by $1-2/N_C^2$ \begin{equation} N_C^2 + 1 \to N_C^2 \left(1-\frac{2}{N_C^2}\right) + 1 = N_C^2 - 2 + 1 = N_C^2 -1\,. \end{equation} \end{enumerate} *) (* The factor $(1-2/N_C^2)^n$ in the formula \begin{equation} N_C^{l} \left(-\frac{1}{N_C}\right)^{k} \left(\frac{N_C^2-2}{N_C^2}\right)^{n}\,, \end{equation} where $l$ is the number of closed color cycles ([cycles] below), $k$ is the number of external ghosts ([ghosts]) and $n$ is the number of gluon cycles ([gluon_cycles]). is the fudge factor taking care of the couplings of $\mathrm{U}(1)$ ghosts to trace gluons. *) (* [endpoints_of_colors colors] creates maps from the position of the external colors in [colors] to the tips and tails connected by color flow lines. Also produce a set of the positions of external ghosts. *) module IMap = Map.Make(Int) module ISet = Set.Make(Int) type endpoints = { tails : int IMap.t; tips : int IMap.t; ghosts : ISet.t } type color_kind = | CK_Flow of int * int | CK_Ghost let color_kind = function | Flow (cfi, cfo) -> CK_Flow (List.length (PArray.to_pairs cfi), List.length (PArray.to_pairs cfo)) | Ghost -> CK_Ghost let equal_color_kind1 c1 c2 = color_kind c1 = color_kind c2 let equal_color_kind f1 f2 = List.for_all2 equal_color_kind1 f1 f2 let empty_endpoints = { tails = IMap.empty; tips = IMap.empty; ghosts = ISet.empty } let add_endpoint endpoints n = function | Ghost -> { endpoints with ghosts = ISet.add n endpoints.ghosts } | Flow (cfi, cfo) -> begin match PArray.to_pairs cfi, PArray.to_pairs cfo with | [], [] -> endpoints | [(1, c)], [] -> { endpoints with tips = IMap.add (abs c) n endpoints.tips } | [], [(1, c)] -> { endpoints with tails = IMap.add (abs c) n endpoints.tails } | [(1, c1)], [(1, c2)] -> { endpoints with tips = IMap.add (abs c1) n endpoints.tips; tails = IMap.add (abs c2) n endpoints.tails } | _, _ -> failwith "Color.Flow.add_endpoint: incomplete" end let endpoints_of_colors colors = let _, endpoints = List.fold_left (fun (n, endpoints) endpoint -> (succ n, add_endpoint endpoints n endpoint)) (1, empty_endpoints) colors in endpoints (* Merge the maps of tips and tails to find the pair of connected external colors. *) let links_of_endpoints endpoints = IMap.merge (fun _ tail tip -> match tail, tip with | None, None -> None | Some tail, Some tip -> Some (tail, tip) | Some tail, None -> invalid_arg ("no tip for tail " ^ string_of_int tail) | None, Some tip -> invalid_arg ("no tail for tip " ^ string_of_int tip)) endpoints.tails endpoints.tips (* Create an [Arrow.free list] that can be used by [Birdtracks]. *) let arrows_of_links links = IMap.fold (fun _ (tail, tip) acc -> Arrow.Infix.( tail => tip ) :: acc) links [] module LSet = Set.Make (struct type t = int * int let compare = Stdlib.compare end) (* Find the set bidirectional links by computing the intersection of the set of links with the set of reversed links. We must keep both directions for [Birdtracks.multiply] to succeed. *) let double_links links = let links, rev_links = IMap.fold (fun _ (tail, tip) (links, rev_links) -> (LSet.add (tail, tip) links, LSet.add (tip, tail) rev_links)) links (LSet.empty, LSet.empty) in LSet.inter links rev_links (*i let f, g = birdtracks [N 5; N_bar 6; SUN (1,2); SUN (6, 5); SUN (2,1); Ghost] let f' : Birdtracks.t = Birdtracks.( relocate (~-) [ Arrows {coeff = Algebra.Laurent.unit; arrows = f } ] ) let _ = Birdtracks.Infix.( f' *** Birdtracks.rev f' ) i*) let birdtracks_of_arrows arrows = Birdtracks.( relocate (~-) [ Arrows { coeff = Algebra.Laurent.unit; arrows } ] ) type flow = { flows : Birdtracks.t; gluons : Birdtracks.t } let birdtracks colors = let endpoints = endpoints_of_colors colors in let links = links_of_endpoints endpoints in let gluons = double_links links in let flow = ISet.fold (fun ghost acc -> Arrow.Infix.( ?? ghost) :: acc) endpoints.ghosts (arrows_of_links links) and gluons = LSet.fold (fun (tail, tip) acc -> Arrow.Infix.( tail => tip ) :: acc) gluons [] in { flows = birdtracks_of_arrows flow; gluons = birdtracks_of_arrows gluons } (* $1-2/N_C^2$ *) let fudge_factor = Algebra.Laurent.ints [(1,0); (-2,-2)] let factor_birdtracks f1 f2 = let open Birdtracks in match number (Infix.( f1.flows *** rev f2.flows )) with | None -> failwith "factor_new" | Some result -> if Algebra.Laurent.is_null result then result else let gluons = Infix.( f1.gluons *** rev f2.gluons ) in match number gluons with | None -> result | Some gluons -> begin match Algebra.Laurent.log gluons with | None -> failwith "factor_birdtracks log" - | Some (coeff, 0) -> result + | Some (_, 0) -> result | Some (coeff, n) -> if not (Algebra.QC.is_unit coeff) then failwith "factor_birdtracks log is_unit"; if n mod 2 <> 0 then failwith "factor_birdtracks log is odd"; Algebra.Laurent.mul result (Algebra.Laurent.pow fudge_factor (n/2)) end let factor f1 f2 = let f1 = cross_out f1 and f2 = cross_out f2 in if equal_color_kind f1 f2 then factor_birdtracks (birdtracks f1) (birdtracks f2) else Algebra.Laurent.null let factor_of_laurent l = List.map (fun (c, power) -> let num, den = Algebra.Q.to_ratio (Algebra.QC.re c) in { num; den; power} ) (Algebra.Laurent.to_list l) let factor_birdtracks f1 f2 = factor_of_laurent (factor_birdtracks f1 f2) let factor f1 f2 = factor_of_laurent (factor f1 f2) let factor_table cf_list = let cf_array = Array.of_list (List.map cross_out cf_list) in let birdtracks_array = Array.map birdtracks cf_array in let ncf = Array.length cf_array in let cf_table = Array.make_matrix ncf ncf zero in for i = 0 to pred ncf do for j = 0 to i do if equal_color_kind cf_array.(i) cf_array.(j) then begin cf_table.(i).(j) <- factor_birdtracks birdtracks_array.(i) birdtracks_array.(j); cf_table.(j).(i) <- cf_table.(i).(j) end done done; cf_table module Test : Test = struct open OUnit (* Here and elsewhere, we have to resist the temptation to define these tests as functions with an additional argument [()] in the hope to avoid having to package them into an explicit thunk [fun () -> eq v1 v2] in order to delay evaluation. It turns out that the runtime would then sometimes evaluate the argument [v1] or [v2] even \emph{before} the test is run. For pure functions, there is no difference, but the compiler appears to treat explicit thunks specially. \begin{dubious} I haven't yet managed to construct a small demonstrator to find out in which circumstances the premature evaluation happens. \end{dubious} *) (*i let suite_factor = "factor" >::: [ "gg->gg interference" >:: (fun () -> assert_equal [ { num = 1; den = 1; power = 2 }; { num = -2; den = 1; power = 0 } ] (factor ([SUN(3,-1); SUN(4,-2)], [SUN(3,-1); SUN(4,-2)]) ([SUN(2,-1); SUN(1,-2)], [SUN(3,-4); SUN(4,-3)]))); "???" >:: (fun () -> assert_equal [ ] (factor ([N_bar (-1); N 1], [Ghost]) ([N 1; N_bar (-1)], [Ghost]))) ] let suite = "Color.Flow" >::: [suite_factor] i*) let suite = "Color.Flow" >::: [] let suite_long = "Color.Flow long" >::: [] end end (* \thocwmodulesection{$\mathrm{SU}(N_C)$} *) module Vertex = SU3 Index: trunk/omega/src/UFOx_parser.mly =================================================================== --- trunk/omega/src/UFOx_parser.mly (revision 8919) +++ trunk/omega/src/UFOx_parser.mly (revision 8920) @@ -1,111 +1,111 @@ /* vertex_parser.mly -- Copyright (C) 1999-2024 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 () = +let _invalid_parameter_attr () = parse_error "invalid parameter attribute" %} %token < int > INT %token < float > FLOAT %token < string > ID QUOTED %token PLUS MINUS TIMES POWER DIV %token LPAREN RPAREN LBRACKET RBRACKET COMMA %token END %left PLUS MINUS %left TIMES DIV %nonassoc UNARY %right POWER %start input %type < UFOx_syntax.expr > input %% input: | expr END { $1 } ; expr: | INT { X.integer $1 } | FLOAT { X.float $1 } | ID { X.variable $1 } | QUOTED { X.quoted $1 } | young_tableau { X.young_tableau $1 } | expr PLUS expr { X.add $1 $3 } | expr MINUS expr { X.subtract $1 $3 } | expr TIMES expr { X.multiply $1 $3 } | expr DIV expr { X.divide $1 $3 } | PLUS expr %prec UNARY { $2 } | MINUS expr %prec UNARY { X.multiply (X.integer (-1)) $2 } | expr POWER expr { X.power $1 $3 } | LPAREN expr RPAREN { $2 } | ID LPAREN RPAREN { X.apply $1 [] } | ID LPAREN args RPAREN { X.apply $1 $3 } ; args: | expr { [$1] } | expr COMMA args { $1 :: $3 } ; young_tableau: | LBRACKET RBRACKET { [] } | LBRACKET integer_lists RBRACKET { $2 } ; integer_lists: | integer_list { [$1] } | integer_list COMMA integer_lists { $1 :: $3 } ; integer_list: | LBRACKET RBRACKET { [] } | LBRACKET integers RBRACKET { $2 } ; integers: | integer { [$1] } | integer COMMA integers { $1 :: $3 } ; integer: | INT { $1 } | MINUS INT { ~- $2 } ; Index: trunk/omega/src/powSet.mli =================================================================== --- trunk/omega/src/powSet.mli (revision 8919) +++ trunk/omega/src/powSet.mli (revision 8920) @@ -1,84 +1,75 @@ (* powSet.mli -- Copyright (C) 1999-2024 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. *) (* Manipulate the power set, i.\,e.~the set of all subsets, of an set [Ordered_Type]. The concrete order is actually irrelevant, we just need it to construct [Set.S]s in the implementation. In fact, what we are implementating is the \textit{free semilattice} generated from the set of subsets of [Ordered_Type], where the join operation is the set union. The non trivial operation is [basis], which takes a set of subsets and returns the smallest set of disjoint subsets from which the argument can be reconstructed by forming unions. It is used in O'Mega for finding coarsest partitions of sets of partiticles. \begin{dubious} Eventually, this could be generalized from \textit{power set} or \textit{semi lattice} to \textit{lattice} with a notion of subtraction. \end{dubious} *) module type Ordered_Type = sig type t val compare : t -> t -> int (* Debugging \ldots *) val to_string : t -> string end module type T = sig type elt type t val empty : t val is_empty : t -> bool (* Set union (a.\,k.\,a.~join). *) val union : t list -> t (* Construct the abstract type from a list of subsets represented as lists and the inverse operation. *) val of_lists : elt list list -> t val to_lists : t -> elt list list (* The smallest set of disjoint subsets that generates the given subset. *) val basis : t -> t (* Debugging \ldots *) val to_string : t -> string end module Make (E : Ordered_Type) : T with type elt = E.t - - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/color_Fusion.ml =================================================================== --- trunk/omega/src/color_Fusion.ml (revision 8919) +++ trunk/omega/src/color_Fusion.ml (revision 8920) @@ -1,901 +1,901 @@ (* color_Fusion.ml -- Copyright (C) 2022-2023 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. *) (* \label{sec:colorflow-fusions} *) (* Here we will use the color flow described by a [Arrow.free list] to determine the possible outgoing color flows for the incoming color flows in a fusion. This translates from vertices described by connections among integers describing factors in the tensor product to color flows with integers describing individual color flow lines. For the treatment of $\epsilon$ and $\bar\epsilon$, see the discussion on page~\pageref{sec:epsilon-evaluation-strategy}. *) (* \begin{dubious} At the moment both the factors in the tensor product and the color flow lines are [int]s. This could be made clearer by abstract types. \end{dubious} *) (* \begin{dubious} This still needs to be extended to $\epsilon$ and $\bar\epsilon$, i.\,e.~[Arrow.free_eps] and [Arrow.free_eps_bar]. \end{dubious} *) module A = Arrow open A.Infix module CP = Color_Propagator module L = Algebra.Laurent module QC = Algebra.QC (* Take a [Color_Propagator.t list], ignore the uncolored ([Color_Propagator.W]) ones and construct a map into the colored ones indexed by the offset into the original list. Actually, one could use a [Color_Propagator.t option array] instead, but the elements of ['a array] are updated in place, making it harder to keep track. *) let line_map lines = let _, map = List.fold_left (fun (i, acc) line -> (succ i, if CP.is_white line then acc else PArray.add i line acc)) (1, PArray.empty) lines in map (* [clear i lines] removes the [Color_Propagator.t] at position [i] from the map [lines]. *) let clear = PArray.remove (* Return $+1$ if the list [l1] is an even permutation of the list [l2], $-1$ if [l1] is an odd permutation of [l2] and $0$ otherwise. *) let relative_permutation l1 l2 = let eps1, l1 = Combinatorics.sort_signed l1 and eps2, l2 = Combinatorics.sort_signed l2 in if l1 = l2 then eps1 * eps2 else 0 (* Return the integers in the list [elements] that are not in the list [universe]. *) let not_in elements universe = let universe = Sets.Int.of_list universe in let rec collect missing = function | [] -> missing | x :: tail -> if Sets.Int.mem x universe then collect missing tail else collect (x :: missing) tail in collect [] elements (* [open_epsilon] is an $\epsilon_{ii_2\cdots i_n}$ (or~$\bar\epsilon^{ii_2\cdots i_n}$) with one index~$i$ open and [epsilon_bar] a matching $\bar\epsilon^{j_1j_2\cdots j_n}$ (or $\epsilon_{j_1j_2\cdots j_n}$). Replace~$i$ by the single $j\in\{j_m\}_{m=1,\ldots,n}$ with $j\not\in\{i_m\}_{m=2,\ldots,n}$ and compute \begin{equation} \epsilon_{ii_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n} = \delta_{ii_2\cdots i_n}^{j_1j_2\cdots j_n} = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)} \delta_{i}^{\sigma(j_1)} \delta_{i_2}^{\sigma(j_2)} \cdots \delta_{i_n}^{\sigma(j_n)}\,. \end{equation} Return [None] if the two index sets are not permutations of one another and [Some (sign, i)] if they are. *) let open_contract open_epsilon epsilon_bar = match not_in epsilon_bar open_epsilon with | [] -> None | [i] -> let sign = relative_permutation (i :: open_epsilon) epsilon_bar in if sign = 0 then None else Some (sign, i) | _ -> None (* [connect n (sign, flow_n, lines) arrow] tries to form a new connection in the map [lines] using a single [arrow]. The outgoing line in the fusion is represented by [flow_n] and corresponds to [n] in the [arrow]. *) (* If the arrow is a ghost and is connected to the outgoing line, just add it. If it is connected to an incoming line, remove this propagator, as it is saturated. *) let connect_ghost_opt n g (sign, flow_n, lines) = let g' = A.position_ghost g in if g' = n then Some (sign, CP.Ghost, lines) else match PArray.get_opt g' lines with | Some CP.Ghost -> Some (sign, flow_n, clear g' lines) | Some CP.Ghost_with_Epsilons _ -> failwith "connect_ghost_opt: incomplete" | Some CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_ghost_opt: incomplete" | _ -> None (* Add the normalized propagator [p] to the map [lines] at position [i], unless it contains no color flows. Remove it in this case. *) let add_or_remove_if_white i p lines = let p = CP.normalize p in if CP.is_white p then PArray.remove i lines else PArray.add i p lines (* If the arrow is a connection and is connected on one side to the outgoing line, find the matching incoming line. If it is connected to two incoming lines, merge them, which amounts to throwing them away. *) (* \begin{dubious} Here's where the $\epsilon$-$\bar\epsilon$ pairs will be consumed. We should move this to a preprocessing step, so that the repeated application of arrows does not have to take care of it. Or do it in a postprocessing step, which has the advantage that the contractions have been processed and a possible new $\epsilon$ or $\bar\epsilon$ is available. \end{dubious} *) (* Try to extract an $\epsilon$ (or $\bar\epsilon$) from the color flow given as the argument. *) let take_epsilon cfi = let project_opt _ = function | CP.CF_in cf -> Some cf | CP.Epsilon _ -> None in PArray.take_one project_opt cfi let take_epsilon_bar cfo = let project_opt _ = function | CP.CF_out cf -> Some cf | CP.Epsilon_Bar _ -> None in PArray.take_one project_opt cfo (* This is a part of [connect_in_opt] below that requires recursion and therefore needs to be its own function. *) (* Keeping track of the overall [sign], connect the incoming [CP.Flow_with_Epsilons] at index [i'] at position [i] in [lines] with the outgoing [CP.Flow_with_Epsilon_Bars] at index [n']. Return the updated propagator and [lines] if the color flows match. *) let rec connect_in_contract_epsilons_opt sign : int -> CP.flow_eps_bar -> CP.eps_bar list -> int -> CP.flow_eps -> CP.eps list -> int -> CP.t PArray.t -> (int * CP.t * CP.t PArray.t) option = fun n' (cfi_n, cfo_n as cf_n) epsilon_bars_n i' (cfi_i, cfo_i as cf_i) epsilons_i i lines -> let open PArray in match epsilon_bars_n, epsilons_i with | epsilon_bar :: epsilon_bars_n, epsilon :: epsilons_i -> let relative_sign = relative_permutation epsilon epsilon_bar in if relative_sign = 0 then None else connect_in_contract_epsilons_opt (relative_sign * sign) n' cf_n epsilon_bars_n i' cf_i epsilons_i i lines - | epsilon_bar :: _, [] -> + | _epsilon_bar :: _, [] -> begin match take_epsilon cfi_i with | Nothing cfi -> let flow_n = CP.Flow_with_Epsilon_Bars (cf_n, epsilon_bars_n) and pi = CP.Flow (cfi, cfo_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) - | Single (_, _, cfi_i) -> + | Single (_, _, _cfi_i) -> failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete" - | Multiple (_, _, cfi_i) -> + | Multiple (_, _, _cfi_i) -> failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete" end - | [], epsilon :: _ -> + | [], _epsilon :: _ -> begin match take_epsilon_bar cfo_n with | Nothing cfo -> let flow_n = CP.Flow (cfi_n, cfo) and pi = CP.Flow_with_Epsilons (cf_i, epsilons_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) - | Single (_, _, cfo_n) -> + | Single (_, _, _cfo_n) -> failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete" - | Multiple (_, _, cfo_n) -> + | Multiple (_, _, _cfo_n) -> failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete" end | [], [] -> begin match take_epsilon_bar cfo_n, take_epsilon cfi_i with | Nothing cfo, Nothing cfi -> let flow_n = CP.Flow (cfi_n, cfo) and pi = CP.Flow (cfi, cfo_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | _ -> failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete" end let connect_in_opt n' (i, i') (sign, flow_n, lines) = let open PArray in match get_opt i lines with | None -> None | Some flow_i -> begin match flow_i with | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ -> None | CP.Flow (cfi_i, cfo_i) -> begin match get_opt i' cfi_i with | None -> None | Some cfi -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_in_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_in_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let flow_n = CP.Flow (add n' cfi cfi_n, cfo_n) and pi = CP.Flow (remove i' cfi_i, cfo_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> let cfi = CP.CF_in cfi in let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_n) and pi = CP.Flow (remove i' cfi_i, cfo_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_n) and pi = CP.Flow (remove i' cfi_i, cfo_i) in Some (sign, flow_n, add_or_remove_if_white i pi lines) end end | CP.Flow_with_Epsilons ((cfi_i, cfo_i), epsilons_i) -> begin match get_opt i' cfi_i with | None -> None | Some cfi -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_in_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_in_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let cfi_n = map (fun cf -> CP.CF_in cf) cfi_n in let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_i) and pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), []) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_i @ epsilons_n) and pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), []) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> connect_in_contract_epsilons_opt sign n' (cfi_n, cfo_n) epsilon_bars_n i' (cfi_i, cfo_i) epsilons_i i lines end end | CP.Flow_with_Epsilon_Bars ((cfi_i, cfo_i), epsilon_bars_i) -> begin match get_opt i' cfi_i with | None -> None | Some cfi -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_in_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_in_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let cfo_n = map (fun cf -> CP.CF_out cf) cfo_n in let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_i) and pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), []) in Some (sign, flow_n, add_or_remove_if_white i pi lines) | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_i @ epsilon_bars_n) and pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), []) in Some (sign, flow_n, add_or_remove_if_white i pi lines) - | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> + | CP.Flow_with_Epsilons ((_cfi_n, _cfo_n), _epsilons_n) -> failwith "Color_Fusion.connect_in_opt: no epsilon contractions yet" end end end let connect_out_opt n' (o, o') (sign, flow_n, lines) = let open PArray in match get_opt o lines with | None -> None | Some flow -> begin match flow with | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ -> None | CP.Flow (cfi_o, cfo_o) -> begin match get_opt o' cfo_o with | None -> None | Some cfo -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_out_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_out_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let flow_n = CP.Flow (cfi_n, add n' cfo cfo_n) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white o po lines) | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_n) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white o po lines) | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> let cfo = CP.CF_out cfo in let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_n) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white o po lines) end end | CP.Flow_with_Epsilons ((cfi_o, cfo_o), epsilons_o) -> begin match get_opt o' cfo_o with | None -> None | Some cfo -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_out_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_out_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let cfi_n = map (fun cf -> CP.CF_in cf) cfi_n in let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_o) and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), []) in Some (sign, flow_n, add_or_remove_if_white o po lines) | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_o @ epsilons_n) and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), []) in Some (sign, flow_n, add_or_remove_if_white o po lines) - | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> + | CP.Flow_with_Epsilon_Bars ((_cfi_n, _cfo_n), _epsilon_bars_n) -> failwith "Color_Fusion.connect_out_opt: no epsilon contractions yet" end end | CP.Flow_with_Epsilon_Bars ((cfi_o, cfo_o), epsilon_bars_o) -> begin match get_opt o' cfo_o with | None -> None | Some cfo -> begin match flow_n with | CP.Ghost -> None | CP.Ghost_with_Epsilons _ -> failwith "connect_out_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_out_opt: incomplete" | CP.Flow (cfi_n, cfo_n) -> let cfo_n = map (fun cf -> CP.CF_out cf) cfo_n in let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_o) and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), []) in Some (sign, flow_n, add_or_remove_if_white o po lines) | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) -> let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_o @ epsilon_bars_n) and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), []) in Some (sign, flow_n, add_or_remove_if_white o po lines) - | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) -> + | CP.Flow_with_Epsilons ((_cfi_n, _cfo_n), _epsilons_n) -> failwith "Color_Fusion.connect_out_opt: no epsilon contractions yet" end end end let connect_in_out_opt (i, i') (o, o') (sign, flow_n, lines) = let open PArray in match get_opt i lines, get_opt o lines with | None, _ | _, None -> None | Some flow_i, Some flow_o -> begin match flow_i, flow_o with | (CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _), _ | _, (CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _) -> None | CP.Flow (cfi_i, cfo_i), CP.Flow (cfi_o, cfo_o) -> begin match get_opt i' cfi_i, get_opt o' cfo_o with | Some cfi, Some cfo when cfi = cfo -> let pi = CP.Flow (remove i' cfi_i, cfo_i) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | _, _ -> None end | CP.Flow (cfi_i, cfo_i), CP.Flow_with_Epsilons ((cfi_o, cfo_o), epsilons_o) -> begin match get_opt i' cfi_i, get_opt o' cfo_o with | Some cfi, Some cfo when cfi = cfo -> let pi = CP.Flow (remove i' cfi_i, cfo_i) and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), epsilons_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | _, _ -> None end | CP.Flow_with_Epsilons ((_, _), _), CP.Flow_with_Epsilons ((_, _), _) -> failwith "Color_Fusion.connect_in_out_opt: incomplete" | CP.Flow_with_Epsilon_Bars ((cfi_i, cfo_i), epsilon_bars_i), CP.Flow (cfi_o, cfo_o) -> begin match get_opt i' cfi_i, get_opt o' cfo_o with | Some cfi, Some cfo when cfi = cfo -> let pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), epsilon_bars_i) and po = CP.Flow ((cfi_o, remove o' cfo_o)) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | _, _ -> None end | CP.Flow_with_Epsilon_Bars ((_, _), _), CP.Flow_with_Epsilon_Bars ((_, _), _) -> failwith "Color_Fusion.connect_in_out_opt: incomplete" | CP.Flow_with_Epsilons ((cfi_i, cfo_i), epsilons_i), CP.Flow (cfi_o, cfo_o) -> begin match get_opt i' cfi_i, get_opt o' cfo_o with | Some (CP.CF_in cfi), Some cfo when cfi = cfo -> let pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), epsilons_i) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | Some (CP.Epsilon epsilon_i), Some cfo -> let epsilon_n = cfo :: epsilon_i in let flow_n = match flow_n with | CP.Ghost -> CP.Ghost | CP.Ghost_with_Epsilons _ -> failwith "connect_in_out_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_in_out_opt: incomplete" | CP.Flow (cfo, cfi) -> let cfi = map (fun cf -> CP.CF_in cf) cfi in CP.Flow_with_Epsilons ((cfi, cfo), [epsilon_n]) | CP.Flow_with_Epsilons (flow, epsilons_n) -> CP.Flow_with_Epsilons (flow, epsilon_n :: epsilons_n) - | CP.Flow_with_Epsilon_Bars (flow, epsilon_bars_n) -> + | CP.Flow_with_Epsilon_Bars (_flow, _epsilon_bars_n) -> failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" in let pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), epsilons_i) and po = CP.Flow (cfi_o, remove o' cfo_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | _, _ -> None end | CP.Flow (cfi_i, cfo_i), CP.Flow_with_Epsilon_Bars ((cfi_o, cfo_o), epsilon_bars_o) -> begin match get_opt i' cfi_i, get_opt o' cfo_o with | Some cfi, Some (CP.CF_out cfo) when cfi = cfo -> let pi = CP.Flow (remove i' cfi_i, cfo_i) and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), epsilon_bars_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | Some cfi, Some (CP.Epsilon_Bar epsilon_bar_o) -> let epsilon_bar_n = cfi :: epsilon_bar_o in let flow_n = match flow_n with | CP.Ghost -> CP.Ghost | CP.Ghost_with_Epsilons _ -> failwith "connect_in_out_opt: incomplete" | CP.Ghost_with_Epsilon_Bars _ -> failwith "connect_in_out_opt: incomplete" | CP.Flow (cfo, cfi) -> let cfo = map (fun cf -> CP.CF_out cf) cfo in CP.Flow_with_Epsilon_Bars ((cfi, cfo), [epsilon_bar_n]) | CP.Flow_with_Epsilon_Bars (flow, epsilon_bars_n) -> CP.Flow_with_Epsilon_Bars (flow, epsilon_bar_n :: epsilon_bars_n) - | CP.Flow_with_Epsilons (flow, epsilons_n) -> + | CP.Flow_with_Epsilons (_flow, _epsilons_n) -> failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" in let pi = CP.Flow (remove i' cfi_i, cfo_i) and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), epsilon_bars_o) in Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines)) | _, _ -> None end | CP.Flow_with_Epsilons ((_, _), _), CP.Flow_with_Epsilon_Bars ((_, _), _) -> failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" | CP.Flow_with_Epsilon_Bars ((_, _), _), CP.Flow_with_Epsilons ((_, _), _) -> failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" end (* \thocwmodulesection{Putting Everything Together} *) let decode_endpoint = function | A.I n -> (n, 0) | A.M (n, m) -> (n, m) let decode_tail t = decode_endpoint (t : A.tail :> A.endpoint) let decode_tip t = decode_endpoint (t : A.tip :> A.endpoint) -let decode_ghost g = decode_endpoint (g : A.ghost :> A.endpoint) +let _decode_ghost g = decode_endpoint (g : A.ghost :> A.endpoint) let endpoint_to_string = function | A.I n -> string_of_int n | A.M (n, m) -> string_of_int n ^ "." ^ string_of_int m let tail_to_string t = endpoint_to_string (t : A.tail :> A.endpoint) let tip_to_string t = endpoint_to_string (t : A.tip :> A.endpoint) -let ghost_to_string g = endpoint_to_string (g : A.ghost :> A.endpoint) +let _ghost_to_string g = endpoint_to_string (g : A.ghost :> A.endpoint) let connect_arrow_opt n i o lines = let i, i' as ii' = decode_tail i and o, o' as oo' = decode_tip o in if o = n then connect_in_opt o' ii' lines else if i = n then connect_out_opt i' oo' lines else connect_in_out_opt ii' oo' lines let lines_to_string (sign, flow_n, lines) = Printf.sprintf "%d*%s<%s" sign (CP.to_string flow_n) (ThoList.to_string (fun (i, p) -> Printf.sprintf "%s@%d" (CP.to_string p) i) (PArray.to_pairs lines)) -let connect_arrow_opt_logging n i o lines = +let _connect_arrow_opt_logging n i o lines = let result = connect_arrow_opt n i o lines in Printf.eprintf " (%s,%s) %s >>> %s\n" (tail_to_string i) (tip_to_string o) (lines_to_string lines) (match result with | None -> "None" | Some lines -> lines_to_string lines); result (*i let connect_arrow_opt = connect_arrow_opt_logging i*) (* Performan a single connection of the [lines] as described by [arrow_or_ghost]. Use [n] as the index of the outgoing line. Return the updated outgoing and incoming lines. *) let connect_arrow_or_ghost_opt : int -> A.free -> int * CP.t * CP.t PArray.t -> (int * CP.t * CP.t PArray.t) option = fun n arrow_or_ghost lines -> match arrow_or_ghost with | A.Ghost g -> connect_ghost_opt n g lines | A.Arrow (i, o) -> connect_arrow_opt n i o lines (* Return the signed color [flow] iff all color flows in [lines] have been consumed. *) let all_lines_consumed_opt (sign, flow, lines) = if PArray.is_empty lines then Some (sign, flow) else None (* Try to use the ghosts and arrows in [connections] to combine the color flows in [lines]. *) let connect_arrows_opt : A.free list -> CP.t list -> (int * CP.t) option = fun connections lines -> let n = List.length lines + 1 in let rec connect' acc = function | arrow :: arrows -> begin match connect_arrow_or_ghost_opt n arrow acc with | None -> None | Some acc -> connect' acc arrows end | [] -> Some acc in match connect' (1, CP.white, line_map lines) connections with | Some acc -> all_lines_consumed_opt acc | None -> None -let extract_lines_opt endpoints lines = +let _extract_lines_opt endpoints lines = let rec extract_lines' acc lines = function | [] -> Some (List.rev acc, lines) | A.I i :: rest -> begin match PArray.get_opt i lines with | None -> None | Some (CP.Flow (_, cfo)) -> begin match PArray.to_option_list cfo with | [Some cf] -> extract_lines' (cf :: acc) (PArray.remove i lines) rest | _ -> failwith "extract_lines_opt: incomplete" end | Some (CP.Flow_with_Epsilons ((_, _), _)) -> failwith "extract_lines_opt: incomplete" | Some (CP.Flow_with_Epsilon_Bars ((_, _), _)) -> failwith "extract_lines_opt: incomplete" | Some CP.Ghost -> failwith "extract_lines_opt: incomplete" | Some (CP.Ghost_with_Epsilons _)-> failwith "extract_lines_opt: incomplete" | Some (CP.Ghost_with_Epsilon_Bars _) -> failwith "extract_lines_opt: incomplete" end | A.M (_, _) :: _ -> failwith "extract_lines_opt: incomplete" in extract_lines' [] endpoints lines (*i let connect_epsilon_saturated_opt n epsilon (flow_n, lines) = match extract_lines_opt epsilon lines with | None -> None | Some (flow_n, lines) -> Some (CP.Epsilon flow_n, lines) let connect_epsilon_opt n epsilon (flow_n, lines) = match extract_lines_opt epsilon lines with | None -> None | Some (flow_n, lines) -> Some (CP.Epsilon flow_n, lines) i*) let fuse1 n_c lines arrow = let open Birdtracks in match arrow with | Arrows { coeff; arrows } -> begin match connect_arrows_opt arrows lines with | None -> [] | Some (sign, flow) -> [(QC.mul (QC.int sign) (L.eval (QC.int n_c) coeff), flow)] end | Epsilons _ -> failwith "Birdtracks.fuse1: Epsilons" | Epsilon_Bars _ -> failwith "Birdtracks.fuse1: Epsilon_Bars" let fuse n_c vertex lines = match vertex with | [] -> if List.for_all CP.is_white lines then [(QC.unit, CP.white)] else [] | vertex -> ThoList.flatmap (fuse1 n_c lines) vertex let flow_to_string flow = ThoList.to_string (fun (c, p) -> let p = CP.to_string p in if QC.is_unit c then p else Printf.sprintf "%s*%s" (QC.to_string c) p) flow -let fuse_logging n_c vertex lines = +let _fuse_logging n_c vertex lines = let flow_n = fuse n_c vertex lines in Printf.eprintf "%s >>> %s\n" (ThoList.to_string CP.to_string lines) (flow_to_string flow_n); flow_n (*i let fuse = fuse_logging i*) (* \thocwmodulesection{Unit Tests} *) module Test = struct open OUnit let vertices_equal v1 v2 = (Birdtracks.canonicalize v1) = (Birdtracks.canonicalize v2) - let eq v1 v2 = + let _eq v1 v2 = assert_equal ~printer:Birdtracks.to_string_raw ~cmp:vertices_equal v1 v2 let suite_open_contract = "open_contract" >::: [ "[2;3] [1;2;4]" >:: (fun () -> assert_equal None (open_contract [2;3] [1;2;4])); "[2;3] [1;2;3;4]" >:: (fun () -> assert_equal None (open_contract [2;3] [1;2;3;4])); "[2;3] [1;2;3]" >:: (fun () -> assert_equal (Some ( 1,1)) (open_contract [2;3] [1;2;3])); "[1;3] [1;2;3]" >:: (fun () -> assert_equal (Some (-1, 2)) (open_contract [1;3] [1;2;3])) ] let signed_flow_option_to_string = function | Some (sign, flow) -> let flow = CP.to_string flow in if sign = 1 then flow else Printf.sprintf "%d*%s" sign flow | None -> "None" let test_connect_arrows_msg vertex formatter (expected, result) = Format.fprintf formatter "[%s]: expected %s, got %s" (ThoList.to_string A.free_to_string vertex) (signed_flow_option_to_string expected) (signed_flow_option_to_string result) - let test_connect_arrows expected lines vertex = + let _test_connect_arrows expected lines vertex = assert_equal ~printer:signed_flow_option_to_string expected (connect_arrows_opt vertex lines) let test_connect_arrows_permutations expected lines vertex = List.iter (fun v -> assert_equal ~pp_diff:(test_connect_arrows_msg v) expected (connect_arrows_opt v lines)) (Combinatorics.permute vertex) let suite_connect_arrows = "connect_arrows" >::: [ "delta" >:: (fun () -> test_connect_arrows_permutations (Some (1, CP.of_lists [1] [])) [ CP.of_lists [1] []; CP.white] ( 1 ==> 3 )); "f: 1->3->2->1" >:: (fun () -> test_connect_arrows_permutations (Some (1, CP.of_lists [1] [3])) [CP.of_lists [1] [2]; CP.of_lists [2] [3]] (A.cycle [1; 3; 2])); "f: 1->2->3->1" >:: (fun () -> test_connect_arrows_permutations (Some (1, CP.of_lists [1] [2])) [CP.of_lists [3] [2]; CP.of_lists [1] [3]] (A.cycle [1; 2; 3])) ] let test_fuse_msg vertex lines formatter (expected, result) = Format.fprintf formatter "%s // %s => %s failed, got %s instead" (Birdtracks.to_string vertex) (ThoList.to_string CP.to_string lines) (flow_to_string expected) (flow_to_string result) let compare_fusion (c1, p1) (c2, p2) = let c = Algebra.QC.compare c1 c2 in if c <> 0 then c else CP.compare p1 p2 let equal_fusion f1 f2 = compare_fusion f1 f2 = 0 let cmp_fusions f1 f2 = let f1 = List.sort compare_fusion f1 and f2 = List.sort compare_fusion f2 in try List.for_all2 equal_fusion f1 f2 with | Invalid_argument _ -> false let test_fuse expected vertex lines = let nc = 3 in assert_equal ~cmp:cmp_fusions ~pp_diff:(test_fuse_msg vertex lines) expected (fuse nc vertex lines) (* This way, we can write [vertex // lines => expected] in the tests. *) let (//) vertex lines = (vertex, lines) let (=>) (vertex, lines) expected = test_fuse expected vertex lines (* Abbreviations *) - let tf = test_fuse + let _tf = test_fuse let e = QC.unit - let half = QC.fraction 2 + let h = QC.fraction 2 let w = CP.white (* Quarks and anti quarks: *) let q i = CP.of_lists [i] [] let aq i = CP.of_lists [] [i] (* Diquarks and anti diquarks: *) let dq i j = CP.of_lists [i; j] [] let adq i j = CP.of_lists [] [i; j] (* Gluons without ghosts *) let g i j = CP.of_lists [i] [j] (* Couplings *) let d = SU3.delta3 let d6 = SU3.delta6 let t = SU3.t let t6 = SU3.t6 let k6 = SU3.k6 let k6b = SU3.k6bar let suite_binary_qed3 = "triplet" >::: [ "1 2 " >:: (fun () -> d 2 1 // [q 1; aq 1] => [(e, w)]); "1 2'" >:: (fun () -> d 2 1 // [aq 1; q 1 ] => []); "2 1 " >:: (fun () -> d 1 2 // [aq 1; q 1 ] => [(e, w)]); "2 1'" >:: (fun () -> d 1 2 // [q 1; aq 1] => []); "1 3 " >:: (fun () -> d 3 1 // [q 1; w ] => [(e, q 1)]); "2 3 " >:: (fun () -> d 3 2 // [w; q 1 ] => [(e, q 1)]); "3 1 " >:: (fun () -> d 1 3 // [aq 1; w ] => [(e, aq 1)]); "3 2 " >:: (fun () -> d 2 3 // [w; aq 1] => [(e, aq 1)]) ] let suite_binary_qed6 = "sextet" >::: - [ "1 2 " >:: (fun () -> d6 2 1 // [dq 1 2; adq 1 2] => [(half, w)]); - "1 2' " >:: (fun () -> d6 2 1 // [dq 1 2; adq 2 1] => [(half, w)]); + [ "1 2 " >:: (fun () -> d6 2 1 // [dq 1 2; adq 1 2] => [(h, w)]); + "1 2' " >:: (fun () -> d6 2 1 // [dq 1 2; adq 2 1] => [(h, w)]); "1 2''" >:: (fun () -> d6 2 1 // [dq 1 2; adq 1 3] => []) ] let suite_binary_qcd3 = "triplet" >::: [ "1 2 " >:: (fun () -> t 3 2 1 // [q 1; aq 2] => [(e, g 1 2)]); "1 2'" >:: (fun () -> t 3 2 1 // [aq 1; q 2] => []) ] let suite_binary_qcd6 = "sextet" >::: - [ "1 2" >:: (fun () -> t6 3 2 1 // [dq 1 2; adq 2 3] => [(half, g 1 3)]) ] + [ "1 2" >:: (fun () -> t6 3 2 1 // [dq 1 2; adq 2 3] => [(h, g 1 3)]) ] let suite_binary_k6 = "k6(bar)" >::: - [ "321 " >:: (fun () -> k6b 3 2 1 // [q 1; q 2 ] => [(e, dq 2 1); (e, dq 1 2)]); - "321* " >:: (fun () -> k6 3 2 1 // [aq 1; aq 2] => [(e, adq 2 1); (e, adq 1 2)]); - "123 " >:: (fun () -> k6b 1 2 3 // [adq 1 2; q 1] => [(e, aq 2)]); - "132 " >:: (fun () -> k6b 1 3 2 // [adq 1 2; q 1] => [(e, aq 2)]); - "123' " >:: (fun () -> k6b 1 2 3 // [adq 1 2; q 2] => [(e, aq 1)]); - "132' " >:: (fun () -> k6b 1 3 2 // [adq 1 2; q 2] => [(e, aq 1)]); - "213 " >:: (fun () -> k6b 2 1 3 // [q 1; adq 1 2] => [(e, aq 2)]); - "231 " >:: (fun () -> k6b 2 3 1 // [q 1; adq 1 2] => [(e, aq 2)]); - "213' " >:: (fun () -> k6b 2 1 3 // [q 2; adq 1 2] => [(e, aq 1)]); - "231' " >:: (fun () -> k6b 2 3 1 // [q 2; adq 1 2] => [(e, aq 1)]); - "123 *" >:: (fun () -> k6 1 2 3 // [dq 1 2; aq 1] => [(e, q 2)]); - "132 *" >:: (fun () -> k6 1 3 2 // [dq 1 2; aq 1] => [(e, q 2)]); - "123'*" >:: (fun () -> k6 1 2 3 // [dq 1 2; aq 2] => [(e, q 1)]); - "132'*" >:: (fun () -> k6 1 3 2 // [dq 1 2; aq 2] => [(e, q 1)]); - "213 *" >:: (fun () -> k6 2 1 3 // [aq 1; dq 1 2] => [(e, q 2)]); - "231 *" >:: (fun () -> k6 2 3 1 // [aq 1; dq 1 2] => [(e, q 2)]); - "213'*" >:: (fun () -> k6 2 1 3 // [aq 2; dq 1 2] => [(e, q 1)]); - "231'*" >:: (fun () -> k6 2 3 1 // [aq 2; dq 1 2] => [(e, q 1)]) ] + [ "321 " >:: (fun () -> k6 3 2 1 // [q 1; q 2 ] => [(h, dq 2 1); (h, dq 1 2)]); + "321* " >:: (fun () -> k6b 3 2 1 // [aq 1; aq 2] => [(h, adq 2 1); (h, adq 1 2)]); + "123 " >:: (fun () -> k6 1 2 3 // [adq 1 2; q 1] => [(h, aq 2)]); + "132 " >:: (fun () -> k6 1 3 2 // [adq 1 2; q 1] => [(h, aq 2)]); + "123' " >:: (fun () -> k6 1 2 3 // [adq 1 2; q 2] => [(h, aq 1)]); + "132' " >:: (fun () -> k6 1 3 2 // [adq 1 2; q 2] => [(h, aq 1)]); + "213 " >:: (fun () -> k6 2 1 3 // [q 1; adq 1 2] => [(h, aq 2)]); + "231 " >:: (fun () -> k6 2 3 1 // [q 1; adq 1 2] => [(h, aq 2)]); + "213' " >:: (fun () -> k6 2 1 3 // [q 2; adq 1 2] => [(h, aq 1)]); + "231' " >:: (fun () -> k6 2 3 1 // [q 2; adq 1 2] => [(h, aq 1)]); + "123 *" >:: (fun () -> k6b 1 2 3 // [dq 1 2; aq 1] => [(h, q 2)]); + "132 *" >:: (fun () -> k6b 1 3 2 // [dq 1 2; aq 1] => [(h, q 2)]); + "123'*" >:: (fun () -> k6b 1 2 3 // [dq 1 2; aq 2] => [(h, q 1)]); + "132'*" >:: (fun () -> k6b 1 3 2 // [dq 1 2; aq 2] => [(h, q 1)]); + "213 *" >:: (fun () -> k6b 2 1 3 // [aq 1; dq 1 2] => [(h, q 2)]); + "231 *" >:: (fun () -> k6b 2 3 1 // [aq 1; dq 1 2] => [(h, q 2)]); + "213'*" >:: (fun () -> k6b 2 1 3 // [aq 2; dq 1 2] => [(h, q 1)]); + "231'*" >:: (fun () -> k6b 2 3 1 // [aq 2; dq 1 2] => [(h, q 1)]) ] let suite_binary = "binary" >::: [ "colorless" >:: (fun () -> [] // [w; w] => [(e, w)]); "qed" >::: [ suite_binary_qed3; suite_binary_qed6; suite_binary_k6 ]; "qcd" >::: [ suite_binary_qcd3; suite_binary_qcd6 ] ] let suite_tertiary = "tertiary" >::: [ "colorless" >:: (fun () -> [] // [w; w; w] => [(e, w)]); "qed 1 2" >:: (fun () -> d 2 1 // [q 1; aq 1; w] => [(e, w)]); "qed 1 3" >:: (fun () -> d 3 1 // [q 1; w; aq 1] => [(e, w)]); "qed 2 3" >:: (fun () -> d 3 2 // [w; q 1; aq 1] => [(e, w)]) ] let suite_nary = "n-ary" >::: [ "colorless" >:: (fun () -> [] // [w; w; w; w; w] => [(e, w)]) ] let suite_fuse = "fuse" >::: [ suite_binary; suite_tertiary; suite_nary ] let suite = "Color_Fusion" >::: [suite_open_contract; suite_connect_arrows; suite_fuse] let suite_long = "Color_Fusion long" >::: [] end Index: trunk/omega/src/arrow.ml =================================================================== --- trunk/omega/src/arrow.ml (revision 8919) +++ trunk/omega/src/arrow.ml (revision 8920) @@ -1,1096 +1,1295 @@ (* arrow.ml -- Copyright (C) 2022-2024 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. *) (* \newcommand{\setupFourAmp}{% \fmfleft{i1,i2} \fmfright{o1,o2} \fmf{phantom}{i1,v1,i2} \fmf{phantom}{o2,v2,o1} \fmf{phantom}{v1,v2} \fmffreeze} \fmfcmd{% numeric joindiameter; joindiameter := 7thick;} \fmfcmd{% vardef sideways_at (expr d, p, frac) = save len; len = length p; (point frac*len of p) shifted ((d,0) rotated (90 + angle direction frac*len of p)) enddef; secondarydef p sideways d = for frac = 0 step 0.01 until 0.99: sideways_at (d, p, frac) .. endfor sideways_at (d, p, 1) enddef; secondarydef p choptail d = subpath (ypart (fullcircle scaled d shifted (point 0 of p) intersectiontimes p), infinity) of p enddef; secondarydef p choptip d = reverse ((reverse p) choptail d) enddef; secondarydef p pointtail d = fullcircle scaled d shifted (point 0 of p) intersectionpoint p enddef; secondarydef p pointtip d = (reverse p) pointtail d enddef; secondarydef pa join pb = pa choptip joindiameter .. pb choptail joindiameter enddef; vardef cyclejoin (expr p) = subpath (0.5*length p, infinity) of p join subpath (0, 0.5*length p) of p .. cycle enddef;} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \fmfcmd{% style_def double_line_arrow expr p = save pi, po; path pi, po; pi = reverse (p sideways thick); po = p sideways -thick; cdraw pi; cdraw po; cfill (arrow (subpath (0, 0.9 length pi) of pi)); cfill (arrow (subpath (0, 0.9 length po) of po)); enddef;} \fmfcmd{% style_def double_line_arrow_beg expr p = save pi, po, pc; path pi, po, pc; pc = p choptail 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw pi .. p pointtail 5thick .. po; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_line_arrow_end expr p = save pi, po, pc; path pi, po, pc; pc = p choptip 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw po .. p pointtip 5thick .. pi; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_line_arrow_both expr p = save pi, po, pc; path pi, po, pc; pc = p choptip 7thick choptail 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw po .. p pointtip 5thick .. pi .. p pointtail 5thick .. cycle; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_arrow_parallel expr p = save pi, po; path pi, po; pi = p sideways thick; po = p sideways -thick; save li, lo; li = length pi; lo = length po; cdraw pi; cdraw po; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_arrow_crossed_beg expr p = save lp; lp = length p; save pi, po; path pi, po; pi = p sideways thick; po = p sideways -thick; save li, lo; li = length pi; lo = length po; cdraw subpath (0, 0.1 li) of pi .. subpath (0.3 lo, lo) of po; cdraw subpath (0, 0.1 lo) of po .. subpath (0.3 li, li) of pi; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_arrow_crossed_end expr p = save lp; lp = length p; save pi, po; path pi, po; pi = p sideways thick; po = p sideways -thick; save li, lo; li = length pi; lo = length po; cdraw subpath (0, 0.7 li) of pi .. subpath (0.9 lo, lo) of po; cdraw subpath (0, 0.7 lo) of po .. subpath (0.9 li, li) of pi; cfill (arrow pi); cfill (arrow po); enddef;} *) (* \thocwmodulesection{Arrows and Epsilons} *) type endpoint = | I of int | M of int * int +let compare_endpoints x x' = + match x, x' with + | I i, I i' | I i, M (i', _) | M (i, _), I i' -> + Int.compare i i' + | M (i, j), M (i', j') -> + let c = Int.compare i i' in + if c <> 0 then + c + else + Int.compare j j' + let position_endpoint = function | I i -> i | M (i, _) -> i let relocate_endpoint f = function | I i -> I (f i) | M (i, n) -> M (f i, n) type tip = endpoint type tail = endpoint type ghost = endpoint +let compare_tips = compare_endpoints +let compare_tails = compare_endpoints +let compare_ghosts = compare_endpoints + let position_tip = position_endpoint let position_tail = position_endpoint let position_ghost = position_endpoint let relocate_tip = relocate_endpoint let relocate_tail = relocate_endpoint let relocate_ghost = relocate_endpoint (* Note that in the case of double lines for the adjoint representation the \emph{same} [endpoint] appears twice: once as a [tip] and once as a [tail]. If we want to multiply two factors by merging arrows with matching [tip] and [tail], we must make sure that the [tip] is from one factor and the [tail] from the other factor. *) (* The [Free] variant contains positive indices as well as negative indices that don't appear on both sides and will be summed in a later product. [SumL] and [SumR] indices appear on both sides. *) type 'a index = | Free of 'a | SumL of 'a | SumR of 'a let is_free_index = function | Free _ -> true | SumL _ | SumR _ -> false type ('tail, 'tip, 'ghost) t = | Arrow of 'tail * 'tip | Ghost of 'ghost type 'tip eps = 'tip list type 'tail eps_bar = 'tail list type free = (tail, tip, ghost) t type free_eps = tip eps type factor_eps = tip index eps type factor = (tail index, tip index, ghost index) t type free_eps_bar = tail eps_bar type factor_eps_bar = tail index eps_bar +let epsilon tips = tips +let epsilon_bar tails = tails + let relocate f = function | Arrow (tail, tip) -> Arrow (relocate_tail f tail, relocate_tip f tip) | Ghost ghost -> Ghost (relocate_ghost f ghost) let rev = function | Arrow (tail, tip) -> Arrow (tip, tail) | Ghost _ as ghost -> ghost let rev_eps tips = tips let rev_eps_bar tails = tails let tips = function | Arrow (_, tip) -> [tip] | Ghost _ -> [] let tails = function | Arrow (tail, _) -> [tail] | Ghost _ -> [] let tips_eps tips = tips let tails_eps_bar tails = tails +module ISet = Set.Make(Int) + +let adjoint_tips arrows = + List.fold_left + (fun acc -> function Arrow (_, I i) -> ISet.add i acc | _ -> acc) + ISet.empty arrows + +let adjoint_tails arrows = + List.fold_left + (fun acc -> function Arrow (I i, _) -> ISet.add i acc | _ -> acc) + ISet.empty arrows + +let single_endpoints endpoints = + List.fold_left (fun acc -> function I i -> ISet.add i acc | _ -> acc) ISet.empty endpoints + +let adjoint_tips_eps eps = + NEList.fold_right + (fun eps -> ISet.union (single_endpoints (tips_eps eps))) + eps ISet.empty + +let adjoint_tails_eps_bar eps_bar = + NEList.fold_right + (fun eps_bar -> ISet.union (single_endpoints (tails_eps_bar eps_bar))) + eps_bar ISet.empty + +let common set1 set2 = + ISet.elements (ISet.inter set1 set2) + +let adjoints arrows = + common (adjoint_tips arrows) (adjoint_tails arrows) + +let adjoints_eps arrows eps = + common (ISet.union (adjoint_tips arrows) (adjoint_tips_eps eps)) (adjoint_tails arrows) + +let adjoints_eps_bar arrows eps_bar = + common (adjoint_tips arrows) (ISet.union (adjoint_tails arrows) (adjoint_tails_eps_bar eps_bar)) + let endpoint_to_string = function | I i -> string_of_int i | M (i, n) -> Printf.sprintf "%d.%d" i n let index_to_string = function | Free i -> endpoint_to_string i | SumL i -> endpoint_to_string i ^ "L" | SumR i -> endpoint_to_string i ^ "R" let to_string i2s = function | Arrow (tail, tip) -> Printf.sprintf "%s>%s" (i2s tail) (i2s tip) | Ghost ghost -> Printf.sprintf "{%s}" (i2s ghost) let to_string_eps i2s tips = Printf.sprintf ">>>%s" (ThoList.to_string i2s tips) -let to_string_eps_bar i2s tails = Printf.sprintf "<<<%s" (ThoList.to_string i2s tails) +let to_string_eps_bar i2s tails = Printf.sprintf "%s>>>" (ThoList.to_string i2s tails) let free_to_string = to_string endpoint_to_string let free_eps_to_string = to_string_eps endpoint_to_string let free_eps_bar_to_string = to_string_eps_bar endpoint_to_string let factor_to_string = to_string index_to_string let factor_eps_to_string = to_string_eps index_to_string let factor_eps_bar_to_string = to_string_eps_bar index_to_string let matching_summation i1 i2 = match i1, i2 with | SumL i1, SumR i2 | SumR i1, SumL i2 -> i1 = i2 | _ -> false let map f = function | Arrow (tail, tip) -> Arrow (f tail, f tip) | Ghost ghost -> Ghost (f ghost) let map_eps = List.map let map_eps_bar = List.map let free_index = function | Free i -> i - | SumL i -> invalid_arg "Arrow.free_index: leftover LHS summation" - | SumR i -> invalid_arg "Arrow.free_index: leftover RHS summation" + | SumL i -> invalid_arg ("Arrow.free_index: leftover LHS summation: " ^ endpoint_to_string i) + | SumR i -> invalid_arg ("Arrow.free_index: leftover RHS summation: " ^ endpoint_to_string i) let to_left_index is_sum i = if is_sum i then SumL i else Free i let to_right_index is_sum i = if is_sum i then SumR i else Free i let to_left_factor is_sum = map (to_left_index is_sum) let to_right_factor is_sum = map (to_right_index is_sum) let of_factor = map free_index let to_left_factor_eps is_sum = map_eps (to_left_index is_sum) let to_right_factor_eps is_sum = map_eps (to_right_index is_sum) let of_factor_eps = map_eps free_index let to_left_factor_eps_bar is_sum = map_eps_bar (to_left_index is_sum) let to_right_factor_eps_bar is_sum = map_eps_bar (to_right_index is_sum) let of_factor_eps_bar = map_eps_bar free_index let negatives = function | Arrow (tail, tip) -> if position_tail tail < 0 then if position_tip tip < 0 then [tail; tip] else [tail] else if position_tip tip < 0 then [tip] else [] | Ghost ghost -> if position_ghost ghost < 0 then [ghost] else [] let negatives_eps = List.filter (fun tip -> position_tip tip < 0) let negatives_eps_bar = List.filter (fun tail -> position_tail tail < 0) let is_free = function | Arrow (Free _, Free _) | Ghost (Free _) -> true | Arrow (_, _) | Ghost _ -> false let is_free_eps = List.for_all is_free_index let is_free_eps_bar = List.for_all is_free_index let is_ghost = function | Ghost _ -> true | Arrow _ -> false let single tail tip = Arrow (tail, tip) let double a b = if a = b then [single a b] else [single a b; single b a] let ghost g = Ghost g module Infix = struct let ( => ) i j = single (I i) (I j) let ( ==> ) i j = [i => j] let ( <=> ) i j = double (I i) (I j) let ( >=> ) (i, n) j = single (M (i, n)) (I j) let ( =>> ) i (j, m) = single (I i) (M (j, m)) let ( >=>> ) (i, n) (j, m) = single (M (i, n)) (M (j, m)) let ( ?? ) i = ghost (I i) end open Infix (* Split [a_list] at the first element equal to [a] according to [eq]. Return the reversed first part and the rest as a pair and wrap it in [Some]. Return [None] if there is no match. *) let take_first_match_opt ?(eq=(=)) a a_list = let rec take_first_match_opt' rev_head = function | [] -> None | elt :: tail -> if eq elt a then Some (rev_head, tail) else take_first_match_opt' (elt :: rev_head) tail in take_first_match_opt' [] a_list (* Split [a_list] and [b_list] at the first element equal according to [eq]. Return the reversed first part and the rest of each as a pair of pairs wrap it in [Some]. Return [None] if there is no match. \begin{dubious} This function remains from an earlier version and is no longer used. \end{dubious} *) let take_first_matching_pair_opt ?(eq=(=)) a_list b_list = let rec take_first_matching_pair_opt' rev_a_head = function | [] -> None | a :: a_tail -> begin match take_first_match_opt ~eq a b_list with | Some (rev_b_head, b_tail) -> Some ((rev_a_head, a_tail), (rev_b_head, b_tail)) | None -> take_first_matching_pair_opt' (a :: rev_a_head) a_tail end in take_first_matching_pair_opt' [] a_list (* Replace the first occurence of an element equal to [a] according to [eq] in [a_list] by [a'] and wrap the new list in [Some]. Return [None] if there is no match. *) let replace_first_opt ?(eq=(=)) a a' a_list = match take_first_match_opt ~eq a a_list with | Some (rev_head, tail) -> Some (List.rev_append rev_head (a' :: tail)) | None -> None let tee a = function | Arrow (tail, tip) -> [Arrow (tail, I a); Arrow (I a, tip)] | Ghost _ as g -> [g] let dir i j = function | Arrow (tail, tip) -> let tail = position_tail tail and tip = position_tip tip in if tip = i && tail = j then 1 else if tip = j && tail = i then -1 else invalid_arg "Arrow.dir" | Ghost _ -> 0 type merge = | Match of factor | Ghost_Match | Loop_Match | Mismatch | No_Match (* As an optimization, don't attempt to merge if neither of the arrows contains a summation index and return immediately. *) let merge_arrow_arrow arrow1 arrow2 = if is_free arrow1 || is_free arrow2 then No_Match else match arrow1, arrow2 with | Ghost g1, Ghost g2 -> if matching_summation g1 g2 then Ghost_Match else No_Match | Arrow (tail, tip), Ghost g | Ghost g, Arrow (tail, tip) -> if matching_summation g tail || matching_summation g tip then Mismatch else No_Match | Arrow (tail, tip), Arrow (tail', tip') -> if matching_summation tip tail' then if matching_summation tip' tail then Loop_Match else Match (Arrow (tail, tip')) else if matching_summation tip' tail then Match (Arrow (tail', tip)) else No_Match type 'a merge_eps = | Match_Eps of 'a | Mismatch_Eps | No_Match_Eps let merge_arrow_eps arrow tips = if is_free_eps tips || is_free arrow then No_Match_Eps else match arrow with | Arrow (tail, tip) -> begin match replace_first_opt ~eq:matching_summation tail tip tips with | None -> No_Match_Eps | Some tips -> Match_Eps tips end | Ghost g -> if List.exists (matching_summation g) tips then Mismatch_Eps else No_Match_Eps let merge_arrow_eps_bar arrow tails = if is_free_eps_bar tails || is_free arrow then No_Match_Eps else match arrow with | Arrow (tail, tip) -> begin match replace_first_opt ~eq:matching_summation tip tail tails with | None -> No_Match_Eps | Some tails -> Match_Eps tails end | Ghost g -> if List.exists (matching_summation g) tails then Mismatch_Eps else No_Match_Eps (* \thocwmodulesection{Evaluation Rules for Epsilon Tensors} \label{sec:evaluation-of-epsilon-tensors} *) (* In the case of matching dimension~$N=\delta_m^m$ and rank~$n$ of~$\epsilon$ and $\bar\epsilon$, the tensor algebra of the $\delta_{i}^{j}$, $\epsilon_{i_1i_2\cdots i_n}$ and $\bar\epsilon^{j_1j_2\cdots j_n}$ is \emph{not} freely generated. Indeed, introducing the \emph{generalized Kronecker~$\delta$} symbol \begin{equation} \label{eq:generalized-delta} \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)} \delta_{i_1}^{\sigma(j_1)} \delta_{i_2}^{\sigma(j_2)} \cdots \delta_{i_n}^{\sigma(j_n)} = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)} \delta_{\sigma(i_1)}^{j_1} \delta_{\sigma(i_2)}^{j_2} \cdots \delta_{\sigma(i_n)}^{j_n} = \begin{vmatrix} \delta_{i_1}^{j_1} & \delta_{i_1}^{j_2} & \cdots & \delta_{i_1}^{j_n} \\ \delta_{i_2}^{j_1} & \delta_{i_2}^{j_2} & \cdots & \delta_{i_2}^{j_n} \\ \vdots & \vdots & \ddots & \vdots \\ \delta_{i_n}^{j_1} & \delta_{i_n}^{j_2} & \cdots & \delta_{i_n}^{j_n} \end{vmatrix} \,, \end{equation} there is the relation~$\forall n=N\in\mathbf{N}$ with~$N\ge2$: \begin{equation} \label{eq:epsilon*epsilonbar-0} \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n} = \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}\,, \end{equation} which follows from anti-symmetry and the choice of normalization $\epsilon_{12\cdots n} = 1 = \bar\epsilon^{12\cdots n}$ alone. Contracting $k$ indices in the relation~\eqref{eq:epsilon*epsilonbar-0}, we find~$\forall k, n, N \in \mathbf{N}$ with $0 \le k \le n = N\ge2$: \begin{equation} \label{eq:epsilon*epsilonbar} \epsilon_{m_1\cdots m_ki_{k+1}\cdots i_n} \bar\epsilon^{m_1\cdots m_kj_{k+1}\cdots j_n} = k!\, \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n}\,. \end{equation} *) (* Note that the generalized Kronecker delta~\eqref{eq:generalized-delta} is well defined for arbitrary rank~$n\ge1$, including $nN$. It satisfies \begin{subequations} \label{eq:delta*delta/epsilon} \begin{align} \label{eq:delta*delta} \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} \delta_{j_1j_2\cdots j_n}^{k_1k_2\cdots k_n} &= n!\, \delta_{i_1i_2\cdots i_n}^{k_1k_2\cdots k_n} \\ \label{eq:delta*epsilon} \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} \epsilon_{j_1j_2\cdots j_n} &= n!\, \epsilon_{i_1i_2\cdots i_n} \\ \label{eq:delta*epsilonbar} \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} \bar\epsilon^{i_1i_2\cdots i_n} &= n!\, \bar\epsilon^{j_1j_2\cdots j_n} \end{align} \end{subequations} since every $\sigma\in S_n$ gives the same contribution when contracting totally antisymmetric combinations. Note also that the relations~\eqref{eq:delta*delta/epsilon} are independent of the dimension~$N$ and remain valid for rank~$n\not=N$, as long as~$\epsilon_{i_1i_2\cdots i_n}$ and~$\bar\epsilon^{j_1j_2\cdots j_n}$ are totally antisymmetric. In our birdtrack based evaluator, the condition~$N=n$ is not enforced. Indeed, $N$ is just a variable in Laurent polynomials [Algebra.Laurent.t] and $n$ is the arbitrary length of the lists in [tip Arrow.eps] and [tail Arrow.eps_bar] of colorflows. Therefore, we can use neither~\eqref{eq:epsilon*epsilonbar-0} nor~\eqref{eq:epsilon*epsilonbar} directly to test our evaluator. *) (* Nevertheless, for the purpose of testing our evaluator, we can \emph{define} a \emph{formal} evaluation rule for birdtracks in the general case~$N\not=n$, that is compatible with anti-symmetry and reduces to~\eqref{eq:epsilon*epsilonbar-0} for $N=n$ \begin{equation} \label{eq:epsilon*epsilonbar-generalized} %%% \forall 2\le n \le N \in\mathbf{N}:\; \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n} \to \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}\,, \end{equation} where we use the arrow $\to$ instead of the equal sign to stress that is a rule and not an equation, in contrast to the special case~\eqref{eq:epsilon*epsilonbar-0} for~$n=N$. *) let merge_eps_eps_bar tips tails = if List.length tails <> List.length tips then None else Some (List.fold_left (fun (even, odd) (eps, tips) -> if eps > 0 then (List.rev_map2 single tails tips :: even, odd) else (even, List.rev_map2 single tails tips :: odd)) ([], []) (Combinatorics.permute_signed tips)) (* Contracting one index, we find the equation \begin{multline} \delta_{mi_2\cdots i_n}^{mj_2\cdots j_n} = \delta_m^m \sum_{\substack{\sigma\in S_n\\\sigma(m)=m}} (-1)^{\varepsilon(\sigma)} \delta_{i_2}^{\sigma(j_2)} \cdots \delta_{i_n}^{\sigma(j_n)} + \sum_{\substack{\sigma\in S_n\\\sigma(m)\not=m}} (-1)^{\varepsilon(\sigma)} \delta_{m}^{\sigma(m)} \delta_{i_2}^{\sigma(j_2)} \cdots \delta_{i_n}^{\sigma(j_n)} \\ = N \delta_{i_2\cdots i_n}^{j_2\cdots j_n} - (n-1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n} = (N - n + 1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n}\,, \end{multline} where the~$N=\delta_m^m$ comes from the permutations with~$\sigma(m)=m$ that correspond to a loop in the color flow and the~$n-1$ from the permutations with~$\sigma(m)\in\{i_2,\ldots,i_n\}$ that do not lead to a loop. The minus is due to the fact that there is exactly one transposition $m\leftrightarrow\sigma(m)$. Thus the consistent evalution rule for a contracted $\epsilon$-$\bar\epsilon$-pair is \begin{equation} \label{eq:epsilon*epsilonbar-single-contraction} %%% \forall 2\le n \le N \in\mathbf{N}:\; \epsilon_{mi_2\cdots i_n} \bar\epsilon^{mj_2\cdots j_n} \to \delta_{mi_2\cdots i_n}^{mj_2\cdots j_n} = (N-n+1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n}\,. \end{equation} Note that~$N-n+1=1$ in the special case~$N=n$ when rank and dimension match. Proceeding by induction, we obtain the equation \begin{equation} %%% \forall k, n, N \in \mathbf{N}, 2\le n \le N \land 1\le k \le n:\; \delta_{m_1\cdots m_ki_{k+1}\cdots i_n}^{m_1\cdots m_kj_{k+1}\cdots j_n} = \frac{(N-n+k)!}{(N-n)!}\, \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n} \end{equation} and the corresponding evaluation rule \begin{equation} \label{eq:epsilon*epsilonbar-generalized-contracted} %%% \forall k, n, N \in \mathbf{N}, 2\le n \le N \land 1\le k \le n:\; \epsilon_{m_1\cdots m_ki_{k+1}\cdots i_n} \bar\epsilon^{m_1\cdots m_kj_{k+1}\cdots j_n} \to \delta_{m_1\cdots m_ki_{k+1}\cdots i_n}^{m_1\cdots m_kj_{k+1}\cdots j_n} = \frac{(N-n+k)!}{(N-n)!}\, \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n}\,, \end{equation} where \begin{equation} \frac{(N-n+k)!}{(N-n)!} = (N-n+1)(N-n+2)\cdots(N-n+k)\,. \end{equation} In the case~$N=n$, we recover \begin{equation} \frac{(N-n+k)!}{(N-n)!} = k! \end{equation} as in~\eqref{eq:epsilon*epsilonbar}, of course. *) (* \thocwmodulesubsection{Ambiguities for $n\not=N$} *) (* While~\eqref{eq:epsilon*epsilonbar-generalized} and~\eqref{eq:epsilon*epsilonbar-generalized-contracted} can be used for a single pair of $\epsilon$ and $\bar\epsilon$, it must be stressed that~\eqref{eq:epsilon*epsilonbar-generalized} is \emph{not} a well defined rule for more general expressions in the case~$n\not=N$, because the result depends on the way pairs of $\epsilon$ and $\bar\epsilon$ are chosen for the application of the rule. As a simple example consider the complete pairwise contractions of two $\epsilon$ and two $\bar\epsilon$ \begin{equation} \label{eq:eps2-epsbar2} \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n} \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n}\,. \end{equation} Using~\eqref{eq:epsilon*epsilonbar-generalized}, this can be evaluated in two ways \begin{subequations} \label{eq:eps2-epsbar2*} \begin{equation} \label{eq:eps2-epsbar2*a} \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n} \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n} = \left( \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n} \right)^2 \to \left(\frac{(N-n+n)!}{(N-n)!}\right)^2 = \left(\frac{N!}{(N-n)!} \right)^2 \end{equation} and \begin{multline} \label{eq:eps2-epsbar2*b} \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n} \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n} = \left(\epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}\right) \left(\epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{i_1i_2\cdots i_n}\right) \\ \to \delta^{j_1j_2\cdots j_n}_{i_1i_2\cdots i_n} \delta_{j_1j_2\cdots j_n}^{i_1i_2\cdots i_n} = n!\, \delta^{j_1j_2\cdots j_n}_{i_1i_2\cdots i_n} = n!\, \frac{(N-n+n)!}{(N-n)!} = \frac{N!n!}{(N-n)!}\,, \end{multline} \end{subequations} which agree only for~$N=n$. This observation must be taken into account when interpreting the results of self tests. Even if the expressions~\eqref{eq:eps2-epsbar2*a} and~\eqref{eq:eps2-epsbar2*b} agree for~$n=N$, one might wonder if they correspond to two different physical interpretations of the color flows. The expression~\eqref{eq:eps2-epsbar2} appears in the color summed square matrix elements for $2n$~particles that contain color flows of the form \begin{equation} \epsilon_{i_1i_2\cdots i_n}\bar\epsilon^{j_1j_2\cdots j_n} = \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph*}(25,15) \fmfleft{i1,i2,i3} \fmfright{j1,j2,j3} \fmfv{label=$\epsilon$,label.angle=0}{e} \fmfv{label=$\bar\epsilon$,label.angle=180}{eb} \fmf{fermion}{i1,e} \fmf{fermion}{i2,e} \fmf{fermion}{i3,e} \fmf{fermion}{eb,j1} \fmf{fermion}{eb,j2} \fmf{fermion}{eb,j3} \fmf{phantom,tension=1.5}{e,eb} \fmfdot{e,eb} \end{fmfgraph*}}}\,. \end{equation} The evaluation~\eqref{eq:eps2-epsbar2*a} corresponds to coupling $n$~particles carrying the flows $\epsilon_{i_1,i_2,\ldots i_n}$ to the $n$ particles carrying the flows $\bar\epsilon^{j_1,j_2,\ldots j_n}$ via an intermediate color singlet state. On the other hand, the evaluation~\eqref{eq:eps2-epsbar2*b} corresponds to substituting this flow by \begin{equation} \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} = \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph}(20,10) \fmfleft{i1,i2,i3} \fmfright{j1,j2,j3} \fmf{fermion}{i1,j1} \fmf{fermion}{i2,j2} \fmf{fermion}{i3,j3} \end{fmfgraph}}} - \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph}(20,10) \fmfleft{i1,i2,i3} \fmfright{j1,j2,j3} \fmf{plain}{i1,d1} \fmf{plain,rubout}{i2,d2} \fmf{fermion,tension=2}{d1,j2} \fmf{fermion,tension=2}{d2,j1} \fmf{fermion}{i3,j3} \end{fmfgraph}}} + \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph}(20,10) \fmfleft{i1,i2,i3} \fmfright{j1,j2,j3} \fmf{fermion}{i1,d1} \fmf{plain,rubout}{i2,d2} \fmf{plain}{d1,j2} \fmf{fermion,rubout}{d2,j3} \fmf{fermion,rubout}{i3,j1} \end{fmfgraph}}} + \ldots\,, \end{equation} which, at first sight, appears to introduce colored intermediate states. However, this is not really the case, because the colors cancel out for $n=N=N_C$. This can be seen by looking at the scattering of such a state with a particle in the fundamental representation \begin{equation} \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph*}(25,15) \fmfleft{i1,i2} \fmfright{j1,j2} \fmflabel{$A_n$}{i2} \fmflabel{$A_n$}{j2} \fmflabel{$N$}{i1} \fmflabel{$N$}{j1} \fmf{fermion}{i1,v1,j1} \fmf{dbl_plain_arrow}{i2,v2,j2} \fmf{gluon,tension=0.4}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}}} \end{equation} and calculating the spin summed squared matrix element \begin{multline} \label{eq:AnS1->AnS1} \sum \left|M_n\right|^2 = \tr\left(T^{A_n}_a T^{A_n}_b\right) \tr\left(T_a T_b\right) = \tr\left(T^{A_n}_a T^{A_n}_a\right) = \dim(A_n) C_2(A_n) \\ %%% = { N \choose n } \frac{n(N-n)(N+1)}{N} = \frac{N!}{n!(N-n)!} \frac{n(N-n)(N+1)}{N} = \frac{N+1}{(n-1)!}\frac{(N-1)!}{(N-n-1)!} \end{multline} where~$T^{A_n}$ denotes the generator, $\dim(A_n)$ the dimension and $C_2(A_n)$ the quadratic Casimir~\eqref{eq:C_2(A_n)} in the totally antisymmetric product of $n$ fundamental representations\footnote{% We can use~\eqref{eq:AnS1->AnS1} to test our evaluator and find agreement, e.\,g.~for $n=2,3,4,5$ \begin{subequations} \begin{align} \sum \left|M_2\right|^2 %% % = \left( N^3 - 2 N^2 - N + 2 \right) &= \left(N+1\right) \left(N-1\right) \left(N-2\right) \\ \sum \left|M_3\right|^2 %% % = \frac{1}{2} \left( N^4 - 5 N^3 + 5 N^2 + 5 N - 6 \right) &= \frac{N+1}{2} \left(N-1\right) \left(N-2\right) \left(N-3\right) \\ \sum \left|M_4\right|^2 %% % = \frac{1}{6} \left( N^5 - 9 N^4 + 25 N^3 - 15 N^2 - 26 N + 24 \right) &= \frac{N+1}{6} \left(N-1\right) \left(N-2\right) \left(N-3\right) \left(N-4\right) \\ \sum \left|M_5\right|^2 &= \frac{N+1}{24} \left(N-1\right) \left(N-2\right) \left(N-3\right) \left(N-4\right) \left(N-5\right) \,. \end{align} \end{subequations}}. This expression vanishes for $n\ge N$ and is non-zero for $nN$ is obvious from antisymmetry, but the case $n=N$ depends on the fact that the totally antisymmetric product of $N$ fundamental representations corresponds to a singlet. Therefore, we are free to choose arbitrary pairings of $\epsilon$ with $\bar\epsilon$ without affecting the our results for summed squared matrix elements. Nevertheless, there appear to remain ambiguities in amplitudes with more than one $\epsilon$ or $\bar\epsilon$. For $n=N=3$, they first appear in amplitudes for 5~particles. These can contain color flows of the form \begin{equation} M_{i_1i_2,j_1j_2}^{k} = \epsilon_{i_1i_2m_1}\epsilon_{j_1j_2m_2} \bar\epsilon^{m_1m_2k} \end{equation} and we have to decide whether to evaluate this as \begin{subequations} \begin{equation} M_{i_1i_2,j_1j_2}^{k} \to M_{i_1i_2,j_1j_2}^{(j)\,k} = \epsilon_{i_1i_2m_1} (N-2)\,\left( \delta_{j_1}^{k}\delta_{j_2}^{m_1} - \delta_{j_1}^{m_1}\delta_{j_2}^{k} \right) \\ = (N-2)\,\left( \epsilon_{i_1i_2j_2} \delta_{j_1}^{k} - \epsilon_{i_1i_2j_1} \delta_{j_2}^{k} \right) \end{equation} or \begin{equation} M_{i_1i_2,j_1j_2}^{k} \to M_{i_1i_2,j_1j_2}^{(i)\,k} = \epsilon_{j_1j_2m_2} (N-2)\,\left( \delta_{i_1}^{m_2}\delta_{i_2}^{k} - \delta_{i_1}^{k}\delta_{i_2}^{m_2} \right) = (N-2)\,\left( \epsilon_{j_1j_2i_1}\delta_{i_2}^{k} - \epsilon_{j_1j_2i_2}\delta_{i_1}^{k} \right)\,, \end{equation} \end{subequations} where the superscript denotes which of the $\epsilon$ has been contracted with the $\bar\epsilon$ using~\eqref{eq:epsilon*epsilonbar}. These results are manifestly antisymmetric under the exchange of the elements of each of the two pairs of indices separately, but not under the exchange of the pairs. Fortunately, in the case~$n=N$, we can make use of relations of the form \begin{equation} \label{eq:sum(epsilon*delta)=0} \sum_{\sigma\in S_{n+1}} (-1)^{\varepsilon(\sigma)} \epsilon_{\sigma(i_1)\sigma(i_2)\cdots\sigma(i_n)} \delta_{\sigma(i_{n+1})}^j = 0\,, \end{equation} that follow from the fact that there is no totally antisymmetric tensor of rank~$n>N$ in $N$ dimensions. For example \begin{equation} \epsilon_{ijk}\delta_l^m - \epsilon_{lij}\delta_k^m + \epsilon_{kli}\delta_j^m - \epsilon_{jkl}\delta_i^m = 0 \end{equation} or \begin{equation} \epsilon_{ijk}\delta_l^m - \epsilon_{ijl}\delta_k^m = - \epsilon_{kli}\delta_j^m + \epsilon_{klj}\delta_i^m \end{equation} proves that \begin{equation} M_{i_1i_2,j_1j_2}^{(j)\,k} = - M_{j_1j_2,i_1i_2}^{(j)\,k} \end{equation} and equivalent relations for~$M^{(k)}$ and~$M^{(i)}$ in the case~$n=N=3$. Therefore the amplitudes satisfy all symmetry requirements in the physical case, just not manifestly. Note that we could also observe that \begin{equation} M_{i_1i_2,j_1j_2}^{(i)\,k} = - M_{j_1j_2,i_1i_2}^{(j)\,k} \end{equation} and construct an equivalent amplitude that manifestly satisfies all required antisymmetries \begin{equation} M_{i_1i_2,j_1j_2}^{k} = \frac{1}{2}\left( M_{i_1i_2,j_1j_2}^{(i)\,k} + M_{j_1j_2,i_1i_2}^{(j)\,k} \right) = \frac{N-2}{2} \left( \epsilon_{i_1i_2j_2} \delta_{j_1}^{k} - \epsilon_{i_1i_2j_1} \delta_{j_2}^{k} + \epsilon_{j_1j_2i_1}\delta_{i_2}^{k} - \epsilon_{j_1j_2i_2}\delta_{i_1}^{k} \right)\,. \end{equation} However, this approach conflicts with a recursive construction of the amplitudes, since it would require a consideration of the complete amplitude, using more and more complicated variations on~\eqref{eq:sum(epsilon*delta)=0}. *) (* \thocwmodulesubsection{Evaluation Strategy} \label{sec:epsilon-evaluation-strategy} *) (* Faced with a non-free tensor algebra, we have to choose an evaluation strategy. If we encounter a pair of $\epsilon$ and $\bar\epsilon$ with a joint contracted index, we should use~\eqref{eq:epsilon*epsilonbar-single-contraction} immediately. Note this does not yet resolve all ambiguities because there are cases in which an $\epsilon$ (or $\bar\epsilon$) can be contracted with more than one $\bar\epsilon$ (or $\epsilon$) and we have to make a choice. However, we will obtain equivalent, if not manifestly equal, results in the case $n=N$. In the case of disconnected pairs of~$\epsilon$ and $\bar\epsilon$, we have to decide whether to use~\eqref{eq:epsilon*epsilonbar-generalized} to produce an amplitude that contains \emph{only} $\epsilon$ (or $\bar\epsilon$). A disadvantage of this strategy is that each application of~\eqref{eq:epsilon*epsilonbar-generalized} produces $n!$ permutations of Kronecker deltas that have to be evaluated. However, keeping all disconnected $\epsilon$ and $\bar\epsilon$ will require to try many more color flows for the complete amplitude since there can be both incoming and outgoing lines that are not continued through the diagram. Therefore we decide to \emph{always apply~\eqref{eq:epsilon*epsilonbar-generalized} as soon as possible}. There remains to determine a prescription for consistently selecting the $\epsilon$-$\bar\epsilon$-pairs to be contracted if there is more than one possibility. In particular, we \emph{must not} give in to the temptation of premature optimization: when evaluating the color flows for a 1POW in a fusion (cf.~[Color_Fusion], pages~\pageref{sec:colorflow-fusions}\,f{}f), we know the color flows for all incoming lines. One is therefore tempted to choose a pair with disjoint color flows, since the evaluation for this color flow could be terminated immediately. Unfortunately, this would not be consistent, because a different choice would be made for different color flows. Imagine, for example the fusion of $\bar\epsilon^{123}$ with $\epsilon_{123}\epsilon_{456}$ or $\epsilon_{456}\epsilon_{123}$. In both cases, we will obtain $3!\,\epsilon_{456}$ or~$0$, depending of our choice. If we were to attempt to optimize the evaluation and make the choice that results in~$0$, we would not get the correct result. Instead we have to make the \emph{same} choice for every external color flow. This requires ignoring the external color flow indices. For this to work, we must use an ordered data structure for the unprocessed $\epsilon$ and $\bar\epsilon$. In particular, we \emph{must not} use a [Set], where the ordering of the elements will typically depend on the color flow indices. Instead, we should use lists and apply~\eqref{eq:epsilon*epsilonbar-generalized} consequently to the heads of these lists. Note that selecting contracted mutually $\epsilon$-$\bar\epsilon$-pairs does not introduce a dependency on the external color flow indices! *) let is_tadpole = function | Arrow (tail, tip) -> matching_summation tail tip | Ghost _ -> false -let epsilon = function +module IMap = Map.Make(Int) + +(* Check if we have seen the position [pos] already and increase the + index or return [None]. *) +let new_max_tips max_tips = function + | I _ -> Some max_tips + | M (pos, idx) -> + begin match IMap.find_opt pos max_tips with + | None -> Some (IMap.add pos idx max_tips) + | Some max_idx -> + if idx > max_idx then + Some (IMap.add pos idx max_tips) + else + None + end + +(* Check if we have seen the position [pos] already and increase the + corresponding [max_tip] or return [None]. *) +let new_max_tails max_tails tip = function + | I _ -> Some max_tails + | M (pos, _) -> + begin match IMap.find_opt pos max_tails with + | None -> Some (IMap.add pos tip max_tails) + | Some max_tip -> + if compare_tips tip max_tip > 0 then + Some (IMap.add pos tip max_tails) + else + None + end + +let rec in_canonical_order' max_tails max_tips = function + | [] -> true + | Ghost _ :: arrows -> in_canonical_order' max_tails max_tips arrows + | Arrow (tail, tip) :: arrows -> + if position_tail tail = position_tip tip then + false + else + match new_max_tips max_tips tip with + | None -> false + | Some max_tips -> + begin match new_max_tails max_tails tip tail with + | None -> false + | Some max_tails -> in_canonical_order' max_tails max_tips arrows + end + +let in_canonical_order arrows = + in_canonical_order' IMap.empty IMap.empty arrows + +let endpoints (pos, rank) = + if rank <= 1 then + [I pos] + else + List.map (fun idx -> M (pos, idx)) (ThoList.range 0 (pred rank)) + +let make_tips = endpoints +let make_tails = endpoints + +let epsilon0 = function | [] -> invalid_arg "Arrow.epsilon: rank 0" | [_] -> invalid_arg "Arrow.epsilon: rank 1" | tips -> List.map (fun tip -> I tip) tips -let epsilon_bar = function +let epsilon0_bar = function | [] -> invalid_arg "Arrow.epsilon_bar: rank 0" | [_] -> invalid_arg "Arrow.epsilon_bar: rank 1" | tails -> List.map (fun tail -> I tail) tails (* Composite Arrows. *) let rec chain = function | [] -> [] | [a] -> [a => a] | [a; b] -> [a => b] | a :: (b :: _ as rest) -> (a => b) :: chain rest let rec cycle' a = function | [] -> [a => a] | [b] -> [b => a] | b :: (c :: _ as rest) -> (b => c) :: cycle' a rest let cycle = function | [] -> [] | a :: _ as a_list -> cycle' a a_list +(* \thocwmodulesubsection{Functions for Tangara} + \label{sec:tangara-support} *) + +type matching_adjoint_arrows = Tee | Reflex + +let rec adjoint_arrows a tails tips reflex seen = function + | [] -> (tails, tips, reflex, List.rev seen) + | arrow :: arrows -> + begin match arrow with + | Arrow (I tail, I tip) -> + if tail = a then + if tip = a then + adjoint_arrows a tails tips (succ reflex) seen arrows + else + adjoint_arrows a tails (I tip :: tips) reflex seen arrows + else + if tip = a then + adjoint_arrows a (I tail :: tails) tips reflex seen arrows + else + adjoint_arrows a tails tips reflex (arrow :: seen) arrows + | Arrow (I tail, (M _ as tip)) -> + if tail = a then + adjoint_arrows a tails (tip :: tips) reflex seen arrows + else + adjoint_arrows a tails tips reflex (arrow :: seen) arrows + | Arrow ((M _ as tail), I tip) -> + if tip = a then + adjoint_arrows a (tail :: tails) tips reflex seen arrows + else + adjoint_arrows a tails tips reflex (arrow :: seen) arrows + | Arrow (M _, M _) | Ghost _ as arrow -> + adjoint_arrows a tails tips reflex (arrow :: seen) arrows + end + +let adjoint_arrows_opt a arrows = + match adjoint_arrows a [] [] 0 [] arrows with + | [], [], 0, _ -> None + | [tail], [tip], 0, other -> Some (Tee, single tail tip :: other) + | [], [], 1, other -> Some (Reflex, other) + | tails, tips, n, other -> + invalid_arg + (Printf.sprintf + "Arrow.adjoint_arrows_opt: bad match for %d in %s: tails=%s, tips=%s, reflex=%d, other=%s" + a (ThoList.to_string free_to_string arrows) + (ThoList.to_string endpoint_to_string tails) + (ThoList.to_string endpoint_to_string tips) + n (ThoList.to_string free_to_string other)) + +let replace_adjoint_eps tip a eps = + map_eps (function I b when a = b -> tip | tip -> tip) eps + +let replace_adjoint_eps_bar tail a eps_bar = + map_eps_bar (function I b when a = b -> tail | tail -> tail) eps_bar + +let adjoint_eps_opt a arrows eps = + match adjoint_arrows a [] [] 0 [] arrows with + | [], [], 0, _ -> None + | [tail], [tip], 0, other -> Some (Tee, single tail tip :: other, eps) + | [], [tip], 0, other -> + Some (Tee, other, NEList.map (replace_adjoint_eps tip a) eps) + | [], [], 1, other -> Some (Reflex, other, eps) + | tails, tips, n, other -> + invalid_arg + (Printf.sprintf + "Arrow.adjoint_eps_opt: bad match for %d in %s: tails=%s, tips=%s, reflex=%d, other=%s" + a (ThoList.to_string free_to_string arrows) + (ThoList.to_string endpoint_to_string tails) + (ThoList.to_string endpoint_to_string tips) + n (ThoList.to_string free_to_string other)) + + +let adjoint_eps_bar_opt a arrows eps_bar = + match adjoint_arrows a [] [] 0 [] arrows with + | [], [], 0, _ -> None + | [tail], [tip], 0, other -> Some (Tee, single tail tip :: other, eps_bar) + | [tail], [], 0, other -> + Some (Tee, other, NEList.map (replace_adjoint_eps_bar tail a) eps_bar) + | [], [], 1, other -> Some (Reflex, other, eps_bar) + | tails, tips, n, other -> + invalid_arg + (Printf.sprintf + "Arrow.adjoint_eps_bar_opt: bad match for %d in %s: tails=%s, tips=%s, reflex=%d, other=%s" + a (ThoList.to_string free_to_string arrows) + (ThoList.to_string endpoint_to_string tails) + (ThoList.to_string endpoint_to_string tips) + n (ThoList.to_string free_to_string other)) + module Test = struct open OUnit let suite_chain = "chain" >::: [ "[]" >:: (fun () -> assert_equal [] (chain [])); "[1]" >:: (fun () -> assert_equal [1 => 1] (chain [1])); "[1;2]" >:: (fun () -> assert_equal [1 => 2] (chain [1; 2])); "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3] (chain [1; 2; 3])); "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4] (chain [1; 2; 3; 4])) ] let suite_cycle = "cycle" >::: [ "[]" >:: (fun () -> assert_equal [] (cycle [])); "[1]" >:: (fun () -> assert_equal [1 => 1] (cycle [1])); "[1;2]" >:: (fun () -> assert_equal [1 => 2; 2 => 1] (cycle [1; 2])); "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 1] (cycle [1; 2; 3])); "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4; 4 => 1] (cycle [1; 2; 3; 4])) ] let suite_take = "take" >::: [ "1 []" >:: (fun () -> assert_equal None (take_first_match_opt 1 [])); "1 [1]" >:: (fun () -> assert_equal (Some ([], [])) (take_first_match_opt 1 [1])); "1 [2;3;4]" >:: (fun () -> assert_equal None (take_first_match_opt 1 [2;3;4])); "1 [1;2;3]" >:: (fun () -> assert_equal (Some ([], [2;3])) (take_first_match_opt 1 [1;2;3])); "2 [1;2;3]" >:: (fun () -> assert_equal (Some ([1], [3])) (take_first_match_opt 2 [1;2;3])); "3 [1;2;3]" >:: (fun () -> assert_equal (Some ([2;1], [])) (take_first_match_opt 3 [1;2;3])) ] let suite_take2 = "take2" >::: [ "[] []" >:: (fun () -> assert_equal None (take_first_matching_pair_opt [] [])); "[] [1;2;3]" >:: (fun () -> assert_equal None (take_first_matching_pair_opt [] [1;2;3])); "[1] [2;3;4]" >:: (fun () -> assert_equal None (take_first_matching_pair_opt [1] [2;3;4])); "[2;3;4] [1]" >:: (fun () -> assert_equal None (take_first_matching_pair_opt [2;3;4] [1])); "[1;2;3] [4;5;6;7]" >:: (fun () -> assert_equal None (take_first_matching_pair_opt [1;2;3] [4;5;6;7])); "[1] [1;2;3]" >:: (fun () -> assert_equal (Some (([],[]), ([],[2;3]))) (take_first_matching_pair_opt [1] [1;2;3])); "[1;2;3] [1;20;30]" >:: (fun () -> assert_equal (Some (([],[2;3]), ([],[20;30]))) (take_first_matching_pair_opt [1;2;3] [1;20;30])); "[1;2;3;4;5;6] [10;20;4;30;40]" >:: (fun () -> assert_equal (Some (([3;2;1],[5;6]), ([20;10],[30;40]))) (take_first_matching_pair_opt [1;2;3;4;5;6] [10;20;4;30;40])) ] let suite_replace = "replace" >::: [ "1 10 []" >:: (fun () -> assert_equal None (replace_first_opt 1 2 [])); "1 10 [1]" >:: (fun () -> assert_equal (Some [10]) (replace_first_opt 1 10 [1])); "1 [2;3;4]" >:: (fun () -> assert_equal None (replace_first_opt 1 10 [2;3;4])); "1 [1;2;3]" >:: (fun () -> assert_equal (Some [10;2;3]) (replace_first_opt 1 10 [1;2;3])); "2 [1;2;3]" >:: (fun () -> assert_equal (Some [1;10;3]) (replace_first_opt 2 10 [1;2;3])); "3 [1;2;3]" >:: (fun () -> assert_equal (Some [1;2;10]) (replace_first_opt 3 10 [1;2;3])) ] let suite = "Arrow" >::: [suite_chain; suite_cycle; suite_take; suite_take2; suite_replace] let suite_long = "Arrow long" >::: [] end let pp_free fmt f = Format.fprintf fmt "%s" (free_to_string f) let pp_factor fmt f = Format.fprintf fmt "%s" (factor_to_string f) Index: trunk/omega/src/algebra.ml =================================================================== --- trunk/omega/src/algebra.ml (revision 8919) +++ trunk/omega/src/algebra.ml (revision 8920) @@ -1,848 +1,960 @@ (* algebra.ml -- Copyright (C) 1999-2024 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 suite : OUnit.test end (* The terms will be small and there's no need to be fancy and/or efficient. It's more important to have a unique representation. *) module PM = Pmap.List (* \thocwmodulesection{Coefficients} *) module type CRing = sig type t val null : t val is_null : t -> bool val add : t -> t -> t val neg : t -> t val sub : t -> t -> t val unit : t val is_unit : t -> bool val mul : t -> t -> t val equal : t -> t -> bool end module type Rational = sig include CRing val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int val int : int -> t val fraction : int -> t val compare : t -> t -> int val to_string : t -> string val pp : Format.formatter -> t -> unit module Test : Test end (* \thocwmodulesection{Naive Rational Arithmetic} *) (* \begin{dubious} This \emph{is} dangerous and will overflow even for simple applications. The production code will have to be linked to a library for large integer arithmetic. \end{dubious} *) (* Anyway, here's Euclid's algorithm: *) let rec gcd i1 i2 = if i2 = 0 then abs i1 else gcd i2 (i1 mod i2) -let lcm i1 i2 = (i1 / gcd i1 i2) * i2 +let _lcm i1 i2 = (i1 / gcd i1 i2) * i2 let abs_int = abs module Small_Rational : Rational = struct type t = int * int let is_null (n, _) = (n = 0) let is_unit (n, d) = (n <> 0) && (n = d) let is_positive (n, d) = n * d > 0 let is_negative (n, d) = n * d < 0 let is_integer (n, d) = (gcd n d = d) let null = (0, 1) let unit = (1, 1) let make n d = let c = gcd n d in (n / c, d / c) let abs (n, d) = (abs n, abs d) let inv (n, d) = (d, n) let mul (n1, d1) (n2, d2) = make (n1 * n2) (d1 * d2) let div q1 q2 = mul q1 (inv q2) let add (n1, d1) (n2, d2) = make (n1 * d2 + n2 * d1) (d1 * d2) let sub (n1, d1) (n2, d2) = make (n1 * d2 - n2 * d1) (d1 * d2) let neg (n, d) = (- n, d) let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let sum qs = List.fold_right add qs null let to_ratio (n, d) = if d < 0 then (-n, -d) else (n, d) let to_float (n, d) = float n /. float d let to_string (n, d) = if abs_int d = 1 then Printf.sprintf "%d" (d * n) else let n, d = to_ratio (n, d) in Printf.sprintf "(%d/%d)" n d let pp fmt qc = Format.fprintf fmt "%s" (to_string qc) let to_integer (n, d) = if is_integer (n, d) then n else invalid_arg "Algebra.Small_Rational.to_integer" let int n = make n 1 let fraction n = make 1 n let compare q1 q2 = let n1, d1 = to_ratio q1 and n2, d2 = to_ratio q2 in compare (d2 * n1) (d1 * n2) let equal (n1, d1) (n2, d2) = d2 * n1 = d1 * n2 module Test = struct open OUnit let assert_equal_rational z1 z2 = assert_equal ~printer:to_string ~cmp:equal z1 z2 let suite_mul = "mul" >::: [ "1*1=1" >:: (fun () -> assert_equal_rational (mul unit unit) unit) ] let suite = "Algebra.Small_Rational" >::: [suite_mul] end end module Q = Small_Rational (* \thocwmodulesection{Rational Complex Numbers} *) module type QComplex = sig include CRing type q val make : q -> q -> t val re : t -> q val im : t -> q val conj : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val is_real : t -> bool val rational : q -> t val int : int -> t val fraction : int -> t val imag : int -> t val compare : t -> t -> int val to_string : t -> string val pp : Format.formatter -> t -> unit module Test : Test end module QComplex (Q : Rational) : QComplex with type q = Q.t = struct type q = Q.t type t = { re : q; im : q } let make re im = { re; im } let null = { re = Q.null; im = Q.null } let unit = { re = Q.unit; im = Q.null } let re z = z.re let im z = z.im let conj z = { re = z.re; im = Q.neg z.im } let neg z = { re = Q.neg z.re; im = Q.neg z.im } let add z1 z2 = { re = Q.add z1.re z2.re; im = Q.add z1.im z2.im } let sub z1 z2 = { re = Q.sub z1.re z2.re; im = Q.sub z1.im z2.im } let sum qs = List.fold_right add qs null (* Save one multiplication with respect to the standard formula \begin{equation} (x+iy)(u+iv) = \lbrack xu-yv\rbrack + i\lbrack(x+u)(y+v)-xu-yv\rbrack\, \end{equation} at the expense of one addition and two subtractions. *) let mul z1 z2 = let re12 = Q.mul z1.re z2.re and im12 = Q.mul z1.im z2.im in { re = Q.sub re12 im12; im = Q.sub (Q.sub (Q.mul (Q.add z1.re z1.im) (Q.add z2.re z2.im)) re12) im12 } let inv z = let modulus = Q.add (Q.mul z.re z.re) (Q.mul z.im z.im) in { re = Q.div z.re modulus; im = Q.div (Q.neg z.im) modulus } let div n d = mul (inv d) n let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let is_real q = Q.is_null q.im let test_real test q = is_real q && test q.re let is_null = test_real Q.is_null let is_unit = test_real Q.is_unit let is_positive = test_real Q.is_positive let is_negative = test_real Q.is_negative let is_integer = test_real Q.is_integer let rational q = make q Q.null let int n = rational (Q.int n) let fraction n = rational (Q.fraction n) let imag n = make Q.null (Q.int n) let compare { re = re1; im = im1 } { re = re2; im = im2 } = let c = compare re1 re2 in if c <> 0 then c else compare im1 im2 let equal c1 c2 = compare c1 c2 = 0 - let q_to_string q = - (if Q.is_negative q then "-" else " ") ^ Q.to_string (Q.abs q) + let q_to_string ?(leading_plus=false) q = + (if Q.is_positive q then + if leading_plus then + "+" + else + "" + else + "-") ^ Q.to_string (Q.abs q) + + let im_to_string ?(leading_plus=false) im = + if Q.is_unit im then + if leading_plus then + "+I" + else + "I" + else if Q.is_unit (Q.neg im) then + "-I" + else + q_to_string ~leading_plus im ^ "*I" let to_string z = if Q.is_null z.im then q_to_string z.re else if Q.is_null z.re then - if Q.is_unit z.im then - " I" - else if Q.is_unit (Q.neg z.im) then - "-I" - else - q_to_string z.im ^ "*I" + im_to_string z.im else - Printf.sprintf "(%s%s*I)" (Q.to_string z.re) (q_to_string z.im) + Printf.sprintf "(%s%s)" (Q.to_string z.re) (im_to_string ~leading_plus:true z.im) let pp fmt qc = Format.fprintf fmt "%s" (to_string qc) module Test = struct open OUnit let assert_equal_complex z1 z2 = assert_equal ~printer:to_string ~cmp:equal z1 z2 let suite_mul = "mul" >::: [ "1*1=1" >:: (fun () -> assert_equal_complex (mul unit unit) unit) ] let suite = "Algebra.QComplex" >::: [suite_mul] end end module QC = QComplex(Q) (* \thocwmodulesection{Laurent Polynomials} *) module type Laurent = sig include CRing type c val atom : c -> int -> t val const : c -> t val scale : c -> t -> t val sum : t list -> t val product : t list -> t val pow : t -> int -> t val log : t -> (c * int) option val to_list : t -> (c * int) list val eval : c -> t -> c val compare : t -> t -> int val rationals : (Q.t * int) list -> t val ints : (int * int) list -> t val rational : Q.t -> t val int : int -> t val fraction : int -> t val imag : int -> t val nc : int -> t val over_nc : int -> t + val prefactor : t list -> c val to_string : string -> t -> string val pp : Format.formatter -> t -> unit module Test : Test end module Laurent : Laurent with type c = QC.t = struct + (* For the function [to_string] below, it would be convenient to order + in decreasing order of powers, but [to_string] is slow anyway, + so we can simply revert the result of [IMap.bindings]. *) module IMap = Map.Make(Int) type c = QC.t let qc_minus_one = QC.neg QC.unit type t = c IMap.t let null = IMap.empty let is_null l = IMap.for_all (fun _ -> QC.is_null) l let atom qc n = if qc = QC.null then null else IMap.singleton n qc let const z = atom z 0 let unit = const QC.unit let is_unit l = IMap.equal QC.equal l unit let add1 n qc l = try let qc' = QC.add qc (IMap.find n l) in if qc' = QC.null then IMap.remove n l else IMap.add n qc' l with | Not_found -> IMap.add n qc l let add l1 l2 = IMap.fold add1 l1 l2 let sum = function | [] -> null | [l] -> l | l :: l_list -> List.fold_left add l l_list let scale qc l = IMap.map (QC.mul qc) l let neg l = IMap.map QC.neg l let sub l1 l2 = add l1 (neg l2) (* cf.~[Product.fold2_rev] *) let fold2 f l1 l2 acc = IMap.fold (fun n1 qc1 acc1 -> IMap.fold (fun n2 qc2 acc2 -> f n1 qc1 n2 qc2 acc2) l2 acc1) l1 acc let mul l1 l2 = fold2 (fun n1 qc1 n2 qc2 acc -> add1 (n1 + n2) (QC.mul qc1 qc2) acc) l1 l2 null let product = function | [] -> unit | [l] -> l | l :: l_list -> List.fold_left mul l l_list let poly_pow multiply one inverse x n = let rec pow' i x' acc = if i < 1 then acc else pow' (pred i) x' (multiply x' acc) in if n < 0 then let x' = inverse x in pow' (pred (-n)) x' x' else if n = 0 then one else pow' (pred n) x x let qc_pow z n = poly_pow QC.mul QC.unit QC.inv z n let pow l n = poly_pow mul unit (fun _ -> invalid_arg "Algebra.Laurent.pow") l n let log l = match IMap.bindings l with | [] -> Some (QC.null, 0) | [(p, c)] -> Some (c, p) | _ -> None let to_list l = - List.map (fun (p, c) -> (c, p)) (IMap.bindings l) + List.map (fun (p, c) -> (c, p)) (List.rev (IMap.bindings l)) + + let q_compare_abs q1 q2 = + Q.compare (Q.abs q1) (Q.abs q2) - let q_to_string q = - (if Q.is_positive q then "+" else "-") ^ Q.to_string (Q.abs q) + let closer_to_null c1 c2 = + let r1 = QC.re c1 and r2 = QC.re c2 in + if Q.is_null r1 then + if Q.is_null r2 then + if q_compare_abs (QC.im c1) (QC.im c2) <= 0 then + c1 + else + c2 + else + c2 + else + if Q.is_null r2 then + c1 + else if q_compare_abs r1 r2 <= 0 then + c1 + else + c2 + + let transfer_sign c1 c2 = + if Q.compare (QC.re c1) Q.null = Q.compare (QC.re c2) Q.null then + c2 + else + QC.neg c2 + + let prefactor1 l = + match IMap.max_binding_opt l with + | None -> QC.unit + | Some (_, c1) -> transfer_sign c1 (IMap.fold (fun _ -> closer_to_null) l c1) + + let prefactor = function + | [] -> QC.unit + | l1 :: ls -> + List.fold_left + (fun acc l -> closer_to_null acc (prefactor1 l)) + (prefactor1 l1) ls + + let q_to_string ?(leading_plus=true) q = + (if Q.is_positive q then + if leading_plus then + "+" + else + "" + else + "-") ^ Q.to_string (Q.abs q) - let qc_to_string z = + let qc_to_string ?(leading_plus=true) z = let r = QC.re z and i = QC.im z in if Q.is_null i then - q_to_string r + q_to_string ~leading_plus r else if Q.is_null r then if Q.is_unit i then - "+I" + if leading_plus then + "+I" + else + "I" else if Q.is_unit (Q.neg i) then "-I" else q_to_string i ^ "*I" else Printf.sprintf "(%s%s*I)" (Q.to_string r) (q_to_string i) - let to_string1 name (n, qc) = + let to_string1 ?(leading_plus=true) name (n, qc) = if n = 0 then - qc_to_string qc + qc_to_string ~leading_plus qc else if n = 1 then if QC.is_unit qc then - name + if leading_plus then + "+" ^ name + else + name else if qc = qc_minus_one then "-" ^ name else - Printf.sprintf "%s*%s" (qc_to_string qc) name + Printf.sprintf "%s*%s" (qc_to_string ~leading_plus qc) name else if n = -1 then - Printf.sprintf "%s/%s" (qc_to_string qc) name + Printf.sprintf "%s/%s" (qc_to_string ~leading_plus qc) name else if n > 1 then if QC.is_unit qc then - Printf.sprintf "%s^%d" name n + Printf.sprintf "%s%s^%d" (if leading_plus then "+" else "") name n else if qc = qc_minus_one then Printf.sprintf "-%s^%d" name n else - Printf.sprintf "%s*%s^%d" (qc_to_string qc) name n + Printf.sprintf "%s*%s^%d" (qc_to_string ~leading_plus qc) name n else - Printf.sprintf "%s/%s^%d" (qc_to_string qc) name (-n) + Printf.sprintf "%s/%s^%d" (qc_to_string ~leading_plus qc) name (-n) let to_string name l = - match IMap.bindings l with + match List.rev (IMap.bindings l) with | [] -> "0" - | l -> String.concat "" (List.map (to_string1 name) l) + | t::l -> to_string1 ~leading_plus:false name t ^ String.concat "" (List.map (to_string1 name) l) let pp fmt l = Format.fprintf fmt "%s" (to_string "N" l) let eval v l = IMap.fold (fun n qc acc -> QC.add (QC.mul qc (qc_pow v n)) acc) l QC.null let compare l1 l2 = IMap.compare Stdlib.compare l1 l2 let equal l1 l2 = compare l1 l2 = 0 (* Laurent polynomials: *) let of_pairs f pairs = sum (List.map (fun (coeff, power) -> atom (f coeff) power) pairs) let rationals = of_pairs QC.rational let ints = of_pairs QC.int let rational q = rationals [(q, 0)] let int n = ints [(n, 0)] let fraction n = const (QC.fraction n) let imag n = const (QC.imag n) let nc n = ints [(n, 1)] let over_nc n = ints [(n, -1)] module Test = struct open OUnit + let assert_equal_string s l = + assert_equal ~printer:Fun.id s (to_string "N" l) + let assert_equal_laurent l1 l2 = assert_equal ~printer:(to_string "N") ~cmp:equal l1 l2 + let assert_equal_coeff c1 c2 = + assert_equal ~printer:QC.to_string ~cmp:QC.equal c1 c2 + + let suite_to_string = + "to_string" >::: + + [ "N" >:: (fun () -> assert_equal_string "N" (ints [(1,1)])); + "-N" >:: (fun () -> assert_equal_string "-N" (ints [(-1,1)])); + "2N" >:: (fun () -> assert_equal_string "2*N" (ints [(2,1)])); + "-2N" >:: (fun () -> assert_equal_string "-2*N" (ints [(-2,1)])); + "1" >:: (fun () -> assert_equal_string "1" (ints [(1,0)])); + "-1" >:: (fun () -> assert_equal_string "-1" (ints [(-1,0)])); + "2" >:: (fun () -> assert_equal_string "2" (ints [(2,0)])); + "-2" >:: (fun () -> assert_equal_string "-2" (ints [(-2,0)])); + "1/N" >:: (fun () -> assert_equal_string "1/N" (ints [(1,-1)])); + "-1/N" >:: (fun () -> assert_equal_string "-1/N" (ints [(-1,-1)])); + "2/N" >:: (fun () -> assert_equal_string "2/N" (ints [(2,-1)])); + "-2/N" >:: (fun () -> assert_equal_string "-2/N" (ints [(-2,-1)])); + "N^2+N+1" >:: (fun () -> assert_equal_string "N^2+N+1" (ints [(1,2); (1,1); (1,0)])); + "N^2-N+1" >:: (fun () -> assert_equal_string "N^2-N+1" (ints [(1,2); (-1,1); (1,0)])); + "N^2+2N+1" >:: (fun () -> assert_equal_string "N^2+2*N+1" (ints [(1,2); (2,1); (1,0)])); + "N^2-2N+1" >:: (fun () -> assert_equal_string "N^2-2*N+1" (ints [(1,2); (-2,1); (1,0)])); + "N^2+N-1" >:: (fun () -> assert_equal_string "N^2+N-1" (ints [(1,2); (1,1); (-1,0)])); + "N^2-N-1" >:: (fun () -> assert_equal_string "N^2-N-1" (ints [(1,2); (-1,1); (-1,0)])); + "N^2+2N-1" >:: (fun () -> assert_equal_string "N^2+2*N-1" (ints [(1,2); (2,1); (-1,0)])); + "N^2-2N-1" >:: (fun () -> assert_equal_string "N^2-2*N-1" (ints [(1,2); (-2,1); (-1,0)])) ] + let suite_mul = "mul" >::: [ "(1+N)(1-N)=1-N^2" >:: (fun () -> assert_equal_laurent (sum [unit; atom (QC.neg QC.unit) 2]) (product [sum [unit; atom QC.unit 1]; sum [unit; atom (QC.neg QC.unit) 1]])); "(1+N)(1-1/N)=N-1/N" >:: (fun () -> assert_equal_laurent (sum [atom QC.unit 1; atom (QC.neg QC.unit) (-1)]) (product [sum [unit; atom QC.unit 1]; sum [unit; atom (QC.neg QC.unit) (-1)]])); ] + let suite_prefactor = + "prefactor" >::: + + [ "0" >:: (fun () -> assert_equal_coeff QC.unit (prefactor [])); + "1" >:: (fun () -> assert_equal_coeff QC.unit (prefactor [unit])); + "2" >:: (fun () -> assert_equal_coeff (QC.int 2 ) (prefactor [int 2])); + "1/2" >:: (fun () -> assert_equal_coeff (QC.fraction 2) (prefactor [fraction 2])); + + "1/2-2N" >:: + (fun () -> assert_equal_coeff + (QC.neg (QC.fraction 2)) + (prefactor [sum [fraction 2; nc (-2)]])) ] + let suite = "Algebra.Laurent" >::: - [suite_mul] + [suite_to_string; + suite_mul; + suite_prefactor] end end (* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *) (* The tensor algebra will be spanned by an abelian monoid: *) module type Term = sig type 'a t val unit : unit -> 'a t val is_unit : 'a t -> bool val atom : 'a -> 'a t val power : 'a t -> int -> 'a t val mul : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list val product : 'a t list -> 'a t val atoms : 'a t -> 'a list end module type Ring = sig module C : Rational type 'a t val null : unit -> 'a t val unit : unit -> 'a t val is_null : 'a t -> bool val is_unit : 'a t -> bool val atom : 'a -> 'a t val scale : C.t -> 'a t -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val neg : 'a t -> 'a t val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *) val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *) val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list val sum : 'a t list -> 'a t val product : 'a t list -> 'a t val atoms : 'a t -> 'a list val to_string : ('a -> string) -> 'a t -> string end module type Linear = sig module C : Ring type ('a, 'c) t val null : unit -> ('a, 'c) t val atom : 'a -> ('a, 'c) t val singleton : 'c C.t -> 'a -> ('a, 'c) t val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t val sum : ('a, 'c) t list -> ('a, 'c) t val atoms : ('a, 'c) t -> 'a list * 'c list val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string end module Term : Term = struct module M = PM type 'a t = ('a, int) M.t let unit () = M.empty let is_unit = M.is_empty let atom f = M.singleton f 1 let power x p = M.map (( * ) p) x let insert1 binop f p term = let p' = binop (try M.find compare f term with Not_found -> 0) p in if p' = 0 then M.remove compare f term else M.add compare f p' term let mul1 f p term = insert1 (+) f p term let mul x y = M.fold mul1 x y let map f term = M.fold (fun t -> mul1 (f t)) term M.empty let to_string fmt term = String.concat "*" (M.fold (fun f p acc -> (if p = 0 then "1" else if p = 1 then fmt f else "[" ^ fmt f ^ "]^" ^ string_of_int p) :: acc) term []) let derive derive1 x = M.fold (fun f p dx -> if p <> 0 then match derive1 f with | Some df -> (df, p, mul1 f (pred p) (M.remove compare f x)) :: dx | None -> dx else dx) x [] let product factors = List.fold_left mul (unit ()) factors let atoms t = List.map fst (PM.elements t) end module Make_Ring (C : Rational) (T : Term) : Ring = struct module C = C let one = C.unit module M = PM type 'a t = ('a T.t, C.t) M.t let null () = M.empty let is_null = M.is_empty let power t p = M.singleton t p let unit () = power (T.unit ()) one let is_unit t = unit () = t (* \begin{dubious} The following should be correct too, but produces to many false positives instead! What's going on? \end{dubious} *) - let broken__is_unit t = + 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 = + let _neg x = sub (null ()) x let neg x = scale (C.neg C.unit) x (* Multiply the [derivatives] by [c] and add the result to [dx]. *) let add_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> add (mul df (power dt_t (C.mul c (C.make dt_c 1)))) acc) dx derivatives let derive_inner derive1 x = M.fold (fun t -> add_derivatives (T.derive (fun f -> Some (derive1 f)) t)) x (null ()) let derive_inner' derive1 x = M.fold (fun t -> add_derivatives (T.derive derive1 t)) x (null ()) let collect_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> (df, power dt_t (C.mul c (C.make dt_c 1))) :: acc) dx derivatives let derive_outer derive1 x = M.fold (fun t -> collect_derivatives (T.derive derive1 t)) x [] let sum terms = List.fold_left add (null ()) terms let product factors = List.fold_left mul (unit ()) factors let atoms t = ThoList.uniq (List.sort compare (ThoList.flatmap (fun (t, _) -> T.atoms t) (PM.elements t))) let to_string fmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then T.to_string fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ T.to_string fmt t ^ ")") :: acc else (C.to_string c ^ "*[" ^ T.to_string fmt t ^ "]") :: acc) sum []) ^ ")" end module Make_Linear (C : Ring) : Linear with module C = C = struct module C = C module M = PM type ('a, 'c) t = ('a, 'c C.t) M.t let null () = M.empty let is_null = M.is_empty let atom a = M.singleton a (C.unit ()) let singleton c a = M.singleton a c let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null ()) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x let map f t = M.fold (fun a c -> add (f a c)) t M.empty let sum terms = List.fold_left add (null ()) terms let linear terms = List.fold_left (fun acc (a, c) -> add (scale c a) acc) (null ()) terms let partial derive t = let d t' = let dt' = derive t' in if is_null dt' then None else Some dt' in linear (C.derive_outer d t) let atoms t = let a, c = List.split (PM.elements t) in (a, ThoList.uniq (List.sort compare (ThoList.flatmap C.atoms c))) let to_string fmt cfmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ fmt t ^ ")") :: acc else (C.to_string cfmt c ^ "*" ^ fmt t) :: acc) sum []) ^ ")" end Index: trunk/omega/src/combinatorics.mli =================================================================== --- trunk/omega/src/combinatorics.mli (revision 8919) +++ trunk/omega/src/combinatorics.mli (revision 8920) @@ -1,172 +1,193 @@ (* combinatorics.mli -- Copyright (C) 1999-2024 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 val permute_cyclic_signed : 'a seq -> (int * '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{Subsets} *) + +(* The function $A\mapsto2^A$, where the set and the subsets are represented + as lists of elements in unspecified sequence. In order to be able to optimize + for stack space, we make no guarantee about ordering of the lists. *) +val subsets : 'a list -> 'a list list + +(* If we write $f_b:A\to A: a\mapsto f(a,b)$, then the elements of the resulting list + are $(f_{b_1}\circ f_{b_2}\circ\cdots\circ f_{b_n})(a)$ for all + subsets $\{b_1,b_2,\ldots,b_n\} \in 2^B$. + In order to be able to optimize for stack space, we make again no + guarantee about ordering of the lists. Therefore the function only + makes sense for~$\forall b,b': f_{b}\circ f_{b'}=f_{b'}\circ f_{b}$. *) +val subfolds : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a list + +(* We could even try to generalize this to a function of the type + [('c -> 'a -> 'c) -> ('a -> 'b -> 'a) -> 'a -> 'b list -> 'c -> 'c], + in order the replace ['a list] by a more general type ['c] for the + result. But at the moment, there doesn't appear to be a pressing need + for this and the interface is then too complex. *) + (* \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/src/UFO_targets.ml =================================================================== --- trunk/omega/src/UFO_targets.ml (revision 8919) +++ trunk/omega/src/UFO_targets.ml (revision 8920) @@ -1,1548 +1,1548 @@ (* 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. *) (* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) (* \begin{dubious} O'Caml before 4.02 had a module typing bug that forced us to put these definitions outside of [Lorentz_Fusion]. Since then, they might have appeared in more places. Investigate, if it is worthwhile to encapsulate them again. \end{dubious} *) module Q = Algebra.Q module QC = Algebra.QC module type T = sig (* [lorentz formatter name spins v] writes a representation of the Lorentz structure [v] of particles with the Lorentz representations [spins] as a (Fortran) function [name] to [formatter]. *) val lorentz : Format_Fortran.formatter -> string -> Coupling.lorentz array -> UFO_Lorentz.t -> unit val propagator : Format_Fortran.formatter -> string -> string -> string list -> Coupling.lorentz * Coupling.lorentz -> UFO_Lorentz.t -> UFO_Lorentz.t -> unit val fusion_name : string -> Permutation.Default.t -> Coupling.fermion_lines -> string val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val eps4_g4_g44_decl : Format_Fortran.formatter -> unit -> unit val eps4_g4_g44_init : Format_Fortran.formatter -> unit -> unit val inner_product_functions : Format_Fortran.formatter -> unit -> unit module type Test = sig val suite : OUnit.test end module Test : Test end module Fortran : T = struct open Format_Fortran let pp_divide ?(indent=0) ff () = fprintf ff "%*s! %s" indent "" (String.make (70 - indent) '-'); pp_newline ff () let conjugate = function | Coupling.Spinor -> Coupling.ConjSpinor | Coupling.ConjSpinor -> Coupling.Spinor | r -> r let spin_mnemonic = function | Coupling.Scalar -> "phi" | Coupling.Spinor -> "psi" | Coupling.ConjSpinor -> "psibar" | Coupling.Majorana -> "chi" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "a" | Coupling.Massive_Vector -> "v" | Coupling.Vectorspinor -> "grav" (* itino *) | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "h" - | Coupling.BRS l -> + | Coupling.BRS _ -> invalid_arg "UFO_targets: BRS" let fortran_type = function | Coupling.Scalar -> "complex(kind=default)" | Coupling.Spinor -> "type(spinor)" | Coupling.ConjSpinor -> "type(conjspinor)" | Coupling.Majorana -> "type(bispinor)" | Coupling.Maj_Ghost -> invalid_arg "UFO_targets: Maj_Ghost" | Coupling.Vector -> "type(vector)" | Coupling.Massive_Vector -> "type(vector)" | Coupling.Vectorspinor -> "type(vectorspinor)" | Coupling.Tensor_1 -> invalid_arg "UFO_targets: Tensor_1" | Coupling.Tensor_2 -> "type(tensor)" - | Coupling.BRS l -> + | Coupling.BRS _ -> invalid_arg "UFO_targets: BRS" (* The \texttt{omegalib} separates time from space. Maybe not a good idea after all. Mend it locally \ldots *) type wf = { pos : int; spin : Coupling.lorentz; name : string; local_array : string option; momentum : string; momentum_array : string; fortran_type : string } let wf_table spins = Array.mapi (fun i s -> let spin = if i = 0 then conjugate s else s in let pos = succ i in let i = string_of_int pos in let name = spin_mnemonic s ^ i in let local_array = begin match spin with | Coupling.Vector | Coupling.Massive_Vector -> Some (name ^ "a") | _ -> None end in { pos; spin; name; local_array; momentum = "k" ^ i; momentum_array = "p" ^ i; fortran_type = fortran_type spin } ) spins module L = UFO_Lorentz (* Format rational ([Q.t]) and complex rational ([QC.t]) numbers as fortran values. *) let format_rational q = if Q.is_integer q then string_of_int (Q.to_integer q) else let n, d = Q.to_ratio q in Printf.sprintf "%d.0_default/%d" n d - let format_complex_rational cq = + let _format_complex_rational cq = let real = QC.re cq and imag = QC.im cq in if Q.is_null imag then begin if Q.is_negative real then "(" ^ format_rational real ^ ")" else format_rational real end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "(%d,%d)" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "cmplx(%s,%s,kind=default)" (format_rational real) (format_rational imag) (* Optimize the representation if used as a prefactor of a summand in a sum. *) - let format_rational_factor q = + 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.re cq and imag = QC.im cq in if Q.is_null imag then begin if Q.is_unit real then "+ " else if Q.is_unit (Q.neg real) then "- " else if Q.is_negative real then "- " ^ format_rational (Q.neg real) ^ "*" else "+ " ^ format_rational real ^ "*" end else if Q.is_integer real && Q.is_integer imag then Printf.sprintf "+ (%d,%d)*" (Q.to_integer real) (Q.to_integer imag) else Printf.sprintf "+ cmplx(%s,%s,kind=default)*" (format_rational real) (format_rational imag) (* Append a formatted list of indices to [name]. *) let append_indices name = function | [] -> name | indices -> name ^ "(" ^ String.concat "," (List.map string_of_int indices) ^ ")" (* Dirac string variables and their names. *) type dsv = | Ket of int | Bra of int | Braket of int let dsv_name = function | Ket n -> Printf.sprintf "ket%02d" n | Bra n -> Printf.sprintf "bra%02d" n | Braket n -> Printf.sprintf "bkt%02d" n let dirac_dimension dsv indices = let tail ilist = String.concat "," (List.map (fun _ -> "0:3") ilist) ^ ")" in match dsv, indices with | Braket _, [] -> "" | (Ket _ | Bra _), [] -> ", dimension(1:4)" | Braket _, indices -> ", dimension(" ^ tail indices | (Ket _ | Bra _), indices -> ", dimension(1:4," ^ tail indices (* Write Fortran code to [decl] and [eval]: apply the Dirac matrix [gamma] with complex rational entries to the spinor [ket] from the left. [ket] must be the name of a scalar variable and cannot be an array element. The result is stored in [dsv_name (Ket n)] which can have additional [indices]. Return [Ket n] for further processing. *) let dirac_ket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_ket_to_fortran_eval ff n indices gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Ket n in for i = 0 to 3 do let name = append_indices (dsv_name dsv) (succ i :: indices) in printf " @[<%d>%s = 0" (String.length name + 4) name; for j = 0 to 3 do if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) ket.name (succ j) done; printf "@]"; nl () done; dsv (* The same as [dirac_ket_to_fortran], but apply the Dirac matrix [gamma] to [bra] from the right and return [Bra n]. *) let dirac_bra_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_bra_to_fortran_eval ff n indices bra gamma = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Bra n in for j = 0 to 3 do let name = append_indices (dsv_name dsv) (succ j :: indices) in printf " @[<%d>%s = 0" (String.length name + 4) name; for i = 0 to 3 do if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) done; printf "@]"; nl () done; dsv (* More of the same, but evaluating a spinor sandwich and returning [Braket n]. *) let dirac_braket_to_fortran_decl ff n indices = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in printf " @[<2>complex(kind=default)%s ::@ %s@]" (dirac_dimension dsv indices) (dsv_name dsv); nl () let dirac_braket_to_fortran_eval ff n indices bra gamma ket = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let dsv = Braket n in let name = append_indices (dsv_name dsv) indices in printf " @[<%d>%s = 0" (String.length name + 4) name; for i = 0 to 3 do for j = 0 to 3 do if not (QC.is_null gamma.(i).(j)) then printf "@ %s%s%%a(%d)*%s%%a(%d)" (format_complex_rational_factor gamma.(i).(j)) bra.name (succ i) ket.name (succ j) done done; printf "@]"; nl (); dsv (* Choose among the previous functions according to the position of [bra] and [ket] among the wavefunctions. If any is in the first position evaluate the spinor expression with the corresponding spinor removed, otherwise evaluate the spinir sandwich. *) let dirac_bra_or_ket_to_fortran_decl ff n indices bra ket = if bra = 1 then dirac_ket_to_fortran_decl ff n indices else if ket = 1 then dirac_bra_to_fortran_decl ff n indices else dirac_braket_to_fortran_decl ff n indices let dirac_bra_or_ket_to_fortran_eval ff n indices wfs bra gamma ket = if bra = 1 then dirac_ket_to_fortran_eval ff n indices gamma wfs.(pred ket) else if ket = 1 then dirac_bra_to_fortran_eval ff n indices wfs.(pred bra) gamma else dirac_braket_to_fortran_eval ff n indices wfs.(pred bra) gamma wfs.(pred ket) (* UFO summation indices are negative integers. Derive a valid Fortran variable name. *) let prefix_summation = "mu" let prefix_polarization = "nu" let index_spinor = "alpha" - let index_tensor = "nu" + let _index_tensor = "nu" let index_variable mu = if mu < 0 then Printf.sprintf "%s%d" prefix_summation (- mu) else if mu == 0 then prefix_polarization else Printf.sprintf "%s%d" prefix_polarization mu let format_indices indices = String.concat "," (List.map index_variable indices) - module IntPM = - Partial.Make (struct type t = int let compare = compare end) + module IntPM = Partial.Make (Int) type tensor = | DS of dsv | V of string | T of UFOx.Lorentz_Atom.vector | S of UFOx.Lorentz_Atom.scalar | Inv of UFOx.Lorentz_Atom.scalar (* Transform the Dirac strings if we have Majorana fermions involved, in order to implement the algorithm from JRR's thesis. NB: The following is for reference only, to better understand what JRR was doing\ldots *) (* If the vertex is (suppressing the Lorentz indices of~$\phi_2$ and~$\Gamma$) \begin{equation} \label{eq:FVF-Vertex} \bar\psi \Gamma\phi \psi = \Gamma_{\alpha\beta} \bar\psi_{\alpha} \phi \psi_{\beta} \end{equation} (cf.~[Coupling.FBF] in the hardcoded O'Mega models), then this is the version implemented by [fuse] below. *) - let tho_print_dirac_current f c wf1 wf2 fusion = + let _tho_print_dirac_current f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *) | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *) | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) | [1; 2] -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | [2; 1] -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | _ -> () (* The corresponding UFO [fuse] exchanges the arguments in the case of two fermions. This is the natural choice for cyclic permutations. *) - let tho_print_FBF_current f c wf1 wf2 fusion = + let _tho_print_FBF_current f c wf1 wf2 fusion = match fusion with | [3; 1] -> printf "f%sf_p120(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *) | [1; 3] -> printf "f%sf_p120(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *) | [2; 3] -> printf "f%sf_p012(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) | [3; 2] -> printf "f%sf_p012(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *) | [1; 2] -> printf "f%sf_p201(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | [2; 1] -> printf "f%sf_p201(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *) | _ -> () (* This is how JRR implemented (see subsection~\ref{sec:dirac-matrices-jrr}) the Dirac matrices that don't change sign under $C\Gamma^T C^{-1} = \Gamma$, i.\,e.~$\mathbf{1}$, $\gamma_5$ and~$\gamma_5\gamma_\mu$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current]) \begin{itemize} \item In the case of two fermions, the second wave function [wf2] is always put into the second slot, as described in JRR's thesis. \label{pg:JRR-Fusions} \item In the case of a boson and a fermion, there is no need for both ["f_%sf"] and ["f_f%s"], since the latter can be obtained by exchanging arguments. \end{itemize} *) - let jrr_print_majorana_current_S_P_A f c wf1 wf2 fusion = + let _jrr_print_majorana_current_S_P_A f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* This is how JRR implemented the Dirac matrices that do change sign under $C\Gamma^T C^{-1} = - \Gamma$, i.\,e.~$\gamma_\mu$ and~$\sigma_{\mu\nu}$ (see [Targets.Fortran_Majorana_Fermions.print_fermion_current_vector]). *) - let jrr_print_majorana_current_V f c wf1 wf2 fusion = + let _jrr_print_majorana_current_V f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff( %s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2 (* $-(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong -C\Gamma = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf( %s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf( %s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1 (* $-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2 (* $-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong -\Gamma = C\Gamma^T C^{-1} $ *) | _ -> () (* These two can be unified, if the \texttt{\_c} functions implement~$\Gamma'=C\Gamma^T C^{-1}$, but we \emph{must} make sure that the multiplication with~$C$ from the left happens \emph{after} the transformation~$\Gamma\to\Gamma'$. *) - let jrr_print_majorana_current f c wf1 wf2 fusion = + let _jrr_print_majorana_current f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma')_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong C\Gamma' = C\,C\Gamma^T C^{-1} $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_%sf_c(%s,%s,%s)" f c wf2 wf1 (* $\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | [2; 1] -> printf "f_%sf_c(%s,%s,%s)" f c wf1 wf2 (* $\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong \Gamma' = C\Gamma^T C^{-1} $ *) | _ -> () (* Since we may assume~$C^{-1}=-C=C^T$, this can be rewritten if the \texttt{\_c} functions implement \begin{equation} \Gamma^{\prime\,T} = \left(C\Gamma^T C^{-1}\right)^T = \left(C^{-1}\right)^T \Gamma C^T = C \Gamma C^{-1} \end{equation} instead. *) - let jrr_print_majorana_current_transposing f c wf1 wf2 fusion = + let _jrr_print_majorana_current_transposing f c wf1 wf2 fusion = match fusion with | [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong C\Gamma $ *) | [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf2 wf1 (* $(C\Gamma')^T_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong (C\Gamma')^T = - C\Gamma $ *) | [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f_f%s_c(%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [2; 1] -> printf "f_f%s_c(%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | _ -> () (* where we have used \begin{equation} (C\Gamma')^T = \Gamma^{\prime,T}C^T = C\Gamma C^{-1} C^T = C\Gamma C^{-1} (-C) = - C\Gamma\,. \end{equation} *) (* This puts the arguments in the same slots as [tho_print_dirac_current] above and can be implemented by [fuse], iff we inject the proper transformations in [dennerize] below. We notice that we do \emph{not} need the conjugated version for all combinations, but only for the case of two fermions. In the two cases of one column spinor~$\psi$, only the original version appears and in the two cases of one row spinor~$\bar\psi$, only the conjugated version appears. *) (* Before we continue, we must however generalize from the assumption~\eqref{eq:FVF-Vertex} that the fields in the vertex are always ordered as in~[Coupling.FBF]. First, even in this case the slots of the fermions must be exchanged to accomodate the cyclic permutations. Therefore we exchange the arguments of the [[1; 3]] and [[3; 1]] fusions. *) - let jrr_print_majorana_FBF f c wf1 wf2 fusion = + let _jrr_print_majorana_FBF f c wf1 wf2 fusion = match fusion with (* [fline = (3, 1)] *) | [3; 1] -> printf "f%sf_p120_c(%s,%s,%s)" f c wf1 wf2 (* $(C\Gamma')^T_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong (C\Gamma')^T = - C\Gamma $ *) | [1; 3] -> printf "f%sf_p120 (%s,%s,%s)" f c wf2 wf1 (* $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong C\Gamma $ *) | [2; 3] -> printf "f%sf_p012 (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [3; 2] -> printf "f%sf_p012 (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 2] -> printf "f%sf_p201 (%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [2; 1] -> printf "f%sf_p201 (%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | _ -> () (* The other two permutations: *) - let jrr_print_majorana_FFB f c wf1 wf2 fusion = + let _jrr_print_majorana_FFB f c wf1 wf2 fusion = match fusion with (* [fline = (1, 2)] *) | [3; 1] -> printf "ff%s_p120 (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [1; 3] -> printf "ff%s_p120 (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [2; 3] -> printf "ff%s_p012 (%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [3; 2] -> printf "ff%s_p012 (%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | [1; 2] -> printf "ff%s_p201 (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong C\Gamma $ *) | [2; 1] -> printf "ff%s_p201_c(%s,%s,%s)" f c wf2 wf1 (* $(C\Gamma')^T_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong (C\Gamma')^T = - C\Gamma $ *) | _ -> () - let jrr_print_majorana_BFF f c wf1 wf2 fusion = + let _jrr_print_majorana_BFF f c wf1 wf2 fusion = match fusion with (* [fline = (2, 3)] *) | [3; 1] -> printf "%sff_p120 (%s,%s,%s)" f c wf1 wf2 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1} $ *) | [1; 3] -> printf "%sff_p120 (%s,%s,%s)" f c wf2 wf1 (* $\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong \Gamma^{\prime\,T} = C\Gamma C^{-1}$ *) | [2; 3] -> printf "%sff_p012 (%s,%s,%s)" f c wf1 wf2 (* $ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong C\Gamma $ *) | [3; 2] -> printf "%sff_p012_c(%s,%s,%s)" f c wf2 wf1 (* $(C\Gamma')^T_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong (C\Gamma')^T = - C\Gamma $ *) | [1; 2] -> printf "%sff_p201 (%s,%s,%s)" f c wf1 wf2 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | [2; 1] -> printf "%sff_p201 (%s,%s,%s)" f c wf2 wf1 (* $ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong \Gamma $ *) | _ -> () (* In the model, the necessary information is provided as [Coupling.fermion_lines], encoded as [(right,left)] in the usual direction of the lines. E.\,g.~the case of~\eqref{eq:FVF-Vertex} is~[(3,1)]. Equivalent information is available as~[(ket, bra)] in [UFO_Lorentz.dirac_string]. *) let is_majorana = function | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false - let is_dirac = function + let _is_dirac = function | Coupling.Spinor | Coupling.ConjSpinor -> true | _ -> false let dennerize ~eval wfs atom = let printf fmt = fprintf eval fmt and nl = pp_newline eval in if is_majorana wfs.(pred atom.L.bra).spin || is_majorana wfs.(pred atom.L.ket).spin then if atom.L.bra = 1 then (* Fusing one or more bosons with a ket like fermion: $\chi \leftarrow \Gamma\chi$. *) (* Don't do anything, as per subsection~\ref{sec:dirac-matrices-jrr}. *) atom else if atom.L.ket = 1 then (* We fuse one or more bosons with a bra like fermion: $\bar\chi \leftarrow \bar\chi\Gamma$. *) (* $\Gamma\to C \Gamma C^{-1}$. *) begin let atom = L.conjugate atom in printf " ! conjugated for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else if not atom.L.conjugated then (* We fuse zero or more bosons with a sandwich of fermions. $\phi \leftarrow \bar\chi\gamma\chi$.*) (* Multiply by~$C$ from the left, as per subsection~\ref{sec:dirac-matrices-jrr}. *) begin let atom = L.cc_times atom in printf " ! multiplied by CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else (* Transposed: multiply by~$-C$ from the left. *) begin let atom = L.minus (L.cc_times atom) in printf " ! multiplied by -CC for Majorana"; nl (); printf " ! %s" (L.dirac_string_to_string atom); nl (); atom end else atom (* Write the [i]th Dirac string [ds] as Fortran code to [eval], including a shorthand representation as a comment. Return [ds] with [ds.L.atom] replaced by the dirac string variable, i,\,e.~[DS dsv] annotated with the internal and external indices. In addition write the declaration to [decl]. *) let dirac_string_to_fortran ~decl ~eval i wfs ds = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let bra = ds.L.atom.L.bra and ket = ds.L.atom.L.ket in pp_divide ~indent:4 eval (); printf " ! %s" (L.dirac_string_to_string ds.L.atom); nl (); let atom = dennerize ~eval wfs ds.L.atom in begin match ds.L.indices with | [] -> let gamma = L.dirac_string_to_matrix (fun _ -> 0) atom in dirac_bra_or_ket_to_fortran_decl decl i [] bra ket; let dsv = dirac_bra_or_ket_to_fortran_eval eval i [] wfs bra gamma ket in L.map_atom (fun _ -> DS dsv) ds | indices -> dirac_bra_or_ket_to_fortran_decl decl i indices bra ket; let combinations = Product.power (List.length indices) [0; 1; 2; 3] in let dsv = List.map (fun combination -> let substitution = IntPM.of_lists indices combination in let substitute = IntPM.apply substitution in let indices = List.map substitute indices in let gamma = L.dirac_string_to_matrix substitute atom in dirac_bra_or_ket_to_fortran_eval eval i indices wfs bra gamma ket) combinations in begin match ThoList.uniq (List.sort compare dsv) with | [dsv] -> L.map_atom (fun _ -> DS dsv) ds | _ -> failwith "dirac_string_to_fortran: impossible" end end (* Write the Dirac strings in the list [ds_list] as Fortran code to [eval], including shorthand representations as comments. Return the list of variables and corresponding indices to be contracted. *) let dirac_strings_to_fortran ~decl ~eval wfs last ds_list = List.fold_left (fun (i, acc) ds -> let i = succ i in (i, dirac_string_to_fortran ~decl ~eval i wfs ds :: acc)) (last, []) ds_list (* Perform a nested sum of terms, as printed by [print_term] (which takes the number of spaces to indent as only argument) of the cartesian product of [indices] running from 0 to 3. *) let nested_sums ~decl ~eval initial_indent indices print_term = + ignore decl; let rec nested_sums' indent = function | [] -> print_term indent | index :: indices -> let var = index_variable index in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" var; pp_newline eval (); nested_sums' (indent + 2) indices; pp_newline eval (); fprintf eval "%*s@[<2>end do@]" indent "" in nested_sums' (initial_indent + 2) indices (* Polarization indices also need to be summed over, but they appear only once. *) let indices_of_contractions contractions = let index_pairs, polarizations = L.classify_indices (ThoList.flatmap (fun ds -> ds.L.indices) contractions) in try ThoList.pairs index_pairs @ ThoList.uniq (List.sort compare polarizations) with - | Invalid_argument s -> + | Invalid_argument _ -> invalid_arg ("indices_of_contractions: " ^ ThoList.to_string string_of_int index_pairs) (*i Printf.eprintf "indices_of_contractions: %s / %s\n" (ThoList.to_string string_of_int index_pairs) (ThoList.to_string string_of_int polarizations); i*) let format_dsv dsv indices = match dsv, indices with | Braket _, [] -> dsv_name dsv - | Braket _, ilist -> + | 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 -> + | (Bra _ | Ket _), _ilist -> Printf.sprintf "%s(%s,%s)" (dsv_name dsv) index_spinor (format_indices indices) let denominator_name = "denom_" let mass_name = "m_" let width_name = "w_" let format_tensor t = let indices = t.L.indices in match t.L.atom with | DS dsv -> format_dsv dsv indices | V vector -> Printf.sprintf "%s(%s)" vector (format_indices indices) | T UFOx.Lorentz_Atom.P (mu, n) -> Printf.sprintf "p%d(%s)" n (index_variable mu) | T UFOx.Lorentz_Atom.Epsilon (mu1, mu2, mu3, mu4) -> Printf.sprintf "eps4_(%s)" (format_indices [mu1; mu2; mu3; mu4]) | T UFOx.Lorentz_Atom.Metric (mu1, mu2) -> if mu1 > 0 && mu2 > 0 then Printf.sprintf "g44_(%s)" (format_indices [mu1; mu2]) else failwith "format_tensor: compress_metrics has failed!" | S (UFOx.Lorentz_Atom.Mass _) -> mass_name | S (UFOx.Lorentz_Atom.Width _) -> width_name | S (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "g2_(p%d)" i | S (UFOx.Lorentz_Atom.P12 (i, j)) -> Printf.sprintf "g12_(p%d,p%d)" i j | Inv (UFOx.Lorentz_Atom.Mass _) -> "1/" ^ mass_name | Inv (UFOx.Lorentz_Atom.Width _) -> "1/" ^ width_name | Inv (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "1/g2_(p%d)" i | Inv (UFOx.Lorentz_Atom.P12 (i, j)) -> Printf.sprintf "1/g12_(p%d,p%d)" i j | S (UFOx.Lorentz_Atom.Variable s) -> s | Inv (UFOx.Lorentz_Atom.Variable s) -> "1/" ^ s | S (UFOx.Lorentz_Atom.Coeff c) -> UFOx.Value.to_string c | Inv (UFOx.Lorentz_Atom.Coeff c) -> "1/(" ^ UFOx.Value.to_string c ^ ")" let rec multiply_tensors ~decl ~eval = function | [] -> fprintf eval "1"; | [t] -> fprintf eval "%s" (format_tensor t) | t :: tensors -> fprintf eval "%s@,*" (format_tensor t); multiply_tensors ~decl ~eval tensors - let pseudo_wfs_for_denominator = + let _pseudo_wfs_for_denominator = Array.init 2 (fun i -> let ii = string_of_int i in { pos = i; spin = Coupling.Scalar; name = denominator_name; local_array = None; momentum = "k" ^ ii; momentum_array = "p" ^ ii; fortran_type = fortran_type Coupling.Scalar }) let contract_indices ~decl ~eval indent wf_indices wfs (fusion, contractees) = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let sum_var = begin match wf_indices with | [] -> wfs.(0).name | ilist -> let indices = String.concat "," ilist in begin match wfs.(0).local_array with | None -> let component = begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> "a" | Coupling.Tensor_2 -> "t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "contract_indices: expected local_array for vectors" | _ -> failwith "contract_indices: unexpected spin" end in Printf.sprintf "%s%%%s(%s)" wfs.(0).name component indices | Some a -> Printf.sprintf "%s(%s)" a indices end end in let indices = List.filter (fun i -> UFOx.Index.position i <> 1) (indices_of_contractions contractees) in nested_sums ~decl ~eval indent indices (fun indent -> printf "%*s@[<2>%s = %s" indent "" sum_var sum_var; printf "@ %s" (format_complex_rational_factor fusion.L.coeff); List.iter (fun i -> printf "@,g4_(%s)*" (index_variable i)) indices; printf "@,("; multiply_tensors ~decl ~eval contractees; printf ")"; begin match fusion.L.denominator with | [] -> () - | d -> printf " / %s" denominator_name + | _ -> printf " / %s" denominator_name end; printf "@]"); printf "@]"; nl () let scalar_expression1 ~decl ~eval fusion = let printf fmt = fprintf eval fmt in match fusion.L.dirac, fusion.L.vector with | [], [] -> let scalars = List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar and inverses = List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in let contractees = scalars @ inverses in printf "@ %s" (format_complex_rational_factor fusion.L.coeff); multiply_tensors ~decl ~eval contractees | _, [] -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected spinor indices" | [], _ -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected vector indices" | _, _ -> invalid_arg "UFO_targets.Fortran.scalar_expression1: unexpected indices" let scalar_expression ~decl ~eval indent name fusions = let printf fmt = fprintf eval fmt and nl = pp_newline eval in let sum_var = name in printf "%*s@[<2>%s =" indent "" sum_var; List.iter (scalar_expression1 ~decl ~eval) fusions; printf "@]"; nl () let local_vector_copies ~decl ~eval wfs = begin match wfs.(0).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl () end; let n = Array.length wfs in for i = 1 to n - 1 do match wfs.(i).local_array with | None -> () | Some a -> fprintf decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a; pp_newline decl (); fprintf eval " @[<2>%s(0) = %s%%t@]" a wfs.(i).name; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" a wfs.(i).name; pp_newline eval () done let return_vector ff wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in match wfs.(0).local_array with | None -> () | Some a -> pp_divide ~indent:4 ff (); printf " @[<2>%s%%t = %s(0)@]" wfs.(0).name a; nl (); printf " @[<2>%s%%x = %s(1:3)@]" wfs.(0).name a; nl () let multiply_coupling_and_scalars ff g_opt wfs = let printf fmt = fprintf ff fmt and nl = pp_newline ff in pp_divide ~indent:4 ff (); let g = match g_opt with | None -> "" | Some g -> g ^ "*" in let wfs0name = match wfs.(0).local_array with | None -> wfs.(0).name | Some a -> a in printf " @[<2>%s = %s%s" wfs0name g wfs0name; for i = 1 to Array.length wfs - 1 do match wfs.(i).spin with | Coupling.Scalar -> printf "@,*%s" wfs.(i).name | _ -> () done; printf "@]"; nl () let local_momentum_copies ~decl ~eval wfs = let n = Array.length wfs in fprintf decl " @[<2>real(kind=default),@ dimension(0:3) ::@ %s" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf decl ",@ %s" wfs.(i).momentum_array; fprintf eval " @[<2>%s(0) = %s%%t@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval (); fprintf eval " @[<2>%s(1:3) = %s%%x@]" wfs.(i).momentum_array wfs.(i).momentum; pp_newline eval () done; fprintf eval " @[<2>%s =" wfs.(0).momentum_array; for i = 1 to n - 1 do fprintf eval "@ - %s" wfs.(i).momentum_array done; fprintf decl "@]"; pp_newline decl (); fprintf eval "@]"; pp_newline eval () let contractees_of_fusion ~decl ~eval wfs (max_dsv, indices_seen, contractees) fusion = let max_dsv', dirac_strings = dirac_strings_to_fortran ~decl ~eval wfs max_dsv fusion.L.dirac and vectors = List.fold_left (fun acc wf -> match wf.spin, wf.local_array with | Coupling.Tensor_2, None -> { L.atom = V (Printf.sprintf "%s%d%%t" (spin_mnemonic wf.spin) wf.pos); L.indices = [UFOx.Index.pack wf.pos 1; UFOx.Index.pack wf.pos 2] } :: acc | _, None -> acc | _, Some a -> { L.atom = V a; L.indices = [wf.pos] } :: acc) [] (List.tl (Array.to_list wfs)) and tensors = List.map (L.map_atom (fun t -> T t)) fusion.L.vector and scalars = List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar and inverses = List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in let contractees' = dirac_strings @ vectors @ tensors @ scalars @ inverses in let indices_seen' = Sets.Int.of_list (indices_of_contractions contractees') in (max_dsv', Sets.Int.union indices_seen indices_seen', (fusion, contractees') :: contractees) let local_name wf = match wf.local_array with | Some a -> a | None -> match wf.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> wf.name ^ "%a" | Coupling.Scalar -> wf.name | Coupling.Tensor_2 -> wf.name ^ "%t" | Coupling.Vector | Coupling.Massive_Vector -> failwith "UFO_targets.Fortran.local_name: unexpected spin 1" | _ -> failwith "UFO_targets.Fortran.local_name: unhandled spin" let external_wf_loop ~decl ~eval ~indent wfs (fusion, _ as contractees) = pp_divide ~indent eval (); fprintf eval "%*s! %s" indent "" (L.to_string [fusion]); pp_newline eval (); pp_divide ~indent eval (); begin match fusion.L.denominator with | [] -> () | denominator -> scalar_expression ~decl ~eval 4 denominator_name denominator end; match wfs.(0).spin with | Coupling.Scalar -> contract_indices ~decl ~eval 2 [] wfs contractees | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> let idx = index_spinor in fprintf eval "%*s@[<2>do %s = 1, 4@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vector | Coupling.Massive_Vector -> let idx = index_variable 1 in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx; pp_newline eval (); contract_indices ~decl ~eval 4 [idx] wfs contractees; fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Tensor_2 -> let idx1 = index_variable (UFOx.Index.pack 1 1) and idx2 = index_variable (UFOx.Index.pack 1 2) in fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx1; pp_newline eval (); fprintf eval "%*s@[<2>do %s = 0, 3@]" (indent + 2) "" idx2; pp_newline eval (); contract_indices ~decl ~eval 6 [idx1; idx2] wfs contractees; fprintf eval "%*send do@]" (indent + 2) ""; pp_newline eval (); fprintf eval "%*send do@]" indent ""; pp_newline eval () | Coupling.Vectorspinor -> failwith "external_wf_loop: Vectorspinor not supported yet!" | Coupling.Maj_Ghost -> failwith "external_wf_loop: unexpected Maj_Ghost" | Coupling.Tensor_1 -> failwith "external_wf_loop: unexpected Tensor_1" | Coupling.BRS _ -> failwith "external_wf_loop: unexpected BRS" let fusions_to_fortran ~decl ~eval wfs ?(denominator=[]) ?coupling fusions = local_vector_copies ~decl ~eval wfs; local_momentum_copies ~decl ~eval wfs; begin match denominator with | [] -> () | _ -> fprintf decl " @[<2>complex(kind=default) :: %s@]" denominator_name; pp_newline decl () end; - let max_dsv, indices_used, contractions = + let _max_dsv, indices_used, contractions = List.fold_left (contractees_of_fusion ~decl ~eval wfs) (0, Sets.Int.empty, []) fusions in Sets.Int.iter (fun index -> fprintf decl " @[<2>integer ::@ %s@]" (index_variable index); pp_newline decl ()) indices_used; begin match wfs.(0).spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> fprintf decl " @[<2>integer ::@ %s@]" index_spinor; pp_newline decl () | _ -> () end; pp_divide ~indent:4 eval (); let wfs0name = local_name wfs.(0) in fprintf eval " %s = 0" wfs0name; pp_newline eval (); List.iter (external_wf_loop ~decl ~eval ~indent:4 wfs) contractions; multiply_coupling_and_scalars eval coupling wfs; begin match denominator with | [] -> () | denominator -> pp_divide ~indent:4 eval (); fprintf eval "%*s! %s" 4 "" (L.to_string denominator); pp_newline eval (); scalar_expression ~decl ~eval 4 denominator_name denominator; fprintf eval " @[<2>%s =@ %s / %s@]" wfs0name wfs0name denominator_name; pp_newline eval () end; return_vector eval wfs (* TODO: eventually, we should include the momentum among the arguments only if required. But this can wait for another day. *) let lorentz ff name spins lorentz = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let wfs = wf_table spins in let n = Array.length wfs in printf " @[<4>pure function %s@ (g,@ " name; for i = 1 to n - 2 do printf "%s,@ %s,@ " wfs.(i).name wfs.(i).momentum done; printf "%s,@ %s" wfs.(n - 1).name wfs.(n - 1).momentum; printf ")@ result (%s)@]" wfs.(0).name; nl (); printf " @[<2>%s ::@ %s@]" wfs.(0).fortran_type wfs.(0).name; nl(); printf " @[<2>complex(kind=default),@ intent(in) ::@ g@]"; nl(); for i = 1 to n - 1 do printf " @[<2>%s, intent(in) :: %s@]" wfs.(i).fortran_type wfs.(i).name; nl(); done; printf " @[<2>type(momentum), intent(in) ::@ %s" wfs.(1).momentum; for i = 2 to n - 1 do printf ",@ %s" wfs.(i).momentum done; printf "@]"; nl (); let width = 80 in (* get this from the default formatter instead! *) let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval ~coupling:"g" wfs lorentz; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); (*i printf " ! %s" (L.to_string lorentz); nl (); pp_divide ~indent:4 ff (); i*) printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); printf " if (g == 0) then"; nl (); printf " call set_zero (%s)" wfs.(0).name; nl (); printf " return"; nl (); printf " end if"; nl (); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function %s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () let use_variables ff parameter_module variables = let printf fmt = fprintf ff fmt and nl = pp_newline ff in match variables with | [] -> () | v :: v_list -> printf " @[<2>use %s, only: %s" parameter_module v; List.iter (fun s -> printf ", %s" s) v_list; printf "@]"; nl () let propagator ff name parameter_module variables - (bra_spin, ket_spin) numerator denominator = + (_bra_spin, ket_spin) numerator denominator = let printf fmt = fprintf ff fmt and nl = pp_newline ff in let width = 80 in (* get this from the default formatter instead! *) let wf_name = spin_mnemonic ket_spin and wf_type = fortran_type ket_spin in let wfs = wf_table [| ket_spin; ket_spin |] in printf " @[<4>pure function pr_U_%s@ (k2, %s, %s, %s2)" name mass_name width_name wf_name; printf " result (%s1)@]" wf_name; nl (); use_variables ff parameter_module variables; printf " %s :: %s1" wf_type wf_name; nl (); printf " type(momentum), intent(in) :: k2"; nl (); printf " real(kind=default), intent(in) :: %s, %s" mass_name width_name; nl (); printf " %s, intent(in) :: %s2" wf_type wf_name; nl (); let decl_buf = Buffer.create 1024 and eval_buf = Buffer.create 1024 in let decl = formatter_of_buffer ~width decl_buf and eval = formatter_of_buffer ~width eval_buf in fusions_to_fortran ~decl ~eval wfs ~denominator numerator; pp_flush decl (); pp_flush eval (); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents decl_buf); pp_divide ~indent:4 ff (); printf "%s" (Buffer.contents eval_buf); printf " end function pr_U_%s@]" name; nl (); Buffer.reset decl_buf; Buffer.reset eval_buf; () - let scale_coupling c g = + let _scale_coupling c g = if c = 1 then g else if c = -1 then "-" ^ g else Printf.sprintf "%d*%s" c g let scale_coupling z g = format_complex_rational_factor z ^ g (* As a prototypical example consider the vertex \begin{subequations} \label{eq:cyclic-UFO-fusions} \begin{equation} \bar\psi\fmslash{A}\psi = \tr\left(\psi\otimes\bar\psi\fmslash{A}\right) \end{equation} encoded as \texttt{FFV} in the SM UFO file. This example is useful, because all three fields have different type and we can use the Fortran compiler to check our implementation. In this case we need to generate the following function calls with the arguments in the following order \begin{center} \begin{tabular}{lcl} \texttt{F12}:&$\psi_1\bar\psi_2\to A$& \texttt{FFV\_p201(g,psi1,p1,psibar2,p2)} \\ \texttt{F21}:&$\bar\psi_1\psi_2\to A$& \texttt{FFV\_p201(g,psi2,p2,psibar1,p1)} \\ \texttt{F23}:&$\bar\psi_1 A_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar1,p1,A2,p2)} \\ \texttt{F32}:&$A_1\bar\psi_2 \to \bar\psi$& \texttt{FFV\_p012(g,psibar2,p2,A1,p1)} \\ \texttt{F31}:&$A_1\psi_2\to \psi$& \texttt{FFV\_p120(g,A1,p1,psi2,p2)} \\ \texttt{F13}:&$\psi_1A_2\to \psi$& \texttt{FFV\_p120(g,A2,p2,psi1,p1)} \end{tabular} \end{center} *) (* Fortunately, all Fermi signs have been taken care of by [Fusions] and we can concentrate on injecting the wave functions into the correct slots. *) (* The other possible cases are \begin{equation} \bar\psi\fmslash{A}\psi \end{equation} which would be encoded as \texttt{FVF} in a UFO file \begin{center} \begin{tabular}{lcl} \texttt{F12}:&$\bar\psi_1 A_2 \to \bar\psi$& \texttt{FVF\_p201(g,psibar1,p1,A2,p2)} \\ \texttt{F21}:&$A_1\bar\psi_2 \to \bar\psi$& \texttt{FVF\_p201(g,psibar2,p2,A1,p1)} \\ \texttt{F23}:&$A_1\psi_2\to \psi$& \texttt{FVF\_p012(g,A1,p1,psi2,p2)} \\ \texttt{F32}:&$\psi_1A_2\to \psi$& \texttt{FVF\_p012(g,A2,p2,psi1,p1)} \\ \texttt{F31}:&$\psi_1\bar\psi_2\to A$& \texttt{FVF\_p120(g,psi1,p1,psibar2,p2)} \\ \texttt{F13}:&$\bar\psi_1\psi_2\to A$& \texttt{FVF\_p120(g,psi2,p2,psibar1,p1)} \end{tabular} \end{center} and \begin{equation} \bar\psi\fmslash{A}\psi = \tr\left(\fmslash{A}\psi\otimes\bar\psi\right)\,, \end{equation} corresponding to \texttt{VFF} \begin{center} \begin{tabular}{lcl} \texttt{F12}:&$A_1\psi_2\to \psi$& \texttt{VFF\_p201(g,A1,p1,psi2,p2)} \\ \texttt{F21}:&$\psi_1A_2\to \psi$& \texttt{VFF\_p201(g,A2,p2,psi1,p1)} \\ \texttt{F23}:&$\psi_1\bar\psi_2\to A$& \texttt{VFF\_p012(g,psi1,p1,psibar2,p2)} \\ \texttt{F32}:&$\bar\psi_1\psi_2\to A$& \texttt{VFF\_p012(g,psi2,p2,psibar1,p1)} \\ \texttt{F31}:&$\bar\psi_1 A_2 \to \bar\psi$& \texttt{VFF\_p120(g,psibar1,p1,A2,p2)} \\ \texttt{F13}:&$A_1\bar\psi_2 \to \bar\psi$& \texttt{VFF\_p120(g,psibar2,p2,A1,p1)} \end{tabular} \end{center} \end{subequations} *) (* \begin{dubious} Once the Majorana code generation is fully debugged, we should replace the lists by reverted lists everywhere in order to become a bit more efficient. \end{dubious} *) module P = Permutation.Default let factor_cyclic f12__n = let f12__, fn = ThoList.split_last f12__n in let cyclic = ThoList.cycle_until fn (List.sort compare f12__n) in (P.of_list (List.map pred cyclic), P.of_lists (List.tl cyclic) f12__) let ccs_to_string ccs = String.concat "" (List.map (fun (f, i) -> Printf.sprintf "_c%x%x" i f) ccs) let fusion_name v perm ccs = Printf.sprintf "%s_p%s%s" v (P.to_string perm) (ccs_to_string ccs) - let fuse_dirac c v s fl g wfs ps fusion = + let fuse_dirac c v _s _fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in printf "@[<2>%s(@,%s" (fusion_name v cyclic []) g; List.iter (fun (wf, p) -> printf ",@,%s,@,%s" wf p) args; printf ")@]" (* We need to look at the permuted fermion lines in order to decide wether to apply charge conjugations. *) (* It is not enough to look at the cyclic permutation used to move the fields into the correct arguments of the fusions \ldots *) let map_indices perm unit = let pmap = IntPM.of_lists unit (P.list perm unit) in IntPM.apply pmap (* \ldots{} we also need to inspect the full permutation of the fields. *) let map_indices2 perm unit = let pmap = IntPM.of_lists unit (1 :: P.list (P.inverse perm) (List.tl unit)) in IntPM.apply pmap (* This is a more direct implementation of the composition of [map_indices2] and [map_indices], that is used in the unit tests. *) let map_indices_raw fusion = let unit = ThoList.range 1 (List.length fusion) in let f12__, fn = ThoList.split_last fusion in let fusion = fn :: f12__ in let map_index = IntPM.of_lists fusion unit in IntPM.apply map_index (* Map the fermion line indices in [fl] according to [map_index]. *) let map_fermion_lines map_index fl = List.map (fun (i, f) -> (map_index i, map_index f)) fl (* Map the fermion line indices in [fl] according to [map_index], but keep a copy of the original. *) let map_fermion_lines2 map_index fl = List.map (fun (i, f) -> ((i, f), (map_index i, map_index f))) fl - let permute_fermion_lines cyclic unit fl = + let _permute_fermion_lines cyclic unit fl = map_fermion_lines (map_indices cyclic unit) fl let permute_fermion_lines2 cyclic factor unit fl = map_fermion_lines2 (map_indices2 factor unit) (map_fermion_lines (map_indices cyclic unit) fl) (* \begin{dubious} TODO: this needs more more work for the fully general case with 4-fermion operators involving Majoranas. \end{dubious} *) - let charge_conjugations fl2 = + let _charge_conjugations fl2 = ThoList.filtermap (fun ((i, f), (i', f')) -> match (i, f), (i', f') with | (1, 2), _ | (2, 1), _ -> Some (f, i) (* $\chi^T\Gamma'$ *) | _, (2, 3) -> Some (f, i) (* $\chi^T(C\Gamma')\chi$ *) | _ -> None) fl2 (*i let fuse_majorana c v s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let wfs_ps_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) wfs_ps) in let args = P.list (P.inverse factor) wfs_ps in let args_string = String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in let f12__, fn = ThoList.split_last fusion in Printf.eprintf "fusion : %d < %s\n" fn (ThoList.to_string string_of_int f12__); Printf.eprintf "cyclic : %s\n" (P.to_string cyclic); Printf.eprintf "factor : %s\n" (P.to_string factor); let unit = ThoList.range 1 (List.length fusion) in Printf.eprintf "permutation : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices cyclic unit) unit)); Printf.eprintf "permutation raw : %s -> %s\n" (ThoList.to_string string_of_int unit) (ThoList.to_string string_of_int (List.map (map_indices_raw fusion) unit)); Printf.eprintf "fermion lines : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); let fl2 = permute_fermion_lines2 cyclic factor unit fl in let fl = permute_fermion_lines cyclic unit fl in Printf.eprintf "permuted : %s\n" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl); Printf.eprintf "arguments : %s\n" wfs_ps_string; Printf.eprintf "permuted : %s\n" args_string; Printf.eprintf ">> %s(%s,%s)\n" (fusion_name v cyclic (charge_conjugations fl2)) g args_string; printf "%s(%s,%s)" (fusion_name v cyclic (charge_conjugations fl2)) g args_string i*) let charge_conjugations fl2 = ThoList.filtermap (fun ((i, f), (i', f')) -> match (i, f), (i', f') with | _, (2, 3) -> Some (f, i) | _ -> None) fl2 - let fuse_majorana c v s fl g wfs ps fusion = + let fuse_majorana c v _s fl g wfs ps fusion = let g = scale_coupling c g and cyclic, factor = factor_cyclic fusion in let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in let args = P.list (P.inverse factor) wfs_ps in let unit = ThoList.range 1 (List.length fusion) in let ccs = charge_conjugations (permute_fermion_lines2 cyclic factor unit fl) in printf "@[<2>%s(%s" (fusion_name v cyclic ccs) g; List.iter (fun (wf, p) -> printf ",@,%s,@,%s" wf p) args; printf ")@]" let fuse c v s fl g wfs ps fusion = if List.exists is_majorana s then fuse_majorana c v s fl g wfs ps fusion else fuse_dirac c v s fl g wfs ps fusion let eps4_g4_g44_decl ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>integer,@ dimension(0:3)"; printf ",@ save,@ private ::@ g4_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3)"; printf ",@ save,@ private ::@ g44_@]"; nl (); printf " @[<2>integer,@ dimension(0:3,0:3,0:3,0:3)"; printf ",@ save,@ private ::@ eps4_@]"; nl () let eps4_g4_g44_init ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " @[<2>data g4_@ /@ 1, -1, -1, -1 /@]"; nl (); printf " @[<2>data g44_(0,:)@ /@ 1, 0, 0, 0 /@]"; nl (); printf " @[<2>data g44_(1,:)@ /@ 0, -1, 0, 0 /@]"; nl (); printf " @[<2>data g44_(2,:)@ /@ 0, 0, -1, 0 /@]"; nl (); printf " @[<2>data g44_(3,:)@ /@ 0, 0, 0, -1 /@]"; nl (); for mu1 = 0 to 3 do for mu2 = 0 to 3 do for mu3 = 0 to 3 do printf " @[<2>data eps4_(%d,%d,%d,:)@ /@ " mu1 mu2 mu3; for mu4 = 0 to 3 do if mu4 <> 0 then printf ",@ "; let mus = [mu1; mu2; mu3; mu4] in if List.sort compare mus = [0; 1; 2; 3] then printf "%2d" (Combinatorics.sign mus) else printf "%2d" 0; done; printf " /@]"; nl () done done done let inner_product_functions ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf " pure function g2_ (p) result (p2)"; nl(); printf " real(kind=default), dimension(0:3), intent(in) :: p"; nl(); printf " real(kind=default) :: p2"; nl(); printf " p2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3)"; nl(); printf " end function g2_"; nl(); printf " pure function g12_ (p1, p2) result (p12)"; nl(); printf " real(kind=default), dimension(0:3), intent(in) :: p1, p2"; nl(); printf " real(kind=default) :: p12"; nl(); printf " p12 = p1(0)*p2(0) - p1(1)*p2(1) - p1(2)*p2(2) - p1(3)*p2(3)"; nl(); printf " end function g12_"; nl() module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let assert_mappings fusion = let unit = ThoList.range 1 (List.length fusion) in let cyclic, factor = factor_cyclic fusion in let raw = map_indices_raw fusion and map1 = map_indices cyclic unit and map2 = map_indices2 factor unit in let map i = map2 (map1 i) in assert_equal ~printer:(ThoList.to_string string_of_int) (List.map raw unit) (List.map map unit) let suite_mappings = "mappings" >::: [ "1<-2" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3])); "1<-3" >:: (fun () -> List.iter assert_mappings (Combinatorics.permute [1;2;3;4])) ] let suite = "UFO_targets" >::: [suite_mappings] end end Index: trunk/omega/src/cascade.ml =================================================================== --- trunk/omega/src/cascade.ml (revision 8919) +++ trunk/omega/src/cascade.ml (revision 8920) @@ -1,521 +1,521 @@ (* cascade.ml -- Copyright (C) 1999-2024 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)) + (Gauss_not (List.map M.flavor_of_string f, P.of_ints dim p)) | CS.Any_flavor p -> only_wf (Any_flavor (P.of_ints dim p)) | CS.And cs -> let cs = List.map import' cs in { wf = and_cascades_wf cs; flavors = uniq (List.concat (List.map (fun c -> c.flavors) cs)); vertices = uniq (List.concat (List.map (fun c -> c.vertices) cs)) } | CS.X_Flavor fs -> let fs = List.map M.flavor_of_string fs in { default with flavors = uniq (fs @ List.map M.conjugate fs) } | CS.X_Vertex (cs, fss) -> let cs = List.map Constant.of_string cs and fss = List.map (List.map M.flavor_of_string) fss in let expanded = List.map (fun fs -> { couplings = cs; fields = fs }) (match fss with | [] -> [[]] (* Subtle: \emph{not} an empty list! *) | fss -> Product.list (fun fs -> fs) fss) in { default with vertices = expanded } in import' cascades let of_string_list dim strings = match List.map of_string strings with | [] -> default | first :: next -> import dim (List.fold_right CS.mk_and next first) let flavors_to_string fs = (String.concat ":" (List.map M.flavor_to_string fs)) let momentum_to_string p = String.concat "+" (List.map string_of_int (P.to_ints p)) let rec wf_to_string = function | True -> "true" | False -> "false" | On_shell (fs, p) -> momentum_to_string p ^ " = " ^ flavors_to_string fs | On_shell_not (fs, p) -> momentum_to_string p ^ " = !" ^ flavors_to_string fs | Off_shell (fs, p) -> momentum_to_string p ^ " ~ " ^ flavors_to_string fs | Off_shell_not (fs, p) -> momentum_to_string p ^ " ~ !" ^ flavors_to_string fs | Gauss (fs, p) -> momentum_to_string p ^ " # " ^ flavors_to_string fs | Gauss_not (fs, p) -> momentum_to_string p ^ " # !" ^ flavors_to_string fs | Any_flavor p -> momentum_to_string p ^ " ~ ?" | And cs -> String.concat " && " (List.map (fun c -> "(" ^ wf_to_string c ^ ")") cs) let vertex_to_string v = "^" ^ String.concat ":" (List.map M.constant_symbol v.couplings) ^ "[" ^ String.concat "," (List.map M.flavor_to_string v.fields) ^ "]" let vertices_to_string vs = (String.concat " && " (List.map vertex_to_string vs)) let to_string = function | { wf = True; flavors = []; vertices = [] } -> "" | { wf = True; flavors = fs; vertices = [] } -> "!" ^ flavors_to_string fs | { wf = True; flavors = []; vertices = vs } -> vertices_to_string vs | { wf = True; flavors = fs; vertices = vs } -> "!" ^ flavors_to_string fs ^ " && " ^ vertices_to_string vs | { wf = wf; flavors = []; vertices = [] } -> wf_to_string wf | { wf = wf; flavors = []; vertices = vs } -> vertices_to_string vs ^ " && " ^ wf_to_string wf | { wf = wf; flavors = fs; vertices = [] } -> "!" ^ flavors_to_string fs ^ " && " ^ wf_to_string wf | { wf = wf; flavors = fs; vertices = vs } -> "!" ^ flavors_to_string fs ^ " && " ^ vertices_to_string vs ^ " && " ^ wf_to_string wf type selectors = { select_p : p -> p list -> bool; select_wf : (p -> bool) -> flavor -> p -> p list -> bool; on_shell : flavor -> p -> bool; is_gauss : flavor -> p -> bool; select_vtx : constant Coupling.t -> flavor -> flavor list -> bool; partition : int list list; description : string option } let no_cascades = { select_p = (fun _ _ -> true); select_wf = (fun _ _ _ _ -> true); on_shell = (fun _ _ -> false); is_gauss = (fun _ _ -> false); select_vtx = (fun _ _ _ -> true); partition = []; description = None } let select_p s = s.select_p let select_wf s = s.select_wf let on_shell s = s.on_shell let is_gauss s = s.is_gauss let select_vtx s = s.select_vtx let partition s = s.partition let description s = s.description let to_select_p cascades p p_in = let rec to_select_p' = function | True -> true | False -> false | On_shell (_, momentum) | On_shell_not (_, momentum) | Off_shell (_, momentum) | Off_shell_not (_, momentum) | Gauss (_, momentum) | Gauss_not (_, momentum) | Any_flavor momentum -> all_compatible p p_in momentum | And [] -> false | And cs -> List.for_all to_select_p' cs in to_select_p' cascades let to_select_wf cascades is_timelike f p p_in = let f' = M.conjugate f in let rec to_select_wf' = function | True -> true | False -> false | Off_shell (flavors, momentum) -> if p = momentum then List.mem f' flavors || (if is_timelike p then false else List.mem f flavors) else if p = P.neg momentum then List.mem f flavors || (if is_timelike p then false else List.mem f' flavors) else one_compatible p momentum && all_compatible p p_in momentum | On_shell (flavors, momentum) | Gauss (flavors, momentum) -> if is_timelike p then begin if p = momentum then List.mem f' flavors else if p = P.neg momentum then List.mem f flavors else one_compatible p momentum && all_compatible p p_in momentum end else false | Off_shell_not (flavors, momentum) -> if p = momentum then not (List.mem f' flavors || (if is_timelike p then false else List.mem f flavors)) else if p = P.neg momentum then not (List.mem f flavors || (if is_timelike p then false else List.mem f' flavors)) else one_compatible p momentum && all_compatible p p_in momentum | On_shell_not (flavors, momentum) | Gauss_not (flavors, momentum) -> if is_timelike p then begin if p = momentum then not (List.mem f' flavors) else if p = P.neg momentum then not (List.mem f flavors) else one_compatible p momentum && all_compatible p p_in momentum end else false | Any_flavor momentum -> one_compatible p momentum && all_compatible p p_in momentum | And [] -> false | And cs -> List.for_all to_select_wf' cs in not (List.mem f cascades.flavors) && to_select_wf' cascades.wf (* In case you're wondering: [to_on_shell f p] and [is_gauss f p] only search for on shell conditions and are to be used in a target, not in [Fusion]! *) let to_on_shell cascades f p = let f' = M.conjugate f in let rec to_on_shell' = function | True | False | Any_flavor _ | Off_shell (_, _) | Off_shell_not (_, _) | Gauss (_, _) | Gauss_not (_, _) -> false | On_shell (flavors, momentum) -> (p = momentum || p = P.neg momentum) && (List.mem f flavors || List.mem f' flavors) | On_shell_not (flavors, momentum) -> (p = momentum || p = P.neg momentum) && not (List.mem f flavors || List.mem f' flavors) | And [] -> false | And cs -> List.for_all to_on_shell' cs in to_on_shell' cascades let to_gauss cascades f p = let f' = M.conjugate f in let rec to_gauss' = function | True | False | Any_flavor _ | Off_shell (_, _) | Off_shell_not (_, _) | On_shell (_, _) | On_shell_not (_, _) -> false | Gauss (flavors, momentum) -> (p = momentum || p = P.neg momentum) && (List.mem f flavors || List.mem f' flavors) | Gauss_not (flavors, momentum) -> (p = momentum || p = P.neg momentum) && not (List.mem f flavors || List.mem f' flavors) | And [] -> false | And cs -> List.for_all to_gauss' cs in to_gauss' cascades module Fields = struct type f = M.flavor type c = M.constant list let compare = compare let conjugate = M.conjugate end module Fusions = Modeltools.Fusions (Fields) let dummy3 = Coupling.Scalar_Scalar_Scalar 1 let dummy4 = Coupling.Scalar4 1 let dummyn = Coupling.UFO (Algebra.QC.unit, "dummy", [], [], Birdtracks.one) (* Translate the vertices in a pair of lists: the first is the list of always rejected couplings and the second the remaining vertices suitable as input to [Fusions.of_vertices]. *) let translate_vertices vertices = List.fold_left (fun (cs, (v3, v4, vn) as acc) v -> match v.fields with | [] -> (v.couplings @ cs, (v3, v4, vn)) | [_] | [_;_] -> acc | [f1; f2; f3] -> (cs, (((f1, f2, f3), dummy3, v.couplings)::v3, v4, vn)) | [f1; f2; f3; f4] -> (cs, (v3, ((f1, f2, f3, f4), dummy4, v.couplings)::v4, vn)) | fs -> (cs, (v3, v4, (fs, dummyn, v.couplings)::vn))) ([], ([], [], [])) vertices (*i let fusion_to_string c f fs = M.flavor_to_string f ^ " <- " ^ M.constant_symbol c ^ "[" ^ String.concat " , " (List.map M.flavor_to_string fs) ^ "]" i*) let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs (* Sometimes, the empty list is a wildcard and matches any coupling: *) let match_coupling c cs = List.mem c cs let match_coupling_wildcard c = function | [] -> true | cs -> match_coupling c cs let to_select_vtx cascades = match cascades.vertices with | [] -> (* No vertex constraints means that we always accept. *) - (fun c f fs -> true) + (fun _ _ _ -> 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 -> + (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 (Int) let rec coarsest_partition' = function | True | False -> IPowSet.empty | On_shell (_, momentum) | On_shell_not (_, momentum) | Off_shell (_, momentum) | Off_shell_not (_, momentum) | Gauss (_, momentum) | Gauss_not (_, momentum) | Any_flavor momentum -> IPowSet.of_lists [P.to_ints momentum] | And [] -> IPowSet.empty | And cs -> IPowSet.basis (IPowSet.union (List.map coarsest_partition' cs)) let coarsest_partition cascades = let p = coarsest_partition' cascades in if IPowSet.is_empty p then [] else IPowSet.to_lists p let part_to_string part = "{" ^ String.concat "," (List.map string_of_int part) ^ "}" let partition_to_string = function | [] -> "" | parts -> " grouping {" ^ String.concat "," (List.map part_to_string parts) ^ "}" let to_selectors = function | { wf = True; flavors = []; vertices = [] } -> no_cascades | c -> let partition = coarsest_partition c.wf in { select_p = to_select_p c.wf; select_wf = to_select_wf c; on_shell = to_on_shell c.wf; is_gauss = to_gauss c.wf; select_vtx = to_select_vtx c; partition = partition; description = Some (to_string c ^ partition_to_string partition) } (*i let to_selectors cascades = prerr_endline (">>> " ^ to_string cascades); to_selectors cascades i*) end Index: trunk/omega/src/young.ml =================================================================== --- trunk/omega/src/young.ml (revision 8919) +++ trunk/omega/src/young.ml (revision 8920) @@ -1,284 +1,348 @@ (* young.ml -- Copyright (C) 2022-2024 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 diagram = int list type 'a tableau = 'a list list -(* Not exposed. Just for documentation. *) -type 'a table = 'a option array array - (* The following three are candidates for [ThoList]. *) let rec sum = function | [] -> 0 | n :: rest -> n + sum rest let rec product = function | [] -> 1 | n :: rest -> n * product rest (* Test a predicate for each pair of consecutive elements of a list. Trivially true for empty and one-element lists. *) let rec for_all_pairs predicate = function | [] | [_] -> true | a1 :: (a2 :: _ as a_list) -> if not (predicate a1 a2) then false else for_all_pairs predicate a_list -let decreasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 > 0) l +let _decreasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 > 0) l let increasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 < 0) l -let non_increasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 >= 0) l +let _non_increasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 >= 0) l let non_decreasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 <= 0) l let non_increasing_never_zero l = for_all_pairs (fun a1 a2 -> a2 > 0 && compare a1 a2 >= 0) l let valid_diagram = non_increasing_never_zero let diagram_rows d = List.length d let diagram_columns = function | [] -> 0 | nc :: _ -> nc let take_column d = let rec take_column' len acc = function | [] -> (len, List.rev acc) | cols :: rest -> if cols <= 1 then take_column' (succ len) acc rest else take_column' (succ len) (pred cols :: acc) rest in take_column' 0 [] d -let conjugate_diagram_new d = +let _conjugate_diagram_new d = let rec conjugate_diagram' rows = match take_column rows with | n, [] -> [n] | n, rest -> n :: conjugate_diagram' rest in conjugate_diagram' d let tableau_rows t = List.length t let tableau_columns = function | [] -> 0 | row :: _ -> List.length row let num_cells_diagram d = sum d let cells_tableau t = List.flatten t let num_cells_tableau t = List.fold_left (fun acc row -> acc + List.length row) 0 t let diagram_of_tableau t = List.map List.length t let tableau_of_diagram cell d = List.map (ThoList.clone cell) d (* Note that the first index counts the rows and the second the columns! *) let array_of_tableau t = let nr = tableau_rows t and nc = tableau_columns t in let a = Array.make_matrix nr nc None in List.iteri (fun ir -> List.iteri (fun ic cell -> a.(ir).(ic) <- Some cell)) t; a let transpose_array a = let nr = Array.length a in if nr <= 0 then invalid_arg "Young.transpose_array" else let nc = Array.length a.(0) in let a' = Array.make_matrix nc nr None in for ic = 0 to pred nc do for ir = 0 to pred nr do a'.(ic).(ir) <- a.(ir).(ic) done done; a' let list_of_array_row a = let n = Array.length a in let rec list_of_array_row' ic = if ic >= n then [] else match a.(ic) with | None -> [] | Some cell -> cell :: list_of_array_row' (succ ic) in list_of_array_row' 0 let tableau_of_array a = Array.fold_right (fun row acc -> list_of_array_row row :: acc) a [] let conjugate_tableau t = array_of_tableau t |> transpose_array |> tableau_of_array let conjugate_diagram d = tableau_of_diagram () d |> conjugate_tableau |> diagram_of_tableau let valid_tableau t = valid_diagram (diagram_of_tableau t) let semistandard_tableau t = let rows = t and columns = conjugate_tableau t in valid_tableau t && List.for_all non_decreasing rows && List.for_all increasing columns let standard_tableau ?offset t = match List.sort compare (cells_tableau t) with | [] -> true | cell :: _ as cell_list -> (match offset with None -> true | Some o -> cell = o) && for_all_pairs (fun c1 c2 -> c2 = c1 + 1) cell_list && semistandard_tableau t +let quasi_standard_tableau t = + match List.sort compare (cells_tableau t) with + | [] -> None + | _ :: _ as cell_list -> + if for_all_pairs (fun c1 c2 -> c2 > c1) cell_list && semistandard_tableau t then + Some cell_list + else + None + let map f t = List.map (List.map f) t let tableau_to_string to_string t = ThoList.to_string (ThoList.to_string to_string) t let pp fmt y = Format.fprintf fmt "%s" (tableau_to_string string_of_int y) -let hook_lengths_table d = +let _hook_lengths_table d = let nr = diagram_rows d and nc = diagram_columns d in if min nr nc <= 0 then invalid_arg "Young.hook_lengths_table" else let a = array_of_tableau (tableau_of_diagram 0 d) in let cols = Array.of_list d and rows = transpose_array a |> tableau_of_array |> diagram_of_tableau |> Array.of_list in for ir = 0 to pred nr do for ic = 0 to pred cols.(ir) do a.(ir).(ic) <- Some (rows.(ic) - ir + cols.(ir) - ic - 1) done done; a (* \begin{dubious} The following products and factorials can easily overflow, even if the final ratio is a smallish number. We can avoid this by representing them as lists of factors (or maps from factors to powers). The ratio can be computed by first cancelling all common factors and multiplying the remaining factors at the very end. \end{dubious} *) let hook_lengths_product d = let nr = diagram_rows d and nc = diagram_columns d in if min nr nc <= 0 then 0 else let cols = Array.of_list d and rows = Array.of_list (conjugate_diagram d) in let n = ref 1 in for ir = 0 to pred nr do for ic = 0 to pred cols.(ir) do n := !n * (rows.(ic) - ir + cols.(ir) - ic - 1) done done; !n let num_standard_tableaux d = let num = Combinatorics.factorial (num_cells_diagram d) and den = hook_lengths_product d in if num mod den <> 0 then failwith "Young.num_standard_tableaux" else num / den (* Note that [hook_lengths_product] calls [conjugate_diagram] and this calls it again. This is wasteful, but probably no big deal for our applications. *) let normalization d = let num = product (List.map Combinatorics.factorial (d @ conjugate_diagram d)) and den = hook_lengths_product d in (num, den) +module L = Algebra.Laurent + +(* \begin{equation} + R(i_0,l) = \prod_{i=0}^{n_{\text{boxes}}-1} (N_c+i+i_0) + \end{equation} *) +let row_polynomial i0 num_boxes = + let rec factors acc i = + if i >= num_boxes then + acc + else + factors (L.ints [(1,1); (i + i0, 0)] :: acc) (succ i) in + L.product (factors [] 0) + +(* \begin{equation} + \prod_{i=1}^{n_{\text{rows}}} R(1-i,n_{\text{boxes}}(i)) + \end{equation} *) +let diagram_polynomial rows = + let factors, _ = + List.fold_left + (fun (acc, i) num_boxes -> (row_polynomial i num_boxes :: acc, pred i)) + ([], 0) rows in + L.product factors + +let dimension d = + L.product [diagram_polynomial d; L.fraction (hook_lengths_product d)] + module type Test = sig val suite : OUnit.test val suite_long : OUnit.test end module Test = struct open OUnit + let assert_equal_laurent l1 l2 = + assert_equal ~printer:(L.to_string "N") l1 l2 + let random_int ratio = truncate (Random.float ratio +. 0.5) - let random_diagram ?(ratio=1.0) rows = + let _random_diagram ?(ratio=1.0) rows = let rec random_diagram' acc row cols = if row >= rows then acc else let cols' = cols + random_int ratio in random_diagram' (cols' :: acc) (succ row) cols' in random_diagram' [] 0 (1 + random_int ratio) let suite_hook_lengths_product = "hook_lengths_product" >::: [ "[4;3;2]" >:: (fun () -> assert_equal 2160 (hook_lengths_product [4; 3; 2])) ] let suite_num_standard_tableaux = "num_standard_tableaux" >::: [ "[4;3;2]" >:: (fun () -> assert_equal 168 (num_standard_tableaux [4; 3; 2])) ] let suite_normalization = "normalization" >::: [ "[2;1]" >:: (fun () -> assert_equal (4, 3) (normalization [2; 1])) ] + let assert_decomposition powers yd_list = + assert_equal_laurent (L.ints powers) + (L.sum (List.map (fun (n, yd) -> L.product [L.int n; dimension yd]) yd_list)) + + let suite_dimension = + "dimension" >::: + + [ "[1]" >:: + (fun () -> assert_equal_laurent (L.ints [(1,1)]) (dimension [1])); + + "[2]" >:: + (fun () -> assert_equal_laurent (L.product [L.ints [(1,2);(1,1)]; L.fraction 2]) (dimension [2])); + + "[1;1]" >:: + (fun () -> assert_equal_laurent (L.product [L.ints [(1,2);(-1,1)]; L.fraction 2]) (dimension [1;1])); + + "[2;1]" >:: + (fun () -> assert_equal_laurent (L.product [L.ints [(1,3);(-1,1)]; L.fraction 3]) (dimension [2;1])); + + "N*N" >:: + (fun () -> assert_decomposition [(1,2)] [(1, [1;1]); (1, [2])]); + + "N*N*N" >:: + (fun () -> assert_decomposition [(1,3)] [(1, [1;1;1]); (2, [2;1]); (1, [3])]); + + "N*N*N*N" >:: + (fun () -> assert_decomposition [(1,4)] [(1, [1;1;1;1]); (3, [2;1;1]); (2, [2;2]); (3, [3;1]); (1, [4])]) ] + let suite = "Young" >::: [suite_hook_lengths_product; suite_num_standard_tableaux; - suite_normalization] + suite_normalization; + suite_dimension] let suite_long = "Young long" >::: [] end Index: trunk/omega/src/omega3.ml =================================================================== --- trunk/omega/src/omega3.ml (revision 8919) +++ trunk/omega/src/omega3.ml (revision 8920) @@ -1,420 +1,420 @@ (* omega3.ml -- Copyright (C) 1999-2024 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. *) (* \begin{dubious} Next generation single executable. \begin{center} $\Omega^3$: only healthy fatty acids included! \end{center} Playground for first class modules. \end{dubious} *) (* \begin{dubious} The following static models are still missing \begin{itemize} \item model defined in the compilation unit of the executable: \verb+CQED+, \verb+Littlest_Zprime+, \verb+SM_top+, \verb+SYM+. \end{itemize} \end{dubious} *) let static_models_SM : (string * string * (module Model.T)) list = let open Modellib_SM in let pfx = "from Modellib_SM: " in [ ("QED", "Quantum Electro Dynamics", (module QED)); ("QCD", "Quantum Chromo Dynamics", (module QCD)); ("SM", "Standard Model (minimal, no CKM)", (module SM(SM_no_anomalous))); ("SM_CKM", pfx^"SM(SM_no_anomalous_ckm)", (module SM(SM_no_anomalous_ckm))); ("SM_Higgs", pfx^"SM(SM_Higgs)", (module SM(SM_Higgs))); ("SM_Higgs_CKM", pfx^"SM(SM_Higgs_CKM)", (module SM(SM_Higgs_CKM))); ("SM_ac", pfx^"SM(SM_anomalous)", (module SM(SM_anomalous))); ("SM_ac_CKM", pfx^"SM(SM_anomalous_ckm)", (module SM(SM_anomalous_ckm))); ("SM_top_anom", pfx^"SM(SM_anomalous_top)", (module SM(SM_anomalous_top))); ("SM_dim6", pfx^"SM(SM_dim6)", (module SM(SM_dim6))); ("SM_tt_threshold", pfx^"SM(SM_tt_threshold)", (module SM(SM_tt_threshold))); ("SM_ul", pfx^"SM(SM_k_matrix)", (module SM(SM_k_matrix))); ("SM_rx", pfx^"SM(SM_k_matrix) = SM_ul with fewer parameters in Whizard", (module SM(SM_k_matrix))); ("SM_Rxi", pfx^"SM_Rxi", (module SM_Rxi)); ("SM_clones", pfx^"SM_clones", (module SM_clones)); ("Phi3", "phi^3 toy model", (module Phi3)); ("Phi4", "phi^3 + phi^4 toy model", (module Phi4)) ] let static_models_BSM : (string * string * (module Model.T)) list = let open Modellib_BSM in let pfx = "from Modellib_BSM: " in [ ("THDM", pfx^"TwoHiggsDoublet(THDM)", (module TwoHiggsDoublet(THDM))); ("THDM_CKM", pfx^"TwoHiggsDoublet(THDM_CKM)", (module TwoHiggsDoublet(THDM_CKM))); ("GravTest", pfx^"GravTest(BSM_bsm)", (module GravTest(BSM_bsm))); ("HSExt", pfx^"HSExt(BSM_bsm)", (module HSExt(BSM_bsm))); ("Littlest", pfx^"Littlest(BSM_bsm)", (module Littlest(BSM_bsm))); ("Littlest_Eta", pfx^"Littlest(BSM_ungauged)", (module Littlest(BSM_ungauged))); ("Littlest_Tpar", pfx^"(Littlest_Tpar(BSM_bsm))", (module (Littlest_Tpar(BSM_bsm)))); ("Simplest", pfx^"Simplest(BSM_bsm)", (module Simplest(BSM_bsm))); ("Simplest_univ", pfx^"Simplest(BSM_anom)", (module Simplest(BSM_anom))); ("SSC", pfx^"SSC(SSC_kmatrix)", (module SSC(SSC_kmatrix))); ("SSC_2", pfx^"SSC(SSC_kmatrix_2)", (module SSC(SSC_kmatrix_2))); ("SSC_AltT", pfx^"SSC_AltT(SSC_kmatrix_2)", (module SSC_AltT(SSC_kmatrix_2))); ("Template", pfx^"Template(BSM_bsm)", (module Template(BSM_bsm))); ("Threeshl", pfx^"Threeshl(Threeshl_no_ckm)", (module Threeshl(Threeshl_no_ckm))); ("Threeshl_nohf", pfx^"Threeshl(Threeshl_no_ckm_no_hf)", (module Threeshl(Threeshl_no_ckm_no_hf))); ("UED", pfx^"UED(BSM_bsm)", (module UED(BSM_bsm))); ("Xdim", pfx^"Xdim(BSM_bsm)", (module Xdim(BSM_bsm))) ] let static_models_MSSM : (string * string * (module Model.T)) list = let open Modellib_MSSM in let pfx = "from Modellib_MSSM: " in [ ("MSSM", pfx^"MSSM(MSSM_no_4)", (module MSSM(MSSM_no_4))); ("MSSM_CKM", pfx^"MSSM(MSSM_no_4_ckm)", (module MSSM(MSSM_no_4_ckm))); ("MSSM_Hgg", pfx^"MSSM(MSSM_Hgg)", (module MSSM(MSSM_Hgg))); ("MSSM_Grav", pfx^"MSSM(MSSM_Grav)", (module MSSM(MSSM_Grav))) ] let static_models_NMSSM : (string * string * (module Model.T)) list = let open Modellib_NMSSM in let pfx = "from Modellib_NMSSM: " in [ ("NMSSM", pfx^"NMSSM_func(NMSSM)", (module NMSSM_func(NMSSM))); ("NMSSM_CKM", pfx^"NMSSM_func(NMSSM_CKM)", (module NMSSM_func(NMSSM_CKM))); ("NMSSM_Hgg", pfx^"NMSSM_func(NMSSM_Hgg)", (module NMSSM_func(NMSSM_Hgg))) ] let static_models_NoH : (string * string * (module Model.T)) list = let open Modellib_NoH in let pfx = "from Modellib_NoH: " in [ ("AltH", pfx^"AltH(NoH_k_matrix)", (module AltH(NoH_k_matrix))); ("NoH_rx", pfx^"NoH(NoH_k_matrix)", (module NoH(NoH_k_matrix))) ] let static_models_other : (string * string * (module Model.T)) list = let module Zprime = Modellib_Zprime in let module PSSSM = Modellib_PSSSM in let module WZW = Modellib_WZW in let pfx s = "from Modellib_" ^ s ^ ": " in [ ("Zprime", pfx "Zprime"^"Zprime.Zprime(Zprime.SM_no_anomalous)", (module Zprime.Zprime(Zprime.SM_no_anomalous))); ("PSSSM", pfx "PSSSM"^"PSSSM.ExtMSSM(PSSSM.PSSSM)", (module PSSSM.ExtMSSM(PSSSM.PSSSM))); ("WZW", pfx "WZW"^"WZW.WZW(WZW.SM_no_anomalous)", (module WZW.WZW(WZW.SM_no_anomalous))) ] let static_models = Omega_cli.Models.of_list (List.concat [ static_models_SM; static_models_BSM; static_models_MSSM; static_models_NMSSM; static_models_NoH; static_models_other ]) let list_models () = List.iter (fun (name, description) -> Printf.printf "%s : %s\n" name description) (Omega_cli.Models.names static_models) type model = | Static_Model of string | UFO_Model of string let load_model ?(flags=[]) = function | Static_Model name -> begin match Omega_cli.Models.by_name_opt static_models name with | Some (module S) -> (module Modeltools.Static(S) : Model.Mutable) | None -> invalid_arg (Printf.sprintf "omega: static model '%s' not found!" name) end | UFO_Model directory -> let (module U) = (module UFO.Model : Model.Mutable with type init = string * string list) in U.init (directory, flags); (module U : Model.Mutable) (* Check if the model [M] contains Majorana fermions. In the case of UFO, this can only be used \emph{after} the UFO model has been loaded with [M.init dir], of course! *) let needs_majorana (module M : Model.T) = List.exists (fun f -> M.fermion f = 2) (M.flavors ()) (* Interface to the old CLI module [Omega] for testing the first class modules code before implementing the new [Omega_cli]. *) module Legacy = struct (* Match a model without Majorana fermions and a target to a topology. *) let dirac (module T : Target.Maker) (module M : Model.Mutable) = let n = M.max_degree () in if n > 4 then (module (Omega.Nary(T)(M)) : Omega_cli.T) else if n = 4 then (module (Omega.Mixed23(T)(M)) : Omega_cli.T) else if n = 3 then (module (Omega.Binary(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.Legacy.dirac: max_degree < 3" (* Match a model containing Majorana fermions and a target to a topology. *) let majorana (module T : Target.Maker) (module M : Model.Mutable) = let n = M.max_degree () in if n > 4 then (module (Omega.Nary_Majorana(T)(M)) : Omega_cli.T) else if n = 4 then (module (Omega.Mixed23_Majorana(T)(M)) : Omega_cli.T) else if n = 3 then (module (Omega.Binary_Majorana(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.Legacy.majorana: max_degree < 3" (* Match a model containing Majorana fermions and a target to a topology using the old implementation. *) let vintage_majorana (module T : Target.Maker) (module M : Model.Mutable) = let n = M.max_degree () in if n = 3 || n = 4 then (module (Omega.Mixed23_Majorana_vintage(T)(M)) : Omega_cli.T) else if n > 4 then invalid_arg "Omega3.Legacy.vintage_majorana: max_degree > 4" else invalid_arg "Omega3.Legacy.vintage_majorana: max_degree < 3" let fortran ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana then vintage_majorana (module Target_Fortran.Make_Majorana) (module M) else if force_majorana || needs_majorana (module M) then majorana (module Target_Fortran.Make_Majorana) (module M) else dirac (module Target_Fortran.Make) (module M) let vm ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana || force_majorana || needs_majorana (module M) then invalid_arg "Omega3.Legacy.vm: Majorana fermions not yet supported by the virtual machine" else dirac (module Target_VM.Make) (module M) let adjoin_target ?force_majorana ?force_vintage_majorana (module M : Model.Mutable) name = match String.lowercase_ascii name with | "fortran" -> fortran ?force_majorana ?force_vintage_majorana (module M) - | "vm" -> vm ?force_majorana ?force_vintage_majorana (module M) + | "ovm" -> vm ?force_majorana ?force_vintage_majorana (module M) | _ -> invalid_arg (Printf.sprintf "omega: target '%s' not found!" name) let load_omega ?flags ?force_majorana ?force_vintage_majorana target model = adjoin_target ?force_majorana ?force_vintage_majorana (load_model ?flags model) target end module Bound (M : Model.T) : Tuple.Bound = struct let max_arity () = pred (M.max_degree ()) end module V3 = struct module CLI = Omega_cli.Make (* Match a model without Majorana fermions and a target to a topology. *) let dirac (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion in let n = M.max_degree () in if n > 4 then (module (CLI(Nary(Bound(M)))(Helac(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 4 then (module (CLI(Mixed23)(Helac_Mixed23)(T)(M)) : Omega_cli.T) else if n = 3 then (module (CLI(Binary)(Helac_Binary)(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.dirac: max_degree < 3" let dirac_helac (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion in let n = M.max_degree () in if n > 4 then (module (CLI(Helac(Bound(M)))(Helac(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 4 then (module (CLI(Helac_Mixed23)(Helac_Mixed23)(T)(M)) : Omega_cli.T) else if n = 3 then (module (CLI(Helac_Binary)(Helac_Binary)(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.dirac_helac: max_degree < 3" (* Match a model containing Majorana fermions and a target to a topology. *) let majorana (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion in let n = M.max_degree () in if n > 4 then (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 4 then (module (CLI(Mixed23_Majorana)(Helac_Mixed23_Majorana)(T)(M)) : Omega_cli.T) else if n = 3 then (module (CLI(Binary_Majorana)(Helac_Binary_Majorana)(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.majorana: max_degree < 3" let majorana_helac (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion in let n = M.max_degree () in if n > 4 then (module (CLI(Helac_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 4 then (module (CLI(Helac_Mixed23_Majorana)(Helac_Mixed23_Majorana)(T)(M)) : Omega_cli.T) else if n = 3 then (module (CLI(Helac_Binary_Majorana)(Helac_Binary_Majorana)(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.majorana_helac: max_degree < 3" (* Match a model containing Majorana fermions and a target to a topology using the old implementation. *) let vintage_majorana (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion_vintage in let n = M.max_degree () in if n > 4 then (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 4 then (module (CLI(Mixed23_Majorana)(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else if n = 3 then (module (CLI(Binary_Majorana)(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.vintage_majorana: max_degree < 3" let vintage_majorana_helac (module T : Target.Maker) (module M : Model.Mutable) = let open Fusion_vintage in let n = M.max_degree () in if n > 2 then (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T) else invalid_arg "Omega3.V3.vintage_majorana_helac: max_degree < 3" let fortran ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana then vintage_majorana (module Target_Fortran.Make_Majorana) (module M) else if force_majorana || needs_majorana (module M) then majorana (module Target_Fortran.Make_Majorana) (module M) else dirac (module Target_Fortran.Make) (module M) let fortran_helac ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana then vintage_majorana_helac (module Target_Fortran.Make_Majorana) (module M) else if force_majorana || needs_majorana (module M) then majorana_helac (module Target_Fortran.Make_Majorana) (module M) else dirac_helac (module Target_Fortran.Make) (module M) let vm ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana || force_majorana || needs_majorana (module M) then invalid_arg "Omega3.V3.vm: Majorana fermions not yet supported by the virtual machine" else dirac (module Target_VM.Make) (module M) let vm_helac ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) = if force_vintage_majorana || force_majorana || needs_majorana (module M) then invalid_arg "Omega3.V3.vm_helac: Majorana fermions not yet supported by the virtual machine" else dirac_helac (module Target_VM.Make) (module M) let adjoin_target ?(helac=false) ?force_majorana ?force_vintage_majorana (module M : Model.Mutable) name = match String.lowercase_ascii name with | "fortran" -> if helac then fortran_helac ?force_majorana ?force_vintage_majorana (module M) else fortran ?force_majorana ?force_vintage_majorana (module M) - | "vm" -> + | "ovm" -> if helac then vm_helac ?force_majorana ?force_vintage_majorana (module M) else vm ?force_majorana ?force_vintage_majorana (module M) | _ -> invalid_arg (Printf.sprintf "omega: target '%s' not found!" name) let load_omega ?helac ?flags ?force_majorana ?force_vintage_majorana target model = adjoin_target ?helac ?force_majorana ?force_vintage_majorana (load_model ?flags model) target end (* This is the first part of the command line processing. Interpret the options up to ["--"] to load a model (static or UFO) and a target. Then dispatch the rest of the command line to the old ([Omega.Make().main], selected by ["--legacy"]) main program or the new one ([Omega_cli.Make().main], selected by ["--v3"] or by default). For static models, the old command line interface should work in exactly the same way as the single executables. For UFO models, some options in the old interface will not work, due to the new loading sequence. *) let list_targets () = List.iter print_endline ["fortran"; "ovm"] type mode = | V3 | Legacy let default_static_model_name = "SM" let default_target_name = "fortran" let _ = let argv0 = Sys.argv.(0) in let usage = "usage: " ^ argv0 ^ " [-help] [options]" and mode = ref V3 and arg_head_rev = ref [] and arg_tail_rev = ref [] and ufo_debug = ref [] and model = ref (Static_Model default_static_model_name) and target_name = ref default_target_name and force_majorana = ref None and force_vintage_majorana = ref None and helac = ref None in Arg.parse (Arg.align [ ( "-M", Arg.String (fun s -> model := Static_Model s), "model select static model (default='" ^ default_static_model_name ^ "')"); ( "--model", Arg.String (fun s -> model := Static_Model s), "model select static model (default='" ^ default_static_model_name ^ "')"); ( "--model_list", Arg.Unit list_models, " list all available static models"); ( "-U", Arg.String (fun s -> model := UFO_Model s), "dir select UFO and read from directory"); ( "--ufo_directory", Arg.String (fun s -> model := UFO_Model s), "dir select UFO and read from directory"); ( "--ufo_debug", Arg.String (fun s -> ufo_debug := s :: !ufo_debug), "flag add UFO debug flags (undocumented)"); ( "-T", Arg.String ((:=) target_name), "target select target (default='" ^ !target_name ^ "')"); ( "--target", Arg.String ((:=) target_name), "target select target (default='" ^ !target_name ^ "')"); ( "--target_list", Arg.Unit list_targets, " list all available targets"); ( "--majorana", Arg.Unit (fun () -> force_majorana := Some true), " use Majorana spinors even if not needed"); ( "--vintage_majorana", Arg.Unit (fun () -> force_vintage_majorana := Some true), " use the original implementation of Majorana spinors"); ( "--helac", Arg.Unit (fun () -> helac := Some true), " use asymmetrical topologies like HELAC"); ( "--v3", Arg.Unit (fun () -> mode := V3), " use the new omega CLI, version 3 (default)"); ( "--legacy", Arg.Unit (fun () -> mode := Legacy), " use the historically grown omega CLI"); ( "--", Arg.Rest (fun s -> arg_tail_rev := s :: !arg_tail_rev), " pass remaining options to the selected omega CLI") ]) (fun s -> arg_head_rev := s :: !arg_head_rev) usage; let arg_head = List.rev !arg_head_rev and arg_tail = List.rev !arg_tail_rev in begin match arg_head with | [] -> () | args -> Printf.eprintf "omega3: ignoring options before --: %s\n" (String.concat " " args) end; let force_majorana = !force_majorana and force_vintage_majorana = !force_vintage_majorana and helac = !helac and flags = match !ufo_debug with | [] -> None | flags -> Some flags in let (module O) = match !mode with | Legacy -> Legacy.load_omega ?flags ?force_majorana ?force_vintage_majorana !target_name !model | V3 -> V3.load_omega ?flags ?helac ?force_majorana ?force_vintage_majorana !target_name !model in let current = ref 0 and argv = Array.of_list (argv0 :: arg_tail) in O.main ~current ~argv () Index: trunk/omega/src/phasespace.ml =================================================================== --- trunk/omega/src/phasespace.ml (revision 8919) +++ trunk/omega/src/phasespace.ml (revision 8920) @@ -1,382 +1,374 @@ (* phasespace.ml -- Copyright (C) 1999-2024 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{Tools} *) (* These are candidates for [ThoList] and not specific to phase space. *) let rec first_match' mismatch f = function | [] -> None | x :: rest -> if f x then Some (x, List.rev_append mismatch rest) else first_match' (x :: mismatch) f rest (* Returns $(x,X\setminus\{x\})$ if $\exists x\in X: f(x)$. *) let first_match f l = first_match' [] f l let rec first_pair' mismatch1 f l1 l2 = match l1 with | [] -> None | x1 :: rest1 -> begin match first_match (f x1) l2 with | None -> first_pair' (x1 :: mismatch1) f rest1 l2 | Some (x2, rest2) -> Some ((x1, x2), (List.rev_append mismatch1 rest1, rest2)) end (* Returns $((x,y),(X\setminus\{x\},Y\setminus\{y\}))$ if $\exists x\in X: \exists y\in Y: f(x,y)$. *) let first_pair f l1 l2 = first_pair' [] f l1 l2 (* \thocwmodulesection{Phase Space Parameterization Trees} *) module type T = sig type momentum type 'a t type 'a decay val sort : ('a -> 'a -> int) -> 'a t -> 'a t val sort_decay : ('a -> 'a -> int) -> 'a decay -> 'a decay val map : ('a -> 'b) -> 'a t -> 'b t val map_decay : ('a -> 'b) -> 'a decay -> 'b decay val eval : ('a -> 'b) -> ('a -> 'b) -> ('a -> 'b -> 'b -> 'b) -> 'a t -> 'b t val eval_decay : ('a -> 'b) -> ('a -> 'b -> 'b -> 'b) -> 'a decay -> 'b decay val of_momenta : 'a -> 'a -> (momentum * 'a) list -> (momentum * 'a) t val decay_of_momenta : (momentum * 'a) list -> (momentum * 'a) decay exception Duplicate of momentum exception Unordered of momentum exception Incomplete of momentum end module Make (M : Momentum.T) = struct type momentum = M.t (* \begin{dubious} Finally, we came back to binary trees \ldots \end{dubious} *) (* \thocwmodulesubsection{Cascade Decays} *) type 'a decay = | Leaf of 'a | Branch of 'a * 'a decay * 'a decay (* \begin{dubious} Trees of type [(momentum * 'a option) decay] can be build easily and mapped to [(momentum * 'a) decay] later, once all the ['a] slots are filled. A more elegant functor operating on ['b decay] directly (with [Momentum] style functions defined for ['b]) would not allow holes in the ['b decay] during the construction. \end{dubious} *) let label = function | Leaf p -> p | Branch (p, _, _) -> p let rec sort_decay cmp = function | Leaf _ as l -> l | Branch (p, d1, d2) -> let d1' = sort_decay cmp d1 and d2' = sort_decay cmp d2 in if cmp (label d1') (label d2') <= 0 then Branch (p, d1', d2') else Branch (p, d2', d1') let rec map_decay f = function | Leaf p -> Leaf (f p) | Branch (p, d1, d2) -> Branch (f p, map_decay f d1, map_decay f d2) let rec eval_decay fl fb = function | Leaf p -> Leaf (fl p) | Branch (p, d1, d2) -> let d1' = eval_decay fl fb d1 and d2' = eval_decay fl fb d2 in Branch (fb p (label d1') (label d2'), d1', d2') (* Assuming that $p>p_D \lor p=p_D \lor p if M.less p' p then Branch ((p, Some f), d', Leaf (M.sub p p', None)) else if M.less p p' then Branch (pf', Leaf (p, Some f), Leaf (M.sub p' p, None)) else if p = p' then begin match f' with | None -> Leaf (p, Some f) | Some _ -> raise (Duplicate p) end else raise (Unordered p) | Branch ((p', f' as pf'), d1, d2) as d' -> let p1, _ = label d1 and p2, _ = label d2 in if M.less p' p then Branch ((p, Some f), d', Leaf (M.sub p p', None)) else if M.lesseq p p1 then Branch (pf', embed_in_decay pf d1, d2) else if M.lesseq p p2 then Branch (pf', d1, embed_in_decay pf d2) else if p = p' then begin match f' with | None -> Branch ((p, Some f), d1, d2) | Some _ -> raise (Duplicate p) end else raise (Unordered p) (* \begin{dubious} Note that both [embed_in_decay] and [embed_in_decays] below do \emph{not} commute, and should process `bigger' momenta first, because disjoint sub-momenta will create disjoint subtrees in the latter and raise exceptions in the former. \end{dubious} *) exception Incomplete of momentum let finalize1 = function | p, Some f -> (p, f) | p, None -> raise (Incomplete p) let finalize_decay t = map_decay finalize1 t (* Process the momenta starting in with the highest [M.rank]: *) let sort_momenta plist = List.sort (fun (p1, _) (p2, _) -> M.compare p1 p2) plist let decay_of_momenta plist = match sort_momenta plist with | (p, f) :: rest -> finalize_decay (List.fold_right embed_in_decay rest (Leaf (p, Some f))) | [] -> invalid_arg "Phasespace.decay_of_momenta: empty" (* \thocwmodulesubsection{$2\to n$ Scattering } *) (* \begin{figure} \begin{center} \begin{fmfgraph*}(80,50) %%%\fmfstraight \fmftopn{i}{2} \fmfbottomn{o}{20} \fmf{plain,label=$p_1$}{i1,v1} \fmf{plain,label=$p_2$}{i2,v2} \fmf{phantom}{o1,v1,w1,w2,w3,w4,w5,v2,o20} \fmfdot{v1,v2} \fmfdot{w2,w4} \fmffreeze \fmfshift{(0,.2h)}{w1,w3,w5} \fmflabel{$t_1$}{w1} \fmflabel{$t_2$}{w3} %%% Workaround for MetaPost 1.504 bug \fmfcmd{pair fubara, fubarb, fubarc; fubara = vloc(__v1); fubarb = vloc(__w2); fubarc = vloc(__w4);} \fmfi{plain}{fubara...{right}vloc(__w1){right}...vloc(__w2)} \fmfi{plain}{fubarb...{right}vloc(__w3){right}...vloc(__w4)} \fmfi{dashes}{fubarc...{right}vloc(__w5){right}...vloc(__v2)} \fmf{plain,tension=2,label=$s_1$}{v1,p1} \fmf{plain}{o1,p1,q1,o4} \fmf{plain,tension=0}{q1,o3} \fmf{plain,tension=2,label=$s_2$}{w2,p2} \fmf{plain}{o6,p2,q2,o9} \fmf{plain,tension=0}{q2,o8} \fmf{plain,tension=2,label=$s_3$}{w4,p3} \fmf{plain}{o12,q3,p3,o15} \fmf{plain,tension=0}{q3,o13} \fmf{plain,tension=2,label=$s_4$}{v2,p4} \fmf{plain}{o17,q4,p4,o20} \fmf{plain,tension=0}{q4,o18} \fmfdotn{p}{4} \fmfdotn{q}{4} \end{fmfgraph*} \end{center} \caption{\label{fig:phasespace}% Phasespace parameterization for~$2\to n$ scattering by a sequence of cascade decays.} \end{figure} A general $2\to n$ scattering process can be parameterized by a sequence of cascade decays. The most symmetric representation is a little bit redundant and enters each $t$-channel momentum twice. *) type 'a t = ('a * 'a decay * 'a) list (* \begin{dubious} [let topology = map snd] has type [(momentum * 'a) t -> 'a t] and can be used to define topological equivalence classes ``up to permutations of momenta,'' which are useful for calculating Whizard ``groves''\footnote{Not to be confused with gauge invariant classes of Feynman diagrams~\cite{Boos/Ohl:groves}.}~\cite{Kilian:WHIZARD}. \end{dubious} *) let sort cmp = List.map (fun (l, d, r) -> (l, sort_decay cmp d, r)) let map f = List.map (fun (l, d, r) -> (f l, map_decay f d, f r)) let eval ft fl fb = List.map (fun (l, d, r) -> (ft l, eval_decay fl fb d, ft r)) (* Find a tree with a defined ordering relation with respect to~$p$ or create a new one at the end of the list. *) let rec embed_in_decays (p, f as pf) = function | [] -> [Leaf (p, Some f)] | d' :: rest -> let p', _ = label d' in if M.lesseq p' p || M.less p p' then embed_in_decay pf d' :: rest else d' :: embed_in_decays pf rest (* \thocwmodulesubsection{Collecting Ingredients} *) type 'a unfinished_decays = { n : int; t_channel : (momentum * 'a option) list; decays : (momentum * 'a option) decay list } let empty n = { n = n; t_channel = []; decays = [] } let insert_in_unfinished_decays (p, f as pf) d = if M.Scattering.spacelike p then { d with t_channel = (p, Some f) :: d.t_channel } else { d with decays = embed_in_decays pf d.decays } let flip_incoming plist = List.map (fun (p', f') -> (M.Scattering.flip_s_channel_in p', f')) plist let unfinished_decays_of_momenta n f2 p = List.fold_right insert_in_unfinished_decays (sort_momenta (flip_incoming ((M.of_ints n [2], f2) :: p))) (empty n) (* \thocwmodulesubsection{Assembling Ingredients} *) let sort3 compare x y z = let a = [| x; y; z |] in Array.sort compare a; (a.(0), a.(1), a.(2)) (* Take advantage of the fact that sorting with [M.compare] sorts with \emph{rising} values of [M.rank]: *) let allows_momentum_fusion (p, _) (p1, _) (p2, _) = let p2', p1', p' = sort3 M.compare p p1 p2 in match M.try_fusion p' p1' p2' with | Some _ -> true | None -> false let allows_fusion p1 p2 d = allows_momentum_fusion (label d) p1 p2 let rec thread_unfinished_decays' p acc tlist dlist = match first_pair (allows_fusion p) tlist dlist with | None -> (p, acc, tlist, dlist) | Some ((t, _ as td), (tlist', dlist')) -> thread_unfinished_decays' t (td :: acc) tlist' dlist' let thread_unfinished_decays p c = match thread_unfinished_decays' p [] c.t_channel c.decays with | _, pairs, [], [] -> pairs | _ -> failwith "thread_unfinished_decays" let rec combine_decays = function | [] -> [] | ((t, f as tf), d) :: rest -> let p, _ = label d in begin match M.try_sub t p with | Some p' -> (tf, d, (p', f)) :: combine_decays rest | None -> (tf, d, (M.sub (M.neg t) p, f)) :: combine_decays rest end let finalize t = map finalize1 t let of_momenta f1 f2 = function | (p, _) :: _ as l -> let n = M.dim p in finalize (combine_decays (thread_unfinished_decays (M.of_ints n [1], Some f1) (unfinished_decays_of_momenta n f2 l))) | [] -> [] (* \thocwmodulesubsection{Diagnostics} *) let p_to_string p = String.concat "" (List.map string_of_int (M.to_ints (M.abs p))) let rec to_string1 = function | Leaf p -> "(" ^ p_to_string p ^ ")" | Branch (_, d1, d2) -> "(" ^ to_string1 d1 ^ to_string1 d2 ^ ")" - let to_string ps = + let _to_string ps = String.concat "/" (List.map (fun (p1, d, p2) -> p_to_string p1 ^ to_string1 d ^ p_to_string p2) ps) (* \thocwmodulesubsection{Examples} *) let try_thread_unfinished_decays p c = thread_unfinished_decays' p [] c.t_channel c.decays - let try_of_momenta f = function + let _try_of_momenta f = function | (p, _) :: _ as l -> let n = M.dim p in try_thread_unfinished_decays (M.of_ints n [1], None) (unfinished_decays_of_momenta n f l) | [] -> invalid_arg "try_of_momenta" end (*i module M = Momentum.Lists module PS = Phasespace.Make (M) open PS let u n = List.map (fun p -> (M.of_ints n p, ())) let four_t = u 6 [[3;4]; [1;3;4]; [5;6]] let four_s = u 6 [[3;4;5;6]; [3;4]; [5;6]] let six_mp_1 = u 8 [[3;4]; [1;3;4]; [5;6]; [1;3;4;5;6]; [7;8]] let six_mp_2 = u 8 [[3;4]; [1;3;4]; [5;6]; [2;7;8]; [7;8]] let f = map (fun (p, ()) -> M.to_ints p) let four_t' = f (of_momenta () () four_t) let four_s' = f (of_momenta () () four_s) let six_mp_1' = f (of_momenta () () six_mp_1) let six_mp_2' = f (of_momenta () () six_mp_2) i*) - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/Makefile.sources =================================================================== --- trunk/omega/src/Makefile.sources (revision 8919) +++ trunk/omega/src/Makefile.sources (revision 8920) @@ -1,323 +1,324 @@ # Makefile.sources -- Makefile component for O'Mega ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2024 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 ORDERS_MLL = orders_lexer.mll ORDERS_MLY = orders_parser.mly ORDERS_MLD = $(ORDERS_MLL:.mll=.ml) $(ORDERS_MLY:.mly=.ml) ORDERS_ML_PRIMARY = orders_syntax.ml orders.ml ORDERS_ML = orders_syntax.ml $(ORDERS_MLD) orders.ml VERTEX_MLL = vertex_lexer.mll VERTEX_MLY = vertex_parser.mly VERTEX_MLD = $(VERTEX_MLL:.mll=.ml) $(VERTEX_MLY:.mly=.ml) VERTEX_ML_PRIMARY = vertex_syntax.ml vertex.ml VERTEX_ML = vertex_syntax.ml $(VERTEX_MLD) vertex.ml UFO_MLL = UFOx_lexer.mll UFO_lexer.mll UFO_MLY = UFOx_parser.mly UFO_parser.mly UFO_MLD = $(UFO_MLL:.mll=.ml) $(UFO_MLY:.mly=.ml) UFO_ML_PRIMARY = UFO_tools.ml UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml UFO_ML = UFO_tools.ml UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml OMEGA_MLL = $(CASCADE_MLL) $(ORDERS_MLL) $(VERTEX_MLL) $(UFO_MLL) OMEGA_MLY = $(CASCADE_MLY) $(ORDERS_MLY) $(VERTEX_MLY) $(UFO_MLY) OMEGA_DERIVED_CAML = \ $(OMEGA_MLL:.mll=.mli) $(OMEGA_MLL:.mll=.ml) \ $(OMEGA_MLY:.mly=.mli) $(OMEGA_MLY:.mly=.ml) -OMEGA_INTERFACES_MLI = \ - coupling.mli \ - model.mli \ - target.mli +OMEGA_INTERFACES_ML = \ + coupling.ml \ + model.ml \ + target.ml ######################################################################## # We need lists of all modules including and excluding derived # files (*_PRIMARY). Unfortunately, we need the longer list in # proper linking order, so we can't just tack the additional # files to the end of the shorter list. ######################################################################## # Derived from a *.ml.in, not to be distributed OMEGA_CONFIG_ML = \ config.ml OMEGA_CONFIG_MLI = $(OMEGA_CONFIG_ML:.ml=.mli) # Not used anymore: trie.ml OMEGA_CORE_ML_PART1 = \ OUnit.ml OUnitDiff.ml \ partial.ml pmap.ml format_Fortran.ml \ thoString.ml sets.ml NList.ml NEList.ml thoList.ml \ PArray.ml thoArray.ml thoMap.ml bundle.ml powSet.ml \ thoFilename.ml cache.ml progress.ml linalg.ml tree2.ml \ algebra.ml options.ml product.ml combinatorics.ml \ permutation.ml partition.ml tree.ml young.ml \ tuple.ml topology.ml DAG.ml momentum.ml phasespace.ml \ charges.ml arrow.ml birdtracks.ml SU3.ml \ color_Propagator.ml color_Fusion.ml color.ml \ modeltools.ml whizard.ml dirac.ml OMEGA_CORE_ML_PART2 = \ $(VERTEX_ML) $(UFO_ML) $(CASCADE_ML) $(ORDERS_ML) OMEGA_CORE_ML_PART2_PRIMARY = \ $(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY) $(ORDERS_ML_PRIMARY) OMEGA_CORE_ML_PART3 = \ colorize.ml orders.ml process.ml fusion.ml fusion_vintage.ml \ feynmp.ml omega.ml omega_cli.ml OMEGA_CORE_ML_PRIMARY = \ $(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2_PRIMARY) $(OMEGA_CORE_ML_PART3) OMEGA_CORE_ML = \ $(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2) $(OMEGA_CORE_ML_PART3) -OMEGA_CORE_MLI_PRIMARY = $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML_PRIMARY:.ml=.mli) -OMEGA_CORE_MLI = \ - $(OMEGA_CONFIG_MLI) $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML:.ml=.mli) +OMEGA_CORE_MLI_PRIMARY = $(OMEGA_CORE_ML_PRIMARY:.ml=.mli) +OMEGA_CORE_MLI = $(OMEGA_CONFIG_MLI) $(OMEGA_CORE_ML:.ml=.mli) OMEGA_MODELLIB_ML = \ modellib_SM.ml \ modellib_MSSM.ml \ modellib_NoH.ml \ modellib_NMSSM.ml \ modellib_PSSSM.ml \ modellib_BSM.ml \ modellib_WZW.ml \ modellib_Zprime.ml OMEGA_MODELLIB_MLI = $(OMEGA_MODELLIB_ML:.ml=.mli) OMEGA_TARGETLIB_ML = \ targets_Kmatrix.ml \ targets_Kmatrix_2.ml \ target_Fortran_Names.ml \ targets_vintage.ml \ target_Fortran.ml \ target_VM.ml \ targets.ml OMEGA_TARGETLIB_MLI = $(OMEGA_TARGETLIB_ML:.ml=.mli) ######################################################################## # The supported models: ######################################################################## OMEGA_MINIMAL_APPLICATIONS_ML = \ omega_QED.ml \ omega_QCD.ml \ omega_SM.ml OMEGA_APPLICATIONS_ML = \ omega3.ml \ omega_QED.ml \ omega_QED_VM.ml \ omega_QCD.ml \ omega_QCD_VM.ml \ omega_SM.ml \ omega_SM_VM.ml \ omega_SM_CKM.ml \ omega_SM_CKM_VM.ml \ omega_SM_ac.ml \ omega_SM_ac_CKM.ml \ omega_SM_dim6.ml \ omega_SM_top.ml \ omega_SM_top_anom.ml \ omega_SM_tt_threshold.ml \ omega_SM_Higgs.ml \ omega_SM_Higgs_VM.ml \ omega_SM_Higgs_CKM.ml \ omega_SM_Higgs_CKM_VM.ml \ omega_THDM.ml \ omega_THDM_VM.ml \ omega_THDM_CKM.ml \ omega_THDM_CKM_VM.ml \ omega_MSSM.ml \ omega_MSSM_CKM.ml \ omega_MSSM_Grav.ml \ omega_MSSM_Hgg.ml \ omega_NMSSM.ml \ omega_NMSSM_CKM.ml \ omega_NMSSM_Hgg.ml \ omega_PSSSM.ml \ omega_Littlest.ml \ omega_Littlest_Eta.ml \ omega_Littlest_Tpar.ml \ omega_Simplest.ml \ omega_Simplest_univ.ml \ omega_Xdim.ml \ omega_GravTest.ml \ omega_NoH_rx.ml \ omega_AltH.ml \ omega_SM_rx.ml \ omega_SM_ul.ml \ omega_SSC.ml \ omega_SSC_2.ml \ omega_SSC_AltT.ml \ omega_UED.ml \ omega_WZW.ml \ omega_Zprime.ml \ omega_Zprime_VM.ml \ omega_Threeshl.ml \ omega_Threeshl_nohf.ml \ omega_HSExt.ml \ omega_HSExt_VM.ml \ omega_Template.ml \ omega_SYM.ml \ omega_UFO.ml \ omega_UFO_Dirac.ml \ omega_UFO_Majorana.ml \ omega_SM_Majorana.ml \ omega_SM_Majorana_legacy.ml -OMEGA_CORE_CMO = $(OMEGA_CONFIG_ML:.ml=.cmo) $(OMEGA_CORE_ML:.ml=.cmo) +OMEGA_CORE_CMO = $(OMEGA_CONFIG_ML:.ml=.cmo) $(OMEGA_INTERFACES_ML:.ml=.cmo) $(OMEGA_CORE_ML:.ml=.cmo) OMEGA_CORE_CMX = $(OMEGA_CORE_CMO:.cmo=.cmx) OMEGA_TARGETS_CMO = $(OMEGA_TARGETLIB_ML:.ml=.cmo) OMEGA_TARGETS_CMX = $(OMEGA_TARGETLIB_ML:.ml=.cmx) OMEGA_MODELS_CMO = $(OMEGA_MODELLIB_ML:.ml=.cmo) OMEGA_MODELS_CMX = $(OMEGA_MODELLIB_ML:.ml=.cmx) OMEGA_APPLICATIONS_CMO = $(OMEGA_APPLICATIONS_ML:.ml=.cmo) OMEGA_APPLICATIONS_CMX = $(OMEGA_APPLICATIONS_ML:.ml=.cmx) OMEGA_APPLICATIONS_BYTECODE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT)) OMEGA_APPLICATIONS_NATIVE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT)) OMEGA_CACHES = $(OMEGA_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX)) OMEGA_MINIMAL_APPLICATIONS_BYTECODE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT)) OMEGA_MINIMAL_APPLICATIONS_NATIVE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT)) OMEGA_MINIMAL_CACHES = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX)) # Only primary sources, excluding generated parsers and lexers # (used for dependency generation) OMEGA_ML_PRIMARY = \ + $(OMEGA_INTERFACES_ML) \ $(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_INTERFACES_ML) \ $(OMEGA_CORE_ML) \ $(OMEGA_MODELLIB_ML) \ $(OMEGA_TARGETLIB_ML) \ $(OMEGA_APPLICATIONS_ML) OMEGA_MLI = \ $(OMEGA_CONFIG_MLI) \ $(OMEGA_CORE_MLI) \ $(OMEGA_MODELLIB_MLI) \ $(OMEGA_TARGETLIB_MLI) OMEGA_CAML = $(OMEGA_ML) $(OMEGA_MLI) $(OMEGA_MLL) $(OMEGA_MLY) $(OMEGA_DERIVED_CAML) ######################################################################## # # Fortran 90/95/2003 sources # ######################################################################## AM_FCFLAGS = ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif KINDS_F90 = kinds.f90 CONSTANTS_F90 = constants.f90 STRINGS_F90 = iso_varying_string.f90 OMEGA_PARAMETERS_F90 = # omega_parameters.f90 omega_parameters_madgraph.f90 OMEGALIB_DERIVED_F90 = \ omega_spinors.f90 omega_bispinors.f90 omega_vectors.f90 \ omega_vectorspinors.f90 omega_tensors.f90 \ omega_couplings.f90 omega_spinor_couplings.f90 omega_bispinor_couplings.f90 \ omega_polarizations.f90 omega_polarizations_madgraph.f90 \ omega_tensor_polarizations.f90 omega_vspinor_polarizations.f90 \ - omega_color.f90 omega_utils.f90 \ + omega_color.f90 omega_birdtracks.f90 omega_api_v3.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/model.ml =================================================================== --- trunk/omega/src/model.ml (revision 0) +++ trunk/omega/src/model.ml (revision 8920) @@ -0,0 +1,322 @@ +(* model.mli -- + + Copyright (C) 1999-2024 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{General Quantum Field Theories} *) + +module type T = + sig + +(* [flavor] abstractly encodes all quantum numbers. *) + type flavor + +(* [Color.t] encodes the ($\textrm{SU}(N)$) color representation. *) + val color : flavor -> Color.t + val nc : unit -> int + +(* The set of conserved charges. *) + module Ch : Charges.T + val charges : flavor -> Ch.t + +(* The PDG particle code for interfacing with Monte Carlos. *) + val pdg : flavor -> int + +(* The Lorentz representation of the particle. *) + val lorentz : flavor -> Coupling.lorentz + +(* The propagator for the particle, which \emph{can} depend + on a gauge parameter. *) + type gauge + val propagator : flavor -> gauge Coupling.propagator + +(* \emph{Not} the symbol for the numerical value, but the + scheme or strategy. *) + val width : flavor -> Coupling.width + +(* Charge conjugation, with and without color. *) + val conjugate : flavor -> flavor + +(* Returns $1$ for fermions, $-1$ for anti-fermions, $2$ for Majoranas + and $0$ otherwise. *) + val fermion : flavor -> int + +(* The Feynman rules. [vertices] and [(fuse2, fuse3, fusen)] are + redundant, of course. However, [vertices] is required for building + functors for models and [vertices] can be recovered from + [(fuse2, fuse3, fusen)] only at great cost. *) + +(* \begin{dubious} + Nevertheless: [vertices] is a candidate for removal, b/c we can + build a smarter [Colorize] functor acting on [(fuse2, fuse3, fusen)]. + It can support an arbitrary numer of color lines. But we have to test + whether it is efficient enough. And we have to make sure that this + wouldn't break the UFO interface. + \end{dubious} *) + type constant + + val max_degree : unit -> int + val vertices : unit -> + ((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list) + * (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list) + * (((flavor list) * constant Coupling.vertexn * constant) list)) + val fuse2 : flavor -> flavor -> (flavor * constant Coupling.t) list + val fuse3 : flavor -> flavor -> flavor -> (flavor * constant Coupling.t) list + val fuse : flavor list -> (flavor * constant Coupling.t) list + +(* For counting coupling orders. *) + type coupling_order + val all_coupling_orders : unit -> coupling_order list + val coupling_order_to_string : coupling_order -> string + val coupling_orders : constant -> (coupling_order * int) list + +(* The list of all known flavors. *) + val flavors : unit -> flavor list + +(* The flavors that can appear in incoming or outgoing states, grouped + in a way that is useful for user interfaces. *) + val external_flavors : unit -> (string * flavor list) list + +(* The Goldstone bosons corresponding to a gauge field, if any. *) + val goldstone : flavor -> (flavor * constant Coupling.expr) option + +(* The dependent parameters. *) + val parameters : unit -> constant Coupling.parameters + +(* Translate from and to convenient textual representations of flavors. *) + val flavor_of_string : string -> flavor + val flavor_to_string : flavor -> string + +(* \TeX{} and \LaTeX{} *) + val flavor_to_TeX : flavor -> string + +(* The following must return unique symbols that are acceptable as + symbols in all programming languages under consideration as targets. + Strings of alphanumeric characters (starting with a letter) should + be safe. Underscores are also usable, but would violate strict + Fortran77. *) + val flavor_symbol : flavor -> string + val gauge_symbol : gauge -> string + val mass_symbol : flavor -> string + val width_symbol : flavor -> string + val constant_symbol : constant -> string + +(* Model specific options. *) + val options : Options.t + +(* \textit{Not ready for prime time} or other warnings to + be written to the source files for the amplitudes. *) + + val caveats : unit -> string list + + end + +(* In addition to hardcoded models, we can have models that are + initialized at run time. *) + +(* \thocwmodulesection{Mutable Quantum Field Theories} *) + +module type Mutable = + sig + include T + +(* Pass initialization data to the model. Typically, + this is the name of a UFO directory and we can specialize + [Mutable with type init = string] *) + type init + val init : init -> unit + val write_whizard : out_channel -> unit + +(* Export only one big initialization function to discourage + partial initializations. Labels make this usable. *) + + val setup : + color:(flavor -> Color.t) -> + nc:(unit -> int) -> + pdg:(flavor -> int) -> + lorentz:(flavor -> Coupling.lorentz) -> + propagator:(flavor -> gauge Coupling.propagator) -> + width:(flavor -> Coupling.width) -> + goldstone:(flavor -> (flavor * constant Coupling.expr) option) -> + conjugate:(flavor -> flavor) -> + fermion:(flavor -> int) -> + vertices: + (unit -> + ((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list) + * (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list) + * (((flavor list) * constant Coupling.vertexn * constant) list))) -> + flavors:((string * flavor list) list) -> + parameters:(unit -> constant Coupling.parameters) -> + flavor_of_string:(string -> flavor) -> + flavor_to_string:(flavor -> string) -> + flavor_to_TeX:(flavor -> string) -> + flavor_symbol:(flavor -> string) -> + gauge_symbol:(gauge -> string) -> + mass_symbol:(flavor -> string) -> + width_symbol:(flavor -> string) -> + constant_symbol:(constant -> string) -> + all_coupling_orders:(unit -> coupling_order list) -> + coupling_order_to_string:(coupling_order -> string) -> + coupling_orders:(constant -> (coupling_order * int) list) -> + unit + end + +(* \thocwmodulesection{Gauge Field Theories} *) + +(* The following signatures are used only for model building. The diagrammatics + and numerics is supposed to be completely ignorant about the detail of the + models and expected to rely on the interface [T] exclusively. + \begin{dubious} + In the end, we might have functors [(M : T) -> Gauge], but we will + need to add the quantum numbers to [T]. + \end{dubious} *) + +module type Gauge = + sig + include T + +(* Matter field carry conserved quantum numbers and can be replicated + in generations without changing the gauge sector. *) + type matter_field + +(* Gauge bosons proper. *) + type gauge_boson + +(* Higgses, Goldstones and all the rest: *) + type other + +(* We can query the kind of field *) + type field = + | Matter of matter_field + | Gauge of gauge_boson + | Other of other + val field : flavor -> field + +(* and we can build new fields of a given kind: *) + val matter_field : matter_field -> flavor + val gauge_boson : gauge_boson -> flavor + val other : other -> flavor + end + +(* \thocwmodulesection{Gauge Field Theories with Broken Gauge Symmetries} *) + +(* Both are carefully crafted as subtypes of [Gauge] so that + they can be used in place of [Gauge] and [T] everywhere: *) + +module type Broken_Gauge = + sig + include Gauge + + type massless + type massive + type goldstone + + type kind = + | Massless of massless + | Massive of massive + | Goldstone of goldstone + val kind : gauge_boson -> kind + + val massless : massive -> gauge_boson + val massive : massive -> gauge_boson + val goldstone : goldstone -> gauge_boson + + end + +module type Unitarity_Gauge = + sig + include Gauge + + type massless + type massive + + type kind = + | Massless of massless + | Massive of massive + val kind : gauge_boson -> kind + + val massless : massive -> gauge_boson + val massive : massive -> gauge_boson + + end + +module type Colorized = + sig + + include T + + type flavor_sans_color + val flavor_sans_color : flavor -> flavor_sans_color + val conjugate_sans_color : flavor_sans_color -> flavor_sans_color + +(* [amplitude] does \emph{not} compute the amplitude, but + returns all possible color combinations for the given flavor. + These will be used by the functions in [Fusion]. *) + + val amplitude : flavor_sans_color list -> flavor_sans_color list -> + (flavor list * flavor list) list + val flow : flavor list -> flavor list -> Color.Flow.t + + val flavor_equal : flavor -> flavor -> bool + + end + +module type Colorized_Gauge = + sig + + include Gauge + + type flavor_sans_color + val flavor_sans_color : flavor -> flavor_sans_color + val conjugate_sans_color : flavor_sans_color -> flavor_sans_color + + val amplitude : flavor_sans_color list -> flavor_sans_color list -> + (flavor list * flavor list) list + val flow : flavor list -> flavor list -> Color.Flow.t + + val flavor_equal : flavor -> flavor -> bool + + end + +module type Sliced_by_Orders = + sig + + include Colorized + + type flavor_all_orders + val flavor_all_orders : flavor -> flavor_all_orders + val conjugate_all_orders : flavor_all_orders -> flavor_all_orders + + type orders + val orders : flavor -> orders + val add_orders : orders -> orders -> orders + val incr_orders : orders -> orders -> orders + val orders_to_string : orders -> string + val orders_symbol : orders -> string + + val trivial : flavor_all_orders -> flavor + + val amplitude : orders -> flavor_all_orders list -> flavor_all_orders list -> + flavor list * flavor list + val flow : flavor list -> flavor list -> Color.Flow.t + + end Index: trunk/omega/src/birdtracks.ml =================================================================== --- trunk/omega/src/birdtracks.ml (revision 8919) +++ trunk/omega/src/birdtracks.ml (revision 8920) @@ -1,794 +1,963 @@ (* birdtracks.ml -- Copyright (C) 2022-2023 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{Types} *) module QC = Algebra.QC module L = Algebra.Laurent module A = Arrow open A.Infix (* There can be one or more $\epsilon$ or $\bar\epsilon$, but not both at the same time. *) (* I wanted to use a GADT with Peano numerals to track the number of $\epsilon$ and $\bar\epsilon$ in the type system. However, I would have needed to implement a ``multiplication'' function of the type ['n1 term -> 'n2 term -> ('n1 + 'n2) term] that I have not been able to implement using Peano numerals for the type variables ['n1] and ['n2], due to the lack of an addition operator for Peano numerals in the type system. Therefore I will use normal lists, sacrificing some type safety. *) type 'a aterm = { coeff : L.t; arrows : 'a list } type ('a, 'e) eterm = 'a aterm * 'e NEList.t type ('a, 'b) bterm = 'a aterm * 'b NEList.t type ('a, 'e, 'b) term = | Arrows of 'a aterm | Epsilons of ('a, 'e) eterm | Epsilon_Bars of ('a, 'b) bterm (* \begin{dubious} Having already added type annotations for polymorphic recursion, I could use a simple GADT instead of an ADT at the toplevel, trying to maintain some unboxing potential: [ type ('a, 'e, 'b) term = | Arrows : 'a aterm -> ('a, 'e, 'b) term | Epsilons : ('a, 'e) eterm -> ('a, 'e, 'b) term | Epsilon_Bars : ('a, 'b) bterm -> ('a, 'e, 'b) term ] but it is not obvious that this produces a real performance benefit. \end{dubious} *) -type afree = A.free aterm -type efree = (A.free, A.free_eps) eterm -type bfree = (A.free, A.free_eps_bar) bterm +type _afree = A.free aterm +type _efree = (A.free, A.free_eps) eterm +type _bfree = (A.free, A.free_eps_bar) bterm type free = (A.free, A.free_eps, A.free_eps_bar) term type afactor = A.factor aterm type efactor = (A.factor, A.factor_eps) eterm type bfactor = (A.factor, A.factor_eps_bar) bterm type factor = (A.factor, A.factor_eps, A.factor_eps_bar) term type t = free list (* \thocwmodulesection{Functions} *) +let rev_aterm aterm = + { aterm with arrows = List.map A.rev aterm.arrows } + +let _rev1 = function + | Arrows a -> Arrows (rev_aterm a) + | Epsilons (a, e) -> Epsilon_Bars (rev_aterm a, NEList.map A.rev_eps e) + | Epsilon_Bars (a, b) -> Epsilons (rev_aterm a, NEList.map A.rev_eps_bar b) + +let aterm = function + | Arrows a | Epsilons (a, _) | Epsilon_Bars (a, _) -> a + +module ISet = Set.Make(Int) + +let adjoints1 = function + | Arrows a -> A.adjoints a.arrows + | Epsilons (a, e) -> A.adjoints_eps a.arrows e + | Epsilon_Bars (a, b) -> A.adjoints_eps_bar a.arrows b + +let adjoints term = + match List.map adjoints1 term with + | [] -> [] + | a :: _ as all -> + if ThoList.homogeneous all then + a + else + invalid_arg + ("Birdtracks.adjoints: inconsistent: " ^ + (ThoList.to_string (ThoList.to_string string_of_int) all)) + +let term_haunted term = + List.exists A.is_ghost (aterm term).arrows + +let haunted terms = + List.exists term_haunted terms + +let exorcise vertex = + List.filter (Fun.negate term_haunted) vertex + let tips_and_tails_of_aterm aterm = List.fold_left (fun (tips, tails) arrow -> (List.rev_append (A.tips arrow) tips, List.rev_append (A.tails arrow) tails)) ([], []) aterm.arrows let tips_and_tails_raw : free -> A.tip list * A.tail list = function | Arrows aterm -> tips_and_tails_of_aterm aterm | Epsilons (aterm, epsilons) -> let tips, tails = tips_and_tails_of_aterm aterm in (List.concat (tips :: NEList.to_list epsilons), tails) | Epsilon_Bars (aterm, epsilon_bars) -> let tips, tails = tips_and_tails_of_aterm aterm in (tips, List.concat (tails :: NEList.to_list epsilon_bars)) -let tips_and_tails term = +let _tips_and_tails term = let tips, tails = tips_and_tails_raw term in (List.sort compare tips, List.sort compare tails) (* Expressions *) let const coeff = [ Arrows { coeff; arrows = [] } ] let ints pairs = const (L.ints pairs) let null = const L.null let fraction n = const (L.fraction n) -let one = const (L.int 1) +let one = const L.unit let two = const (L.int 2) let minus = const (L.int (-1)) let int n = const (L.int n) let nc = const (L.nc 1) let over_nc = const (L.ints [(1, -1)]) let imag = const (L.imag 1) module AMap = Pmap.Tree let psort alist = List.sort compare alist let ne_psort alist = NEList.sort compare alist let find_term_opt term map = AMap.find_opt compare term map let map_aterm fc fa aterm = { coeff = fc aterm.coeff; arrows = fa aterm.arrows } -let map_term fc fa fe fb = function +let map_term_full fc fa fe fb = function | Arrows aterm -> Arrows (map_aterm fc fa aterm) | Epsilons (aterm, elist) -> Epsilons (map_aterm fc fa aterm, fe elist) | Epsilon_Bars (aterm, blist) -> Epsilon_Bars (map_aterm fc fa aterm, fb blist) let map_term_deep fc fa fe fb term = - map_term fc (List.map fa) (NEList.map fe) (NEList.map fb) term + map_term_full fc (List.map fa) (NEList.map fe) (NEList.map fb) term -let canonicalize_aterm term = +let map_term f = function + | Arrows a -> Arrows (f a) + | Epsilons (a, e) -> Epsilons (f a, e) + | Epsilon_Bars (a, b) -> Epsilon_Bars (f a, b) + +let map_term_opt f = function + | Arrows a -> + begin match f a with + | None -> None + | Some arrows -> Some (Arrows arrows) + end + | Epsilons (a, e) -> + begin match f a with + | None -> None + | Some arrows -> Some (Epsilons (arrows, e)) + end + | Epsilon_Bars (a, b) -> + begin match f a with + | None -> None + | Some arrows -> Some (Epsilon_Bars (arrows, b)) + end + +let _canonicalize_aterm term = map_aterm Fun.id psort term (* \begin{dubious} We're \emph{not yet} canonicalizing the $\epsilon$ and $\bar\epsilon$ themselves. This could be done, if necessary, using [Combinatorics.sort_signed] to keep track of the signs. While we're debugging, it could be beneficial to keep the indices where they are. \end{dubious} *) let canonicalize_term : type a e b. (a, e, b) term -> (a, e, b) term = fun term -> - map_term Fun.id psort ne_psort ne_psort term + map_term_full Fun.id psort ne_psort ne_psort term let split_coeff : type a e b. (a, e, b) term -> L.t * (a, e, b) term = function - | Arrows aterm -> (aterm.coeff, Arrows { aterm with coeff = L.int 1 }) + | Arrows aterm -> (aterm.coeff, Arrows { aterm with coeff = L.unit }) | Epsilons (aterm, epsilons) -> - (aterm.coeff, Epsilons ({ aterm with coeff = L.int 1 }, epsilons)) + (aterm.coeff, Epsilons ({ aterm with coeff = L.unit }, epsilons)) | Epsilon_Bars (aterm, epsilon_bars) -> - (aterm.coeff, Epsilon_Bars ({ aterm with coeff = L.int 1 }, epsilon_bars)) + (aterm.coeff, Epsilon_Bars ({ aterm with coeff = L.unit }, epsilon_bars)) let inject_coeff : type a e b. L.t -> (a, e, b) term -> (a, e, b) term = - fun coeff -> map_term (fun _ -> coeff) Fun.id Fun.id Fun.id + fun coeff -> map_term_full (fun _ -> coeff) Fun.id Fun.id Fun.id (* \begin{dubious} Note that the final result must be a homogeneous list with all elements containing the same number of $\epsilon$ and $\bar\epsilon$, because otherwise the number of incoming and outgoing color lince would not match. Nevertheless, we might have to work very hard to avoid too much code duplication. \end{dubious} *) let canonicalize : type a e b. (a, e, b) term list -> (a, e, b) term list = fun terms -> let map = List.fold_left (fun acc term -> let coeff, term = split_coeff (canonicalize_term term) in if L.is_null coeff then acc else match find_term_opt term acc with | None -> AMap.add compare term coeff acc | Some coeff' -> let coeff'' = L.add coeff coeff' in if L.is_null coeff'' then AMap.remove compare term acc else AMap.add compare term coeff'' acc) AMap.empty terms in if AMap.is_empty map then [] else AMap.fold (fun term coeff acc -> inject_coeff coeff term :: acc) map [] let number v = match canonicalize v with | [] -> Some L.null | [Arrows { coeff; arrows = [] }] -> Some coeff | _ -> None let is_null v = match canonicalize v with | [] -> true | _ -> false let is_unit v = match canonicalize v with | [Arrows { coeff; arrows = [] }] -> coeff = L.unit | _ -> false let with_nc nc t = let substitute c = L.const (L.eval (QC.int nc) c) in - canonicalize (List.map (map_term substitute Fun.id Fun.id Fun.id) t) + canonicalize (List.map (map_term_full substitute Fun.id Fun.id Fun.id) t) let aterm_to_string f term = match term.arrows with | [] -> Printf.sprintf "(%s)" (L.to_string "N" term.coeff) | arrows -> Printf.sprintf "(%s) * %s" (L.to_string "N" term.coeff) (ThoList.to_string f arrows) let to_string1_aux fa fe fb = function | Arrows aterm -> aterm_to_string fa aterm | Epsilons (aterm, epsilons) -> aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fe (NEList.to_list epsilons) | Epsilon_Bars (aterm, epsilon_bars) -> aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fb (NEList.to_list epsilon_bars) let to_string1 term = to_string1_aux A.free_to_string A.free_eps_to_string A.free_eps_bar_to_string term let to_string_raw terms = ThoList.to_string to_string1 terms let to_string terms = to_string_raw (canonicalize terms) (*i let trivial terms = let result = trivial terms in Printf.eprintf "trivial %s -> %b\n" (to_string terms) result; trivial terms i*) let pp fmt v = Format.fprintf fmt "%s" (to_string v) let relocate1 f term = map_term_deep Fun.id (A.relocate f) (List.map (A.relocate_tip f)) (List.map (A.relocate_tail f)) term let relocate f = List.map (relocate1 f) let rev_aterm aterm = { aterm with arrows = List.map A.rev aterm.arrows } let rev1 = function | Arrows aterm -> Arrows (rev_aterm aterm) | Epsilons (aterm, elist) -> Epsilon_Bars (rev_aterm aterm, NEList.map A.rev_eps elist) | Epsilon_Bars (aterm, blist) -> Epsilons (rev_aterm aterm, NEList.map A.rev_eps_bar blist) let rev = List.map rev1 -let of_afactor aterm = +let _of_afactor aterm = map_aterm Fun.id (List.map A.of_factor) aterm let of_factor term = map_term_deep Fun.id A.of_factor A.of_factor_eps A.of_factor_eps_bar term let to_left_factor is_sum term = map_term_deep Fun.id (A.to_left_factor is_sum) (A.to_left_factor_eps is_sum) (A.to_left_factor_eps_bar is_sum) term let to_right_factor is_sum term = map_term_deep Fun.id (A.to_right_factor is_sum) (A.to_right_factor_eps is_sum) (A.to_right_factor_eps_bar is_sum) term (* We start with the simply recursive evaluation functions, leaving the the more complicated mutually recursive functions for later. *) (* Add one [arrow] to a list of arrows, updating [coeff] if necessary. Accumulate already processed arrows in [seen]. Returns [None] if there is a mismatch (a gluon meeting a ghost) and [Some afactor] containing a coefficient and a list of arrows otherwise. *) (* We assume that the trivial cases of no summation indices and the arrow looping back to itself have already been filtered out. *) (* \label{pg:add_arrow} *) let rec add_arrow_to_arrows_list' coeff seen arrow = function | [] -> (* visited all [arrows]: no opportunities for further matches *) Some ({ coeff; arrows = arrow :: seen }) | arrow' :: arrows' -> begin match A.merge_arrow_arrow arrow arrow' with | A.Mismatch -> None | A.Ghost_Match -> (* replace matching ghosts by $-1/N_C$ *) Some ({ coeff = L.mul (L.over_nc (-1)) coeff; arrows = List.rev_append seen arrows' }) | A.Loop_Match -> (* replace a loop by $N_C$ *) Some ({ coeff = L.mul (L.nc 1) coeff; arrows = List.rev_append seen arrows' }) | A.Match arrow'' -> (* two arrows have been merged into one *) if A.is_free arrow'' then (* no opportunities for further matches *) Some ({ coeff; arrows = arrow'' :: List.rev_append seen arrows' }) else (* the new [arrow''] ist not yet saturated, try again: *) add_arrow_to_arrows_list' coeff seen arrow'' arrows' | A.No_Match -> (* recurse to the remaining arrows *) add_arrow_to_arrows_list' coeff (arrow' :: seen) arrow arrows' end let add_arrow_to_arrows_list coeff arrow arrows = add_arrow_to_arrows_list' coeff [] arrow arrows (* Similarly, add one [arrow] to a list of $\epsilon$ and accumulate already processed arrows in [seen]. Returns [[]] if there is no match. Note that there is never the need to update the coefficient and that only the tail of the [arrow] can match. *) let rec add_arrow_to_epsilon_list' seen arrow = function | [] -> [] | epsilon :: epsilons -> begin match A.merge_arrow_eps arrow epsilon with | A.Mismatch_Eps -> [] | A.Match_Eps epsilon' -> List.rev_append seen (epsilon' :: epsilons) | A.No_Match_Eps -> add_arrow_to_epsilon_list' (epsilon :: seen) arrow epsilons end let add_arrow_to_epsilon_list arrow epsilons = add_arrow_to_epsilon_list' [] arrow epsilons (* Same preocedure for adding one [arrow] to a list of $\bar\epsilon$. *) let rec add_arrow_to_epsilon_bar_list' seen arrow = function | [] -> [] | epsilon_bar :: epsilon_bars -> begin match A.merge_arrow_eps_bar arrow epsilon_bar with | A.Mismatch_Eps -> [] | A.Match_Eps epsilon_bar' -> List.rev_append seen (epsilon_bar' :: epsilon_bars) | A.No_Match_Eps -> add_arrow_to_epsilon_bar_list' (epsilon_bar :: seen) arrow epsilon_bars end let add_arrow_to_epsilon_bar_list arrow epsilon_bars = add_arrow_to_epsilon_bar_list' [] arrow epsilon_bars (* Avoid a recursion, if there is no summation index in [arrow]. Likewise, if [arrow] loops back to itself, just replace it by a factor of~$N_C$. *) let add_arrow_to_aterm_trivial : A.factor -> afactor -> afactor option = fun arrow term -> if A.is_free arrow then Some ({ coeff = term.coeff; arrows = arrow :: term.arrows }) else if A.is_tadpole arrow then Some ({ coeff = L.mul (L.nc 1) term.coeff; arrows = term.arrows }) else None (* Straightforwardly add an arrow or an arrow list to a term containing no $\epsilon$ or $\bar\epsilon$, using the functions implemented above. *) let add_arrow_to_aterm : A.factor -> afactor -> afactor option = fun arrow term -> match add_arrow_to_aterm_trivial arrow term with | None -> add_arrow_to_arrows_list term.coeff arrow term.arrows | term_opt -> term_opt let add_arrow_list_to_aterm : A.factor list -> afactor -> afactor option = fun arrows term -> ThoList.fold_left_opt (Fun.flip add_arrow_to_aterm) term arrows (* Adding an arrow or an arrow list to a term containing $\epsilon$ or $\bar\epsilon$ is not more complicated, we only have to make two attempts. *) (* \begin{dubious} Caveat: if the arrow matches one of the $\epsilon$s and this $\epsilon$ has a tip appearing among the remaining tips of this $\epsilon$, the result should be set to zero explicitelty. But such expressions are illegal anyway! \end{dubious} *) let add_arrow_to_eterm : A.factor -> efactor -> efactor option = fun arrow (aterm, epsilons) -> match add_arrow_to_aterm_trivial arrow aterm with | Some aterm -> Some (aterm, epsilons) | None -> begin match add_arrow_to_epsilon_list arrow (NEList.to_list epsilons) with | [] -> begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with | None -> None | Some aterm -> Some (aterm, epsilons) end | epsilon :: epsilons -> Some (aterm, NEList.make epsilon epsilons) end let add_arrow_list_to_eterm : A.factor list -> efactor -> efactor option = fun arrows term -> ThoList.fold_left_opt (Fun.flip add_arrow_to_eterm) term arrows let add_arrow_to_bterm : A.factor -> bfactor -> bfactor option = fun arrow (aterm, epsilon_bars) -> match add_arrow_to_aterm_trivial arrow aterm with | Some aterm -> Some (aterm, epsilon_bars) | None -> begin match add_arrow_to_epsilon_bar_list arrow (NEList.to_list epsilon_bars) with | [] -> begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with | None -> None | Some aterm -> Some (aterm, epsilon_bars) end | epsilon_bar :: epsilon_bars -> Some (aterm, NEList.make epsilon_bar epsilon_bars) end let add_arrow_list_to_bterm : A.factor list -> bfactor -> bfactor option = fun arrows term -> ThoList.fold_left_opt (Fun.flip add_arrow_to_bterm) term arrows (* Adding an $\epsilon$ to a term containing $\epsilon$s is trivial, if there are no summation indices. Otherwise, we add the arrows back in to find matches. \begin{dubious} Here's potential for optimization, since the arrows can only match the new $\epsilon$. \end{dubious} *) let add_epsilon_to_eterm : A.factor_eps -> efactor -> efactor option = fun epsilon (aterm, epsilons) -> if A.is_free_eps epsilon then Some (aterm, NEList.cons epsilon epsilons) else let coeff = { coeff = aterm.coeff; arrows = []} in add_arrow_list_to_eterm aterm.arrows (coeff, NEList.cons epsilon epsilons) let add_epsilon_list_to_eterm : A.factor_eps list -> efactor -> efactor option = fun epsilons eterm -> ThoList.fold_left_opt (Fun.flip add_epsilon_to_eterm) eterm epsilons (* Once more for $\bar\epsilon$. *) let add_epsilon_bar_to_bterm : A.factor_eps_bar -> bfactor -> bfactor option = fun epsilon_bar (aterm, epsilon_bars) -> if A.is_free_eps_bar epsilon_bar then Some (aterm, NEList.cons epsilon_bar epsilon_bars) else let coeff = { coeff = aterm.coeff; arrows = []} in add_arrow_list_to_bterm aterm.arrows (coeff, NEList.cons epsilon_bar epsilon_bars) let add_epsilon_bar_list_to_bterm : A.factor_eps_bar list -> bfactor -> bfactor option = fun epsilon_bars bterm -> ThoList.fold_left_opt (Fun.flip add_epsilon_bar_to_bterm) bterm epsilon_bars (* Here we simply have to select the correct function. *) let add_arrow_to_term : A.factor -> factor -> factor option = fun arrow -> function | Arrows aterm -> Option.map (fun a -> Arrows a) (add_arrow_to_aterm arrow aterm) | Epsilons eterm -> Option.map (fun e -> Epsilons e) (add_arrow_to_eterm arrow eterm) | Epsilon_Bars bterm -> Option.map (fun b -> Epsilon_Bars b) (add_arrow_to_bterm arrow bterm) let add_arrow_list_to_term : A.factor list -> factor -> factor option = fun arrows term -> ThoList.fold_left_opt (Fun.flip add_arrow_to_term) term arrows let scale_aterm : L.t -> afactor -> afactor = fun coeff aterm -> { coeff = L.mul coeff aterm.coeff; arrows = aterm.arrows} let scale_eterm : L.t -> efactor -> efactor = fun coeff (aterm, epsilons) -> (scale_aterm coeff aterm, epsilons) let scale_bterm : L.t -> bfactor -> bfactor = fun coeff (aterm, epsilon_bars) -> (scale_aterm coeff aterm, epsilon_bars) let scale_term : L.t -> factor -> factor = fun coeff -> function | Arrows aterm -> Arrows (scale_aterm coeff aterm) | Epsilons eterm -> Epsilons (scale_eterm coeff eterm) | Epsilon_Bars bterm -> Epsilon_Bars (scale_bterm coeff bterm) let aterm_times_aterm : afactor -> afactor -> afactor option = fun aterm1 aterm2 -> Option.map (scale_aterm aterm1.coeff) (add_arrow_list_to_aterm aterm1.arrows aterm2) (* Almost the same as [aterm_times_term] below, but the arguments are exchanged an the result are [factor]s and not [free]. *) let term_times_aterm : factor -> afactor -> factor list = fun term aterm -> match add_arrow_list_to_term aterm.arrows term with | None -> [] | Some factor -> [scale_term aterm.coeff factor] (* The return type is [factor list], because adding a product of~$\epsilon$ and~$\bar\epsilon$ will produce a sum of terms and the result can be a [afactor], [efactor] or [bfactor] depending on the number of~$\epsilon$s and~$\bar\epsilon$s in the arguments. *) (* \begin{dubious} Add more tests for multiple $\epsilon$ and $\bar\epsilon$! I'm not yet convinced only from playing with the toplevel. \end{dubious} *) (* \begin{dubious} Calling [aterm_times_aterm] in each recursion step and only using the last result ist wasteful. Find a better way! \end{dubious} *) (* \begin{dubious} This would fail if one of [epsilons] or [epsilon_bars] is empty (which does not happen). We could try to replace the ['e list] in [type ('a, 'e) eterm] by a non empty list type (and similarly for ['e list] in [type ('a, 'b) bterm]. But is it worth the effort? It probably enough to hide the list in a [private] ADT that can be deconstructed, but requires a smart constructor that requires at least one element. \end{dubious} *) let rec match_eterm_and_bterm : efactor -> bfactor -> factor list = fun (aterm1, epsilons) (aterm2, epsilon_bars) -> match NEList.snoc_opt epsilons, NEList.snoc_opt epsilon_bars with | (epsilon, epsilons_opt), (epsilon_bar, epsilon_bars_opt) -> begin match aterm_times_aterm aterm1 aterm2 with | None -> [] | Some aterm -> match A.merge_eps_eps_bar epsilon epsilon_bar with | None -> [] | Some (even, odd) -> let even = List.rev_map (fun arrows -> { coeff = L.unit; arrows }) even and odd = List.rev_map (fun arrows -> { coeff = L.neg L.unit; arrows }) odd in let terms = match epsilons_opt, epsilon_bars_opt with | None, None -> [Arrows aterm] | Some epsilons, None-> [Epsilons (aterm, epsilons)] | None, Some epsilon_bars-> [Epsilon_Bars (aterm, epsilon_bars)] | Some epsilon, Some epsilon_bars -> match_eterm_and_bterm (aterm1, epsilon) (aterm2, epsilon_bars) in Product.fold2 (fun term aterm acc -> List.rev_append (term_times_aterm term aterm) acc) terms (List.rev_append even odd) [] end (* NB: we can reject the contributions with unsaturated summation indices from Ghost contributions to~$T_a$ only \emph{after} adding all arrows that might saturate an open index. *) (* Note that a negative index might be summed only later in a sequence of binary products and must therefore be treated as free in this product. Therefore, we have to classify the indices as summation indices \emph{not only} based on their sign, but in addition based on whether they appear in both factors. Only then can we reject surviving ghosts. *) module ESet = Set.Make (struct type t = A.endpoint let compare = compare end) let negatives_arrows arrows acc = List.fold_right (fun a -> List.fold_right ESet.add (A.negatives a)) arrows acc let negatives_eps epsilons acc = NEList.fold_right (fun e -> List.fold_right ESet.add (A.negatives_eps e)) epsilons acc let negatives_eps_bar epsilon_bars acc = NEList.fold_right (fun b -> List.fold_right ESet.add (A.negatives_eps_bar b)) epsilon_bars acc let negatives = function | Arrows aterm -> negatives_arrows aterm.arrows ESet.empty | Epsilons (aterm, epsilons) -> negatives_eps epsilons (negatives_arrows aterm.arrows ESet.empty) | Epsilon_Bars (aterm, epsilon_bars) -> negatives_eps_bar epsilon_bars (negatives_arrows aterm.arrows ESet.empty) let aterm_times_term : afactor -> factor -> free list = fun aterm term -> match add_arrow_list_to_term aterm.arrows term with | None -> [] | Some factor -> [of_factor (scale_term aterm.coeff factor)] let eterm_times_eterm : efactor -> efactor -> free list = fun (aterm, epsilons) eterm -> match add_epsilon_list_to_eterm (NEList.to_list epsilons) eterm with | None -> [] | Some factor -> begin match add_arrow_list_to_eterm aterm.arrows factor with | None -> [] | Some factor -> [of_factor (Epsilons (scale_eterm aterm.coeff factor))] end let bterm_times_bterm : bfactor -> bfactor -> free list = fun (aterm, epsilon_bars) bterm -> match add_epsilon_bar_list_to_bterm (NEList.to_list epsilon_bars) bterm with | None -> [] | Some factor -> begin match add_arrow_list_to_bterm aterm.arrows factor with | None -> [] | Some factor -> [of_factor (Epsilon_Bars (scale_bterm aterm.coeff factor))] end let eterm_times_bterm : efactor -> bfactor -> free list = fun eterm bterm -> List.map of_factor (match_eterm_and_bterm eterm bterm) let times1 term1 term2 = let summations = ESet.inter (negatives term1) (negatives term2) in let is_sum i = ESet.mem i summations in match to_left_factor is_sum term1, to_right_factor is_sum term2 with | Arrows aterm, factor | factor, Arrows aterm -> aterm_times_term aterm factor | Epsilons eterm1, Epsilons eterm2 -> eterm_times_eterm eterm1 eterm2 | Epsilon_Bars bterm1, Epsilon_Bars bterm2 -> bterm_times_bterm bterm1 bterm2 | Epsilons eterm, Epsilon_Bars bterm | Epsilon_Bars bterm, Epsilons eterm -> eterm_times_bterm eterm bterm let sum terms = canonicalize (List.concat terms) let times term term' = canonicalize (Product.fold2 (fun x y -> List.rev_append (times1 x y)) term term' []) (* \begin{dubious} Is that more efficient than the following implementation? \end{dubious} *) (*i let rec multiply1' acc = function | [] -> [acc] | factor :: factors -> List.fold_right multiply1' (times1 acc factor) factors let multiply1 = function | [] -> [(L.unit, [])] | [factor] -> [factor] | factor :: factors -> multiply1' factor factors let multiply terms = canonicalize (Product.fold (fun x -> List.rev_append (multiply1 x)) terms []) i*) (* \begin{dubious} Isn't that the more straightforward implementation? \end{dubious} *) let multiply = function | [] -> [] | term :: terms -> canonicalize (List.fold_left times term terms) let scale1 : type a e b. L.c -> (a, e, b) term -> (a, e, b) term = fun q term -> - map_term (L.scale q) Fun.id Fun.id Fun.id term + map_term_full (L.scale q) Fun.id Fun.id Fun.id term let scale q = List.map (scale1 q) let diff term1 term2 = canonicalize (List.rev_append term1 (scale (QC.int (-1)) term2)) module Infix = struct let ( +++ ) term term' = sum [term; term'] let ( --- ) = diff let ( *** ) = times end open Infix +let is_multiple1 x y = + match x, y with + | Arrows x, Arrows y -> + if x.arrows = y.arrows then + Some (x.coeff, y.coeff) + else + None + | Epsilons (x, xe), Epsilons (y, ye) -> + if x.arrows = y.arrows && xe = ye then + Some (x.coeff, y.coeff) + else + None + | Epsilon_Bars (x, xb), Epsilon_Bars (y, yb) -> + if x.arrows = y.arrows && xb = yb then + Some (x.coeff, y.coeff) + else + None + | Arrows _, (Epsilons _ | Epsilon_Bars _) | (Epsilons _ | Epsilon_Bars _), Arrows _ + | Epsilons _, Epsilon_Bars _ | Epsilon_Bars _, Epsilons _ -> None + +(* \begin{dubious} + The following is not the most efficient way to implement [is_multiple]. + Multiplying all terms by the coefficients avoids having to compute + a gcd in [is_multiple1], but gives up the opportunity of an early exit + at the first mismatch. + \end{dubious} *) + +let _is_multiple x y = + match canonicalize x, canonicalize y with + | [], [] -> Some (L.unit, L.unit) + | [], _ | _, [] -> None + | x1 :: xtail, y1 :: ytail -> + begin match is_multiple1 x1 y1 with + | None -> None + | Some (xc, yc) as result -> + if const yc *** xtail = const xc *** ytail then + result + else + None + end + +(* This should be more efficient: *) + +let rec tail_is_multiple xc yc x y = + match x, y with + | [], [] -> true + | [], _ | _, [] -> false + | x1 :: xtail, y1 :: ytail -> + begin match is_multiple1 x1 y1 with + | None -> false + | Some (x1c, y1c) -> + if L.equal (L.product [yc; x1c]) (L.product [xc; y1c]) then + tail_is_multiple xc yc xtail ytail + else + false + end + +let is_multiple x y = + match canonicalize x, canonicalize y with + | [], [] -> Some (L.unit, L.unit) + | [], _ | _, [] -> None + | x1 :: xtail, y1 :: ytail -> + begin match is_multiple1 x1 y1 with + | None -> None + | Some (xc, yc) as result -> + if tail_is_multiple xc yc xtail ytail then + result + else + None + end + (* Compute $ \tr(r(T_a) r(T_b) r(T_c)) $. NB: this uses the summation indices $-1$, $-2$ and $-3$. Therefore it \emph{must not} appear unevaluated more than once in a product! *) let trace3 r a b c = r a (-1) (-2) *** r b (-2) (-3) *** r c (-3) (-1) let f_of_rep r a b c = minus *** imag *** (trace3 r a b c --- trace3 r a c b) (* $ d_{abc} = \tr(r(T_a) [r(T_b), r(T_c)]_+) $ *) let d_of_rep r a b c = trace3 r a b c +++ trace3 r a c b (* \thocwmodulesection{Unit Tests} *) let vertices_equal v1 v2 = is_null (v1 --- v2) let assert_zero_vertex v = OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal null v (* As an extra protection agains vacuous tests, we make sure that the LHS does not vanish. *) let equal v1 v2 = OUnit.assert_bool "LHS = 0" (not (is_null v1)); OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal v1 v2 module Test = struct open OUnit let vertices_equal v1 v2 = (canonicalize v1) = (canonicalize v2) let eq v1 v2 = assert_equal ~printer:to_string_raw ~cmp:vertices_equal v1 v2 let suite_times1 = "times1" >::: [ "merge two" >:: (fun () -> eq [Arrows { coeff = L.unit; arrows = 1 ==> 2 }] (times1 (Arrows { coeff = L.unit; arrows = 1 ==> -1 }) (Arrows { coeff = L.unit; arrows = -1 ==> 2 }))); "merge two exchanged" >:: (fun () -> eq [Arrows { coeff = L.unit; arrows = 1 ==> 2 }] (times1 (Arrows { coeff = L.unit; arrows = -1 ==> 2 }) (Arrows { coeff = L.unit; arrows = 1 ==> -1 }))); "ghost1" >:: (fun () -> eq [Arrows { coeff = L.over_nc (-1); arrows = 1 ==> 2 }] (times1 (Arrows { coeff = L.unit; arrows = [-1 => 2; ?? (-3)] }) (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] }))); "ghost2" >:: (fun () -> eq [] (times1 (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] }) (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] }))); "ghost2 exchanged" >:: (fun () -> eq [] (times1 (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] }) (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] }))) ] let suite_canonicalize = "canonicalize" >::: [ ] + let multiple_to_string = function + | None -> "None" + | Some (x, y) -> Printf.sprintf "Some (%s, %s)" (L.to_string "N" x) (L.to_string "N" y) + + let assert_equal_multiple x y = + assert_equal ~printer:multiple_to_string x y + + let suite_is_multiple = + "is_multiple" >::: + + [ "1 // 2" >:: + (fun () -> + assert_equal_multiple (Some (L.unit, L.int 2)) (is_multiple one two)); + + "1 => 2 // 2 (1 => 2)" >:: + (fun () -> + assert_equal_multiple (Some (L.unit, L.int 2)) + (is_multiple + [Arrows { coeff = L.unit; arrows = [ 1 => 2 ] }] + [Arrows { coeff = L.int 2; arrows = [ 1 => 2 ] }] )); + + "1 => 2 // 2 (3 => 4)" >:: + (fun () -> + assert_equal_multiple None + (is_multiple + [Arrows { coeff = L.unit; arrows = [ 1 => 2 ] }] + [Arrows { coeff = L.int 2; arrows = [ 3 => 4 ] }] )); + + "1 / 2 N" >:: + (fun () -> + assert_equal_multiple (Some (L.unit, L.nc 2)) + (is_multiple + [Arrows { coeff = L.unit; arrows = [ 1 => 2; 3 => 4 ] }; + Arrows { coeff = L.over_nc (-1); arrows = [ 1 => 4; 3 => 2 ] }] + [Arrows { coeff = L.nc 2; arrows = [ 1 => 2; 3 => 4 ] }; + Arrows { coeff = L.int (-2); arrows = [ 1 => 4; 3 => 2 ] }] )) ] + let suite = "Birdtracks" >::: [suite_times1; - suite_canonicalize] + suite_canonicalize; + suite_is_multiple] let suite_long = "Birdtracks long" >::: [] end Index: trunk/omega/src/arrow.mli =================================================================== --- trunk/omega/src/arrow.mli (revision 8919) +++ trunk/omega/src/arrow.mli (revision 8920) @@ -1,237 +1,290 @@ (* arrow.mli -- Copyright (C) 2022-2024 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 datatypes [Arrow.free] and [Arrow.factor] will be used as building blocks for [Birdtracks.t] below. *) (* For fundamental and adjoint representations, the endpoints of arrows are uniquely specified by a vertex (which will be represented by a number). For representations with more than one outgoing or incoming arrow, we need an additional index. This is abstracted in the [endpoint] type. *) type endpoint = private | I of int | M of int * int +(* Provide a canonical ordering of endpoints: *) +val compare_endpoints : endpoint -> endpoint -> int + (* Endpoints can be the the tip or tail of an arrow or a ghost. Using incompatible types for each forces us to export three identical copies of some functions, but should help to avoid some simple mistakes, in which tips and tails are confused. *) type tip = private endpoint type tail = private endpoint type ghost = private endpoint +(* Type safe aliases for [compare_endpoints]. *) +val compare_tips : tip -> tip -> int +val compare_tails : tail -> tail -> int +val compare_ghosts : ghost -> ghost -> int + (* The position of the endpoint is encoded as an integer, which can be mapped, if necessary. *) val position_tip : tip -> int val position_tail : tail -> int val position_ghost : ghost -> int val relocate_tip : (int -> int) -> tip -> tip val relocate_tail : (int -> int) -> tail -> tail val relocate_ghost : (int -> int) -> tail -> tail (* An [Arrow.t] is either a genuine arrow or a ghost. The rationale for the polymorphic definition is explained below. *) type ('tail, 'tip, 'ghost) t = | Arrow of 'tail * 'tip | Ghost of 'ghost (* $\epsilon_{i_1i_2\cdots i_n}$ and $\bar\epsilon^{i_1i_2\cdots i_n}$ are represented by lists~$\lbrack i_1; i_2; \ldots; i_n \rbrack$. *) type 'tip eps = 'tip list type 'tail eps_bar = 'tail list -(* We distuish [free] arrows, $\epsilon$s and $\bar\epsilon$s +(* We distinguish [free] arrows, $\epsilon$s and $\bar\epsilon$s that must not contain summation indices from [factor]s that may. Indices are opaque. [('tail, 'tip, 'ghost) t] has been defined polymorphic above so that we can use richer ['tail], ['tip] and ['ghost] in [factor] to identify summation indices. Not that it is \emph{not} enough to identify summation indices by negative integers alone. Due to the presence of double arrows representing gluons, we must distinguish summation indices in the left factor of a product from those in the right factor. *) type free = (tail, tip, ghost) t type free_eps = tip eps type free_eps_bar = tail eps_bar type factor type factor_eps type factor_eps_bar +val epsilon : tip list -> free_eps +val epsilon_bar : tail list -> free_eps_bar + val relocate : (int -> int) -> free -> free val rev : free -> free val rev_eps : free_eps -> free_eps_bar val rev_eps_bar : free_eps_bar -> free_eps (* Useful for testing compatibility when adding terms. *) val tips : free -> tip list val tips_eps : free_eps -> tip list val tails : free -> tail list val tails_eps_bar : free_eps_bar -> tail list (* For debugging, logging, etc. *) val free_to_string : free -> string val free_eps_to_string : free_eps -> string val free_eps_bar_to_string : free_eps_bar -> string val factor_to_string : factor -> string val factor_eps_to_string : factor_eps -> string val factor_eps_bar_to_string : factor_eps_bar -> string (* Turn the [endpoint]s satisfying the predicate into a left or right hand side summation index. Left and right refer to the two factors in a product and we must only match arrows with [endpoint]s in both factors, not double lines on either side. Typically, the predicate will be set up to select only the summation indices that appear on both sides.*) val to_left_factor : (endpoint -> bool) -> free -> factor val to_left_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps val to_left_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar val to_right_factor : (endpoint -> bool) -> free -> factor val to_right_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps val to_right_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar (* The incomplete inverse [of_factor] raises an exception if there are remaining summation indices. [is_free] can be used to check first. *) val of_factor : factor -> free val of_factor_eps : factor_eps -> free_eps val of_factor_eps_bar : factor_eps_bar -> free_eps_bar val is_free : factor -> bool val is_free_eps : factor_eps -> bool val is_free_eps_bar : factor_eps_bar -> bool (* Return all the endpoints of the arrow that have a [position] encoded as a negative integer. These are treated as summation indices in our applications. *) val negatives : free -> endpoint list val negatives_eps : free_eps -> endpoint list val negatives_eps_bar : free_eps_bar -> endpoint list +(* Return the list of all positions of endpoints corresponding to + adjoint representations. To be precise, it's the list of + integers~[i] in endpoints [I i] that appear at least once as tip + and as tail. While it is an error to appear \emph{more} + than once as either, this is not checked in the current implementation. *) +val adjoints : free list -> int list +val adjoints_eps : free list -> free_eps NEList.t -> int list +val adjoints_eps_bar : free list -> free_eps_bar NEList.t -> int list + (* We will need to test whether an arrow represents a ghost. *) val is_ghost : free -> bool (* An arrow looping back to itself. *) val is_tadpole : factor -> bool +(* Check if the [tip]s and [tail]s of a list of arrows that + belong to the same positions are in a canonical order. + This can be used to weed out color flows that are equivalent + after applying the symmetrizations and antisymmetrizations + in irreps described by Young tableaux. *) +val in_canonical_order : free list -> bool + +(* [endpoints (position, n)] construct a list of [n] endpoints at + [position] that can be concatenated with other such lists and + then permuted. Examples: [endpoints (42,1) = [I 42] ] and + [endpoints (42,2) = [M (42,0); M (42,1)] ]. *) +val endpoints : int * int -> endpoint list +val make_tips : int * int -> tip list +val make_tails : int * int -> tail list + (* Merging an arrow with another arrow, $\epsilon$ or $\bar\epsilon$ can give a variety of results: *) type merge = | Match of factor (* a tip fits the other's tail: make one arrow out of two *) | Ghost_Match (* two matching ghosts *) | Loop_Match (* both tips fit both tails: drop the arrows *) | Mismatch (* ghost meets arrow: discard *) | No_Match (* nothing to be done *) val merge_arrow_arrow : factor -> factor -> merge (* We can narrow this for $\epsilon$ and $\bar\epsilon$, where [Loop_Match] and [Ghost_Match] are impossible! *) type 'a merge_eps = | Match_Eps of 'a (* a tip fits the other's tail: make one arrow out of two *) | Mismatch_Eps (* ghost meets arrow: discard *) | No_Match_Eps (* nothing to be done *) val merge_arrow_eps : factor -> factor_eps -> factor_eps merge_eps val merge_arrow_eps_bar : factor -> factor_eps_bar -> factor_eps_bar merge_eps (* In order to merge an~$\epsilon$ with an $\bar\epsilon$, we use \begin{equation} \forall n, N \in\mathbf{N}, 2\le n \le N:\; \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n} = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)} \delta_{i_1}^{\sigma(j_1)} \delta_{i_2}^{\sigma(j_2)} \cdots \delta_{i_n}^{\sigma(j_n)}\,, \end{equation} where~$N=\delta_i^i$ is the dimension, to replace the pair by two lists of lists of arrows: the first corresponding to the even permutations, the second to the odd ones. Return [None], if the rank of $\epsilon$ and $\bar\epsilon$ don't match. *) (* See section~\ref{sec:evaluation-of-epsilon-tensors} on pages~\pageref{sec:evaluation-of-epsilon-tensors}ff for a justification for using it also in the case~$n\not=N$. *) val merge_eps_eps_bar : factor_eps -> factor_eps_bar -> (factor list list * factor list list) option (* Break up an arrow [tee a (i => j) -> [i => a; a => j]], i.\,e.~insert a gluon. Returns an empty list for a ghost and raises an exception for~$\epsilon$ and~$\bar\epsilon$. *) val tee : int -> free -> free list (* [dir i j arrow] returns the direction of the arrow relative to [j => i]. Returns 0 for a ghost and raises an exception for~$\epsilon$ and~$\bar\epsilon$. *) val dir : int -> int -> free -> int (* It's intuitive to use infix operators to construct the lines. *) -val single : endpoint -> endpoint -> free +val single : tail -> tip -> free val double : endpoint -> endpoint -> free list val ghost : endpoint -> free module Infix : sig (* [single i j] or [i => j] creates a single line from [i] to [j] and [i ==> j] is a shorthard for [[i => j]]. *) val (=>) : int -> int -> free val (==>) : int -> int -> free list (* [double i j] or [i <=> j] creates a double line from [i] to [j] and back. *) val (<=>) : int -> int -> free list (* Single lines with subindices at the tip and/or tail *) val (>=>) : int * int -> int -> free val (=>>) : int -> int * int -> free val (>=>>) : int * int -> int * int -> free (* [?? i] creates a ghost at [i]. *) val (??) : int -> free (* NB: I wanted to use [~~] instead of [??], but ocamlweb can't handle operators starting with [~] in the index properly. *) end -val epsilon : int list -> free_eps -val epsilon_bar : int list -> free_eps_bar +(* These used to be called [epsilon] and [epsilon_bar], but they are + not general enough! *) +val epsilon0 : int list -> free_eps +val epsilon0_bar : int list -> free_eps_bar (* [chain [1;2;3]] is a shorthand for [[1 => 2; 2 => 3]] and [cycle [1;2;3]] for [[1 => 2; 2 => 3; 3 => 1]]. Other lists and edge cases are handled in the natural way. *) val chain : int list -> free list val cycle : int list -> free list +type matching_adjoint_arrows = Tee | Reflex + +(* [adjoint_arrows_opt a arrows] searches for arrows starting and ending + at [I a]. If a matching pair is found, the arrows are connected and + the resulting [arrow] is returned together with the remaining arrows + [other] as [Some (Tee, arrow :: other)]. If both tip and tail belong + to the same arrow, [Some (Reflex, other)] is returned instead. + If there is no match [None] is returned. In the case of multiple + matches, the exception [Invalid_Arg] is raised. *) + +val adjoint_arrows_opt : int -> free list -> (matching_adjoint_arrows * free list) option +val adjoint_eps_opt : int -> free list -> free_eps NEList.t -> + (matching_adjoint_arrows * free list * free_eps NEList.t) option +val adjoint_eps_bar_opt : int -> free list -> free_eps_bar NEList.t -> + (matching_adjoint_arrows * free list * free_eps_bar NEList.t) option + module Test : sig val suite : OUnit.test val suite_long : OUnit.test end (* Pretty printer for the toplevel. *) val pp_free : Format.formatter -> free -> unit val pp_factor : Format.formatter -> factor -> unit Index: trunk/omega/src/fusion_vintage.ml =================================================================== --- trunk/omega/src/fusion_vintage.ml (revision 8919) +++ trunk/omega/src/fusion_vintage.ml (revision 8920) @@ -1,2923 +1,2923 @@ (* fusion_vintage.ml -- Copyright (C) 1999-2024 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 val vintage : bool type wf val conjugate : wf -> wf type flavor type flavor_all_orders type flavor_sans_color val flavor : wf -> flavor val flavor_all_orders : wf -> flavor_all_orders val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t 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 type slicings val amplitudes : bool -> selectors -> slicings option -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitudes_all_orders : bool -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> 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 type 'a slices val brakets : amplitude -> braket list slices val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val slicings : amplitude -> string list val symmetry : amplitude -> int val allowed : amplitude -> bool (*i val initialize_cache : string -> unit val set_cache_name : string -> unit i*) val check_charges : unit -> flavor_sans_color list list val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list val poles : amplitude -> wf list list val s_channel : amplitude -> wf list val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Orders.Slice(Colorize.It(M)).flavor and type flavor_all_orders = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig type flavor type stat exception Impossible val stat : flavor -> int -> stat val stat_fuse : stat -> stat -> flavor -> stat val stat_sign : stat -> int val stat_to_string : stat -> string end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor (* \thocwmodulesection{Dirac Fermions} *) module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor (* \begin{equation} \gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3) - \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1) \end{equation} *) type stat = | Fermion of int * (int option * int option) list | AntiFermion of int * (int option * int option) list | Boson of (int option * int option) list let stat f p = let s = M.fermion f in if s = 0 then Boson [] else if s < 0 then AntiFermion (p, []) else (* [if s > 0 then] *) Fermion (p, []) let lines_to_string lines = ThoList.to_string (function | Some i, Some j -> Printf.sprintf "%d>%d" i j | Some i, None -> Printf.sprintf "%d>*" i | None, Some j -> Printf.sprintf "*>%d" j | None, None -> "*>*") lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) exception Impossible let stat_fuse s1 s2 f = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion _, Fermion _ | AntiFermion _, AntiFermion _ -> raise Impossible (* \begin{figure} \begin{displaymath} \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f1,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f3,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \qquad\qquad-\qquad \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f3,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f1,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \end{displaymath} \caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.} \end{figure} *) (* \begin{equation} \epsilon \left(\left\{ (0,1), (2,3) \right\}\right) = - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right) \end{equation} *) let permutation lines = let fout, fin = List.split lines in let eps_in, _ = Combinatorics.sort_signed fin and eps_out, _ = Combinatorics.sort_signed fout in (eps_in * eps_out) (* \begin{dubious} This comparing of permutations of fermion lines is a bit tedious and takes a macroscopic fraction of time. However, it's less than 20\,\%, so we don't focus on improving on it yet. \end{dubious} *) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation ((None, Some p) :: lines) | AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines) end (* \thocwmodulesection{The [Fusion.Make] Functor} *) module Make (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct let vintage = true type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite let cache_option = ref Cache_Ignore type qcd_order = | QCD_order of int type ew_order = | EW_order of int let qcd_order = ref (QCD_order 99) let ew_order = ref (EW_order 99) let options = Options.create [ (*i "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore), " ignore cached model tables (default)"; "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use), " use cached model tables"; "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite), " overwrite cached model tables"; i*) "qcd", Arg.Int (fun n -> qcd_order := QCD_order n), " set QCD order n [>= 0, default = 99] (ignored)"; "ew", Arg.Int (fun n -> ew_order := EW_order n), " set QCD order n [>=0, default = 99] (ignored)"] exception Negative_QCD_order exception Negative_EW_order exception Vanishing_couplings exception Negative_QCD_EW_orders let int_orders = match !qcd_order, !ew_order with | QCD_order n, EW_order n' when n < 0 && n' >= 0 -> raise Negative_QCD_order | QCD_order n, EW_order n' when n >= 0 && n' < 0 -> raise Negative_EW_order | QCD_order n, EW_order n' when n < 0 && n' < 0 -> raise Negative_QCD_EW_orders | QCD_order n, EW_order n' -> (n, n') open Coupling module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) let stat_fuse s f = PT.fold_right_internal (fun s' acc -> S.stat_fuse s' acc f) s type constant = M.constant (* \thocwmodulesubsection{Wave Functions} *) (* \begin{dubious} The code below is not yet functional. Too often, we assign to [Tags.null_wf] instead of calling [Tags.fuse]. \end{dubious} *) (* We will need two types of amplitudes: with color and without color. Since we can build them using the same types with only [flavor] replaced, it pays to use a functor to set up the scaffolding. *) (* 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 Signed_Coupling = sig type sign = int type t = { sign : sign; coupling : constant Coupling.t } val sign : t -> sign val coupling : t -> constant Coupling.t end module Signed_Coupling : Signed_Coupling = struct type sign = int type t = { sign : sign; coupling : constant Coupling.t } let sign c = c.sign let coupling c = c.coupling end (* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *) module type Amplitude = sig type flavor type p type wf = { flavor : flavor; momentum : p } val flavor : wf -> flavor val conjugate : wf -> wf val momentum : wf -> p val momentum_list : wf -> int list val order_wf : wf -> wf -> int val external_wfs : int -> (flavor * int) list -> wf list type 'a children type coupling = Signed_Coupling.t type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val children : rhs -> wf list type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list module D : DAG.T with type node = wf and type edge = coupling and type children = wf children val wavefunctions : braket list -> wf list type 'a slices val unsliced : 'a -> 'a slices type amplitude = { fusions : fusion list; brakets : braket list slices; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; slicings : string list; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list slices val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val slicings : amplitude -> string list val symmetry : amplitude -> int val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val fusion_dag : amplitude -> D.t end module type Slicer = sig type 'a t val all : 'a -> 'a t end module Unsliced = struct type 'a t = 'a let all a = a end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) (S : Slicer) : Amplitude with type p = P.t and type flavor = M.flavor and type 'a children = 'a PT.t and type 'a slices = 'a S.t = struct type flavor = M.flavor type p = P.t type wf = { flavor : flavor; momentum : p } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else order_flavor wf1.flavor wf2.flavor (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type coupling = Signed_Coupling.t type 'a children = 'a PT.t type rhs = coupling * wf children let sign (c, _) = Signed_Coupling.sign c let coupling (c, _) = Signed_Coupling.coupling c let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module D = DAG.Make (DAG.Forest(PT) (struct type t = wf let compare = order_wf end) (struct type t = coupling let compare = compare end)) module WFSet = Set.Make (struct type t = wf let compare = order_wf end) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type 'a slices = 'a S.t let unsliced a = S.all a type amplitude = { fusions : fusion list; brakets : braket list slices; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; slicings : string list; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let slicings a = a.slicings let variables a = List.map lhs a.fusions let dependencies a = a.dependencies let fusion_dag a = a.fusion_dag end module A = Amplitude(PT)(P)(M)(Unsliced) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) let is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold collect_vertices flavors VSet.empty) [] (* Performance hack: *) type vertex_table = ((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list * ((A.flavor * A.flavor * A.flavor * A.flavor) * constant Coupling.vertex4 * constant) list * (A.flavor list * constant Coupling.vertexn * constant) list (*i module VCache = Cache.Make (struct type t = vertex_table end) (struct type t = vertices end) let vertices_cache = ref None let hash () = VCache.hash (M.vertices ()) (* \begin{dubious} Can we do better than the executable name provided by [Config.cache_prefix]??? We need a better way to avoid collisions among the caches for different models in the same program. \end{dubious} *) let cache_name = ref (Config.cache_prefix ^ "." ^ Config.cache_suffix) let set_cache_name name = cache_name := name let initialize_cache dir = Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; VCache.write_dir (hash ()) dir !cache_name (vertices_nocache (M.max_degree ()) (M.flavors())); Printf.eprintf "done. <<< \n" let vertices max_degree flavors : vertices = match !vertices_cache with | None -> begin match !cache_option with | Cache_Use -> begin match VCache.maybe_read (hash ()) !cache_name with | VCache.Hit result -> result | VCache.Miss -> Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | VCache.Stale file -> Printf.eprintf " >>> Re-initializing stale vertex table %s in file %s. " !cache_name file; Printf.eprintf "This may take some time ... "; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result end | Cache_Overwrite -> Printf.eprintf " >>> Overwriting vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | Cache_Ignore -> let result = vertices_nocache max_degree flavors in vertices_cache := Some result; result end | Some result -> result i*) let vertices = vertices_nocache (* Note that we must perform any filtering of the vertices \emph{after} caching, because the restrictions \emph{must not} influence the cache (unless we tag the cache with model and restrictions). *) (*i let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs let coupling_and_flavors_to_string (c, fs) = M.constant_symbol (unpack_constant c) ^ "[" ^ String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]" let fusions_to_string (f, cfs) = M.flavor_to_string f ^ " <- { " ^ String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^ " }" let vertices_to_string vertices = String.concat "; " (List.map fusions_to_string vertices) i*) let filter_vertices select_vtx vertices = List.fold_left (fun acc (f, cfs) -> let f' = M.conjugate f in let cfs = List.filter (fun (c, fs) -> select_vtx c f' (PT.to_list fs)) cfs in match cfs with | [] -> acc | cfs -> (f, cfs) :: acc) [] vertices (* \thocwmodulesubsection{Partitions} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let kmatrix_cuts c momenta = match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* Counting QCD and EW orders. *) let qcd_ew_check orders = if fst (orders) <= fst (int_orders) && snd (orders) <= snd (int_orders) then true else false (* Match a set of flavors to a set of momenta. Form the direct product for the lists of momenta two and three with the list of couplings and flavors two and three. *) let flavor_keystone select_p dim (f1, f23) (p1, p23) = ({ A.flavor = f1; A.momentum = P.of_ints dim p1 }, 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'' }) 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 in let p = PT.fold_left_internal P.add momenta in 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 }, s, ({ Signed_Coupling.sign = flip; Signed_Coupling.coupling = c }, wfs)) :: acc else acc) [] (fuse_rhs flavors) with | P.Duplicate _ | S.Impossible -> [] else [] (* \begin{dubious} Eventually, the pairs of [tower] and [dag] in [fusion_tower'] below could and should be replaced by a graded [DAG]. This will look like, but currently [tower] containts statistics information that is missing from [dag]: \begin{quote} \verb+Type node = flavor * p is not compatible with type wf * stat+ \end{quote} This should be easy to fix. However, replacing [type t = wf] with [type t = wf * stat] is \emph{not} a good idea because the variable [stat] makes it impossible to test for the existance of a particular [wf] in a [DAG]. \end{dubious} \begin{dubious} In summary, it seems that [(wf * stat) list array * A.D.t] should be replaced by [(wf -> stat) * A.D.t]. \end{dubious} *) module GF = struct module Nodes = struct type t = A.wf - module G = struct type t = int let compare = compare end + module G = Int 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 Stdlib.compare (PT.graded_sym_power_fold rank (fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower []) let add_offspring dag (wf, _, rhs) = A.D.add_offspring wf rhs dag let filter_offspring fusions = List.map (fun (wf, s, _) -> (wf, s)) fusions let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t = if Array.length tower >= n_max then (tower, dag) else let tower' = grow select_wf select_vtx tower in fusion_tower' n_max select_wf select_vtx (Array.append tower [|filter_offspring tower'|]) (List.fold_left add_offspring dag tower') (* Discard the tower and return a map from wave functions to Fermistatistics together with the DAG. *) let make_external_dag wfs = List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs let mixed_fold_left f acc lists = Array.fold_left (List.fold_left f) acc lists module Stat_Map = Map.Make (struct type t = A.wf let compare = A.order_wf end) let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = let tower, dag = fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in let stats = mixed_fold_left (fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in ((fun wf -> Stat_Map.find wf stats), dag) (* Calculate the minimal tower of fusions that suffices for calculating the amplitude. *) let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (T.max_subtree n) select_wf select_vtx wfs (* Calculate the complete tower of fusions. It is much larger than required, but it allows a complete set of gauge checks. *) let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (List.length wfs - 1) select_wf select_vtx wfs (* \begin{dubious} There is a natural product of two DAGs using [fuse]. Can this be used in a replacement for [fusion_tower]? The hard part is to avoid double counting, of course. A straight forward solution could do a diagonal sum (in order to reject flipped offspring representing the same fusion) and rely on the uniqueness in [DAG] otherwise. However, this will (probably) slow down the procedure significanty, because most fusions (including Fermi signs!) will be calculated before being rejected by [DAG().add_offspring]. \end{dubious} *) (* Add to [dag] all Goldstone bosons defined in [tower] that correspond to gauge bosons in [dag]. This is only required for checking Slavnov-Taylor identities in unitarity gauge. Currently, it is not used, because we use the complete tower for gauge checking. *) let harvest_goldstones tower dag = A.D.fold_nodes (fun wf dag' -> match M.goldstone wf.A.flavor with | Some (g, _) -> let wf' = { wf with A.flavor = g } in if A.D.is_node wf' tower then begin A.D.harvest tower wf' dag' end else begin dag' end | None -> dag') dag dag (* Calculate the sign from Fermi statistics that is not already included in the children. \begin{dubious} The use of [PT.of2_kludge] is the largest skeleton on the cupboard of unified fusions. Currently, it is just another name for [PT.of2], but the existence of the latter requires binary fusions. Of course, this is just a symptom for not fully supporting four fermion vertices \ldots \end{dubious} *) let stat_keystone stats wf1 wfs = let wf1' = stats wf1 and wfs' = PT.map stats wfs in let stat = stat_fuse (PT.of2_kludge wf1' (stat_fuse wfs' (M.conjugate (A.flavor wf1)))) (A.flavor wf1) in (*i Printf.eprintf "Fusion.stat_keystone: %s\n" (S.stat_to_string stat); i*) stat_sign stat * PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs' (* Test all members of a list of wave functions are defined by the DAG simultaneously: *) let test_rhs dag (_, wfs) = PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs (* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag] and calculate the statistical factor depending on [stats] \emph{en passant}: *) let filter_keystone stats dag (wf1, pairs) acc = if is_source wf1 && A.D.is_node wf1 dag then match List.filter (test_rhs dag) pairs with | [] -> acc | pairs' -> (wf1, List.map (fun (c, wfs) -> ({ Signed_Coupling.sign = stat_keystone stats wf1 wfs; Signed_Coupling.coupling = c }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors type slicings = Orders.Conditions(Colorize.It(M)).t let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make (struct type t = A.wf let compare = compare end) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (M.max_degree ()) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.slicings = []; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM)(Unsliced) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum } (* \begin{dubious} At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. \end{dubious} *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum } 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 fibered_dag.bundle wf with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" let fuse_c_wf rhs = let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (_, c) -> kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) let colorize_coupling c coupling = { coupling with Signed_Coupling.coupling = c } let colorize_fusion wf (coupling, children) fibered_dag = let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf) and find_colored wf' = CWFBundle.inv_pi fibered_dag.bundle wf' in let fusions = ThoList.flatmap (fun c_children -> List.map (fun (f, c) -> (colorize_wf f wf, (colorize_coupling c coupling, c_children))) (List.filter match_flavor (fuse_c_wf c_children))) (PT.product (PT.map find_colored children)) in let bundle = List.fold_left (fun acc (c_wf, _) -> CWFBundle.add acc c_wf) fibered_dag.bundle fusions in (fusions, bundle) let colorize_braket1 (wf, (coupling, children)) fibered_dag = let find_colored wf' = CWFBundle.inv_pi fibered_dag.bundle wf' in Product.fold2 (fun bra ket acc -> List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf ket)) (find_colored wf) (PT.product (PT.map find_colored children)) [] module CWFMap = Map.Make (struct type t = CA.wf let compare = CA.order_wf end) module CKetSet = Set.Make (struct type t = CA.rhs let compare = compare end) (* Find a set of kets in [map] that belong to [bra]. Return the empty set, if nothing is found. *) let lookup_ketset bra map = try CWFMap.find bra map with Not_found -> CKetSet.empty (* Return the set of kets belonging to [bra] in [map], augmented by [ket]. *) let addto_ketset bra ket map = CKetSet.add ket (lookup_ketset bra map) (* Augment or update [map] with a new [(bra, ket)] relation. *) let addto_ketset_map map (bra, ket) = CWFMap.add bra (addto_ketset bra ket map) map (* Take a list of [(bra, ket)] pairs and group the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) (* \begin{dubious} Isn't [Bundle]~\ref{Bundle} the correct framework for this? \end{dubious} *) let factorize_brakets brakets = CWFMap.fold (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc) (List.fold_left addto_ketset_map CWFMap.empty brakets) [] let colorize_braket (wf, rhs_list) fibered_dag = factorize_brakets (ThoList.flatmap (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag)) rhs_list) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (fun braket -> colorize_braket braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.slicings = a.A.slicings; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in match amp.CA.brakets with | [] -> amps | _ -> amp :: amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes_all_orders goldstones selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones selectors fin fout = amplitude goldstones selectors fin fout (* \thocwmodulesubsection{Fake Coupling Constant Slices} *) (* For the benefit of [Targets], we also copy the amplitudes to equivalent sliced amplitudes with empty coupling orders. This way, we can use the same output routines for the sliced and unsliced amplitudes. *) module COC = Orders.Conditions(Colorize.It(M)) module SCM = Orders.Slice(Colorize.It(M)) module By_Orders = struct type orders = SCM.orders type 'a t = (orders * 'a) list let all a = [([], a)] end module SCA = Amplitude(PT)(P)(SCM)(By_Orders) type 'a slices = 'a SCA.slices type flavor = SCA.flavor type flavor_all_orders = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = SCA.wf let conjugate = SCA.conjugate let flavor = SCA.flavor let flavor_sans_color wf = SCM.flavor_sans_color (SCA.flavor wf) let flavor_all_orders wf = SCM.flavor_all_orders (SCA.flavor wf) let momentum = SCA.momentum let momentum_list = SCA.momentum_list type coupling = SCA.coupling let sign = SCA.sign let coupling = SCA.coupling type 'a children = 'a SCA.children type rhs = SCA.rhs let children = SCA.children type fusion = SCA.fusion let lhs = SCA.lhs let rhs = SCA.rhs type braket = SCA.braket let bra = SCA.bra let ket = SCA.ket type amplitude = SCA.amplitude type amplitude_sans_color = A.amplitude let incoming = SCA.incoming let outgoing = SCA.outgoing let externals = SCA.externals let fusions = SCA.fusions let brakets = SCA.brakets let symmetry = SCA.symmetry let on_shell = SCA.on_shell let is_gauss = SCA.is_gauss let constraints = SCA.constraints let slicings = SCA.slicings let variables a = List.map lhs (fusions a) let dependencies = SCA.dependencies let slice_wf flavor wf = { SCA.flavor = flavor; SCA.momentum = wf.CA.momentum } let unslice_wf wf = { CA.flavor = SCM.flavor_all_orders wf.SCA.flavor; CA.momentum = wf.SCA.momentum } module SCWFBundle = Bundle.Make (struct type elt = SCA.wf let compare_elt = compare type base = CA.wf let compare_base = compare let pi = unslice_wf end) type sliced_fibered_dag = { sliced_dag : SCA.D.t; sliced_bundle : SCWFBundle.t } type wf_slicer = CA.wf -> sliced_fibered_dag -> SCA.wf * SCWFBundle.t type sliced_fusion = SCA.wf * SCA.rhs type node_slicer = CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fusion list * SCWFBundle.t let slice_sterile_nodes : CA.D.t -> wf_slicer -> CA.D.node -> sliced_fibered_dag -> sliced_fibered_dag = fun dag f wf fibered_dag -> if CA.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { sliced_dag = SCA.D.add_node wf' fibered_dag.sliced_dag; sliced_bundle = wf_bundle' } else fibered_dag let slice_nodes : node_slicer -> CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fibered_dag = fun f wf rhs fibered_dag -> let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> SCA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.sliced_dag in { sliced_dag = dag'; sliced_bundle = wf_bundle' } let slice_dag : node_slicer -> wf_slicer -> CA.D.t -> SCWFBundle.t -> sliced_fibered_dag = fun f_node f_ext dag wf_bundle -> CA.D.fold (slice_nodes f_node) dag (CA.D.fold_nodes (slice_sterile_nodes dag f_ext) dag { sliced_dag = SCA.D.empty; sliced_bundle = wf_bundle }) let lift_wf wf = slice_wf (SCM.trivial wf.CA.flavor) wf let lift_external : wf_slicer = fun wf fibered_dag -> (lift_wf wf, fibered_dag.sliced_bundle) let lift_fusion : node_slicer = fun wf (coupling, children) fibered_dag -> let wf = lift_wf wf and children = PT.map lift_wf children in let sliced_bundle = SCWFBundle.add fibered_dag.sliced_bundle wf in ( [ (wf, (coupling, children)) ], sliced_bundle ) let lift_dag : CA.D.t -> SCWFBundle.t -> sliced_fibered_dag = fun dag wf_bundle -> slice_dag lift_fusion lift_external dag wf_bundle let lift_braket : CA.braket -> SCA.braket = fun (wf, rhs) -> let wf = lift_wf wf and rhs = List.map (fun (coupling, children) -> (coupling, PT.map lift_wf children)) rhs in (wf, rhs) module SCBra = struct type t = SCA.wf let compare = SCA.order_wf end module SCBraMap = Map.Make(SCBra) let lift_amplitude a = let fin = List.map SCM.trivial a.CA.incoming and fout = List.map SCM.trivial a.CA.outgoing in let f = fin @ List.map SCM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = SCA.external_wfs n externals in let wf_bundle = SCWFBundle.of_list external_wfs in let fibered_dag = lift_dag a.CA.fusion_dag wf_bundle in let brakets = List.map lift_braket a.CA.brakets in let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in let dependencies_map = SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in { SCA.fusions = fusions; SCA.brakets = SCA.unsliced brakets; SCA.constraints = a.CA.constraints; SCA.slicings = a.CA.slicings; SCA.incoming = fin; SCA.outgoing = fout; SCA.externals = external_wfs; SCA.fusion_dag = dag; SCA.fusion_tower = dag; SCA.symmetry = a.CA.symmetry; SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf)); SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf)); SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) } let lift_amplitudes amplitudes = List.map lift_amplitude amplitudes let amplitudes goldstones selectors slicings fin fout = let a = amplitudes_all_orders goldstones selectors fin fout in match slicings with | None -> lift_amplitudes a | Some _ -> invalid_arg "Fusion.*.amplitudes: order slicing not supported in the vintage version!" let amplitudes_all_orders goldstones selectors fin fout = lift_amplitudes (amplitudes_all_orders goldstones selectors fin fout) let allowed amplitude = match amplitude.SCA.brakets with | [] -> false | _ -> true (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let all_brakets a = ThoList.flatmap snd a.SCA.brakets let count_propagators a = List.length a.SCA.fusions let count_fusions a = let brakets = all_brakets a in List.fold_left (fun n (_, a) -> n + List.length a) 0 a.SCA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 brakets + List.length brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + SCA.D.count_trees wf1 a.SCA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * SCA.D.count_trees wf a.SCA.fusion_dag) 1 wfs) 0 wf23)) 0 (all_brakets a) exception Impossible let forest' a = let below wf = SCA.D.forest_memoized wf a.SCA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) (all_brakets a) let cross wf = { SCA.flavor = SCM.conjugate wf.SCA.flavor; SCA.momentum = P.neg wf.SCA.momentum } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum } 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 = SCA.D.eval_memoized (fun wf' -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.SCA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.SCA.fusion_dag) wfs))) wf23)) (all_brakets a) module WFSet = Set.Make (struct type t = SCA.wf let compare = SCA.order_wf end) let s_channel a = WFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.SCA.momentum then WFSet.add wf wfs else wfs) (poles a) WFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map SCA.lhs a.SCA.fusions let s_channel a = WFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.SCA.momentum then WFSet.add wf wfs else wfs) (poles' a) WFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = SCM.flavor_symbol wf.SCA.flavor ^ String.concat "" (List.map p2s (P.to_ints wf.SCA.momentum)) module IMap = Map.Make(Int) let add_to_list i n m = IMap.add i (n :: try IMap.find i m with Not_found -> []) m let classify_nodes dag = IMap.fold (fun i n acc -> (i, n) :: acc) (SCA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.SCA.momentum) wf) dag IMap.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; SCA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); SCA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch (all_brakets a) a.SCA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch (all_brakets a) a.SCA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf) let bra_to_channel transform ch dag wf = let tree = A.D.dependencies dag wf in if Tree2.is_singleton tree then let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s tree else failwith "Fusion.phase_space_channels: wrong topology!" let ket_to_channel transform ch dag ket = Printf.fprintf ch "("; begin match A.children ket with | [] -> () | [child] -> below_to_channel transform ch dag child | child :: children -> below_to_channel transform ch dag child; List.iter (fun child -> Printf.fprintf ch ","; below_to_channel transform ch dag child) children end; Printf.fprintf ch ")" let phase_space_braket transform ch (bra, ket) dag = bra_to_channel transform ch dag bra; Printf.fprintf ch ": {"; begin match ket with | [] -> () | [ket1] -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1 | ket1 :: kets -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1; List.iter (fun k -> Printf.fprintf ch " \\\n | "; ket_to_channel transform ch dag k) kets end; Printf.fprintf ch " }\n" (*i Food for thought: let braket_to_tree2 dag (bra, ket) = let bra' = A.D.dependencies dag bra in if Tree2.is_singleton bra' then Tree2.cons [(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))] else failwith "Fusion.phase_space_channels: wrong topology!" let phase_space_braket transform ch (bra, ket) dag = let n2s wf = variable (transform wf) and e2s c = "" in Printf.fprintf ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket))) i*) let phase_space_channels_transformed transform ch a = List.iter (fun braket -> phase_space_braket transform ch braket a.A.fusion_dag) a.A.brakets let phase_space_channels ch a = phase_space_channels_transformed (fun wf -> wf) ch a let exchange_momenta_list p1 p2 p = List.map (fun pi -> if pi = p1 then p2 else if pi = p2 then p1 else pi) p let exchange_momenta p1 p2 p = P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p)) let flip_momenta wf = { wf with A.momentum = exchange_momenta 1 2 wf.A.momentum } let phase_space_channels_flipped ch a = phase_space_channels_transformed flip_momenta ch a end module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary) (* \thocwmodulesection{Fusions with Majorana Fermions} *) module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor type stat = | Fermion of int * int list | AntiFermion of int * int list | Boson of int list | Majorana of int * int list let stat f p = let s = M.fermion f in if s = 0 then Boson [] else if s < 0 then AntiFermion (p, []) else if s = 1 then (* [if s = 1 then] *) Fermion (p, []) else (* [if s > 1 then] *) Majorana (p, []) let lines_to_string lines = ThoList.to_string string_of_int lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) | Majorana (p, lines) -> Printf.sprintf "Majorana (%d, %s)" p (lines_to_string lines) (* \begin{JR} In the formalism of~\cite{Denner:Majorana}, it does not matter to distinguish spinors and conjugate spinors, it is only important to know in which direction a fermion line is calculated. So the sign is made by the calculation together with an aditional one due to the permuation of the pairs of endpoints of fermion lines in the direction they are calculated. We propose a ``canonical'' direction from the right to the left child at a fusion point so we only have to keep in mind which external particle hangs at each side. Therefore we need not to have a list of pairs of conjugate spinors and spinors but just a list in which the pairs are right-left-right-left and so on. Unfortunately it is unavoidable to have couplings with clashing arrows in supersymmetric theories so we need transmutations from fermions in antifermions and vice versa as well. \end{JR} *) exception Impossible (*i let stat_fuse s1 s2 f = match s1, s2, M.lorentz f with | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.Spinor -> Fermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2), _ -> Boson ([p; pbar] @ l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2), _ -> Boson ([pbar; p] @ l1 @ l2) | Fermion (pf, l1), Majorana (pm, l2), _ -> Boson ([pm; pf] @ l1 @ l2) | Majorana (pm, l1), Fermion (pf, l2), _ -> Boson ([pf; pm] @ l1 @ l2) | AntiFermion (pa, l1), Majorana (pm, l2), _ -> Boson ([pm; pa] @ l1 @ l2) | Majorana (pm, l1), AntiFermion (pa, l2), _ -> Boson ([pa; pm] @ l1 @ l2) | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Fermion _, Fermion _, _ | AntiFermion _, AntiFermion _, _ -> raise Impossible i*) let stat_fuse s1 s2 f = match s1, s2, M.lorentz f with | Boson l1, Fermion (p, l2), Coupling.Majorana | Boson l1, AntiFermion (p, l2), Coupling.Majorana | Fermion (p, l1), Boson l2, Coupling.Majorana | AntiFermion (p, l1), Boson l2, Coupling.Majorana | Majorana (p, l1), Boson l2, Coupling.Majorana | Boson l1, Majorana (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Spinor | Boson l1, AntiFermion (p, l2), Coupling.Spinor | Fermion (p, l1), Boson l2, Coupling.Spinor | AntiFermion (p, l1), Boson l2, Coupling.Spinor | Majorana (p, l1), Boson l2, Coupling.Spinor | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.ConjSpinor | Boson l1, AntiFermion (p, l2), Coupling.ConjSpinor | Fermion (p, l1), Boson l2, Coupling.ConjSpinor | AntiFermion (p, l1), Boson l2, Coupling.ConjSpinor | Majorana (p, l1), Boson l2, Coupling.ConjSpinor | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Vectorspinor | Boson l1, AntiFermion (p, l2), Coupling.Vectorspinor | Fermion (p, l1), Boson l2, Coupling.Vectorspinor | AntiFermion (p, l1), Boson l2, Coupling.Vectorspinor | Majorana (p, l1), Boson l2, Coupling.Vectorspinor | Boson l1, Majorana (p, l2), Coupling.Vectorspinor -> Majorana (p, l1 @ l2) | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | AntiFermion (p1, l1), Fermion (p2, l2), _ | Fermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), AntiFermion (p2, l2), _ | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) let stat_fuse s1 s2 f = let stat = stat_fuse s1 s2 f in (*i Printf.eprintf "Fusion.Stat_Majorana.stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string [s1; s2]) (stat_to_string stat); i*) stat (*i These are the old Impossible raising rules. We keep them to ask Ohl what the generalized topologies do and if our stat_fuse does the right for 4-vertices with | Boson l1, AntiFermion (p, l2), _ | Fermion (p, l1), Boson l2, _ | AntiFermion (p, l1), Boson l2, _ | Majorana (p, l1), Boson l2, _ | Boson l1, Majorana (p, l2), _ -> raise Impossible i*) let permutation lines = fst (Combinatorics.sort_signed lines) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation (p :: lines) | AntiFermion (pbar, lines) -> permutation (pbar :: lines) | Majorana (pm, lines) -> permutation (pm :: lines) end module Binary_Majorana = Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary) module Nary (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B)) module Nary_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B)) module Mixed23 = Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23) module Mixed23_Majorana = Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23) module Helac (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B)) module Helac_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B)) (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type selectors type slicings type amplitudes val amplitudes : bool -> int option -> selectors -> slicings option -> process list -> amplitudes val empty : amplitudes (*i val initialize_cache : string -> unit val set_cache_name : string -> unit i*) val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list val process_table : amplitudes -> amplitude option array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option val slicings : amplitudes -> string list end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module SCM = Orders.Slice(Colorize.It(M)) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), "report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "report progress to a file" ] type flavor = M.flavor type p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type selectors = F.selectors type slicings = Orders.Conditions(Colorize.It(M)).t type flavors = flavor list array type helicities = int list array type colors = Color.Flow.t array type amplitudes' = amplitude array array array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; processes : amplitude list; process_table : amplitude option array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option; slicings : string list } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let processes a = a.processes let process_table a = a.process_table let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let slicings a = a.slicings let sans_colors f = List.map SCM.flavor_sans_color f let colors (fin, fout) = List.map M.color (fin @ fout) let process_sans_color a = (sans_colors (F.incoming a), sans_colors (F.outgoing a)) let color_flow a = SCM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) let rec unphysical_of_lorentz = function | Coupling.Vector -> [4] | Coupling.Massive_Vector -> [4] | _ -> invalid_arg "unphysical_of_lorentz: not a vector particle" let unphysical_of_flavor f = unphysical_of_lorentz (M.lorentz f) let unphysical_of_flavors1 n f_list = ThoList.mapi (fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f) 1 f_list let unphysical_of_flavors n (fin, fout) = (unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout) let helicity_table unphysical flavors = let hs = begin match unphysical with | None -> List.map hs_of_flavors flavors | Some n -> List.map (unphysical_of_flavors n) flavors end in if not (ThoList.homogeneous hs) then invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!" else match hs with | [] -> [] | (hs_in, hs_out) :: _ -> sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out)) module Proc = Process.Make(M) module WFMap = Map.Make (struct type t = F.wf let compare = compare end) module WFSet2 = Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFMap2 = Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFTSet = Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end) (* All wavefunctions are unique per amplitude. So we can use per-amplitude dependency trees without additional \emph{internal} tags to identify identical wave functions. *) (* \textbf{NB:} we miss potential optimizations, because we assume all coupling to be different, while in fact we have horizontal/family symmetries and non abelian gauge couplings are universal anyway. *) let disambiguate_fusions amplitudes = let fusions = ThoList.flatmap (fun amplitude -> List.map (fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion))) (F.fusions amplitude)) amplitudes in let duplicates = List.fold_left (fun map (fusion, dependencies) -> let wf = F.lhs fusion in let set = try WFMap.find wf map with Not_found -> WFTSet.empty in WFMap.add wf (WFTSet.add dependencies set) map) WFMap.empty fusions in let multiplicity_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else WFMap.add wf cardinal acc) duplicates WFMap.empty and dictionary_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else snd (WFTSet.fold (fun dependency (i', acc') -> (succ i', WFMap2.add (wf, dependency) i' acc')) dependencies (1, acc))) duplicates WFMap2.empty in let multiplicity wf = WFMap.find wf multiplicity_map and dictionary amplitude wf = WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in (multiplicity, dictionary) let eliminate_common_fusions1 seen_wfs amplitude = List.fold_left (fun (seen, acc) f -> let wf = F.lhs f in let dependencies = F.dependencies amplitude wf in if WFSet2.mem (wf, dependencies) seen then (seen, acc) else (WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc)) seen_wfs (F.fusions amplitude) let eliminate_common_fusions processes = let _, rev_fusions = List.fold_left eliminate_common_fusions1 (WFSet2.empty, []) processes in List.rev rev_fusions (*i let eliminate_common_fusions processes = ThoList.flatmap (fun amplitude -> (List.map (fun f -> (f, amplitude)) (F.fusions amplitude))) processes i*) (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical select_wf orders processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones select_wf orders fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; let cf_array = Array.of_list color_flows in let ncf = Array.length cf_array in let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in for i = 0 to pred ncf do for j = 0 to i do color_factor_table.(i).(j) <- Color.Flow.factor cf_array.(i) cf_array.(j); color_factor_table.(j).(i) <- color_factor_table.(i).(j) done done; let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; processes = allowed; process_table = table; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf; slicings = [] } (*i let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name i*) let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; processes = []; process_table = Array.make_matrix 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None; slicings = [] } end Index: trunk/omega/src/thoString.ml =================================================================== --- trunk/omega/src/thoString.ml (revision 8919) +++ trunk/omega/src/thoString.ml (revision 8920) @@ -1,231 +1,233 @@ (* thoString.ml -- Copyright (C) 1999-2024 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 max_length = List.fold_left (fun acc s -> max acc (String.length s)) 0 + let strip_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then s else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then s else strip_prefix' (succ i) in strip_prefix' 0 let strip_prefix_star p s = let ls = String.length s in if ls < 1 then s else let rec strip_prefix_star' i = if i < ls then begin if p <> s.[i] then String.sub s i (ls - i) else strip_prefix_star' (succ i) end else "" in strip_prefix_star' 0 let strip_required_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else strip_prefix' (succ i) in strip_prefix' 0 let strip_from_first c s = try String.sub s 0 (String.index s c) with | Not_found -> s let strip_from_last c s = try String.sub s 0 (String.rindex s c) with | Not_found -> s let index_string pat s = let lpat = String.length pat and ls = String.length s in if lpat = 0 then 0 else let rec index_string' n = let i = String.index_from s n pat.[0] in if i + lpat > ls then raise Not_found else if String.compare pat (String.sub s i lpat) = 0 then i else index_string' (succ i) in index_string' 0 let quote s = if String.contains s ' ' || String.contains s '\n' then begin if String.contains s '"' then "'" ^ s ^ "'" else "\"" ^ s ^ "\"" end else s let uppercase = String.uppercase_ascii let lowercase = String.lowercase_ascii let compare_caseless s1 s2 = String.compare (lowercase s1) (lowercase s2) let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_numeric c = '0' <= c && c <= '9' let is_alphanum c = is_alpha c || is_numeric c || c = '_' let valid_fortran_id s = let rec valid_fortran_id' n = if n < 0 then false else if n = 0 then is_alpha s.[0] else if is_alphanum s.[n] then valid_fortran_id' (pred n) else false in valid_fortran_id' (pred (String.length s)) let sanitize_fortran_id s = let sanitize s = String.map (fun c -> if is_alphanum c then c else '_') s in if String.length s <= 0 then invalid_arg "ThoString.sanitize_fortran_id: empty" else if is_alpha s.[0] then sanitize s else "N_" ^ sanitize s module Test = struct open OUnit let fortran_empty = "empty" >:: (fun () -> assert_equal false (valid_fortran_id "")) let fortran_digit = "0" >:: (fun () -> assert_equal false (valid_fortran_id "0")) let fortran_digit_alpha = "0abc" >:: (fun () -> assert_equal false (valid_fortran_id "0abc")) let fortran_underscore = "_" >:: (fun () -> assert_equal false (valid_fortran_id "_")) let fortran_underscore_alpha = "_ABC" >:: (fun () -> assert_equal false (valid_fortran_id "_ABC")) let fortran_questionmark = "A?C" >:: (fun () -> assert_equal false (valid_fortran_id "A?C")) let fortran_valid = "A_xyz_0_" >:: (fun () -> assert_equal true (valid_fortran_id "A_xyz_0_")) let sanitize_digit = "0" >:: (fun () -> assert_equal "N_0" (sanitize_fortran_id "0")) let sanitize_digit_alpha = "0abc" >:: (fun () -> assert_equal "N_0abc" (sanitize_fortran_id "0abc")) let sanitize_underscore = "_" >:: (fun () -> assert_equal "N__" (sanitize_fortran_id "_")) let sanitize_underscore_alpha = "_ABC" >:: (fun () -> assert_equal "N__ABC" (sanitize_fortran_id "_ABC")) let sanitize_questionmark = "A?C" >:: (fun () -> assert_equal "A_C" (sanitize_fortran_id "A?C")) let sanitize_valid = "A_xyz_0_" >:: (fun () -> assert_equal "A_xyz_0_" (sanitize_fortran_id "A_xyz_0_")) let suite_fortran = "valid_fortran_id" >::: [fortran_empty; fortran_digit; fortran_digit_alpha; fortran_underscore; fortran_underscore_alpha; fortran_questionmark; fortran_valid] let suite_sanitize = "sanitize_fortran_id" >::: [sanitize_digit; sanitize_digit_alpha; sanitize_underscore; sanitize_underscore_alpha; sanitize_questionmark; sanitize_valid] let suite = "ThoString" >::: [suite_fortran; suite_sanitize] end Index: trunk/omega/src/colorize.ml =================================================================== --- trunk/omega/src/colorize.ml (revision 8919) +++ trunk/omega/src/colorize.ml (revision 8920) @@ -1,2029 +1,2028 @@ (* colorize.ml -- Copyright (C) 1999-2024 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{Auxiliary functions} *) (* \thocwmodulesubsection{Exceptions} *) let incomplete s = failwith ("Colorize." ^ s ^ " not done yet!") let invalid s = invalid_arg ("Colorize." ^ s ^ " must not be evaluated!") let impossible s = invalid_arg ("Colorize." ^ s ^ " can't happen! (but just did ...)") -let mismatch s = +let _mismatch s = invalid_arg ("Colorize." ^ s ^ " mismatch of representations!") let su0 s = invalid_arg ("Colorize." ^ s ^ ": found SU(0)!") let colored_vertex s = invalid_arg ("Colorize." ^ s ^ ": colored vertex!") let non_legacy_color s cp = invalid_arg ("Colorize." ^ s ^ ": non legacy color in legacy code: " ^ Color_Propagator.to_string cp) let baryonic_vertex s = invalid_arg ("Colorize." ^ s ^ ": baryonic (i.e. eps_ijk) vertices not supported yet!") let color_flow_ambiguous s = invalid_arg ("Colorize." ^ s ^ ": ambiguous color flow!") let color_flow_of_string s = let c = int_of_string s in if c < 1 then invalid_arg ("Colorize." ^ s ^ ": color flow # < 1!") else c let young_tableaux s = failwith ("Colorize." ^ s ^ " classic colorizer can't support Young tableaux!") (* \thocwmodulesubsection{Multiplying Vertices by a Constant Factor} *) module Q = Algebra.Q module QC = Algebra.QC let of_int n = QC.make (Q.make n 1) Q.null let integer z = if Q.is_null (QC.im z) then let x = QC.re z in try Some (Q.to_integer x) with | _ -> None else None let mult_vertex3 x v = let open Coupling in match v with | FBF (c, fb, coup, f) -> FBF ((x * c), fb, coup, f) | PBP (c, fb, coup, f) -> PBP ((x * c), fb, coup, f) | BBB (c, fb, coup, f) -> BBB ((x * c), fb, coup, f) | GBG (c, fb, coup, f) -> GBG ((x * c), fb, coup, f) | Gauge_Gauge_Gauge c -> Gauge_Gauge_Gauge (x * c) | I_Gauge_Gauge_Gauge c -> I_Gauge_Gauge_Gauge (x * c) | Aux_Gauge_Gauge c -> Aux_Gauge_Gauge (x * c) | Scalar_Vector_Vector c -> Scalar_Vector_Vector (x * c) | Aux_Vector_Vector c -> Aux_Vector_Vector (x * c) | Aux_Scalar_Vector c -> Aux_Scalar_Vector (x * c) | Scalar_Scalar_Scalar c -> Scalar_Scalar_Scalar (x * c) | Aux_Scalar_Scalar c -> Aux_Scalar_Scalar (x * c) | Vector_Scalar_Scalar c -> Vector_Scalar_Scalar (x * c) | Graviton_Scalar_Scalar c -> Graviton_Scalar_Scalar (x * c) | Graviton_Vector_Vector c -> Graviton_Vector_Vector (x * c) | Graviton_Spinor_Spinor c -> Graviton_Spinor_Spinor (x * c) | Dim4_Vector_Vector_Vector_T c -> Dim4_Vector_Vector_Vector_T (x * c) | Dim4_Vector_Vector_Vector_L c -> Dim4_Vector_Vector_Vector_L (x * c) | Dim4_Vector_Vector_Vector_T5 c -> Dim4_Vector_Vector_Vector_T5 (x * c) | Dim4_Vector_Vector_Vector_L5 c -> Dim4_Vector_Vector_Vector_L5 (x * c) | Dim6_Gauge_Gauge_Gauge c -> Dim6_Gauge_Gauge_Gauge (x * c) | Dim6_Gauge_Gauge_Gauge_5 c -> Dim6_Gauge_Gauge_Gauge_5 (x * c) | Aux_DScalar_DScalar c -> Aux_DScalar_DScalar (x * c) | Aux_Vector_DScalar c -> Aux_Vector_DScalar (x * c) | Dim5_Scalar_Gauge2 c -> Dim5_Scalar_Gauge2 (x * c) | Dim5_Scalar_Gauge2_Skew c -> Dim5_Scalar_Gauge2_Skew (x * c) | Dim5_Scalar_Vector_Vector_T c -> Dim5_Scalar_Vector_Vector_T (x * c) | Dim5_Scalar_Vector_Vector_U c -> Dim5_Scalar_Vector_Vector_U (x * c) | Dim5_Scalar_Vector_Vector_TU c -> Dim5_Scalar_Vector_Vector_TU (x * c) | Dim5_Scalar_Scalar2 c -> Dim5_Scalar_Scalar2 (x * c) | Scalar_Vector_Vector_t c -> Scalar_Vector_Vector_t (x * c) | Dim6_Vector_Vector_Vector_T c -> Dim6_Vector_Vector_Vector_T (x * c) | Tensor_2_Vector_Vector c -> Tensor_2_Vector_Vector (x * c) | Tensor_2_Vector_Vector_cf c -> Tensor_2_Vector_Vector_cf (x * c) | Tensor_2_Scalar_Scalar c -> Tensor_2_Scalar_Scalar (x * c) | Tensor_2_Scalar_Scalar_cf c -> Tensor_2_Scalar_Scalar_cf (x * c) | Tensor_2_Vector_Vector_1 c -> Tensor_2_Vector_Vector_1 (x * c) | Tensor_2_Vector_Vector_t c -> Tensor_2_Vector_Vector_t (x * c) | Dim5_Tensor_2_Vector_Vector_1 c -> Dim5_Tensor_2_Vector_Vector_1 (x * c) | Dim5_Tensor_2_Vector_Vector_2 c -> Dim5_Tensor_2_Vector_Vector_2 (x * c) | TensorVector_Vector_Vector c -> TensorVector_Vector_Vector (x * c) | TensorVector_Vector_Vector_cf c -> TensorVector_Vector_Vector_cf (x * c) | TensorVector_Scalar_Scalar c -> TensorVector_Scalar_Scalar (x * c) | TensorVector_Scalar_Scalar_cf c -> TensorVector_Scalar_Scalar_cf (x * c) | TensorScalar_Vector_Vector c -> TensorScalar_Vector_Vector (x * c) | TensorScalar_Vector_Vector_cf c -> TensorScalar_Vector_Vector_cf (x * c) | TensorScalar_Scalar_Scalar c -> TensorScalar_Scalar_Scalar (x * c) | TensorScalar_Scalar_Scalar_cf c -> TensorScalar_Scalar_Scalar_cf (x * c) | Dim7_Tensor_2_Vector_Vector_T c -> Dim7_Tensor_2_Vector_Vector_T (x * c) | Dim6_Scalar_Vector_Vector_D c -> Dim6_Scalar_Vector_Vector_D (x * c) | Dim6_Scalar_Vector_Vector_DP c -> Dim6_Scalar_Vector_Vector_DP (x * c) | Dim6_HAZ_D c -> Dim6_HAZ_D (x * c) | Dim6_HAZ_DP c -> Dim6_HAZ_DP (x * c) | Gauge_Gauge_Gauge_i c -> Gauge_Gauge_Gauge_i (x * c) | Dim6_GGG c -> Dim6_GGG (x * c) | Dim6_AWW_DP c -> Dim6_AWW_DP (x *c) | Dim6_AWW_DW c -> Dim6_AWW_DW (x * c) | Dim6_Gauge_Gauge_Gauge_i c -> Dim6_Gauge_Gauge_Gauge_i (x * c) | Dim6_HHH c -> Dim6_HHH (x * c) | Dim6_WWZ_DPWDW c -> Dim6_WWZ_DPWDW (x * c) | Dim6_WWZ_DW c -> Dim6_WWZ_DW (x * c) | Dim6_WWZ_D c -> Dim6_WWZ_D (x * c) let cmult_vertex3 z v = match integer z with | None -> invalid_arg "cmult_vertex3" | Some x -> mult_vertex3 x v let mult_vertex4 x v = let open Coupling in match v with | Scalar4 c -> Scalar4 (x * c) | Scalar2_Vector2 c -> Scalar2_Vector2 (x * c) | Vector4 ic4_list -> Vector4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | DScalar4 ic4_list -> DScalar4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | DScalar2_Vector2 ic4_list -> DScalar2_Vector2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | GBBG (c, fb, b2, f) -> GBBG ((x * c), fb, b2, f) | Vector4_K_Matrix_tho (c, ic4_list) -> Vector4_K_Matrix_tho ((x * c), ic4_list) | Vector4_K_Matrix_jr (c, ch2_list) -> Vector4_K_Matrix_jr ((x * c), ch2_list) | Vector4_K_Matrix_cf_t0 (c, ch2_list) -> Vector4_K_Matrix_cf_t0 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t1 (c, ch2_list) -> Vector4_K_Matrix_cf_t1 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t2 (c, ch2_list) -> Vector4_K_Matrix_cf_t2 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t_rsi (c, ch2_list) -> Vector4_K_Matrix_cf_t_rsi ((x * c), ch2_list) | Vector4_K_Matrix_cf_m0 (c, ch2_list) -> Vector4_K_Matrix_cf_m0 ((x * c), ch2_list) | Vector4_K_Matrix_cf_m1 (c, ch2_list) -> Vector4_K_Matrix_cf_m1 ((x * c), ch2_list) | Vector4_K_Matrix_cf_m7 (c, ch2_list) -> Vector4_K_Matrix_cf_m7 ((x * c), ch2_list) | DScalar2_Vector2_K_Matrix_ms (c, ch2_list) -> DScalar2_Vector2_K_Matrix_ms ((x * c), ch2_list) | DScalar2_Vector2_m_0_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_0_K_Matrix_cf ((x * c), ch2_list) | DScalar2_Vector2_m_1_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_1_K_Matrix_cf ((x * c), ch2_list) | DScalar2_Vector2_m_7_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_7_K_Matrix_cf ((x * c), ch2_list) | DScalar4_K_Matrix_ms (c, ch2_list) -> DScalar4_K_Matrix_ms ((x * c), ch2_list) | Dim8_Scalar2_Vector2_1 c -> Dim8_Scalar2_Vector2_1 (x * c) | Dim8_Scalar2_Vector2_2 c -> Dim8_Scalar2_Vector2_1 (x * c) | Dim8_Scalar2_Vector2_m_0 c -> Dim8_Scalar2_Vector2_m_0 (x * c) | Dim8_Scalar2_Vector2_m_1 c -> Dim8_Scalar2_Vector2_m_1 (x * c) | Dim8_Scalar2_Vector2_m_7 c -> Dim8_Scalar2_Vector2_m_7 (x * c) | Dim8_Scalar4 c -> Dim8_Scalar4 (x * c) | Dim8_Vector4_t_0 ic4_list -> Dim8_Vector4_t_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_t_1 ic4_list -> Dim8_Vector4_t_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_t_2 ic4_list -> Dim8_Vector4_t_2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_0 ic4_list -> Dim8_Vector4_m_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_1 ic4_list -> Dim8_Vector4_m_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_7 ic4_list -> Dim8_Vector4_m_7 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim6_H4_P2 c -> Dim6_H4_P2 (x * c) | Dim6_AHWW_DPB c -> Dim6_AHWW_DPB (x * c) | Dim6_AHWW_DPW c -> Dim6_AHWW_DPW (x * c) | Dim6_AHWW_DW c -> Dim6_AHWW_DW (x * c) | Dim6_Vector4_DW c -> Dim6_Vector4_DW (x * c) | Dim6_Vector4_W c -> Dim6_Vector4_W (x * c) | Dim6_Scalar2_Vector2_PB c -> Dim6_Scalar2_Vector2_PB (x * c) | Dim6_Scalar2_Vector2_D c -> Dim6_Scalar2_Vector2_D (x * c) | Dim6_Scalar2_Vector2_DP c -> Dim6_Scalar2_Vector2_DP (x * c) | Dim6_HHZZ_T c -> Dim6_HHZZ_T (x * c) | Dim6_HWWZ_DW c -> Dim6_HWWZ_DW (x * c) | Dim6_HWWZ_DPB c -> Dim6_HWWZ_DPB (x * c) | Dim6_HWWZ_DDPW c -> Dim6_HWWZ_DDPW (x * c) | Dim6_HWWZ_DPW c -> Dim6_HWWZ_DPW (x * c) | Dim6_AHHZ_D c -> Dim6_AHHZ_D (x * c) | Dim6_AHHZ_DP c -> Dim6_AHHZ_DP (x * c) | Dim6_AHHZ_PB c -> Dim6_AHHZ_PB (x * c) let cmult_vertex4 z v = match integer z with | None -> invalid_arg "cmult_vertex4" | Some x -> mult_vertex4 x v -let mult_vertexn x = function +let mult_vertexn _x = function | _ -> incomplete "mult_vertexn" let cmult_vertexn z v = let open Coupling in match v with | UFO (c, v, s, fl, col) -> UFO (QC.mul z c, v, s, fl, col) let mult_vertex x v = let open Coupling in match v with | V3 (v, fuse, c) -> V3 (mult_vertex3 x v, fuse, c) | V4 (v, fuse, c) -> V4 (mult_vertex4 x v, fuse, c) | Vn (v, fuse, c) -> Vn (mult_vertexn x v, fuse, c) let cmult_vertex z v = let open Coupling in match v with | V3 (v, fuse, c) -> V3 (cmult_vertex3 z v, fuse, c) | V4 (v, fuse, c) -> V4 (cmult_vertex4 z v, fuse, c) | Vn (v, fuse, c) -> Vn (cmult_vertexn z v, fuse, c) (* \thocwmodulesection{Flavors Adorned with Colorflows} *) module Flavor (M : Model.T) = struct type cf_in = int type cf_out = int (* \begin{dubious} The legacy types [CF_in], etc, are not orthogonal to [Color_Propagator.t], unfortunately, but we will have to life with this for a while. \end{dubious} *) module CP = Color_Propagator type t = | White of M.flavor | CF_in of M.flavor * cf_in | CF_out of M.flavor * cf_out | CF_io of M.flavor * cf_in * cf_out | CF_aux of M.flavor | CF of M.flavor * CP.t let flavor_sans_color = function | White f -> f | CF_in (f, _) -> f | CF_out (f, _) -> f | CF_io (f, _, _) -> f | CF_aux f -> f | CF (f, _) -> f let pullback f arg1 = f (flavor_sans_color arg1) (* Since the alternatives in the sum type [t] are not orthogonal, we have make sure that we don't produce false negatives. In addition, non trivial color flows of type [Color_Propagator.t] need a special equality. \begin{dubious} Converting everything to [CF (f, cp)] first is the most concise, but not the most efficient approach. However, it's probably not worth the effort to cook up an optimized comparison before we retire the other alternatives in [t]. \end{dubious} *) let to_cp = function | White f -> (f, CP.white) | CF_in (f, cfi) -> (f, CP.of_lists [cfi] []) | CF_out (f, cfo) -> (f, CP.of_lists [] [cfo]) | CF_io (f, cfi, cfo) -> (f, CP.of_lists [cfi] [cfo]) | CF_aux f -> (f, CP.Ghost) | CF (f, cp) -> (f, cp) let equal f1 f2 = let f1, cp1 = to_cp f1 and f2, cp2 = to_cp f2 in f1 = f2 && CP.equal cp1 cp2 end (* \thocwmodulesection{The Legacy Implementation} *) (* We have to keep this legacy implementation around, because it infers the color flows from the $\mathrm{SU}(3)$ representations of a particle in vertices with three and four legs (except for four triplets, where the connections are ambiguous). The new implementation is already used for UFO models exclusively, since they don't use [Coupling.V2] and [Coupling.V3] at all. *) module Legacy_Implementation (M : Model.T) = struct module C = Color module Colored_Flavor = Flavor(M) open Colored_Flavor open Coupling let nc = M.nc (* \thocwmodulesubsection{Auxiliary functions} *) (* Below, we will need to permute Lorentz structures. The following permutes the three possible contractions of four vectors. We permute the first three indices, as they correspond to the particles entering the fusion. *) type permutation4 = | P123 | P231 | P312 | P213 | P321 | P132 let permute_contract4 = function | P123 -> begin function | C_12_34 -> C_12_34 | C_13_42 -> C_13_42 | C_14_23 -> C_14_23 end | P231 -> begin function | C_12_34 -> C_14_23 | C_13_42 -> C_12_34 | C_14_23 -> C_13_42 end | P312 -> begin function | C_12_34 -> C_13_42 | C_13_42 -> C_14_23 | C_14_23 -> C_12_34 end | P213 -> begin function | C_12_34 -> C_12_34 | C_13_42 -> C_14_23 | C_14_23 -> C_13_42 end | P321 -> begin function | C_12_34 -> C_14_23 | C_13_42 -> C_13_42 | C_14_23 -> C_12_34 end | P132 -> begin function | C_12_34 -> C_13_42 | C_13_42 -> C_12_34 | C_14_23 -> C_14_23 end let permute_contract4_list perm ic4_list = List.map (fun (i, c4) -> (i, permute_contract4 perm c4)) ic4_list let permute_vertex4' perm = function | Scalar4 c -> Scalar4 c | Vector4 ic4_list -> Vector4 (permute_contract4_list perm ic4_list) | Vector4_K_Matrix_jr (c, ic4_list) -> Vector4_K_Matrix_jr (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t0 (c, ic4_list) -> Vector4_K_Matrix_cf_t0 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t1 (c, ic4_list) -> Vector4_K_Matrix_cf_t1 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t2 (c, ic4_list) -> Vector4_K_Matrix_cf_t2 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t_rsi (c, ic4_list) -> Vector4_K_Matrix_cf_t_rsi (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m0 (c, ic4_list) -> Vector4_K_Matrix_cf_m0 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m1 (c, ic4_list) -> Vector4_K_Matrix_cf_m1 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m7 (c, ic4_list) -> Vector4_K_Matrix_cf_m7 (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_K_Matrix_ms (c, ic4_list) -> DScalar2_Vector2_K_Matrix_ms (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_0_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_0_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_1_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_1_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_7_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_7_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar4_K_Matrix_ms (c, ic4_list) -> DScalar4_K_Matrix_ms (c, permute_contract4_list perm ic4_list) - | Scalar2_Vector2 c -> + | Scalar2_Vector2 _c -> incomplete "permute_vertex4' Scalar2_Vector2" - | DScalar4 ic4_list -> + | DScalar4 _ic4_list -> incomplete "permute_vertex4' DScalar4" - | DScalar2_Vector2 ic4_list -> + | DScalar2_Vector2 _ic4_list -> incomplete "permute_vertex4' DScalar2_Vector2" - | GBBG (c, fb, b2, f) -> + | GBBG (_c, _fb, _b2, _f) -> incomplete "permute_vertex4' GBBG" - | Vector4_K_Matrix_tho (c, ch2_list) -> + | Vector4_K_Matrix_tho (_c, _ch2_list) -> incomplete "permute_vertex4' Vector4_K_Matrix_tho" - | Dim8_Scalar2_Vector2_1 ic4_list -> + | Dim8_Scalar2_Vector2_1 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_1" - | Dim8_Scalar2_Vector2_2 ic4_list -> + | Dim8_Scalar2_Vector2_2 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_2" - | Dim8_Scalar2_Vector2_m_0 ic4_list -> + | Dim8_Scalar2_Vector2_m_0 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_0" - | Dim8_Scalar2_Vector2_m_1 ic4_list -> + | Dim8_Scalar2_Vector2_m_1 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_1" - | Dim8_Scalar2_Vector2_m_7 ic4_list -> + | Dim8_Scalar2_Vector2_m_7 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_7" - | Dim8_Scalar4 ic4_list -> + | Dim8_Scalar4 _ic4_list -> incomplete "permute_vertex4' Dim8_Scalar4" - | Dim8_Vector4_t_0 ic4_list -> + | Dim8_Vector4_t_0 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_0" - | Dim8_Vector4_t_1 ic4_list -> + | Dim8_Vector4_t_1 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_1" - | Dim8_Vector4_t_2 ic4_list -> + | Dim8_Vector4_t_2 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_2" - | Dim8_Vector4_m_0 ic4_list -> + | Dim8_Vector4_m_0 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_0" - | Dim8_Vector4_m_1 ic4_list -> + | Dim8_Vector4_m_1 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_1" - | Dim8_Vector4_m_7 ic4_list -> + | Dim8_Vector4_m_7 _ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_7" - | Dim6_H4_P2 ic4_list -> + | Dim6_H4_P2 _ic4_list -> incomplete "permute_vertex4' Dim6_H4_P2" - | Dim6_AHWW_DPB ic4_list -> + | Dim6_AHWW_DPB _ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DPB" - | Dim6_AHWW_DPW ic4_list -> + | Dim6_AHWW_DPW _ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DPW" - | Dim6_AHWW_DW ic4_list -> + | Dim6_AHWW_DW _ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DW" - | Dim6_Vector4_DW ic4_list -> + | Dim6_Vector4_DW _ic4_list -> incomplete "permute_vertex4' Dim6_Vector4_DW" - | Dim6_Vector4_W ic4_list -> + | Dim6_Vector4_W _ic4_list -> incomplete "permute_vertex4' Dim6_Vector4_W" - | Dim6_Scalar2_Vector2_D ic4_list -> + | Dim6_Scalar2_Vector2_D _ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_D" - | Dim6_Scalar2_Vector2_DP ic4_list -> + | Dim6_Scalar2_Vector2_DP _ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_DP" - | Dim6_Scalar2_Vector2_PB ic4_list -> + | Dim6_Scalar2_Vector2_PB _ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_PB" - | Dim6_HHZZ_T ic4_list -> + | Dim6_HHZZ_T _ic4_list -> incomplete "permute_vertex4' Dim6_HHZZ_T" - | Dim6_HWWZ_DW ic4_list -> + | Dim6_HWWZ_DW _ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DW" - | Dim6_HWWZ_DPB ic4_list -> + | Dim6_HWWZ_DPB _ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DPB" - | Dim6_HWWZ_DDPW ic4_list -> + | Dim6_HWWZ_DDPW _ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DDPW" - | Dim6_HWWZ_DPW ic4_list -> + | Dim6_HWWZ_DPW _ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DPW" - | Dim6_AHHZ_D ic4_list -> + | Dim6_AHHZ_D _ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_D" - | Dim6_AHHZ_DP ic4_list -> + | Dim6_AHHZ_DP _ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_DP" - | Dim6_AHHZ_PB ic4_list -> + | Dim6_AHHZ_PB _ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_PB" let permute_vertex4 perm = function | V3 (v, fuse, c) -> V3 (v, fuse, c) | V4 (v, fuse, c) -> V4 (permute_vertex4' perm v, fuse, c) | Vn (v, fuse, c) -> Vn (v, fuse, c) (* \thocwmodulesubsection{Cubic Vertices} *) (* \begin{dubious} The following pattern matches could eventually become quite long. The O'Caml compiler will (hopefully) optimize them aggressively (\url{http://pauillac.inria.fr/~maranget/papers/opat/}). \end{dubious} *) let colorize_fusion2 f1 f2 (f, v) = match M.color f with | C.Singlet -> begin match f1, f2 with | White _, White _ -> [White f, v] | CF_in (_, c1), CF_out (_, c2') | CF_out (_, c1), CF_in (_, c2') -> if c1 = c2' then [White f, v] else [] - | CF_io (f1, c1, c1'), CF_io (f2, c2, c2') -> + | CF_io (_, c1, c1'), CF_io (_, c2, c2') -> if c1 = c2' && c2 = c1' then [White f, v] else [] - | CF_aux f1, CF_aux f2 -> + | CF_aux _, CF_aux _ -> [White f, mult_vertex (- (nc ())) v] | CF_aux _, CF_io _ | CF_io _, CF_aux _ -> [] | (CF_in _ | CF_out _ | CF_io _ | CF_aux _), White _ | White _, (CF_in _ | CF_out _ | CF_io _ | CF_aux _) | (CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (CF_in _ | CF_out _), (CF_io _ | CF_aux _) | CF_in _, CF_in _ | CF_out _, CF_out _ -> colored_vertex "colorize_fusion2" | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c end | C.SUN nc1 -> begin match f1, f2 with | CF_in (_, c1), (White _ | CF_aux _) | (White _ | CF_aux _), CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), v] else colored_vertex "colorize_fusion2" | CF_out (_, c1'), (White _ | CF_aux _) | (White _ | CF_aux _), CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), v] else colored_vertex "colorize_fusion2" | CF_in (_, c1), CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_in (_, c1) -> if nc1 > 0 then begin if c1 = c2' then [CF_in (f, c2), v] else [] end else colored_vertex "colorize_fusion2" | CF_out (_, c1'), CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_out (_, c1') -> if nc1 < 0 then begin if c1' = c2 then [CF_out (f, c2'), v] else [] end else colored_vertex "colorize_fusion2" | CF_in _, CF_in _ -> if nc1 > 0 then baryonic_vertex "colorize_fusion2" else colored_vertex "colorize_fusion2" | CF_out _, CF_out _ -> if nc1 < 0 then baryonic_vertex "colorize_fusion2" else colored_vertex "colorize_fusion2" | CF_in _, CF_out _ | CF_out _, CF_in _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) -> colored_vertex "colorize_fusion2" | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c end | C.AdjSUN _ -> begin match f1, f2 with | White _, CF_io (_, c1, c2') | CF_io (_, c1, c2'), White _ -> [CF_io (f, c1, c2'), v] (* Note that for $\tr(F_{mu\nu}F^{\mu\nu})$ couplings, like the effective $Hgg$ coupling, we can't inplement the rules derived in~\cite{Kilian:2012pz}. fusing [White] with [CF_aux] would have to produce a [CF_io], but there is canonical source for a fresh color flow index! If the gluons are not connected via an inbroken string of such couplings to an external line, we can use the considerations in~\eqref{eq:qqqqH} to replace the factor~$N_C$ by $-N_C$. In order to account for the gluons that are connected via an inbroken string of such couplings to an external line, we apply a correction factor $1-2/N_C^2$ for each gluon loop in the very end. *) | White _, CF_aux _ | CF_aux _, White _ -> [CF_aux f, mult_vertex (- (nc ())) v] | CF_in (_, c1), CF_out (_, c2') | CF_out (_, c2'), CF_in (_, c1) -> if c1 <> c2' then [CF_io (f, c1, c2'), v] else [CF_aux f, v] (* In the adjoint representation \begin{subequations} \begin{equation} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3} \fmf{gluon}{v,e1} \fmf{gluon}{v,e2} \fmf{gluon}{v,e3} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e1} \fmf{warrow_right}{v,e2} \fmf{warrow_right}{v,e3} \end{fmfgraph*}}} \,= %begin{split} g f_{a_1a_2a_3} C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3) %end{split} \end{equation} with \begin{multline} \label{eq:C123} C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3) = \\ ( g^{\mu_1\mu_2} (k_1^{\mu_3}-k_2^{\mu_3}) + g^{\mu_2\mu_3} (k_2^{\mu_1}-k_3^{\mu_1}) + g^{\mu_3\mu_1} (k_3^{\mu_2}-k_1^{\mu_2}) ) \end{multline} \end{subequations} while in the color flow basis find from \begin{equation} \label{eq:f=tr(TTT)} \ii f_{a_1a_2a_3} = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right) = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \end{equation} the decomposition \begin{equation} \label{eq:fTTT} \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3} = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,. \end{equation} The resulting Feynman rule is \begin{equation} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3} \fmf{phantom}{v,e1} \fmf{phantom}{v,e2} \fmf{phantom}{v,e3} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmffreeze \fmfi{phantom_arrow}{(reverse vpath (__e1, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e1, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e1, __v) sideways -thick) join ( vpath (__e2, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e2, __v) sideways -thick) join ( vpath (__e3, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e3, __v) sideways -thick) join ( vpath (__e1, __v) sideways -thick)} \end{fmfgraph*}}} \,= \ii g \left( \delta^{i_1j_3}\delta^{i_2j_1}\delta^{i_3j_2} - \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} \right) C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3) \end{equation} *) (* \begin{dubious} We have to generalize this for cases of three particles in the adjoint that are not all gluons (gluinos, scalar octets): \begin{itemize} \item scalar-scalar-scalar \item scalar-scalar-vector \item scalar-vector-vector \item scalar-fermion-fermion \item vector-fermion-fermion \end{itemize} \end{dubious} *) (* \begin{dubious} We could use a better understanding of the signs for the gaugino-gaugino-gaugeboson couplings!!! \end{dubious} *) - | CF_io (f1, c1, c1'), CF_io (f2, c2, c2') -> + | CF_io (_, c1, c1'), CF_io (_, c2, c2') -> let phase = begin match v with | V3 (Gauge_Gauge_Gauge _, _, _) | V3 (I_Gauge_Gauge_Gauge _, _, _) | V3 (Aux_Gauge_Gauge _, _, _) -> of_int 1 | V3 (FBF (_, _, _, _), fuse2, _) -> begin match fuse2 with | F12 -> of_int 1 (* works, needs underpinning *) | F21 -> of_int (-1) (* dto. *) | F31 -> of_int 1 (* dto. *) | F32 -> of_int (-1) (* transposition of [F12] *) | F23 -> of_int 1 (* transposition of [F21] *) | F13 -> of_int (-1) (* transposition of [F12] *) end | V3 _ -> incomplete "colorize_fusion2 (V3 _)" | V4 _ -> impossible "colorize_fusion2 (V4 _)" | Vn _ -> impossible "colorize_fusion2 (Vn _)" end in if c1' = c2 then [CF_io (f, c1, c2'), cmult_vertex (QC.neg phase) v] else if c2' = c1 then [CF_io (f, c2, c1'), cmult_vertex ( phase) v] else [] | CF_aux _ , CF_io _ | CF_io _ , CF_aux _ | CF_aux _ , CF_aux _ -> [] | White _, White _ | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | CF_in _, CF_in _ | CF_out _, CF_out _ -> colored_vertex "colorize_fusion2" | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c end | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusion2" (* \thocwmodulesubsection{Quartic Vertices} *) let colorize_fusion3 f1 f2 f3 (f, v) = match M.color f with | C.Singlet -> begin match f1, f2, f3 with | White _, White _, White _ -> [White f, v] | (White _ | CF_aux _), CF_in (_, c1), CF_out (_, c2') | (White _ | CF_aux _), CF_out (_, c1), CF_in (_, c2') | CF_in (_, c1), (White _ | CF_aux _), CF_out (_, c2') | CF_out (_, c1), (White _ | CF_aux _), CF_in (_, c2') | CF_in (_, c1), CF_out (_, c2'), (White _ | CF_aux _) | CF_out (_, c1), CF_in (_, c2'), (White _ | CF_aux _) -> if c1 = c2' then [White f, v] else [] | White _, CF_io (_, c1, c1'), CF_io (_, c2, c2') | CF_io (_, c1, c1'), White _, CF_io (_, c2, c2') | CF_io (_, c1, c1'), CF_io (_, c2, c2'), White _ -> if c1 = c2' && c2 = c1' then [White f, v] else [] | White _, CF_aux _, CF_aux _ | CF_aux _, White _, CF_aux _ | CF_aux _, CF_aux _, White _ -> [White f, mult_vertex (- (nc ())) v] | White _, CF_io _, CF_aux _ | White _, CF_aux _, CF_io _ | CF_io _, White _, CF_aux _ | CF_aux _, White _, CF_io _ | CF_io _, CF_aux _, White _ | CF_aux _, CF_io _, White _ -> [] | CF_io (_, c1, c1'), CF_in (_, c2), CF_out (_, c3') | CF_io (_, c1, c1'), CF_out (_, c3'), CF_in (_, c2) | CF_in (_, c2), CF_io (_, c1, c1'), CF_out (_, c3') | CF_out (_, c3'), CF_io (_, c1, c1'), CF_in (_, c2) | CF_in (_, c2), CF_out (_, c3'), CF_io (_, c1, c1') | CF_out (_, c3'), CF_in (_, c2), CF_io (_, c1, c1') -> if c1 = c3' && c1' = c2 then [White f, v] else [] | CF_io (_, c1, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') -> if c1' = c2 && c2' = c3 && c3' = c1 then [White f, mult_vertex (-1) v] else if c1' = c3 && c2' = c1 && c3' = c2 then [White f, mult_vertex ( 1) v] else [] | CF_io _, CF_io _, CF_aux _ | CF_io _, CF_aux _, CF_io _ | CF_aux _, CF_io _, CF_io _ | CF_io _, CF_aux _, CF_aux _ | CF_aux _, CF_io _, CF_aux _ | CF_aux _, CF_aux _, CF_io _ | CF_aux _, CF_aux _, CF_aux _ -> [] | CF_in _, CF_in _, CF_in _ | CF_out _, CF_out _, CF_out _ -> baryonic_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_out _ | CF_in _, CF_out _, CF_in _ | CF_out _, CF_in _, CF_in _ | CF_in _, CF_out _, CF_out _ | CF_out _, CF_in _, CF_out _ | CF_out _, CF_out _, CF_in _ | White _, White _, (CF_io _ | CF_aux _) | White _, (CF_io _ | CF_aux _), White _ | (CF_io _ | CF_aux _), White _, White _ | (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _ | CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _ | CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _ | CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _ | CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) -> non_legacy_color "colorize_fusion3" c end | C.SUN nc1 -> begin match f1, f2, f3 with | CF_in (_, c1), CF_io (_, c2, c2'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_in (_, c1), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_in (_, c1) -> if nc1 > 0 then if c1 = c2' && c2 = c3' then [CF_in (f, c3), v] else if c1 = c3' && c3 = c2' then [CF_in (f, c2), v] else [] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_out (_, c1'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_out (_, c1') -> if nc1 < 0 then if c1' = c2 && c2' = c3 then [CF_out (f, c3'), v] else if c1' = c3 && c3' = c2 then [CF_out (f, c2'), v] else [] else colored_vertex "colorize_fusion3" | CF_aux _, CF_in (_, c1), CF_io (_, c2, c2') | CF_aux _, CF_io (_, c2, c2'), CF_in (_, c1) | CF_in (_, c1), CF_aux _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_aux _, CF_in (_, c1) | CF_in (_, c1), CF_io (_, c2, c2'), CF_aux _ | CF_io (_, c2, c2'), CF_in (_, c1), CF_aux _ -> if nc1 > 0 then if c1 = c2' then [CF_in (f, c2), mult_vertex ( 2) v] else [] else colored_vertex "colorize_fusion3" | CF_aux _, CF_out (_, c1'), CF_io (_, c2, c2') | CF_aux _, CF_io (_, c2, c2'), CF_out (_, c1') | CF_out (_, c1'), CF_aux _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_aux _, CF_out (_, c1') | CF_out (_, c1'), CF_io (_, c2, c2'), CF_aux _ | CF_io (_, c2, c2'), CF_out (_, c1'), CF_aux _ -> if nc1 < 0 then if c1' = c2 then [CF_out (f, c2'), mult_vertex ( 2) v] else [] else colored_vertex "colorize_fusion3" | White _, CF_in (_, c1), CF_io (_, c2, c2') | White _, CF_io (_, c2, c2'), CF_in (_, c1) | CF_in (_, c1), White _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), White _, CF_in (_, c1) | CF_in (_, c1), CF_io (_, c2, c2'), White _ | CF_io (_, c2, c2'), CF_in (_, c1), White _ -> if nc1 > 0 then if c1 = c2' then [CF_in (f, c2), v] else [] else colored_vertex "colorize_fusion3" | White _, CF_out (_, c1'), CF_io (_, c2, c2') | White _, CF_io (_, c2, c2'), CF_out (_, c1') | CF_out (_, c1'), White _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), White _, CF_out (_, c1') | CF_out (_, c1'), CF_io (_, c2, c2'), White _ | CF_io (_, c2, c2'), CF_out (_, c1'), White _ -> if nc1 < 0 then if c2 = c1' then [CF_out (f, c2'), v] else [] else colored_vertex "colorize_fusion3" | CF_in (_, c1), CF_aux _, CF_aux _ | CF_aux _, CF_in (_, c1), CF_aux _ | CF_aux _, CF_aux _, CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), mult_vertex ( 2) v] else colored_vertex "colorize_fusion3" | CF_in (_, c1), CF_aux _, White _ | CF_in (_, c1), White _, CF_aux _ | CF_in (_, c1), White _, White _ | CF_aux _, CF_in (_, c1), White _ | White _, CF_in (_, c1), CF_aux _ | White _, CF_in (_, c1), White _ | CF_aux _, White _, CF_in (_, c1) | White _, CF_aux _, CF_in (_, c1) | White _, White _, CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), v] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_aux _, CF_aux _ | CF_aux _, CF_out (_, c1'), CF_aux _ | CF_aux _, CF_aux _, CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), mult_vertex ( 2) v] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_aux _, White _ | CF_out (_, c1'), White _, CF_aux _ | CF_out (_, c1'), White _, White _ | CF_aux _, CF_out (_, c1'), White _ | White _, CF_out (_, c1'), CF_aux _ | White _, CF_out (_, c1'), White _ | CF_aux _, White _, CF_out (_, c1') | White _, CF_aux _, CF_out (_, c1') | White _, White _, CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), v] else colored_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_out _ | CF_in _, CF_out _, CF_in _ | CF_out _, CF_in _, CF_in _ -> if nc1 > 0 then color_flow_ambiguous "colorize_fusion3" else colored_vertex "colorize_fusion3" | CF_in _, CF_out _, CF_out _ | CF_out _, CF_in _, CF_out _ | CF_out _, CF_out _, CF_in _ -> if nc1 < 0 then color_flow_ambiguous "colorize_fusion3" else colored_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_in _ | CF_out _, CF_out _, CF_out _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) -> non_legacy_color "colorize_fusion3" c end - | C.AdjSUN nc -> + | C.AdjSUN _ -> 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_io (_, _, _), CF_aux _, White _ + | CF_aux _, CF_io (_, _, _), White _ + | CF_io (_, _, _), White _, CF_aux _ + | CF_aux _, White _, CF_io (_, _, _) + | White _, CF_io (_, _, _), CF_aux _ + | White _, CF_aux _, CF_io (_, _, _) -> [] | CF_aux _, CF_aux _, White _ | CF_aux _, White _, CF_aux _ | White _, CF_aux _, CF_aux _ -> [] | White _, White _, CF_io (_, c1, c1') | White _, CF_io (_, c1, c1'), White _ | CF_io (_, c1, c1'), White _, White _ -> [CF_io (f, c1, c1'), v] | White _, White _, CF_aux _ | White _, CF_aux _, White _ | CF_aux _, White _, White _ -> [] | White _, White _, White _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _) | CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _ | (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _ | CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _) | CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _ | (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _ | (CF_in _ | CF_out _), (CF_in _ | CF_out _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) -> non_legacy_color "colorize_fusion3" c end | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusion3" (* \thocwmodulesubsection{Quintic and Higher Vertices} *) let is_white = function | White _ -> true | _ -> false - let colorize_fusionn flist (f, v) = + let _colorize_fusionn flist (f, v) = let incomplete_match () = incomplete ("colorize_fusionn { " ^ String.concat ", " (List.map (pullback M.flavor_to_string) flist) ^ " } -> " ^ M.flavor_to_string f) in match M.color f with | C.Singlet -> if List.for_all is_white flist then [White f, v] else incomplete_match () | C.SUN _ -> if List.for_all is_white flist then colored_vertex "colorize_fusionn" else incomplete_match () | C.AdjSUN _ -> if List.for_all is_white flist then colored_vertex "colorize_fusionn" else incomplete_match () | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusionn" end (* \thocwmodulesection{Colorizing a Monochrome Model} *) module It (M : Model.T) = struct open Coupling module C = Color module CA = Arrow module CV = Color.Vertex module Colored_Flavor = Flavor(M) type flavor = Colored_Flavor.t type flavor_sans_color = M.flavor let flavor_sans_color = Colored_Flavor.flavor_sans_color type gauge = M.gauge type constant = M.constant let options = M.options let caveats = M.caveats type coupling_order = M.coupling_order let all_coupling_orders = M.all_coupling_orders let coupling_orders = M.coupling_orders let coupling_order_to_string = M.coupling_order_to_string open Colored_Flavor let flavor_equal = Colored_Flavor.equal let color = pullback M.color let nc = M.nc let pdg = pullback M.pdg let lorentz = pullback M.lorentz module Ch = M.Ch let charges = pullback M.charges (* For the propagator we cannot use pullback because we have to add the case of the color singlet propagator by hand. *) let cf_aux_propagator = function | Prop_Scalar -> Prop_Col_Scalar (* Spin 0 octets. *) | Prop_Majorana -> Prop_Col_Majorana (* Spin 1/2 octets. *) | Prop_Feynman -> Prop_Col_Feynman (* Spin 1 states, massless. *) | Prop_Unitarity -> Prop_Col_Unitarity (* Spin 1 states, massive. *) | Aux_Scalar -> Aux_Col_Scalar (* constant colored scalar propagator *) | Aux_Vector -> Aux_Col_Vector (* constant colored vector propagator *) | Aux_Tensor_1 -> Aux_Col_Tensor_1 (* constant colored tensor propagator *) | Prop_Col_Scalar | Prop_Col_Feynman | Prop_Col_Majorana | Prop_Col_Unitarity | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> failwith ("Colorize.It().colorize_propagator: already colored particle!") | _ -> failwith ("Colorize.It().colorize_propagator: impossible!") let propagator = function | CF_aux f -> cf_aux_propagator (M.propagator f) | White f -> M.propagator f | CF_in (f, _) -> M.propagator f | CF_out (f, _) -> M.propagator f | CF_io (f, _, _) -> M.propagator f | CF (f, c) -> begin match c with | CP.Flow _ | CP.Flow_with_Epsilons _ | CP.Flow_with_Epsilon_Bars _-> M.propagator f | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ -> cf_aux_propagator (M.propagator f) end let width = pullback M.width let goldstone = function | White f -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (White f', g) end | CF_in (f, c) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_in (f', c), g) end | CF_out (f, c) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_out (f', c), g) end | CF_io (f, c1, c2) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_io (f', c1, c2), g) end | CF_aux f -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_aux f', g) end | CF (f, c) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF (f', c), g) end let conjugate = function | White f -> White (M.conjugate f) | CF_in (f, c) -> CF_out (M.conjugate f, c) | CF_out (f, c) -> CF_in (M.conjugate f, c) | CF_io (f, c1, c2) -> CF_io (M.conjugate f, c2, c1) | CF_aux f -> CF_aux (M.conjugate f) | CF (f, c) -> CF (M.conjugate f, CP.conjugate c) let conjugate_sans_color = M.conjugate let fermion = pullback M.fermion - let max_degree = M.max_degree + let _max_degree = M.max_degree let flavors () = invalid "flavors" let external_flavors () = invalid "external_flavors" let parameters = M.parameters let split_color_string s = try let i1 = String.index s '/' in let i2 = String.index_from s (succ i1) '/' in let sf = String.sub s 0 i1 and sc1 = String.sub s (succ i1) (i2 - i1 - 1) and sc2 = String.sub s (succ i2) (String.length s - i2 - 1) in (sf, sc1, sc2) with | Not_found -> (s, "", "") let flavor_of_string s = try let sf, sc1, sc2 = split_color_string s in let f = M.flavor_of_string sf in match M.color f with | C.Singlet -> White f | C.SUN nc -> if nc > 0 then CF_in (f, color_flow_of_string sc1) else CF_out (f, color_flow_of_string sc2) | C.AdjSUN _ -> begin match sc1, sc2 with | "", "" -> CF_aux f | _, _ -> CF_io (f, color_flow_of_string sc1, color_flow_of_string sc2) end | C.YT _ | C.YTC _ -> incomplete "flavor_of_string: Young tableaux" with | Failure s -> if s = "int_of_string" then invalid_arg "Colorize().flavor_of_string: expecting integer" else failwith ("Colorize().flavor_of_string: unexpected Failure(" ^ s ^ ")") let flavor_to_string = function | White f -> M.flavor_to_string f | CF_in (f, c) -> M.flavor_to_string f ^ "/" ^ string_of_int c ^ "/" | CF_out (f, c) -> M.flavor_to_string f ^ "//" ^ string_of_int c | CF_io (f, c1, c2) -> M.flavor_to_string f ^ "/" ^ string_of_int c1 ^ "/" ^ string_of_int c2 | CF_aux f -> M.flavor_to_string f ^ "//" | CF (f, cp) -> M.flavor_to_string f ^ "/" ^ CP.to_string cp (* \begin{dubious} [CP.to_string] need to be replaced! \end{dubious} *) let flavor_to_TeX = function | White f -> M.flavor_to_TeX f | CF_in (f, c) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ string_of_int c ^ "}" | CF_out (f, c) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut\\overline{" ^ string_of_int c ^ "}}" | CF_io (f, c1, c2) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ string_of_int c1 ^ "\\overline{" ^ string_of_int c2 ^ "}}" | CF_aux f -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut 0}" | CF (f, cp) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ CP.to_string cp ^ "}" let flavor_symbol = function | White f -> "f" ^ M.flavor_symbol f | CF_in (f, c) -> "f" ^ M.flavor_symbol f ^ "_i" ^ string_of_int c | CF_out (f, c) -> "f" ^ M.flavor_symbol f ^ "_o" ^ string_of_int c | CF_io (f, c1, c2) -> "f" ^ M.flavor_symbol f ^ "_i" ^ string_of_int c1 ^ "o" ^ string_of_int c2 | CF_aux f -> "f" ^ M.flavor_symbol f ^ "_g" | CF (f, cp) -> "f" ^ M.flavor_symbol f ^ "_" ^ CP.to_symbol cp let gauge_symbol = M.gauge_symbol (* Masses and widths must not depend on the colors anyway! *) let mass_symbol = pullback M.mass_symbol let width_symbol = pullback M.width_symbol let constant_symbol = M.constant_symbol (* \thocwmodulesubsection{Vertices} *) (* [vertices] are \emph{only} used by functor applications and for indexing a cache of precomputed fusion rules, which is not used for colorized models. *) let vertices () = invalid "vertices" module Legacy = Legacy_Implementation (M) let colorize_fusion2 f1 f2 (f, v) = match v with | V3 _ -> Legacy.colorize_fusion2 f1 f2 (f, v) | _ -> [] let colorize_fusion3 f1 f2 f3 (f, v) = match v with | V4 _ -> Legacy.colorize_fusion3 f1 f2 f3 (f, v) | _ -> [] (* In order to match the \emph{correct} positions of the fields in the vertices, we have to undo the permutation effected by the fusion according to [Coupling.fusen]. *) - module PosMap = - Partial.Make (struct type t = int let compare = compare end) + module PosMap = Partial.Make (Int) (* Note that due to the [inverse], the list [l'] can be interpreted here as a map reshuffling the indices. E.\,g., [inverse (Permutation.Default.list [2;0;1])] applied to [[1;2;3]] gives [[3;1;2]]. *) - let partial_map_redoing_permutation l l' = + let _partial_map_redoing_permutation l l' = let module P = Permutation.Default in let p = P.inverse (P.of_list (List.map pred l')) in PosMap.of_lists l (P.list p l) (* Note that, the list [l'] can not be interpreted as a map reshuffling the indices, but gives the new order of the argument. E.\,g., [Permutation.Default.list [2;0;1]] applied to [[1;2;3]] gives [[2;3;1]]. *) let partial_map_undoing_permutation l l' = let module P = Permutation.Default in let p = P.of_list (List.map pred l') in PosMap.of_lists l (P.list p l) let color_sans_flavor = function | White _ -> CP.white | CF_in (_, cfi) -> CP.of_lists [cfi] [] | CF_out (_, cfo) -> CP.of_lists [] [cfo] | CF_io (_, cfi, cfo) -> CP.of_lists [cfi] [cfo] | CF_aux _ -> CP.Ghost - | CF (f, cp) -> cp + | CF (_, cp) -> cp (* \begin{dubious} Should we continue to translate the flows back and forth? \end{dubious} *) let color_with_flavor f = function | CP.Flow (cfis, cfos) as cp -> begin match PArray.to_option_list cfis, PArray.to_option_list cfos with | [], [] -> White f | [Some cfi], [] -> CF_in (f, cfi) | [], [Some cfo] -> CF_out (f, cfo) | [Some cfi], [Some cfo] -> CF_io (f, cfi, cfo) | _, _ -> CF (f, cp) end | CP.Flow_with_Epsilons (_, _) -> failwith "Colorize.color_with_flavor: unexpected epsilon" | CP.Flow_with_Epsilon_Bars (_, _) -> failwith "Colorize.color_with_flavor: unexpected epsilon bar" | CP.Ghost -> CF_aux f | CP.Ghost_with_Epsilons _ -> failwith "Colorize.color_with_flavor: unexpected epsilon" | CP.Ghost_with_Epsilon_Bars _ -> failwith "Colorize.color_with_flavor: unexpected epsilon bar" let colorize vertex_list flavors f v = List.map (fun (coef, cf) -> (color_with_flavor f cf, cmult_vertex coef v)) (Color_Fusion.fuse (nc ()) vertex_list (List.map color_sans_flavor flavors)) let partial_map_undoing_fusen fusen = partial_map_undoing_permutation (ThoList.range 1 (List.length fusen)) fusen let undo_permutation_of_fusen fusen = PosMap.apply_with_fallback (fun _ -> invalid_arg "permutation_of_fusen") (partial_map_undoing_fusen fusen) let colorize_fusionn_ufo flist f c v spins flines color fuse xtra = let v = Vn (UFO (c, v, spins, flines, Birdtracks.one), fuse, xtra) in let p = undo_permutation_of_fusen fuse in colorize (Birdtracks.relocate p color) flist f v let colorize_fusionn flist (f, v) = match v with | Vn (UFO (c, v, spins, flines, color), fuse, xtra) -> colorize_fusionn_ufo flist f c v spins flines color fuse xtra | _ -> [] let fuse_list flist = ThoList.flatmap (colorize_fusionn flist) (M.fuse (List.map flavor_sans_color flist)) let fuse2 f1 f2 = List.rev_append (fuse_list [f1; f2]) (ThoList.flatmap (colorize_fusion2 f1 f2) (M.fuse2 (flavor_sans_color f1) (flavor_sans_color f2))) let fuse3 f1 f2 f3 = List.rev_append (fuse_list [f1; f2; f3]) (ThoList.flatmap (colorize_fusion3 f1 f2 f3) (M.fuse3 (flavor_sans_color f1) (flavor_sans_color f2) (flavor_sans_color f3))) let fuse = function | [] | [_] -> invalid_arg "Colorize.It().fuse" | [f1; f2] -> fuse2 f1 f2 | [f1; f2; f3] -> fuse3 f1 f2 f3 | flist -> fuse_list flist let max_degree = M.max_degree (* \thocwmodulesubsection{Adding Color to External Particles} *) (* Count the color strings in [f_list]: one incoming each quark and gluon, one outgoing for each antiquark and gluon. Keep track of the number of gluons separately. *) (* Count the number of color lines for a given combination of flavors, assuming that the incoming lines have been crossed. Returns a pair $(n_{\text{in}},n_{\text{out}})$, corresponding to the number of incoming and outgoing lines respectively. Note that the two lines of gluons are included in~$n_{\text{in}}$ and~$n_{\text{out}}$. *) let count_color_strings f_list = let rec count_color_strings' n_in n_out = function | f :: rest -> begin match M.color f with | C.Singlet -> count_color_strings' n_in n_out rest | C.SUN nc -> if nc > 0 then count_color_strings' (succ n_in) n_out rest else if nc < 0 then count_color_strings' n_in (succ n_out) rest else su0 "count_color_strings" | C.AdjSUN _ -> count_color_strings' (succ n_in) (succ n_out) rest | C.YT y -> count_color_strings' (Young.num_cells_tableau y + n_in) n_out rest | C.YTC y -> count_color_strings' n_in (Young.num_cells_tableau y + n_out) rest end | [] -> (n_in, n_out) in count_color_strings' 0 0 f_list (* Return a list of all permutations of outgoing color lines. \begin{dubious} Currently, this assumes that there are an equal number of incoming and outgoing lines. This has to change, since we want to support $\epsilon$- and $\bar\epsilon$-couplings that act as sources and sinks of lines. \end{dubious} \begin{dubious} For efficiency, we could check whether the model contains $\epsilon$- or $\bar\epsilon$-couplings and produce only conserved color lines if not. \end{dubious} \begin{dubious} We can do even better if we add an optional parameter that contains the number of $\epsilon$- and $\bar\epsilon$-couplings appearing in the amplitude. This can be computed from the still uncolorized [DAG.t] by the calling function. \end{dubious} *) (* If there are an equal number of incoming and outgoing color strings, generate all permutations, e.\,g.~for $n=2$ we get [([1,2],[1,2]);([1,2],[2,1])]. *) let external_color_flows f_list = let n_in, n_out = 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 + List.exists (fun (_, _, _) -> true) verticesn (* [colorize_crossed_amplitude_opt ghosts flavors (cfi, cfo)] attempts to join the [flavors] with the external color flow [(cfi, cfo)]. Includes $\mathrm{U}(1)$ ghosts iff [ghosts] is [true] (i.\,e.~iff there are \emph{only} external gluons). Note that, despite the name, this only maps the external states and not yet the [DAG.t] describing the scattering amplitude. This will happen in [Fusion] (chapter~\ref{sec:fusion}). *) let external_ghosts f_list = if pure_adjoints f_list then two_adjoints_couple_to_singlets () else true let snoc = function | [] -> invalid_arg "Colorize.It().snoc: not enough color flow lines" | a :: alist -> (a, alist) let snoc_n n alist = try ThoList.splitn n alist with | Invalid_argument _ -> invalid_arg "Colorize.It().snoc_n: not enough color flow lines" let rec cca_opt ghosts acc f_list (ecf_in, ecf_out) = match f_list, ecf_in, ecf_out with | [], [], [] -> Some (List.rev acc) | [], _, _ -> invalid_arg "Colorize.It().colorize_crossed_amplitude_opt: leftover color flow lines" | f :: rest, _, _ -> begin match M.color f with | C.Singlet -> cca_opt ghosts (White f :: acc) rest (ecf_in, ecf_out) | C.SUN nc -> if nc > 0 then let cfi, ecf_in = snoc ecf_in in cca_opt ghosts (CF_in (f, cfi) :: acc) rest (ecf_in, ecf_out) else if nc < 0 then let cfo, ecf_out = snoc ecf_out in cca_opt ghosts (CF_out (f, cfo) :: acc) rest (ecf_in, ecf_out) else su0 "colorize_flavor" | C.AdjSUN _ -> let cfi, ecf_in = snoc ecf_in and cfo, ecf_out = snoc ecf_out in if cfi = cfo then begin if ghosts then cca_opt ghosts (CF_aux f :: acc) rest (ecf_in, ecf_out) else None end else cca_opt ghosts (CF_io (f, cfi, cfo) :: acc) rest (ecf_in, ecf_out) | C.YT y -> let cfi, ecf_in = snoc_n (Young.num_cells_tableau y) ecf_in in cca_opt ghosts (CF (f, CP.of_lists cfi []) :: acc) rest (ecf_in, ecf_out) | C.YTC y -> let cfo, ecf_out = snoc_n (Young.num_cells_tableau y) ecf_out in cca_opt ghosts (CF (f, CP.of_lists [] cfo) :: acc) rest (ecf_in, ecf_out) end let colorize_crossed_amplitude_opt ghosts f_list (ecf_in, ecf_out) = cca_opt ghosts [] f_list (ecf_in, ecf_out) let colorize_crossed_amplitude f_list = let ghosts = external_ghosts f_list in List.fold_left (fun ca_list ecf -> match colorize_crossed_amplitude_opt ghosts f_list ecf with | None -> ca_list | Some ca -> ca :: ca_list) [] (external_color_flows f_list) - let colorize_crossed_amplitude_logging f_list = + let _colorize_crossed_amplitude_logging f_list = let amplitudes = colorize_crossed_amplitude f_list in List.iter (fun a -> Printf.eprintf "%s\n" (ThoList.to_string flavor_to_string a)) amplitudes; amplitudes let cross_uncolored p_in p_out = (List.map M.conjugate p_in) @ p_out let uncross_colored n_in p_lists_colorized = let p_in_out_colorized = List.map (ThoList.splitn n_in) p_lists_colorized in List.map (fun (p_in_colored, p_out_colored) -> (List.map conjugate p_in_colored, p_out_colored)) p_in_out_colorized let amplitude p_in p_out = uncross_colored (List.length p_in) (colorize_crossed_amplitude (cross_uncolored p_in p_out)) (* The $-$-sign in the second component is redundant, but a Whizard convention. *) (* \begin{dubious} The case [CF (f, cp)] needs to be handled properly! \end{dubious} *) let indices = function | White _ -> Color.Flow.of_list [0; 0] | CF_in (_, c) -> Color.Flow.of_list [c; 0] | CF_out (_, c) -> Color.Flow.of_list [0; -c] | CF_io (_, c1, c2) -> Color.Flow.of_list [c1; -c2] | CF_aux _ -> Color.Flow.ghost () - | CF (f, cp) -> + | CF (_, cp) -> Printf.eprintf "Colorize.indices: color flow `%s' not handled yet\n" (CP.to_string cp); Color.Flow.of_list [-42; -42] let flow p_in p_out = (List.map indices p_in, List.map indices p_out) end (* \thocwmodulesection{Colorizing a Monochrome Gauge Model} *) module Gauge (M : Model.Gauge) = struct module CM = It(M) type flavor = CM.flavor type flavor_sans_color = CM.flavor_sans_color type gauge = CM.gauge type constant = CM.constant type coupling_order = CM.coupling_order module Ch = CM.Ch let all_coupling_orders = CM.all_coupling_orders let coupling_orders = CM.coupling_orders let coupling_order_to_string = CM.coupling_order_to_string let charges = CM.charges let flavor_sans_color = CM.flavor_sans_color let flavor_equal = CM.flavor_equal let color = CM.color let pdg = CM.pdg let lorentz = CM.lorentz let propagator = CM.propagator let width = CM.width let conjugate = CM.conjugate let conjugate_sans_color = CM.conjugate_sans_color let fermion = CM.fermion let max_degree = CM.max_degree let vertices = CM.vertices let fuse2 = CM.fuse2 let fuse3 = CM.fuse3 let fuse = CM.fuse let flavors = CM.flavors let nc = CM.nc let external_flavors = CM.external_flavors let goldstone = CM.goldstone let parameters = CM.parameters let flavor_of_string = CM.flavor_of_string let flavor_to_string = CM.flavor_to_string let flavor_to_TeX = CM.flavor_to_TeX let flavor_symbol = CM.flavor_symbol let gauge_symbol = CM.gauge_symbol let mass_symbol = CM.mass_symbol let width_symbol = CM.width_symbol let constant_symbol = CM.constant_symbol let options = CM.options let caveats = CM.caveats let incomplete s = failwith ("Colorize.Gauge()." ^ s ^ " not done yet!") type matter_field = M.matter_field type gauge_boson = M.gauge_boson type other = M.other type field = | Matter of matter_field | Gauge of gauge_boson | Other of other - let field f = + let field _f = incomplete "field" - let matter_field f = + let matter_field _f = incomplete "matter_field" - let gauge_boson f = + let gauge_boson _f = incomplete "gauge_boson" - let other f = + let other _f = incomplete "other" let amplitude = CM.amplitude let flow = CM.flow end Index: trunk/omega/src/birdtracks.mli =================================================================== --- trunk/omega/src/birdtracks.mli (revision 8919) +++ trunk/omega/src/birdtracks.mli (revision 8920) @@ -1,150 +1,168 @@ (* birdtracks.mli -- Copyright (C) 2022-2023 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. *) (* In this module, we implement birdtracks operations on expressions of [type t] as generally as possible. Module [SU3] (cf.~chapter~\ref{sec:su3}), will provide the group specific constructors for [type t] in the special case $\mathrm{SU}(N_C)$ or $\mathrm{SU}(3)$. *) (* \thocwmodulesection{Types} *) (* If there are no $\epsilon$s or $\bar\epsilon$s, a term is simply a list of arrows with a coefficient that is a polynomial, - allowing negative powers, in $N_C$. The the type of arrows - is not fixed, because [Arrow] has both [free] arrows without + allowing negative powers, in $N_C$. Here the type ['a] of arrows + is polymorphic, because [Arrow] has both [free] arrows without summation indices and [factor] arrows that contain summation indices. *) type 'a aterm = { coeff : Algebra.Laurent.t; arrows : 'a list } (* If there are $\epsilon$s, we add them \ldots *) type ('a, 'e) eterm = 'a aterm * 'e NEList.t (* \ldots{} and the same for $\bar\epsilon$s. *) type ('a, 'b) bterm = 'a aterm * 'b NEList.t (* Assuming that $\epsilon$-$\bar\epsilon$-pairs are always reduced as soon as possible, these three alternatives are exhaustive. *) type ('a, 'e, 'b) term = | Arrows of 'a aterm | Epsilons of ('a, 'e) eterm | Epsilon_Bars of ('a, 'b) bterm (* In the public interface, we deal only with [free] indices, without summation indices. *) type free = (Arrow.free, Arrow.free_eps, Arrow.free_eps_bar) term (* An expression is just a sum of terms. *) type t = free list (* \thocwmodulesection{Functions} *) +(* Reverse all arrows and exchange $\epsilon$s and $\bar\epsilon$. *) +val rev : t -> t + +(* Map the ['a aterm] component and leave the epsilons alone. *) +val map_term : ('a aterm -> 'c aterm) -> ('a, 'e, 'b) term -> ('c, 'e, 'b) term +val map_term_opt : ('a aterm -> 'c aterm option) -> ('a, 'e, 'b) term -> ('c, 'e, 'b) term option + +(* Return the list of all positions of endpoints corresponding to + adjoint representations (cf.~[Arrow.adjoints]). *) +val adjoints : t -> int list + +(* Test for ghosts in an expression. *) +val haunted : t -> bool + +(* Filter out all terms containing a ghost. *) +val exorcise : t -> t + (* Strip out redundancies. *) val canonicalize : t -> t (* Substitute a specific value for $N_C$. Mainly for debugging. *) val with_nc : int -> t -> t (* Debugging, logging, etc. *) val to_string : t -> string val to_string_raw : t -> string (* Extract the number if the birdtrack contains no arrows, $\epsilon$s or $\bar\epsilon$s. *) val number : t -> Algebra.Laurent.t option (* Test for trivial color flows that correspond to unity. *) val is_unit : t -> bool (* Test for vanishing coefficients. *) val is_null : t -> bool +(* [is_multiple x y] returns [Some (cx, cy)] iff [const cy *** x = const cx *** y] + and [None] otherwise. *) +val is_multiple : t -> t -> (Algebra.Laurent.t * Algebra.Laurent.t) option + (* Purely numeric factors, implemented as Laurent polynomials (cf.~[Algebra.Laurent] in~$N_C$ with complex rational coefficients and without arrows. *) val const : Algebra.Laurent.t -> t val null : t (* $0$ *) val one : t (* $1$ *) val two : t (* $2$ *) val minus : t (* $-1$ *) val int : int -> t (* $n$ *) val fraction : int -> t (* $1/n$ *) val nc : t (* $N_C$ *) val over_nc : t (* $1/N_C$ *) val imag : t (* $\ii$ *) (* Shorthand: $\{(c_i,p_i)\}_i\to \sum_i c_i (N_C)^{p_i}$*) val ints : (int * int) list -> t val scale : Algebra.Laurent.c -> t -> t val sum : t list -> t val diff : t -> t -> t val times : t -> t -> t val multiply : t list -> t (* For convenience, here are infix versions of the above operations. *) module Infix : sig val ( +++ ) : t -> t -> t val ( --- ) : t -> t -> t val ( *** ) : t -> t -> t end (* We can compute the $f_{abc}$ and $d_{abc}$ invariant tensors from the generators of an arbitrary representation: \begin{subequations} \begin{align} f_{a_1a_2a_3} &= - \ii \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_-\right) = - \ii \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) + \ii \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \\ d_{a_1a_2a_3} &= \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_+\right) = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) + \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)\, \end{align} \end{subequations} assuming the normalization $ \tr(T_aT_b) = \delta_{ab}$. NB: this uses the summation indices $-1$, $-2$ and $-3$. Therefore it \emph{must not} appear unevaluated more than once in a product! *) val f_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t val d_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t (* Rename the indices of endpoints in a birdtrack. This is required by our application in [Colorize.It] to match the permutations of lines at a vertex. *) val relocate : (int -> int) -> t -> t -(* Revert the direction of all lines in a birdtrack. *) -val rev : t -> t - (* Pretty printer for the toplevel. *) val pp : Format.formatter -> t -> unit (* Support for unit tests. *) val equal : t -> t -> unit val assert_zero_vertex : t -> unit module Test : sig val suite : OUnit.test val suite_long : OUnit.test end Index: trunk/omega/src/coupling.ml =================================================================== --- trunk/omega/src/coupling.ml (revision 0) +++ trunk/omega/src/coupling.ml (revision 8920) @@ -0,0 +1,2898 @@ +(* coupling.ml -- + + Copyright (C) 1999-2024 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 + +type fermion_lines = (int * int) 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 + | Prop_UFO of string + +(* \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 = + | 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 = + | 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 = + | UFO of Algebra.QC.t * string * lorentzn * fermion_lines * Color.Vertex.t + +(* 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 + | Integer of int + | Float of float + | 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 + | Asin of 'a expr + | Acos of 'a expr + | Atan of 'a expr + | Atan2 of 'a expr * 'a expr + | Sinh of 'a expr + | Cosh of 'a expr + | Tanh of 'a expr + | Exp of 'a expr + | Log of 'a expr + | Log10 of 'a expr + | Conj of 'a expr + | Abs 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/powSet.ml =================================================================== --- trunk/omega/src/powSet.ml (revision 8919) +++ trunk/omega/src/powSet.ml (revision 8920) @@ -1,201 +1,192 @@ (* powSet.ml -- Copyright (C) 1999-2024 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 Ordered_Type = sig type t val compare : t -> t -> int val to_string : t -> string end module type T = sig type elt type t val empty : t val is_empty : t -> bool val union : t list -> t val of_lists : elt list list -> t val to_lists : t -> elt list list val basis : t -> t val to_string : t -> string end module Make (E : Ordered_Type) = struct type elt = E.t module ESet = Set.Make (E) - type set = ESet.t + type _set = ESet.t module EPowSet = Set.Make (ESet) type t = EPowSet.t let empty = EPowSet.empty let is_empty = EPowSet.is_empty (*i let elements = EPowSet.elements i*) let union s_list = List.fold_right EPowSet.union s_list EPowSet.empty let set_to_string set = "{" ^ String.concat "," (List.map E.to_string (ESet.elements set)) ^ "}" let to_string powset = "{" ^ String.concat "," (List.map set_to_string (EPowSet.elements powset)) ^ "}" - let set_of_list = ESet.of_list + let _set_of_list = ESet.of_list let of_lists lists = List.fold_right (fun list acc -> EPowSet.add (ESet.of_list list) acc) lists EPowSet.empty let to_lists ps = List.map ESet.elements (EPowSet.elements ps) (* [product] $(s_1,s_2) = s_1 \circ s_2 = \{s_1\setminus s_2, s_1 \cap s_2, s_2\setminus s_1\} \setminus \{\emptyset\}$ *) let product s1 s2 = List.fold_left (fun pset set -> if ESet.is_empty set then pset else EPowSet.add set pset) EPowSet.empty [ESet.diff s1 s2; ESet.inter s1 s2; ESet.diff s2 s1] (*i let product s1 s2 = Printf.eprintf "product %s %s" (set_to_string s1) (set_to_string s2); flush stderr; let result = product s1 s2 in Printf.eprintf " => %s\n" (to_string result); flush stderr; result i*) let disjoint s1 s2 = ESet.is_empty (ESet.inter s1 s2) (* In [augment_basis_overlapping] $(s, \{s_i\}_i)$, we are guaranteed that \begin{subequations} \begin{align} \label{eq:powset:overlap} \forall_i :\;& s \cap s_i\not=\emptyset\\ \label{eq:powset:disjoint} \forall_{i\not=j}:\;& s_i\cap s_j =\emptyset\,. \end{align} \end{subequations} Therefore from~(\ref{eq:powset:disjoint}) \begin{subequations} \begin{align} \forall_{i\not=j}:\;& (s \cap s_i) \cap (s \cap s_j) = s \cap (s_i \cap s_j) = s \cap \emptyset = \emptyset\\ \forall_{i\not=j}:\;& (s_i\setminus s ) \cap (s_j\setminus s ) \subset s_i \cap s_j = \emptyset\\ \forall_{i\not=j}:& (s \setminus s_i) \cap (s_j\setminus s ) \subset s \cap \bar s = \emptyset\\ \forall_{i\not=j}:& (s \cap s_i) \cap (s_j\setminus s ) \subset s \cap \bar s = \emptyset\,, \end{align} \end{subequations} but in general \begin{subequations} \begin{align} \exists_{i\not=j} :& (s \setminus s_i) \cap (s \setminus s_j) \not=\emptyset\\ \exists_{i\not=j}:& (s \setminus s_i) \cap (s \cap s_j) \not=\emptyset\,, \end{align} \end{subequations} because, e.\,g., for $s_i=\{i\}$ and $s=\{1,2,3\}$ \begin{subequations} \begin{align} (s \setminus s_1) \cap (s \setminus s_2) &= \{2,3\} \cap \{1,3\} = \{3\} \\ (s \setminus s_1) \cap (s \cap s_2) &= \{2,3\} \cap \{2\} = \{2\}\,. \end{align} \end{subequations} Summarizing: \begin{center} \begin{tabular}{c||c|c|c} $\forall_{i\not=j}:\;A_i\cap A_j$&$s_j\setminus s $&$s \cap s_j $&$s \setminus s_j$\\ \hline\hline $s_i\setminus s $&$\emptyset $&$\emptyset $&$\emptyset $\\ \hline $s \cap s_i$&$\emptyset $&$\emptyset $&$\not=\emptyset $\\ \hline $s \setminus s_i$&$\emptyset $&$\not=\emptyset$&$\not=\emptyset $ \end{tabular} \end{center} Fortunately, we also know from~(\ref{eq:powset:overlap}) that \begin{subequations} \begin{align} \forall_i:\;& |s \setminus s_i| < |s| \\ \forall_i:\;& |s \cap s_i| < \min(|s|,|s_i|) \\ \forall_i:\;& |s_i\setminus s | < |s_i| \end{align} \end{subequations} and can call [basis] recursively without risking non-termination. *) let rec basis ps = EPowSet.fold augment_basis ps EPowSet.empty and augment_basis s ps = if EPowSet.mem s ps then ps else let no_overlaps, overlaps = EPowSet.partition (disjoint s) ps in if EPowSet.is_empty overlaps then EPowSet.add s ps else EPowSet.union no_overlaps (augment_basis_overlapping s overlaps) and augment_basis_overlapping s ps = basis (EPowSet.fold (fun s' -> EPowSet.union (product s s')) ps EPowSet.empty) end (*i -module EPowSet = - Make (struct type t = int let compare = compare let to_string = string_of_int end) +module EPowSet = Make (Int) let test lists = let ps = EPowSet.of_lists lists in let basis = EPowSet.basis ps in Printf.eprintf "basis %s -> %s\n" (EPowSet.to_string ps) (EPowSet.to_string basis); flush stderr let _ = List.iter test [ [[1;3];[2;4];[3;4];[5;6]]; [[1;2];[3;4];[5;6]]; [[1;2;3;4];[3;4];[5;6]]; [[1;2];[1;3;4];[1;4;5]]; [[1;3;4];[1;3;4];[1;3;4]] ] i*) - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/pmap.ml =================================================================== --- trunk/omega/src/pmap.ml (revision 8919) +++ trunk/omega/src/pmap.ml (revision 8920) @@ -1,542 +1,534 @@ (* pmap.ml -- Copyright (C) 1999-2024 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 ('key, 'a) t val empty : ('key, 'a) t val is_empty : ('key, 'a) t -> bool val singleton : 'key -> 'a -> ('key, 'a) t val add : ('key -> 'key -> int) -> 'key -> 'a -> ('key, 'a) t -> ('key, 'a) t val update : ('key -> 'key -> int) -> ('a -> 'a -> 'a) -> 'key -> 'a -> ('key, 'a) t -> ('key, 'a) t val cons : ('key -> 'key -> int) -> ('a -> 'a -> 'a option) -> 'key -> 'a -> ('key, 'a) t -> ('key, 'a) t val find : ('key -> 'key -> int) -> 'key -> ('key, 'a) t -> 'a val find_opt : ('key -> 'key -> int) -> 'key -> ('key, 'a) t -> 'a option val choose : ('key, 'a) t -> 'key * 'a val choose_opt : ('key, 'a) t -> ('key * 'a) option val uncons : ('key, 'a) t -> 'key * 'a * ('key, 'a) t val uncons_opt : ('key, 'a) t -> ('key * 'a * ('key, 'a) t) option val elements : ('key, 'a) t -> ('key * 'a) list val mem : ('key -> 'key -> int) -> 'key -> ('key, 'a) t -> bool val remove : ('key -> 'key -> int) -> 'key -> ('key, 'a) t -> ('key, 'a) t val union : ('key -> 'key -> int) -> ('a -> 'a -> 'a) -> ('key, 'a) t -> ('key, 'a) t -> ('key, 'a) t val compose : ('key -> 'key -> int) -> ('a -> 'a -> 'a option) -> ('key, 'a) t -> ('key, 'a) t -> ('key, 'a) t val iter : ('key -> 'a -> unit) -> ('key, 'a) t -> unit val map : ('a -> 'b) -> ('key, 'a) t -> ('key, 'b) t val mapi : ('key -> 'a -> 'b) -> ('key, 'a) t -> ('key, 'b) t val fold : ('key -> 'a -> 'b -> 'b) -> ('key, 'a) t -> 'b -> 'b val compare : ('key -> 'key -> int) -> ('a -> 'a -> int) -> ('key, 'a) t -> ('key, 'a) t -> int val canonicalize : ('key -> 'key -> int) -> ('key, 'a) t -> ('key, 'a) t end module Tree = struct type ('key, 'a) t = | Empty | Node of ('key, 'a) t * 'key * 'a * ('key, 'a) t * int let empty = Empty let is_empty = function | Empty -> true | _ -> false let singleton k d = Node (Empty, k, d, Empty, 1) let height = function | Empty -> 0 | Node (_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node (l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let bal l x d r = let hl = match l with Empty -> 0 | Node (_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node (_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with | Empty -> invalid_arg "Map.bal" | Node (ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with | Empty -> invalid_arg "Map.bal" | Node (lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with | Empty -> invalid_arg "Map.bal" | Node (rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with | Empty -> invalid_arg "Map.bal" | Node (rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node (l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let rec join l x d r = match bal l x d r with | Empty -> invalid_arg "Pmap.join" | Node (l', x', d', r', _) as t' -> let d = height l' - height r' in if d < -2 || d > 2 then join l' x' d' r' else t' (* Merge two trees [t1] and [t2] into one. All elements of [t1] must precede the elements of [t2]. Assumes [height t1 - height t2 <= 2]. *) let rec merge t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t - | Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2) -> + | Node (l1, v1, d1, r1, _), Node (l2, v2, d2, r2, _) -> bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) (* Same as merge, but does not assume anything about [t1] and [t2]. *) let rec concat t1 t2 = match t1, t2 with | Empty, t -> t | t, Empty -> t - | Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2) -> + | Node (l1, v1, d1, r1, _), Node (l2, v2, d2, r2, _) -> join l1 v1 d1 (join (concat r1 l2) v2 d2 r2) (* Splitting *) let rec split cmp x = function | Empty -> (Empty, None, Empty) | Node (l, v, d, r, _) -> let c = cmp x v in if c = 0 then (l, Some d, r) else if c < 0 then let ll, vl, rl = split cmp x l in (ll, vl, join rl v d r) else (* [if c > 0 then] *) let lr, vr, rr = split cmp x r in (join l v d lr, vr, rr) let rec find cmp x = function | Empty -> raise Not_found | Node (l, v, d, r, _) -> let c = cmp x v in if c = 0 then d else if c < 0 then find cmp x l else (* [if c > 0] *) find cmp x r let rec find_opt cmp x = function | Empty -> None | Node (l, v, d, r, _) -> let c = cmp x v in if c = 0 then Some d else if c < 0 then find_opt cmp x l else (* [if c > 0] *) find_opt cmp x r let rec mem cmp x = function | Empty -> false - | Node (l, v, d, r, _) -> + | Node (l, v, _, r, _) -> let c = cmp x v in if c = 0 then true else if c < 0 then mem cmp x l else (* [if c > 0] *) mem cmp x r let choose = function | Empty -> raise Not_found - | Node (l, v, d, r, _) -> (v, d) + | Node (_, v, d, _, _) -> (v, d) let choose_opt = function | Empty -> None - | Node (l, v, d, r, _) -> Some (v, d) + | Node (_, v, d, _, _) -> Some (v, d) let uncons = function | Empty -> raise Not_found - | Node (l, v, d, r, h) -> (v, d, merge l r) + | Node (l, v, d, r, _) -> (v, d, merge l r) let uncons_opt = function | Empty -> None - | Node (l, v, d, r, h) -> Some (v, d, merge l r) + | Node (l, v, d, r, _) -> Some (v, d, merge l r) let rec remove cmp x = function | Empty -> Empty - | Node (l, v, d, r, h) -> + | Node (l, v, d, r, _) -> let c = cmp x v in if c = 0 then merge l r else if c < 0 then bal (remove cmp x l) v d r else (* [if c > 0] *) bal l v d (remove cmp x r) let rec cons cmp resolve x data' = function | Empty -> Node (Empty, x, data', Empty, 1) | Node (l, v, data, r, h) -> let c = cmp x v in if c = 0 then match resolve data' data with | Some data'' -> Node (l, x, data'', r, h) | None -> merge l r else if c < 0 then bal (cons cmp resolve x data' l) v data r else (* [if c > 0] *) bal l v data (cons cmp resolve x data' r) let rec update cmp resolve x data' = function | Empty -> Node (Empty, x, data', Empty, 1) | Node (l, v, data, r, h) -> let c = cmp x v in if c = 0 then Node (l, x, resolve data' data, r, h) else if c < 0 then bal (update cmp resolve x data' l) v data r else (* [if c > 0] *) bal l v data (update cmp resolve x data' r) - let add cmp x data = update cmp (fun n o -> n) x data + let add cmp x data = update cmp (fun n _ -> n) x data let rec compose cmp resolve s1 s2 = match s1, s2 with | Empty, t2 -> t2 | t1, Empty -> t1 | Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2) -> if h1 >= h2 then if h2 = 1 then cons cmp (fun o n -> resolve n o) v2 d2 s1 else begin match split cmp v1 s2 with | l2', None, r2' -> join (compose cmp resolve l1 l2') v1 d1 (compose cmp resolve r1 r2') | l2', Some d, r2' -> begin match resolve d1 d with | None -> concat (compose cmp resolve l1 l2') (compose cmp resolve r1 r2') | Some d -> join (compose cmp resolve l1 l2') v1 d (compose cmp resolve r1 r2') end end else if h1 = 1 then cons cmp resolve v1 d1 s2 else begin match split cmp v2 s1 with | l1', None, r1' -> join (compose cmp resolve l1' l2) v2 d2 (compose cmp resolve r1' r2) | l1', Some d, r1' -> begin match resolve d d2 with | None -> concat (compose cmp resolve l1' l2) (compose cmp resolve r1' r2) | Some d -> join (compose cmp resolve l1' l2) v2 d (compose cmp resolve r1' r2) end end let rec union cmp resolve s1 s2 = match s1, s2 with | Empty, t2 -> t2 | t1, Empty -> t1 | Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2) -> if h1 >= h2 then if h2 = 1 then update cmp (fun o n -> resolve n o) v2 d2 s1 else begin match split cmp v1 s2 with | l2', None, r2' -> join (union cmp resolve l1 l2') v1 d1 (union cmp resolve r1 r2') | l2', Some d, r2' -> join (union cmp resolve l1 l2') v1 (resolve d1 d) (union cmp resolve r1 r2') end else if h1 = 1 then update cmp resolve v1 d1 s2 else begin match split cmp v2 s1 with | l1', None, r1' -> join (union cmp resolve l1' l2) v2 d2 (union cmp resolve r1' r2) | l1', Some d, r1' -> join (union cmp resolve l1' l2) v2 (resolve d d2) (union cmp resolve r1' r2) end let rec iter f = function | Empty -> () | Node (l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function | Empty -> Empty | Node (l, v, d, r, h) -> Node (map f l, v, f d, map f r, h) let rec mapi f = function | Empty -> Empty | Node(l, v, d, r, h) -> Node (mapi f l, v, f v d, mapi f r, h) let rec fold f m accu = match m with | Empty -> accu | Node (l, v, d, r, _) -> fold f l (f v d (fold f r accu)) let rec compare' cmp_k cmp_d l1 l2 = match l1, l2 with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | Empty :: t1, Empty :: t2 -> compare' cmp_k cmp_d t1 t2 | Node (Empty, v1, d1, r1, _) :: t1, Node (Empty, v2, d2, r2, _) :: t2 -> let cv = cmp_k v1 v2 in if cv <> 0 then begin cv end else begin let cd = cmp_d d1 d2 in if cd <> 0 then cd else compare' cmp_k cmp_d (r1::t1) (r2::t2) end | Node (l1, v1, d1, r1, _) :: t1, t2 -> compare' cmp_k cmp_d (l1 :: Node (Empty, v1, d1, r1, 0) :: t1) t2 | t1, Node (l2, v2, d2, r2, _) :: t2 -> compare' cmp_k cmp_d t1 (l2 :: Node (Empty, v2, d2, r2, 0) :: t2) let compare cmp_k cmp_d m1 m2 = compare' cmp_k cmp_d [m1] [m2] let rec elements' accu = function | Empty -> accu | Node (l, v, d, r, _) -> elements' ((v, d) :: elements' accu r) l let elements s = elements' [] s let canonicalize cmp m = fold (add cmp) m empty end module List = struct type ('key, 'a) t = ('key * 'a) list let empty = [] let is_empty = function | [] -> true | _ -> false let singleton k d = [(k, d)] let rec cons cmp resolve k' d' = function | [] -> [(k', d')] | ((k, d) as kd :: rest) as list -> let c = cmp k' k in if c = 0 then match resolve d' d with | None -> rest | Some d'' -> (k', d'') :: rest else if c < 0 then (* [k' < k] *) (k', d') :: list else (* [if c > 0], i.\,e.~[k < k'] *) kd :: cons cmp resolve k' d' rest let rec update cmp resolve k' d' = function | [] -> [(k', d')] | ((k, d) as kd :: rest) as list -> let c = cmp k' k in if c = 0 then (k', resolve d' d) :: rest else if c < 0 then (* [k' < k] *) (k', d') :: list else (* [if c > 0], i.\,e.~[k < k'] *) kd :: update cmp resolve k' d' rest let add cmp k' d' list = - update cmp (fun n o -> n) k' d' list + update cmp (fun n _ -> n) k' d' list let rec find cmp k' = function | [] -> raise Not_found | (k, d) :: rest -> let c = cmp k' k in if c = 0 then d else if c < 0 then (* [k' < k] *) raise Not_found else (* [if c > 0], i.\,e.~[k < k'] *) find cmp k' rest let rec find_opt cmp k' = function | [] -> None | (k, d) :: rest -> let c = cmp k' k in if c = 0 then Some d else if c < 0 then (* [k' < k] *) None else (* [if c > 0], i.\,e.~[k < k'] *) find_opt cmp k' rest let choose = function | [] -> raise Not_found | kd :: _ -> kd - let rec choose_opt = function + let choose_opt = function | [] -> None | kd :: _ -> Some kd let uncons = function | [] -> raise Not_found | (k, d) :: rest -> (k, d, rest) let uncons_opt = function | [] -> None | (k, d) :: rest -> Some (k, d, rest) let elements list = list let rec mem cmp k' = function | [] -> false - | (k, d) :: rest -> + | (k, _) :: rest -> let c = cmp k' k in if c = 0 then true else if c < 0 then (* [k' < k] *) false else (* [if c > 0], i.\,e.~[k < k'] *) mem cmp k' rest let rec remove cmp k' = function | [] -> [] - | ((k, d) as kd :: rest) as list -> + | ((k, _) as kd :: rest) as list -> let c = cmp k' k in if c = 0 then rest else if c < 0 then (* [k' < k] *) list else (* [if c > 0], i.\,e.~[k < k'] *) kd :: remove cmp k' rest let rec compare cmp_k cmp_d m1 m2 = match m1, m2 with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | (k1, d1) :: rest1, (k2, d2) :: rest2 -> let c = cmp_k k1 k2 in if c = 0 then begin let c' = cmp_d d1 d2 in if c' = 0 then compare cmp_k cmp_d rest1 rest2 else c' end else c let rec iter f = function | [] -> () | (k, d) :: rest -> f k d; iter f rest let rec map f = function | [] -> [] | (k, d) :: rest -> (k, f d) :: map f rest let rec mapi f = function | [] -> [] | (k, d) :: rest -> (k, f k d) :: mapi f rest let rec fold f m accu = match m with | [] -> accu | (k, d) :: rest -> fold f rest (f k d accu) let rec compose cmp resolve m1 m2 = match m1, m2 with | [], [] -> [] | [], m -> m | m, [] -> m | ((k1, d1) as kd1 :: rest1), ((k2, d2) as kd2 :: rest2) -> let c = cmp k1 k2 in if c = 0 then match resolve d1 d2 with | None -> compose cmp resolve rest1 rest2 | Some d -> (k1, d) :: compose cmp resolve rest1 rest2 else if c < 0 then (* [k1 < k2] *) kd1 :: compose cmp resolve rest1 m2 else (* [if c > 0], i.\,e.~[k2 < k1] *) kd2 :: compose cmp resolve m1 rest2 let rec union cmp resolve m1 m2 = match m1, m2 with | [], [] -> [] | [], m -> m | m, [] -> m | ((k1, d1) as kd1 :: rest1), ((k2, d2) as kd2 :: rest2) -> let c = cmp k1 k2 in if c = 0 then (k1, resolve d1 d2) :: union cmp resolve rest1 rest2 else if c < 0 then (* [k1 < k2] *) kd1 :: union cmp resolve rest1 m2 else (* [if c > 0], i.\,e.~[k2 < k1] *) kd2 :: union cmp resolve m1 rest2 - let canonicalize cmp x = x + let canonicalize _ x = x end - -(*i - Local Variables: - mode:caml - indent-tabs-mode:nil - page-delimiter:"^(\\* .*\n" - End: -i*) Index: trunk/omega/src/tree.ml =================================================================== --- trunk/omega/src/tree.ml (revision 8919) +++ trunk/omega/src/tree.ml (revision 8920) @@ -1,761 +1,761 @@ (* tree.ml -- Copyright (C) 1999-2024 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{Abstract Data Type} *) type ('n, 'l) t = | Leaf of 'n * 'l | Node of 'n * ('n, 'l) t list let leaf n l = Leaf (n, l) let cons n children = Node (n, children) (* Presenting the leafs \textit{in order} comes naturally, but will be useful below. *) let rec leafs = function | Leaf (_, l) -> [l] | Node (_, ch) -> ThoList.flatmap leafs ch let node = function | Leaf (n, _) -> n | Node (n, _) -> n (* This guarantees that the root node can be stripped from the result by [List.tl]. *) let rec nodes = function | Leaf _ -> [] | Node (n, ch) -> n :: ThoList.flatmap nodes ch (* [first_match p list] returns [(x,list')], where [x] is the first element of [list] for which [p x = true] and [list'] is [list] sans [x]. *) let first_match p list = let rec first_match' no_match = function | [] -> invalid_arg "Tree.fuse: prospective root not found" | t :: rest when p t -> (t, List.rev_append no_match rest) | t :: rest -> first_match' (t :: no_match) rest in first_match' [] list (* One recursion step in [fuse'] rotates the topmost tree node, moving the prospective root up: \begin{equation} \label{eq:tree-rotation} \parbox{46\unitlength}{% \fmfframe(0,0)(0,4){% \begin{fmfgraph*}(45,30) \fmfstraight \fmftop{r} \fmfbottom{l11,l12,l1x,l1n,db1,l21,l22,l2x,l2n,db2,db3,db4,db5,db6,% lx1,lx2,lxx,lxn,db7,ln1,ln2,lnx,lnn} \fmf{plain,tension=4}{r,vr1} \fmf{plain,tension=4,lab=$p$,lab.side=left}{r,vr2} \fmf{dots,tension=4}{r,vrx} \fmf{plain,tension=4}{r,vrn} \fmf{plain}{vr1,l11}\fmf{plain}{vr1,l12} \fmf{dots}{vr1,l1x}\fmf{plain}{vr1,l1n} \fmf{plain}{vr2,l21}\fmf{plain}{vr2,l22} \fmf{dots}{vr2,l2x}\fmf{plain}{vr2,l2n} \fmf{dots}{vrx,lx1}\fmf{dots}{vrx,lx2} \fmf{dots}{vrx,lxx}\fmf{dots}{vrx,lxn} \fmf{plain}{vrn,ln1}\fmf{plain}{vrn,ln2} \fmf{dots}{vrn,lnx}\fmf{plain}{vrn,lnn} \fmfv{l=$r$,l.ang=-90}{l22} \fmfv{d.shape=circle,d.filled=empty,d.size=7thick,% back=.8white}{r,vr1,vrx,vrn} \fmfv{d.shape=circle,d.filled=empty,d.size=7thick,% lab=$R$,lab.dist=0}{vr2} \end{fmfgraph*}}} \to \parbox{61\unitlength}{% \fmfframe(0,0)(0,4){% \begin{fmfgraph*}(60,30) \fmfstraight \fmftop{r} \fmfbottom{l21,d1,d2,l22,d3,d4,l2x,d5,d6,l2n,d7,d8,db2,% l11,l12,l1x,l1n,db1,db2,db3,lx1,lx2,lxx,lxn,db4,% ln1,ln2,lnx,lnn} \fmf{plain}{r,vr1}\fmf{phantom}{vr1,l21} \fmf{plain}{r,vr2}\fmf{phantom}{vr2,l22} \fmf{dots}{r,vrx}\fmf{phantom}{vrx,l2x} \fmf{plain}{r,vr3}\fmf{phantom}{vr3,l2n} \fmf{plain,tension=12,lab=$-p$,lab.side=left}{r,vrn} \fmf{plain,tension=4}{vrn,vvr1} \fmf{dots,tension=4}{vrn,vvrx} \fmf{plain,tension=4}{vrn,vvrn} \fmf{plain}{vvr1,l11}\fmf{plain}{vvr1,l12} \fmf{dots}{vvr1,l1x}\fmf{plain}{vvr1,l1n} \fmf{dots}{vvrx,lx1}\fmf{dots}{vvrx,lx2} \fmf{dots}{vvrx,lxx}\fmf{dots}{vvrx,lxn} \fmf{plain}{vvrn,ln1}\fmf{plain}{vvrn,ln2} \fmf{dots}{vvrn,lnx}\fmf{plain}{vvrn,lnn} \fmfv{l=$r$,l.ang=-90}{vr2} \fmfv{d.shape=circle,d.filled=empty,d.size=7thick,% back=.8white}{vrn,vvr1,vvrx,vvrn} \fmfv{d.shape=circle,d.filled=empty,d.size=7thick,% lab=$R$,lab.dist=0}{r} \end{fmfgraph*}}} \end{equation} *) let fuse conjg root contains_root trees = let rec fuse' subtrees = match first_match contains_root subtrees with (* If the prospective root is contained in a leaf, we have either found the root---in which case we're done---or have failed catastrophically: *) | Leaf (n, l), children -> if l = root then Node (conjg n, children) else invalid_arg "Tree.fuse: root predicate inconsistent" (* Otherwise, we perform a rotation as in~(\ref{eq:tree-rotation}) and connect all nodes that do not contain the root to a new node. For efficiency, we append the new node at the end and prevent [first_match] from searching for the root in it in vain again. Since [root_children] is probably rather short, this should be a good strategy. *) | Node (n, root_children), other_children -> fuse' (root_children @ [Node (conjg n, other_children)]) in fuse' trees (* Sorting is also straightforward, we only have to keep track of the suprema of the subtrees: *) type ('a, 'b) with_supremum = { sup : 'a; data : 'b } (* Since the lists are rather short, [List.sort] could be replaced by an optimized version, but we're not (yet) dealing with the most important speed bottleneck here: *) let rec sort' lesseq = function | Leaf (_, l) as e -> { sup = l; data = e } | Node (n, ch) -> let ch' = List.sort (fun x y -> compare x.sup y.sup) (List.map (sort' lesseq) ch) in { sup = (List.hd (List.rev ch')).sup; data = Node (n, List.map (fun x -> x.data) ch') } (* finally, throw away the overall supremum: *) let sort lesseq t = (sort' lesseq t).data let rec canonicalize = function | Leaf (_, _) as l -> l | Node (n, ch) -> Node (n, List.sort compare (List.map canonicalize ch)) (* \thocwmodulesection{Homomorphisms} *) (* Isomophisms are simple: *) let rec map fn fl = function | Leaf (n, l) -> Leaf (fn n, fl l) | Node (n, ch) -> Node (fn n, List.map (map fn fl) ch) (* homomorphisms are not more complicated: *) let rec fold leaf node = function | Leaf (n, l) -> leaf n l | Node (n, ch) -> node n (List.map (fold leaf node) ch) (* and tensor products are fun: *) let rec fan leaf node = function | Leaf (n, l) -> leaf n l | Node (n, ch) -> Product.fold (fun ch' t -> node n ch' @ t) (List.map (fan leaf node) ch) [] (* \thocwmodulesection{Output} *) let leaf_to_string n l = if n = "" then l else if l = "" then n else n ^ "(" ^ l ^ ")" let node_to_string n ch = "(" ^ (if n = "" then "" else n ^ ":") ^ (String.concat "," ch) ^ ")" let to_string t = fold leaf_to_string node_to_string t (* \thocwmodulesubsection{Feynmf} Add a value that is greater than all suprema *) type 'a supremum_or_infinity = Infinity | Sup of 'a type ('a, 'b) with_supremum_or_infinity = { sup : 'a supremum_or_infinity; data : 'b } let with_infinity cmp x y = match x.sup, y.sup with | Infinity, _ -> 1 | _, Infinity -> -1 | Sup x', Sup y' -> cmp x' y' (* Using this, we can sort the tree in another way that guarantees that a particular leaf ([i2]) is moved as far to the end as possible. We can then flip this leaf from outgoing to incoming without introducing a crossing: *) let rec sort_2i' lesseq i2 = function | Leaf (_, l) as e -> { sup = if l = i2 then Infinity else Sup l; data = e } | Node (n, ch) -> let ch' = List.sort (with_infinity compare) (List.map (sort_2i' lesseq i2) ch) in { sup = (List.hd (List.rev ch')).sup; data = Node (n, List.map (fun x -> x.data) ch') } (* again, throw away the overall supremum: *) let sort_2i lesseq i2 t = (sort_2i' lesseq i2 t).data type feynmf = { style : (string * string) option; rev : bool; label : string option; tension : float option } open Printf let style prop = match prop.style with | None -> ("plain","") | Some s -> s let species prop = fst (style prop) let tex_lbl prop = snd (style prop) -let leaf_label tex io leaf lab = function +let _leaf_label tex io leaf lab = function | None -> fprintf tex " \\fmflabel{${%s}$}{%s%s}\n" lab io leaf | Some s -> fprintf tex " \\fmflabel{${%s{}^{(%s)}}$}{%s%s}\n" s lab io leaf -let leaf_label tex io leaf lab label = +let leaf_label _tex _io _leaf _lab _label = () (* We try to draw diagrams more symmetrically by reducing the tension on the outgoing external lines. \begin{dubious} \index{shortcomings!algorithmical} This is insufficient for asymmetrical cascade decays. \end{dubious} *) let rec leaf_node tex to_label i2 n prop leaf = let io, tension, rev = if leaf = i2 then ("i", "", not prop.rev) else ("o", ",tension=0.5", prop.rev) in leaf_label tex io (to_label leaf) (tex_lbl prop) prop.label ; fprintf tex " \\fmfdot{v%d}\n" n; if rev then fprintf tex " \\fmf{%s%s}{%s%s,v%d}\n" (species prop) tension io (to_label leaf) n else fprintf tex " \\fmf{%s%s}{v%d,%s%s}\n" (species prop) tension n io (to_label leaf) and int_node tex to_label i2 n n' prop t = if prop.rev then fprintf tex " \\fmf{%s,label=\\begin{scriptsize}${%s}$\\end{scriptsize}}{v%d,v%d}\n" (species prop) (tex_lbl prop) n' n else fprintf tex " \\fmf{%s,label=\\begin{scriptsize}${%s}$\\end{scriptsize}}{v%d,v%d}\n" (species prop) (tex_lbl prop) n n'; fprintf tex " \\fmfdot{v%d,v%d}\n" n n'; edges_feynmf' tex to_label i2 n' t and leaf_or_int_node tex to_label i2 n n' = function | Leaf (prop, l) -> leaf_node tex to_label i2 n prop l | Node (prop, _) as t -> int_node tex to_label i2 n n' prop t and edges_feynmf' tex to_label i2 n = function | Leaf (prop, l) -> leaf_node tex to_label i2 n prop l | Node (_, ch) -> ignore (List.fold_right (fun t' n' -> leaf_or_int_node tex to_label i2 n n' t'; succ n') ch (4*n)) let edges_feynmf tex to_label i1 i2 t = let n = 1 in begin match t with | Leaf _ -> () | Node (prop, _) -> leaf_label tex "i" "1" (tex_lbl prop) prop.label; if prop.rev then fprintf tex " \\fmf{%s}{v%d,i%s}\n" (species prop) n (to_label i1) else fprintf tex " \\fmf{%s}{i%s,v%d}\n" (species prop) (to_label i1) n end; fprintf tex " \\fmfdot{v%d}\n" n; edges_feynmf' tex to_label i2 n t let to_feynmf_channel tex to_TeX to_label incoming t = match incoming with | i1 :: i2 :: _ -> let t' = sort_2i (<=) i2 t in let out = List.filter (fun a -> i2 <> a) (leafs t') in fprintf tex "\\fmfframe(8,7)(8,6){%%\n"; fprintf tex " \\begin{fmfgraph*}(35,30)\n"; fprintf tex " \\fmfpen{thin}\n"; fprintf tex " \\fmfset{arrow_len}{2mm}\n"; fprintf tex " \\fmfleft{i%s,i%s}\n" (to_label i1) (to_label i2); fprintf tex " \\fmfright{o%s}\n" (String.concat ",o" (List.map to_label out)); List.iter (fun s -> fprintf tex " \\fmflabel{${%s}$}{i%s}\n" (to_TeX s) (to_label s)) [i1; i2]; List.iter (fun s -> fprintf tex " \\fmflabel{${%s}$}{o%s}\n" (to_TeX s) (to_label s)) out; edges_feynmf tex to_label i1 i2 t'; fprintf tex " \\end{fmfgraph*}}\\hfil\\allowbreak\n" | _ -> () (* \begin{figure} \fmfframe(3,5)(3,5){% \begin{fmfgraph*}(30,30) \fmfleft{i1,i2} \fmfright{o3,o4,o5,o6} \fmflabel{$1$}{i1} \fmflabel{$2$}{i2} \fmflabel{$3$}{o3} \fmflabel{$4$}{o4} \fmflabel{$5$}{o5} \fmflabel{$6$}{o6} \fmf{plain}{i1,v1} \fmf{plain}{v1,v3} \fmf{plain,tension=0.5}{v3,o3} \fmf{plain}{v3,v9} \fmf{plain,tension=0.5}{v9,o4} \fmf{plain}{v9,v27} \fmf{plain,tension=0.5}{v27,o5} \fmf{plain,tension=0.5}{v27,o6} \fmf{plain}{v1,i2} \end{fmfgraph*}} \fmfframe(3,5)(3,5){% \begin{fmfgraph*}(30,30) \fmfleft{i1,i2} \fmfright{o3,o4,o6,o5} \fmflabel{$1$}{i1} \fmflabel{$2$}{i2} \fmflabel{$3$}{o3} \fmflabel{$4$}{o4} \fmflabel{$6$}{o6} \fmflabel{$5$}{o5} \fmf{plain}{i1,v1} \fmf{plain}{v1,v3} \fmf{plain,tension=0.5}{v3,o3} \fmf{plain}{v3,v9} \fmf{plain}{v9,v27} \fmf{plain,tension=0.5}{v27,o4} \fmf{plain,tension=0.5}{v27,o6} \fmf{plain,tension=0.5}{v9,o5} \fmf{plain}{v1,i2} \end{fmfgraph*}} \fmfframe(3,5)(3,5){% \begin{fmfgraph*}(30,30) \fmfleft{i1,i2} \fmfright{o3,o4,o5,o6} \fmflabel{$1$}{i1} \fmflabel{$2$}{i2} \fmflabel{$3$}{o3} \fmflabel{$4$}{o4} \fmflabel{$5$}{o5} \fmflabel{$6$}{o6} \fmf{plain}{i1,v1} \fmf{plain}{v1,v3} \fmf{plain}{v3,v9} \fmf{plain,tension=0.5}{v9,o3} \fmf{plain,tension=0.5}{v9,o4} \fmf{plain}{v3,v10} \fmf{plain,tension=0.5}{v10,o5} \fmf{plain,tension=0.5}{v10,o6} \fmf{plain}{v1,i2} \end{fmfgraph*}} \caption{\label{fig:to_feynmf}% Note that this is subtly different \ldots} \end{figure} *) let vanilla = { style = None; rev = false; label = None; tension = None } let sty (s, r, l) = { vanilla with style = Some s; rev = r; label = Some l } type 'l feynmf_set = { header : string; incoming : 'l list; diagrams : (feynmf, 'l) t list } type ('l, 'm) feynmf_sets = { outer : 'l feynmf_set; inner : 'm feynmf_set list } type 'l feynmf_levels = { this : 'l feynmf_set; lower : 'l feynmf_levels list } let latex_section = function | level when level < 0 -> "part" | 0 -> "chapter" | 1 -> "section" | 2 -> "subsection" | 3 -> "subsubsection" | 4 -> "paragraph" | _ -> "subparagraph" -let rec feynmf_set tex sections level to_TeX to_label set = +let feynmf_set tex sections level to_TeX to_label set = fprintf tex "%s\\%s{%s}\n" (if sections then "" else "%%% ") (latex_section level) set.header; List.iter (to_feynmf_channel tex to_TeX to_label set.incoming) set.diagrams let feynmf_sets tex sections level to_TeX_outer to_label_outer to_TeX_inner to_label_inner set = feynmf_set tex sections level to_TeX_outer to_label_outer set.outer; List.iter (feynmf_set tex sections (succ level) to_TeX_inner to_label_inner) set.inner let feynmf_sets_plain sections level file to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets = let tex = open_out (file ^ ".tex") in List.iter (feynmf_sets tex sections level to_TeX_outer to_label_outer to_TeX_inner to_label_inner) sets; close_out tex let feynmf_header tex file = fprintf tex "\\documentclass[10pt]{article}\n"; fprintf tex "\\usepackage{ifpdf}\n"; fprintf tex "\\usepackage[colorlinks]{hyperref}\n"; fprintf tex "\\usepackage[a4paper,margin=1cm]{geometry}\n"; fprintf tex "\\usepackage{feynmp}\n"; fprintf tex "\\ifpdf\n"; fprintf tex " \\DeclareGraphicsRule{*}{mps}{*}{}\n"; fprintf tex "\\else\n"; fprintf tex " \\DeclareGraphicsRule{*}{eps}{*}{}\n"; fprintf tex "\\fi\n"; fprintf tex "\\setlength{\\unitlength}{1mm}\n"; fprintf tex "\\setlength{\\parindent}{0pt}\n"; fprintf tex "\\renewcommand{\\mathstrut}{\\protect\\vphantom{\\hat{0123456789}}}\n"; fprintf tex "\\begin{document}\n"; fprintf tex "\\tableofcontents\n"; fprintf tex "\\begin{fmffile}{%s-fmf}\n\n" file let feynmf_footer tex = fprintf tex "\n"; fprintf tex "\\end{fmffile} \n"; fprintf tex "\\end{document} \n" let feynmf_sets_wrapped latex file to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets = let tex = open_out (file ^ ".tex") in if latex then feynmf_header tex file; List.iter (feynmf_sets tex latex 1 to_TeX_outer to_label_outer to_TeX_inner to_label_inner) sets; if latex then feynmf_footer tex; close_out tex let feynmf_sets_wrapped_to_channel latex channel to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets = if latex then feynmf_header channel "\\jobname"; List.iter (feynmf_sets channel latex 1 to_TeX_outer to_label_outer to_TeX_inner to_label_inner) sets; if latex then feynmf_footer channel let rec feynmf_levels tex sections level to_TeX to_label set = fprintf tex "%s\\%s{%s}\n" (if sections then "" else "%%% ") (latex_section level) set.this.header; List.iter (to_feynmf_channel tex to_TeX to_label set.this.incoming) set.this.diagrams; List.iter (feynmf_levels tex sections (succ level) to_TeX to_label) set.lower let feynmf_levels_plain sections level file to_TeX to_label sets = let tex = open_out (file ^ ".tex") in List.iter (feynmf_levels tex sections level to_TeX to_label) sets; close_out tex let feynmf_levels_wrapped file to_TeX to_label sets = let tex = open_out (file ^ ".tex") in feynmf_header tex file; List.iter (feynmf_levels tex true 1 to_TeX to_label) sets; feynmf_footer tex; close_out tex (* \thocwmodulesection{Least Squares Layout} \begin{equation} L = \frac{1}{2} \sum_{i\not=i'} T_{ii'} \left(x_i-x_{i'}\right)^2 + \frac{1}{2} \sum_{i,j} T'_{ij} \left(x_i-e_j\right)^2 \end{equation} and thus \begin{equation} 0 = \frac{\partial L}{\partial x_i} = \sum_{i'\not=i} T_{ii'} \left(x_i-x_{i'}\right) + \sum_{j} T'_{ij} \left(x_i-e_j\right) \end{equation} or \begin{equation} \label{eq:layout} \left(\sum_{i'\not=i} T_{ii'} + \sum_{j} T'_{ij}\right) x_i - \sum_{i'\not=i} T_{ii'} x_{i'} = \sum_{j} T'_{ij} e_j \end{equation} where we can assume that \begin{subequations} \begin{align} T_{ii'} &= T_{i'i} \\ T_{ii} &= 0 \end{align} \end{subequations} *) type 'a node_with_tension = { node : 'a; tension : float } -let unit_tension t = +let _unit_tension t = map (fun n -> { node = n; tension = 1.0 }) (fun l -> l) t let leafs_and_nodes i2 t = let t' = sort_2i (<=) i2 t in match nodes t' with | [] -> failwith "Tree.nodes_and_leafs: impossible" | i1 :: _ as n -> (i1, i2, List.filter (fun l -> l <> i2) (leafs t'), n) (* Not tail recursive, but they're unlikely to meet any deep trees: *) let rec internal_edges_from n = function | Leaf _ -> [] | Node (n', ch) -> (n', n) :: (ThoList.flatmap (internal_edges_from n') ch) (* The root node of the tree represents a vertex (node) and an external line (leaf) of the Feynman diagram simultaneously. Thus it requires special treatment: *) let internal_edges = function | Leaf _ -> [] | Node (n, ch) -> ThoList.flatmap (internal_edges_from n) ch let rec external_edges_from n = function | Leaf (n', _) -> [(n', n)] | Node (n', ch) -> ThoList.flatmap (external_edges_from n') ch let external_edges = function | Leaf (n, _) -> [(n, n)] | Node (n, ch) -> (n, n) :: ThoList.flatmap (external_edges_from n) ch type ('edge, 'node, 'ext) graph = { int_nodes : 'node array; ext_nodes : 'ext array; int_edges : ('edge * int * int) list; ext_edges : ('edge * int * int) list } module M = Pmap.Tree (* Invert an array, viewed as a map from non-negative integers into a set. The result is a map from the set to the integers: [val invert_array : 'a array -> ('a, int) M.t] *) -let invert_array_unsafe a = +let _invert_array_unsafe a = fst (Array.fold_left (fun (m, i) a_i -> (M.add compare a_i i m, succ i)) (M.empty, 0) a) exception Not_invertible let add_unique key data map = if M.mem compare key map then raise Not_invertible else M.add compare key data map let invert_array a = fst (Array.fold_left (fun (m, i) a_i -> (add_unique a_i i m, succ i)) (M.empty, 0) a) let graph_of_tree nodes2edge conjugate i2 t = let i1, i2, out, vertices = leafs_and_nodes i2 t in let int_nodes = Array.of_list vertices and ext_nodes = Array.of_list (conjugate i1 :: i2 :: out) in let int_nodes_index_table = invert_array int_nodes and ext_nodes_index_table = invert_array ext_nodes in let int_nodes_index n = M.find compare n int_nodes_index_table and ext_nodes_index n = M.find compare n ext_nodes_index_table in { int_nodes = int_nodes; ext_nodes = ext_nodes; int_edges = List.map (fun (n1, n2) -> (nodes2edge n1 n2, int_nodes_index n1, int_nodes_index n2)) (internal_edges t); ext_edges = List.map (fun (e, n) -> let e' = if e = i1 then conjugate e else e in (nodes2edge e' n, ext_nodes_index e', int_nodes_index n)) (external_edges t) } let int_incidence f null g = let n = Array.length g.int_nodes in let incidence = Array.make_matrix n n null in List.iter (fun (edge, n1, n2) -> if n1 <> n2 then begin let edge' = f edge g.int_nodes.(n1) g.int_nodes.(n2) in incidence.(n1).(n2) <- edge'; incidence.(n2).(n1) <- edge' end) g.int_edges; incidence let ext_incidence f null g = let n_int = Array.length g.int_nodes and n_ext = Array.length g.ext_nodes in let incidence = Array.make_matrix n_int n_ext null in List.iter (fun (edge, e, n) -> incidence.(n).(e) <- f edge g.ext_nodes.(e) g.int_nodes.(n)) g.ext_edges; incidence let division n = if n < 0 then [] else if n = 1 then [0.5] else let n' = pred n in let d = 1.0 /. (float n') in let rec division' i acc = if i < 0 then acc else division' (pred i) (float i *. d :: acc) in division' n' [] type ('e, 'n, 'ext) ext_layout = ('e, 'n, 'ext * float * float) graph type ('e, 'n, 'ext) layout = ('e, 'n * float * float, 'ext) ext_layout let left_to_right num_in g = if num_in < 1 then invalid_arg "left_to_right" else let num_out = Array.length g.ext_nodes - num_in in if num_out < 1 then invalid_arg "left_to_right" else let incoming = List.map2 (fun e y -> (e, 0.0, y)) (Array.to_list (Array.sub g.ext_nodes 0 num_in)) (division num_in) and outgoing = List.map2 (fun e y -> (e, 1.0, y)) (Array.to_list (Array.sub g.ext_nodes num_in num_out)) (division num_out) in { g with ext_nodes = Array.of_list (incoming @ outgoing) } (* Reformulating~(\ref{eq:layout}) \begin{subequations} \begin{align} Ax &= b_x \\ Ay &= b_y \end{align} \end{subequations} with \begin{subequations} \begin{align} A_{ii'} &= \left( \sum_{i''\not=i} T_{ii''} + \sum_j T'_{ij} \right) \delta_{ii'} - T_{ii'} \\ (b_{x/y})_i &= \sum_j T'_{ij} (e_{x/y})_j \end{align} \end{subequations} *) let sum a = Array.fold_left (+.) 0.0 a let tension_to_equation t t' e = let xe, ye = List.split e in let bx = Linalg.matmulv t' (Array.of_list xe) and by = Linalg.matmulv t' (Array.of_list ye) and a = Array.init (Array.length t) (fun i -> let a_i = Array.map (~-.) t.(i) in a_i.(i) <- a_i.(i) +. sum t.(i) +. sum t'.(i); a_i) in (a, bx, by) let layout g = let ext_nodes = List.map (fun (_, x, y) -> (x, y)) (Array.to_list g.ext_nodes) in let a, bx, by = tension_to_equation (int_incidence (fun _ _ _ -> 1.0) 0.0 g) (ext_incidence (fun _ _ _ -> 1.0) 0.0 g) ext_nodes in match Linalg.solve_many a [bx; by] with | [x; y] -> { g with int_nodes = Array.mapi (fun i n -> (n, x.(i), y.(i))) g.int_nodes } | _ -> failwith "impossible" let iter_edges f g = List.iter (fun (edge, n1, n2) -> let _, x1, y1 = g.int_nodes.(n1) and _, x2, y2 = g.int_nodes.(n2) in f edge (x1, y1) (x2, y2)) g.int_edges; List.iter (fun (edge, e, n) -> let _, x1, y1 = g.ext_nodes.(e) and _, x2, y2 = g.int_nodes.(n) in f edge (x1, y1) (x2, y2)) g.ext_edges let iter_internal f g = - Array.iter (fun (node, x, y) -> f (x, y)) g.int_nodes + Array.iter (fun (_, x, y) -> f (x, y)) g.int_nodes let iter_incoming f g = f g.ext_nodes.(0); f g.ext_nodes.(1) let iter_outgoing f g = for i = 2 to pred (Array.length g.ext_nodes) do f g.ext_nodes.(i) done let dump g = Array.iter (fun (_, x, y) -> Printf.eprintf "(%g,%g) " x y) g.ext_nodes; Printf.eprintf "\n => "; Array.iter (fun (_, x, y) -> Printf.eprintf "(%g,%g) " x y) g.int_nodes; Printf.eprintf "\n" Index: trunk/omega/src/trie.ml =================================================================== --- trunk/omega/src/trie.ml (revision 8919) +++ trunk/omega/src/trie.ml (revision 8920) @@ -1,376 +1,368 @@ (* trie.ml -- Copyright (C) 1999-2024 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{Monomorphically} *) module type T = sig type key type (+'a) t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val longest : key -> 'a t -> 'a option * key val shortest : key -> 'a t -> 'a option * key val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val export : (int -> unit) -> (int -> unit) -> (int -> key -> unit) -> (int -> key -> 'a -> unit) -> 'a t -> unit end (* O'Caml's [Map.S] prior to Version 3.12: *) module type Map_S = sig type key type (+'a) t val empty: 'a t val is_empty: 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val find: key -> 'a t -> 'a val remove: key -> 'a t -> 'a t val mem: key -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool end module Make (M : Map_S) : (T with type key = M.key list) = struct (* Derived from SML code by Chris Okasaki~\cite{Okasaki:1998:book}. *) type key = M.key list type 'a t = Trie of 'a option * 'a t M.t let empty = Trie (None, M.empty) let is_empty = function | Trie (None, m) -> M.is_empty m | _ -> false let rec add key data trie = match key, trie with | [], Trie (_, children) -> Trie (Some data, children) | k :: rest, Trie (node, children) -> let t = try M.find k children with Not_found -> empty in Trie (node, M.add k (add rest data t) children) let rec find key trie = match key, trie with | [], Trie (None, _) -> raise Not_found | [], Trie (Some data, _) -> data | k :: rest, Trie (_, children) -> find rest (M.find k children) (* The rest is my own fault \ldots{} *) let find1 k children = try Some (M.find k children) with Not_found -> None let add_non_empty k t children = if t = empty then M.remove k children else M.add k t children let rec remove key trie = match key, trie with | [], Trie (_, children) -> Trie (None, children) | k :: rest, (Trie (node, children) as orig) -> match find1 k children with | None -> orig | Some t -> Trie (node, add_non_empty k (remove rest t) children) let rec mem key trie = match key, trie with | [], Trie (None, _) -> false - | [], Trie (Some data, _) -> true + | [], Trie (Some _, _) -> true | k :: rest, Trie (_, children) -> match find1 k children with | None -> false | Some t -> mem rest t let rec map f = function | Trie (Some data, children) -> Trie (Some (f data), M.map (map f) children) | Trie (None, children) -> Trie (None, M.map (map f) children) let rec mapi' key f = function | Trie (Some data, children) -> Trie (Some (f key data), descend key f children) | Trie (None, children) -> Trie (None, descend key f children) and descend key f = M.mapi (fun k -> mapi' (key @ [k]) f) let mapi f = mapi' [] f let rec iter' key f = function | Trie (Some data, children) -> f key data; descend key f children | Trie (None, children) -> descend key f children and descend key f = M.iter (fun k -> iter' (key @ [k]) f) let iter f = iter' [] f let rec fold' key f t acc = match t with | Trie (Some data, children) -> descend key f children (f key data acc) | Trie (None, children) -> descend key f children acc and descend key f = M.fold (fun k -> fold' (key @ [k]) f) let fold f t acc = fold' [] f t acc let rec longest' partial partial_rest key trie = match key, trie with | [], Trie (data, _) -> (data, []) | k :: rest, Trie (data, children) -> match data, find1 k children with | None, None -> (partial, partial_rest) | Some _, None -> (data, key) | _, Some t -> longest' partial partial_rest rest t let longest key = longest' None key key let rec shortest' partial partial_rest key trie = match key, trie with | [], Trie (data, _) -> (data, []) - | k :: rest, Trie (Some _ as data, children) -> (data, key) + | _ :: _, Trie (Some _ as data, _) -> (data, key) | k :: rest, Trie (None, children) -> match find1 k children with | None -> (partial, partial_rest) | Some t -> shortest' partial partial_rest rest t let shortest key = shortest' None key key (* \thocwmodulesection{O'Mega customization} *) let rec export' n key f_open f_close f_descend f_match = function | Trie (Some data, children) -> f_match n key data; if children <> M.empty then descend n key f_open f_close f_descend f_match children | Trie (None, children) -> if children <> M.empty then begin f_descend n key; descend n key f_open f_close f_descend f_match children end and descend n key f_open f_close f_descend f_match children = f_open n; M.iter (fun k -> export' (succ n) (k :: key) f_open f_close f_descend f_match) children; f_close n let export f_open f_close f_descend f_match = export' 0 [] f_open f_close f_descend f_match let compare _ _ _ = failwith "incomplete" (*i let compare cmp m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with | (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) i*) let equal _ _ _ = failwith "incomplete" (*i let equal cmp m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with | (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) i*) end module MakeMap (M : Map_S) : (Map_S with type key = M.key list) = Make(M) (* \thocwmodulesection{Polymorphically} *) module type Poly = sig type ('a, 'b) t val empty : ('a, 'b) t val add : ('a -> 'a -> int) -> 'a list -> 'b -> ('a, 'b) t -> ('a, 'b) t val find : ('a -> 'a -> int) -> 'a list -> ('a, 'b) t -> 'b val remove : ('a -> 'a -> int) -> 'a list -> ('a, 'b) t -> ('a, 'b) t val mem : ('a -> 'a -> int) -> 'a list -> ('a, 'b) t -> bool val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val mapi : ('a list -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val iter : ('a list -> 'b -> unit) -> ('a, 'b) t -> unit val fold : ('a list -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c val longest : ('a -> 'a -> int) -> 'a list -> ('a, 'b) t -> 'b option * 'a list val shortest : ('a -> 'a -> int) -> 'a list -> ('a, 'b) t -> 'b option * 'a list val export : (int -> unit) -> (int -> unit) -> (int -> 'a list -> unit) -> (int -> 'a list -> 'b -> unit) -> ('a, 'b) t -> unit end module MakePoly (M : Pmap.T) : Poly = struct (* Derived from SML code by Chris Okasaki~\cite{Okasaki:1998:book}. *) type ('a, 'b) t = Trie of 'b option * ('a, ('a, 'b) t) M.t let empty = Trie (None, M.empty) let rec add cmp key data trie = match key, trie with | [], Trie (_, children) -> Trie (Some data, children) | k :: rest, Trie (node, children) -> let t = try M.find cmp k children with Not_found -> empty in Trie (node, M.add cmp k (add cmp rest data t) children) let rec find cmp key trie = match key, trie with | [], Trie (None, _) -> raise Not_found | [], Trie (Some data, _) -> data | k :: rest, Trie (_, children) -> find cmp rest (M.find cmp k children) (* The rest is my own fault \ldots{} *) let find1 cmp k children = try Some (M.find cmp k children) with Not_found -> None let add_non_empty cmp k t children = if t = empty then M.remove cmp k children else M.add cmp k t children let rec remove cmp key trie = match key, trie with | [], Trie (_, children) -> Trie (None, children) | k :: rest, (Trie (node, children) as orig) -> match find1 cmp k children with | None -> orig | Some t -> Trie (node, add_non_empty cmp k (remove cmp rest t) children) let rec mem cmp key trie = match key, trie with | [], Trie (None, _) -> false - | [], Trie (Some data, _) -> true + | [], Trie (Some _, _) -> true | k :: rest, Trie (_, children) -> match find1 cmp k children with | None -> false | Some t -> mem cmp rest t let rec map f = function | Trie (Some data, children) -> Trie (Some (f data), M.map (map f) children) | Trie (None, children) -> Trie (None, M.map (map f) children) let rec mapi' key f = function | Trie (Some data, children) -> Trie (Some (f key data), descend key f children) | Trie (None, children) -> Trie (None, descend key f children) and descend key f = M.mapi (fun k -> mapi' (key @ [k]) f) let mapi f = mapi' [] f let rec iter' key f = function | Trie (Some data, children) -> f key data; descend key f children | Trie (None, children) -> descend key f children and descend key f = M.iter (fun k -> iter' (key @ [k]) f) let iter f = iter' [] f let rec fold' key f t acc = match t with | Trie (Some data, children) -> descend key f children (f key data acc) | Trie (None, children) -> descend key f children acc and descend key f = M.fold (fun k -> fold' (key @ [k]) f) let fold f t acc = fold' [] f t acc let rec longest' cmp partial partial_rest key trie = match key, trie with | [], Trie (data, _) -> (data, []) | k :: rest, Trie (data, children) -> match data, find1 cmp k children with | None, None -> (partial, partial_rest) | Some _, None -> (data, key) | _, Some t -> longest' cmp partial partial_rest rest t let longest cmp key = longest' cmp None key key let rec shortest' cmp partial partial_rest key trie = match key, trie with | [], Trie (data, _) -> (data, []) - | k :: rest, Trie (Some _ as data, children) -> (data, key) + | _ :: _, Trie (Some _ as data, _) -> (data, key) | k :: rest, Trie (None, children) -> match find1 cmp k children with | None -> (partial, partial_rest) | Some t -> shortest' cmp partial partial_rest rest t let shortest cmp key = shortest' cmp None key key (* \thocwmodulesection{O'Mega customization} *) let rec export' n key f_open f_close f_descend f_match = function | Trie (Some data, children) -> f_match n key data; if children <> M.empty then descend n key f_open f_close f_descend f_match children | Trie (None, children) -> if children <> M.empty then begin f_descend n key; descend n key f_open f_close f_descend f_match children end and descend n key f_open f_close f_descend f_match children = f_open n; M.iter (fun k -> export' (succ n) (k :: key) f_open f_close f_descend f_match) children; f_close n let export f_open f_close f_descend f_match = export' 0 [] f_open f_close f_descend f_match end - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/color_Propagator.ml =================================================================== --- trunk/omega/src/color_Propagator.ml (revision 8919) +++ trunk/omega/src/color_Propagator.ml (revision 8920) @@ -1,225 +1,225 @@ (* color_Propagator.ml -- Copyright (C) 2022-2023 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 cf_in = int type cf_out = int type eps = cf_out list type s_eps = cf_out list type cf_in_or_eps = | CF_in of cf_in | Epsilon of eps type eps_bar = cf_in list type s_eps_bar = cf_in list type cf_out_or_eps_bar = | CF_out of cf_out | Epsilon_Bar of eps_bar type flow = cf_in PArray.t * cf_out PArray.t type flow_eps = cf_in_or_eps PArray.t * cf_out PArray.t type flow_eps_bar = cf_in PArray.t * cf_out_or_eps_bar PArray.t type t = | Flow of flow | Flow_with_Epsilons of flow_eps * s_eps list | Flow_with_Epsilon_Bars of flow_eps_bar * s_eps_bar list | Ghost | Ghost_with_Epsilons of s_eps_bar list | Ghost_with_Epsilon_Bars of s_eps_bar list (* For partial maps of ['a Map.t], an exception is the right choice, since we would have to use ['a Map.fold] to reconstruct resulting map completele. *) exception Fail let to_cf_in_opt cfi = let project = function | CF_in cf -> cf | Epsilon _ -> raise Fail in try Some (PArray.map project cfi) with Fail -> None let to_cf_out_opt cfo = let project = function | CF_out cf -> cf | Epsilon_Bar _ -> raise Fail in try Some (PArray.map project cfo) with Fail -> None let normalize = function | (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _ | Flow _) as flow -> flow | Flow_with_Epsilons ((cfi, cfo), []) as flow -> begin match to_cf_in_opt cfi with | None -> flow | Some cfi -> Flow (cfi, cfo) end | Flow_with_Epsilons (_, _ :: _) as flow -> flow | Flow_with_Epsilon_Bars ((cfi, cfo), []) as flow -> begin match to_cf_out_opt cfo with | None -> flow | Some cfo -> Flow (cfi, cfo) end | Flow_with_Epsilon_Bars (_, _ :: _) as flow -> flow let white = Flow (PArray.empty, PArray.empty) let of_lists cfi cfo = let cfi = ThoList.mapi (fun n cf -> (n, cf)) 0 cfi and cfo = ThoList.mapi (fun n cf -> (n, cf)) 0 cfo in Flow (PArray.of_pairs cfi, PArray.of_pairs cfo) let is_white = function | Flow (incoming, outgoing) -> PArray.is_empty incoming && PArray.is_empty outgoing | Flow_with_Epsilons (_, _) | Flow_with_Epsilon_Bars (_, _) -> false | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _ -> false let cfi_or_eps_to_cfo_or_eps_bar = function | CF_in cf -> CF_out cf | Epsilon eps -> Epsilon_Bar eps let cfo_or_eps_bar_to_cfi_or_eps = function | CF_out cf -> CF_in cf | Epsilon_Bar eps -> Epsilon eps let conjugate = function | Flow (cfi, cfo) -> Flow (cfo, cfi) | Flow_with_Epsilons ((cfi, cfo), eps) -> Flow_with_Epsilon_Bars ((cfo, PArray.map cfi_or_eps_to_cfo_or_eps_bar cfi), eps) | Flow_with_Epsilon_Bars ((cfi, cfo), eps) -> Flow_with_Epsilons ((PArray.map cfo_or_eps_bar_to_cfi_or_eps cfo, cfi), eps) | Ghost -> Ghost | Ghost_with_Epsilons eps -> Ghost_with_Epsilon_Bars eps | Ghost_with_Epsilon_Bars eps -> Ghost_with_Epsilons eps -let cf_in_or_eps_to_string = function +let _cf_in_or_eps_to_string = function | CF_in i -> string_of_int i | Epsilon cfos -> Printf.sprintf "E(%s)" (ThoList.to_string string_of_int cfos) -let cf_out_or_eps_bar_to_string = function +let _cf_out_or_eps_bar_to_string = function | CF_out i -> string_of_int i | Epsilon_Bar cfis -> Printf.sprintf "B(%s)" (ThoList.to_string string_of_int cfis) let cf_in_out_to_string cfi cfo = match PArray.is_empty cfi, PArray.is_empty cfo with | true, true -> "W" | false, true -> Printf.sprintf "I(%s)" (PArray.to_string string_of_int cfi) | true, false -> Printf.sprintf "O(%s)" (PArray.to_string string_of_int cfo) | false, false -> Printf.sprintf "IO(%s,%s)" (PArray.to_string string_of_int cfi) (PArray.to_string string_of_int cfo) let to_string = function | Ghost -> "G" | Flow (cfi, cfo) -> cf_in_out_to_string cfi cfo - | Ghost_with_Epsilons epsilons -> + | Ghost_with_Epsilons _epsilons -> failwith "Color_Propagator.to_string: incomplete" - | Ghost_with_Epsilon_Bars epsilon_bars -> + | Ghost_with_Epsilon_Bars _epsilon_bars -> failwith "Color_Propagator.to_string: incomplete" - | Flow_with_Epsilons ((cfi, cfo), epsilons) -> + | Flow_with_Epsilons ((_cfi, _cfo), _epsilons) -> failwith "Color_Propagator.to_string: incomplete" - | Flow_with_Epsilon_Bars ((cfi, cfo), epsilon_bars) -> + | Flow_with_Epsilon_Bars ((_cfi, _cfo), _epsilon_bars) -> failwith "Color_Propagator.to_string: incomplete" let digit_option_to_symbol = function | None -> "_" | Some i -> if i < 0 then invalid_arg "Color_Propagator.digit_option_to_symbol: negative" else if i < 10 then string_of_int i else if i < 36 then String.make 1 (Char.chr (Char.code 'A' + i - 10)) else invalid_arg "Color_Propagator.digit_option_to_symbol: too large" let cf_in_cf_out_to_symbol cfi cfo = match PArray.to_option_list cfi, PArray.to_option_list cfo with | [], [] -> "w" | cfi, [] -> "i" ^ String.concat "" (List.map digit_option_to_symbol cfi) | [], cfo -> "o" ^ String.concat "" (List.map digit_option_to_symbol cfo) | cfi, cfo -> "i" ^ String.concat "" (List.map digit_option_to_symbol cfi) ^ "_o" ^ String.concat "" (List.map digit_option_to_symbol cfo) let to_symbol = function | Ghost -> "g" | Flow (cfi, cfo) -> cf_in_cf_out_to_symbol cfi cfo - | Ghost_with_Epsilons epsilons -> + | Ghost_with_Epsilons _epsilons -> failwith "Color_Propagator.to_string: incomplete" - | Ghost_with_Epsilon_Bars epsilon_bars -> + | Ghost_with_Epsilon_Bars _epsilon_bars -> failwith "Color_Propagator.to_string: incomplete" - | Flow_with_Epsilons ((cfi, cfo), epsilons) -> + | Flow_with_Epsilons ((_cfi, _cfo), _epsilons) -> failwith "Color_Propagator.to_string: incomplete" - | Flow_with_Epsilon_Bars ((cfi, cfo), epsilon_bars) -> + | Flow_with_Epsilon_Bars ((_cfi, _cfo), _epsilon_bars) -> failwith "Color_Propagator.to_string: incomplete" let pp fmt p = Format.fprintf fmt "%s" (to_string p) let compare_pairs compare_x compare_y (x1, y1) (x2, y2) = let c = compare_x x1 x2 in if c <> 0 then c else compare_y y1 y2 let compare_flows p1 p2 = compare_pairs (PArray.compare compare) (PArray.compare compare) p1 p2 let compare_eps e1 e2 = compare_pairs (compare_pairs (PArray.compare compare) (PArray.compare compare)) compare e1 e2 let compare p1 p2 = match normalize p1, normalize p2 with | Flow f1, Flow f2 -> compare_flows f1 f2 | Flow_with_Epsilons (f1, e1), Flow_with_Epsilons (f2, e2) -> compare_eps (f1, e1) (f2, e2) | Flow_with_Epsilon_Bars (f1, e1), Flow_with_Epsilon_Bars (f2, e2) -> compare_eps (f1, e1) (f2, e2) | Ghost, Ghost -> 0 | Ghost_with_Epsilons e1, Ghost_with_Epsilons e2 -> compare e1 e2 | Ghost_with_Epsilon_Bars e1, Ghost_with_Epsilon_Bars e2 -> compare e1 e2 | Flow _, (Flow_with_Epsilons _ | Flow_with_Epsilon_Bars _ | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _) | Flow_with_Epsilons _, (Flow_with_Epsilon_Bars _ | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _) | Flow_with_Epsilon_Bars _ , (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _) | Ghost, (Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _) | Ghost_with_Epsilons _, Ghost_with_Epsilon_Bars _ -> -1 | (Flow_with_Epsilons _ | Flow_with_Epsilon_Bars _ | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow _ | (Flow_with_Epsilon_Bars _ | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow_with_Epsilons _ | (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow_with_Epsilon_Bars _ | (Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Ghost | Ghost_with_Epsilon_Bars _, Ghost_with_Epsilons _ -> 1 -let equal p1 p2 = +let _equal p1 p2 = compare p1 p2 = 0 (* Since [PArray.Alist.t] has a unique physical representation, we can fall back on the polymorphic [compare] again. *) let compare = compare let equal = (=) Index: trunk/omega/src/omegalib.nw =================================================================== --- trunk/omega/src/omegalib.nw (revision 8919) +++ trunk/omega/src/omegalib.nw (revision 8920) @@ -1,14261 +1,15388 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % omegalib.nw -- % % Copyright (C) 1999-2024 by % Wolfgang Kilian % Thorsten Ohl % Juergen Reuter % with contributions from % Fabian Bach % Bijan Chokoufe Nejad % Marco Sekulla % Christian Speckner % % WHIZARD is free software; you can redistribute it and/or modify it % under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % WHIZARD is distributed in the hope that it will be useful, but % WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; if not, write to the Free Software % Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \section{Trivia} <<[[omega_spinors.f90]]>>= <> module omega_spinors use kinds use constants implicit none private public :: operator (*), operator (+), operator (-) public :: abs, set_zero <<[[intrinsic :: abs]]>> type, public :: conjspinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type conjspinor type, public :: spinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type spinor <> integer, parameter, public :: omega_spinors_2010_01_A = 0 contains <> end module omega_spinors @ <<[[intrinsic :: abs]] (if working)>>= intrinsic :: abs @ <<[[intrinsic :: conjg]] (if working)>>= intrinsic :: conjg @ well, the Intel Fortran Compiler chokes on these with an internal error: <<[[intrinsic :: abs]]>>= @ <<[[intrinsic :: conjg]]>>= @ To reenable the pure functions that have been removed for OpenMP, one should set this chunk to [[pure &]] <<[[pure]] unless OpenMP>>= @ \subsection{Inner Product} <>= interface operator (*) module procedure conjspinor_spinor end interface private :: conjspinor_spinor @ \begin{equation} \bar\psi\psi' \end{equation} NB: [[dot_product]] conjugates its first argument, we can either cancel this or inline [[dot_product]]: <>= pure function conjspinor_spinor (psibar, psi) result (psibarpsi) complex(kind=default) :: psibarpsi type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi psibarpsi = psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2) & + psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4) end function conjspinor_spinor @ \subsection{Spinor Vector Space} <>= interface set_zero module procedure set_zero_spinor, set_zero_conjspinor end interface private :: set_zero_spinor, set_zero_conjspinor @ <>= elemental subroutine set_zero_spinor (x) type(spinor), intent(out) :: x x%a = 0 end subroutine set_zero_spinor @ <>= elemental subroutine set_zero_conjspinor (x) type(conjspinor), intent(out) :: x x%a = 0 end subroutine set_zero_conjspinor @ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_spinor, spinor_integer, & real_spinor, double_spinor, & complex_spinor, dcomplex_spinor, & spinor_real, spinor_double, & spinor_complex, spinor_dcomplex end interface private :: integer_spinor, spinor_integer, real_spinor, & double_spinor, complex_spinor, dcomplex_spinor, & spinor_real, spinor_double, spinor_complex, spinor_dcomplex @ <>= pure function integer_spinor (x, y) result (xy) integer, intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function integer_spinor @ <>= pure function real_spinor (x, y) result (xy) real(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function real_spinor pure function double_spinor (x, y) result (xy) real(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function double_spinor pure function complex_spinor (x, y) result (xy) complex(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function complex_spinor pure function dcomplex_spinor (x, y) result (xy) complex(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function dcomplex_spinor pure function spinor_integer (y, x) result (xy) integer, intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_integer pure function spinor_real (y, x) result (xy) real(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_real pure function spinor_double (y, x) result (xy) real(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_double pure function spinor_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_complex pure function spinor_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(spinor), intent(in) :: y type(spinor) :: xy xy%a = x * y%a end function spinor_dcomplex @ <>= interface operator (*) module procedure integer_conjspinor, conjspinor_integer, & real_conjspinor, double_conjspinor, & complex_conjspinor, dcomplex_conjspinor, & conjspinor_real, conjspinor_double, & conjspinor_complex, conjspinor_dcomplex end interface private :: integer_conjspinor, conjspinor_integer, real_conjspinor, & double_conjspinor, complex_conjspinor, dcomplex_conjspinor, & conjspinor_real, conjspinor_double, conjspinor_complex, & conjspinor_dcomplex @ <>= pure function integer_conjspinor (x, y) result (xy) integer, intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function integer_conjspinor pure function real_conjspinor (x, y) result (xy) real(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function real_conjspinor pure function double_conjspinor (x, y) result (xy) real(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function double_conjspinor pure function complex_conjspinor (x, y) result (xy) complex(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function complex_conjspinor pure function dcomplex_conjspinor (x, y) result (xy) complex(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function dcomplex_conjspinor pure function conjspinor_integer (y, x) result (xy) integer, intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_integer pure function conjspinor_real (y, x) result (xy) real(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_real pure function conjspinor_double (y, x) result (xy) real(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_double pure function conjspinor_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_complex pure function conjspinor_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(conjspinor), intent(in) :: y type(conjspinor) :: xy xy%a = x * y%a end function conjspinor_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_spinor, plus_conjspinor end interface private :: plus_spinor, plus_conjspinor interface operator (-) module procedure neg_spinor, neg_conjspinor end interface private :: neg_spinor, neg_conjspinor @ <>= pure function plus_spinor (x) result (plus_x) type(spinor), intent(in) :: x type(spinor) :: plus_x plus_x%a = x%a end function plus_spinor pure function neg_spinor (x) result (neg_x) type(spinor), intent(in) :: x type(spinor) :: neg_x neg_x%a = - x%a end function neg_spinor @ <>= pure function plus_conjspinor (x) result (plus_x) type(conjspinor), intent(in) :: x type(conjspinor) :: plus_x plus_x%a = x%a end function plus_conjspinor pure function neg_conjspinor (x) result (neg_x) type(conjspinor), intent(in) :: x type(conjspinor) :: neg_x neg_x%a = - x%a end function neg_conjspinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_spinor, add_conjspinor end interface private :: add_spinor, add_conjspinor interface operator (-) module procedure sub_spinor, sub_conjspinor end interface private :: sub_spinor, sub_conjspinor @ <>= pure function add_spinor (x, y) result (xy) type(spinor), intent(in) :: x, y type(spinor) :: xy xy%a = x%a + y%a end function add_spinor pure function sub_spinor (x, y) result (xy) type(spinor), intent(in) :: x, y type(spinor) :: xy xy%a = x%a - y%a end function sub_spinor @ <>= pure function add_conjspinor (x, y) result (xy) type(conjspinor), intent(in) :: x, y type(conjspinor) :: xy xy%a = x%a + y%a end function add_conjspinor pure function sub_conjspinor (x, y) result (xy) type(conjspinor), intent(in) :: x, y type(conjspinor) :: xy xy%a = x%a - y%a end function sub_conjspinor @ \subsection{Norm} <>= interface abs module procedure abs_spinor, abs_conjspinor end interface private :: abs_spinor, abs_conjspinor @ <>= pure function abs_spinor (psi) result (x) type(spinor), intent(in) :: psi real(kind=default) :: x x = sqrt (real (dot_product (psi%a, psi%a))) end function abs_spinor @ <>= pure function abs_conjspinor (psibar) result (x) real(kind=default) :: x type(conjspinor), intent(in) :: psibar x = sqrt (real (dot_product (psibar%a, psibar%a))) end function abs_conjspinor @ \section{Spinors Revisited} <<[[omega_bispinors.f90]]>>= <> module omega_bispinors use kinds use constants implicit none private public :: operator (*), operator (+), operator (-) public :: abs, set_zero type, public :: bispinor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4) :: a end type bispinor <> integer, parameter, public :: omega_bispinors_2010_01_A = 0 contains <> end module omega_bispinors @ <>= interface operator (*) module procedure spinor_product end interface private :: spinor_product @ \begin{equation} \bar\psi\psi' \end{equation} NB: [[dot_product]] conjugates its first argument, we have to cancel this. <>= pure function spinor_product (psil, psir) result (psilpsir) complex(kind=default) :: psilpsir type(bispinor), intent(in) :: psil, psir type(bispinor) :: psidum psidum%a(1) = psir%a(2) psidum%a(2) = - psir%a(1) psidum%a(3) = - psir%a(4) psidum%a(4) = psir%a(3) psilpsir = dot_product (conjg (psil%a), psidum%a) end function spinor_product @ \subsection{Spinor Vector Space} <>= interface set_zero module procedure set_zero_bispinor end interface private :: set_zero_bispinor @ <>= elemental subroutine set_zero_bispinor (x) type(bispinor), intent(out) :: x x%a = 0 end subroutine set_zero_bispinor @ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_bispinor, bispinor_integer, & real_bispinor, double_bispinor, & complex_bispinor, dcomplex_bispinor, & bispinor_real, bispinor_double, & bispinor_complex, bispinor_dcomplex end interface private :: integer_bispinor, bispinor_integer, real_bispinor, & double_bispinor, complex_bispinor, dcomplex_bispinor, & bispinor_real, bispinor_double, bispinor_complex, bispinor_dcomplex @ <>= pure function integer_bispinor (x, y) result (xy) type(bispinor) :: xy integer, intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function integer_bispinor @ <>= pure function real_bispinor (x, y) result (xy) type(bispinor) :: xy real(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function real_bispinor @ <>= pure function double_bispinor (x, y) result (xy) type(bispinor) :: xy real(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function double_bispinor @ <>= pure function complex_bispinor (x, y) result (xy) type(bispinor) :: xy complex(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function complex_bispinor @ <>= pure function dcomplex_bispinor (x, y) result (xy) type(bispinor) :: xy complex(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function dcomplex_bispinor @ <>= pure function bispinor_integer (y, x) result (xy) type(bispinor) :: xy integer, intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_integer @ <>= pure function bispinor_real (y, x) result (xy) type(bispinor) :: xy real(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_real @ <>= pure function bispinor_double (y, x) result (xy) type(bispinor) :: xy real(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_double @ <>= pure function bispinor_complex (y, x) result (xy) type(bispinor) :: xy complex(kind=single), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_complex @ <>= pure function bispinor_dcomplex (y, x) result (xy) type(bispinor) :: xy complex(kind=default), intent(in) :: x type(bispinor), intent(in) :: y xy%a = x * y%a end function bispinor_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_bispinor end interface private :: plus_bispinor interface operator (-) module procedure neg_bispinor end interface private :: neg_bispinor @ <>= pure function plus_bispinor (x) result (plus_x) type(bispinor) :: plus_x type(bispinor), intent(in) :: x plus_x%a = x%a end function plus_bispinor @ <>= pure function neg_bispinor (x) result (neg_x) type(bispinor) :: neg_x type(bispinor), intent(in) :: x neg_x%a = - x%a end function neg_bispinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_bispinor end interface private :: add_bispinor interface operator (-) module procedure sub_bispinor end interface private :: sub_bispinor @ <>= pure function add_bispinor (x, y) result (xy) type(bispinor) :: xy type(bispinor), intent(in) :: x, y xy%a = x%a + y%a end function add_bispinor @ <>= pure function sub_bispinor (x, y) result (xy) type(bispinor) :: xy type(bispinor), intent(in) :: x, y xy%a = x%a - y%a end function sub_bispinor @ \subsection{Norm} <>= interface abs module procedure abs_bispinor end interface private :: abs_bispinor @ <>= pure function abs_bispinor (psi) result (x) real(kind=default) :: x type(bispinor), intent(in) :: psi x = sqrt (real (dot_product (psi%a, psi%a))) end function abs_bispinor @ \section{Vectorspinors} <<[[omega_vectorspinors.f90]]>>= <> module omega_vectorspinors use kinds use constants use omega_bispinors use omega_vectors implicit none private public :: operator (*), operator (+), operator (-) public :: abs, set_zero type, public :: vectorspinor ! private (omegalib needs access, but DON'T TOUCH IT!) type(bispinor), dimension(4) :: psi end type vectorspinor <> integer, parameter, public :: omega_vectorspinors_2010_01_A = 0 contains <> end module omega_vectorspinors @ <>= interface operator (*) module procedure vspinor_product end interface private :: vspinor_product @ \begin{equation} \bar\psi^\mu\psi'_\mu \end{equation} <>= pure function vspinor_product (psil, psir) result (psilpsir) complex(kind=default) :: psilpsir type(vectorspinor), intent(in) :: psil, psir psilpsir = psil%psi(1) * psir%psi(1) & - psil%psi(2) * psir%psi(2) & - psil%psi(3) * psir%psi(3) & - psil%psi(4) * psir%psi(4) end function vspinor_product @ \subsection{Vectorspinor Vector Space} <>= interface set_zero module procedure set_zero_vectorspinor end interface private :: set_zero_vectorspinor @ <>= elemental subroutine set_zero_vectorspinor (x) type(vectorspinor), intent(out) :: x call set_zero (x%psi) end subroutine set_zero_vectorspinor @ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_vectorspinor, vectorspinor_integer, & real_vectorspinor, double_vectorspinor, & complex_vectorspinor, dcomplex_vectorspinor, & vectorspinor_real, vectorspinor_double, & vectorspinor_complex, vectorspinor_dcomplex, & momentum_vectorspinor, vectorspinor_momentum end interface private :: integer_vectorspinor, vectorspinor_integer, real_vectorspinor, & double_vectorspinor, complex_vectorspinor, dcomplex_vectorspinor, & vectorspinor_real, vectorspinor_double, vectorspinor_complex, & vectorspinor_dcomplex @ <>= pure function integer_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy integer, intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function integer_vectorspinor @ <>= pure function real_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy real(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function real_vectorspinor @ <>= pure function double_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy real(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function double_vectorspinor @ <>= pure function complex_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy complex(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function complex_vectorspinor @ <>= pure function dcomplex_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy complex(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = x * y%psi(k) end do end function dcomplex_vectorspinor @ <>= pure function vectorspinor_integer (y, x) result (xy) type(vectorspinor) :: xy integer, intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_integer @ <>= pure function vectorspinor_real (y, x) result (xy) type(vectorspinor) :: xy real(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_real @ <>= pure function vectorspinor_double (y, x) result (xy) type(vectorspinor) :: xy real(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_double @ <>= pure function vectorspinor_complex (y, x) result (xy) type(vectorspinor) :: xy complex(kind=single), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_complex @ <>= pure function vectorspinor_dcomplex (y, x) result (xy) type(vectorspinor) :: xy complex(kind=default), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%psi(k) = y%psi(k) * x end do end function vectorspinor_dcomplex @ <>= pure function momentum_vectorspinor (y, x) result (xy) type(bispinor) :: xy type(momentum), intent(in) :: y type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 xy%a(k) = y%t * x%psi(1)%a(k) - y%x(1) * x%psi(2)%a(k) - & y%x(2) * x%psi(3)%a(k) - y%x(3) * x%psi(4)%a(k) end do end function momentum_vectorspinor @ <>= pure function vectorspinor_momentum (y, x) result (xy) type(bispinor) :: xy type(momentum), intent(in) :: x type(vectorspinor), intent(in) :: y integer :: k do k = 1,4 xy%a(k) = x%t * y%psi(1)%a(k) - x%x(1) * y%psi(2)%a(k) - & x%x(2) * y%psi(3)%a(k) - x%x(3) * y%psi(4)%a(k) end do end function vectorspinor_momentum @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_vectorspinor end interface private :: plus_vectorspinor interface operator (-) module procedure neg_vectorspinor end interface private :: neg_vectorspinor @ <>= pure function plus_vectorspinor (x) result (plus_x) type(vectorspinor) :: plus_x type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 plus_x%psi(k) = + x%psi(k) end do end function plus_vectorspinor @ <>= pure function neg_vectorspinor (x) result (neg_x) type(vectorspinor) :: neg_x type(vectorspinor), intent(in) :: x integer :: k do k = 1,4 neg_x%psi(k) = - x%psi(k) end do end function neg_vectorspinor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_vectorspinor end interface private :: add_vectorspinor interface operator (-) module procedure sub_vectorspinor end interface private :: sub_vectorspinor @ <>= pure function add_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy type(vectorspinor), intent(in) :: x, y integer :: k do k = 1,4 xy%psi(k) = x%psi(k) + y%psi(k) end do end function add_vectorspinor @ <>= pure function sub_vectorspinor (x, y) result (xy) type(vectorspinor) :: xy type(vectorspinor), intent(in) :: x, y integer :: k do k = 1,4 xy%psi(k) = x%psi(k) - y%psi(k) end do end function sub_vectorspinor @ \subsection{Norm} <>= interface abs module procedure abs_vectorspinor end interface private :: abs_vectorspinor @ <>= pure function abs_vectorspinor (psi) result (x) real(kind=default) :: x type(vectorspinor), intent(in) :: psi x = sqrt (real (dot_product (psi%psi(1)%a, psi%psi(1)%a) & - dot_product (psi%psi(2)%a, psi%psi(2)%a) & - dot_product (psi%psi(3)%a, psi%psi(3)%a) & - dot_product (psi%psi(4)%a, psi%psi(4)%a))) end function abs_vectorspinor @ \section{Vectors and Tensors} Condensed representation of antisymmetric rank-2 tensors: \begin{equation} \begin{pmatrix} T^{00} & T^{01} & T^{02} & T^{03} \\ T^{10} & T^{11} & T^{12} & T^{13} \\ T^{20} & T^{21} & T^{22} & T^{23} \\ T^{30} & T^{31} & T^{32} & T^{33} \end{pmatrix} = \begin{pmatrix} 0 & T_e^1 & T_e^2 & T_e^3 \\ -T_e^1 & 0 & T_b^3 & -T_b^2 \\ -T_e^2 & -T_b^3 & 0 & T_b^1 \\ -T_e^3 & T_b^2 & -T_b^1 & 0 \end{pmatrix} \end{equation} <<[[omega_vectors.f90]]>>= <> module omega_vectors use kinds use constants implicit none private public :: assignment (=), operator(==) public :: operator (*), operator (+), operator (-), operator (.wedge.) public :: abs, conjg, set_zero public :: random_momentum <<[[intrinsic :: abs]]>> <<[[intrinsic :: conjg]]>> type, public :: momentum ! private (omegalib needs access, but DON'T TOUCH IT!) real(kind=default) :: t real(kind=default), dimension(3) :: x end type momentum type, public :: vector ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default) :: t complex(kind=default), dimension(3) :: x end type vector type, public :: tensor2odd ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(3) :: e complex(kind=default), dimension(3) :: b end type tensor2odd <> integer, parameter, public :: omega_vectors_2010_01_A = 0 contains <> end module omega_vectors @ \subsection{Constructors} <>= interface assignment (=) module procedure momentum_of_array, vector_of_momentum, & vector_of_array, vector_of_double_array, & array_of_momentum, array_of_vector end interface private :: momentum_of_array, vector_of_momentum, vector_of_array, & vector_of_double_array, array_of_momentum, array_of_vector @ <>= pure subroutine momentum_of_array (m, p) type(momentum), intent(out) :: m real(kind=default), dimension(0:), intent(in) :: p m%t = p(0) m%x = p(1:3) end subroutine momentum_of_array pure subroutine array_of_momentum (p, v) real(kind=default), dimension(0:), intent(out) :: p type(momentum), intent(in) :: v p(0) = v%t p(1:3) = v%x end subroutine array_of_momentum @ <>= pure subroutine vector_of_array (v, p) type(vector), intent(out) :: v complex(kind=default), dimension(0:), intent(in) :: p v%t = p(0) v%x = p(1:3) end subroutine vector_of_array pure subroutine vector_of_double_array (v, p) type(vector), intent(out) :: v real(kind=default), dimension(0:), intent(in) :: p v%t = p(0) v%x = p(1:3) end subroutine vector_of_double_array pure subroutine array_of_vector (p, v) complex(kind=default), dimension(0:), intent(out) :: p type(vector), intent(in) :: v p(0) = v%t p(1:3) = v%x end subroutine array_of_vector @ <>= pure subroutine vector_of_momentum (v, p) type(vector), intent(out) :: v type(momentum), intent(in) :: p v%t = p%t v%x = p%x end subroutine vector_of_momentum @ <>= interface operator(==) module procedure momentum_eq end interface @ <>= elemental function momentum_eq (lhs, rhs) result (yorn) logical :: yorn type(momentum), intent(in) :: lhs type(momentum), intent(in) :: rhs yorn = all (abs(lhs%x - rhs%x) < eps0) .and. abs(lhs%t - rhs%t) < eps0 end function momentum_eq @ \subsection{Inner Products} <>= interface operator (*) module procedure momentum_momentum, vector_vector, & vector_momentum, momentum_vector, tensor2odd_tensor2odd end interface private :: momentum_momentum, vector_vector, vector_momentum, & momentum_vector, tensor2odd_tensor2odd @ <>= pure function momentum_momentum (x, y) result (xy) type(momentum), intent(in) :: x type(momentum), intent(in) :: y real(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function momentum_momentum pure function momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function momentum_vector pure function vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function vector_momentum pure function vector_vector (x, y) result (xy) type(vector), intent(in) :: x type(vector), intent(in) :: y complex(kind=default) :: xy xy = x%t*y%t - x%x(1)*y%x(1) - x%x(2)*y%x(2) - x%x(3)*y%x(3) end function vector_vector @ Just like classical electrodynamics: \begin{equation} \frac{1}{2} T_{\mu\nu} U^{\mu\nu} = \frac{1}{2} \left( - T^{0i} U^{0i} - T^{i0} U^{i0} + T^{ij} U^{ij} \right) = T_b^k U_b^k - T_e^k U_e^k \end{equation} <>= pure function tensor2odd_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x type(tensor2odd), intent(in) :: y complex(kind=default) :: xy xy = x%b(1)*y%b(1) + x%b(2)*y%b(2) + x%b(3)*y%b(3) & - x%e(1)*y%e(1) - x%e(2)*y%e(2) - x%e(3)*y%e(3) end function tensor2odd_tensor2odd @ \subsection{Not Entirely Inner Products} <>= interface operator (*) module procedure momentum_tensor2odd, tensor2odd_momentum, & vector_tensor2odd, tensor2odd_vector end interface private :: momentum_tensor2odd, tensor2odd_momentum, vector_tensor2odd, & tensor2odd_vector @ \begin{subequations} \begin{align} y^\nu = x_\mu T^{\mu\nu}: & y^0 = - x^i T^{i0} = x^i T^{0i} \\ & y^1 = x^0 T^{01} - x^2 T^{21} - x^3 T^{31} \\ & y^2 = x^0 T^{02} - x^1 T^{12} - x^3 T^{32} \\ & y^3 = x^0 T^{03} - x^1 T^{13} - x^2 T^{23} \end{align} \end{subequations} <>= pure function vector_tensor2odd (x, t2) result (xt2) type(vector), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(vector) :: xt2 xt2%t = x%x(1)*t2%e(1) + x%x(2)*t2%e(2) + x%x(3)*t2%e(3) xt2%x(1) = x%t*t2%e(1) + x%x(2)*t2%b(3) - x%x(3)*t2%b(2) xt2%x(2) = x%t*t2%e(2) + x%x(3)*t2%b(1) - x%x(1)*t2%b(3) xt2%x(3) = x%t*t2%e(3) + x%x(1)*t2%b(2) - x%x(2)*t2%b(1) end function vector_tensor2odd pure function momentum_tensor2odd (x, t2) result (xt2) type(momentum), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(vector) :: xt2 xt2%t = x%x(1)*t2%e(1) + x%x(2)*t2%e(2) + x%x(3)*t2%e(3) xt2%x(1) = x%t*t2%e(1) + x%x(2)*t2%b(3) - x%x(3)*t2%b(2) xt2%x(2) = x%t*t2%e(2) + x%x(3)*t2%b(1) - x%x(1)*t2%b(3) xt2%x(3) = x%t*t2%e(3) + x%x(1)*t2%b(2) - x%x(2)*t2%b(1) end function momentum_tensor2odd @ \begin{subequations} \begin{align} y^\mu = T^{\mu\nu} x_\nu : & y^0 = - T^{0i} x^i \\ & y^1 = T^{10} x^0 - T^{12} x^2 - T^{13} x^3 \\ & y^2 = T^{20} x^0 - T^{21} x^1 - T^{23} x^3 \\ & y^3 = T^{30} x^0 - T^{31} x^1 - T^{32} x^2 \end{align} \end{subequations} <>= pure function tensor2odd_vector (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 type(vector), intent(in) :: x type(vector) :: t2x t2x%t = - t2%e(1)*x%x(1) - t2%e(2)*x%x(2) - t2%e(3)*x%x(3) t2x%x(1) = - t2%e(1)*x%t + t2%b(2)*x%x(3) - t2%b(3)*x%x(2) t2x%x(2) = - t2%e(2)*x%t + t2%b(3)*x%x(1) - t2%b(1)*x%x(3) t2x%x(3) = - t2%e(3)*x%t + t2%b(1)*x%x(2) - t2%b(2)*x%x(1) end function tensor2odd_vector pure function tensor2odd_momentum (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 type(momentum), intent(in) :: x type(vector) :: t2x t2x%t = - t2%e(1)*x%x(1) - t2%e(2)*x%x(2) - t2%e(3)*x%x(3) t2x%x(1) = - t2%e(1)*x%t + t2%b(2)*x%x(3) - t2%b(3)*x%x(2) t2x%x(2) = - t2%e(2)*x%t + t2%b(3)*x%x(1) - t2%b(1)*x%x(3) t2x%x(3) = - t2%e(3)*x%t + t2%b(1)*x%x(2) - t2%b(2)*x%x(1) end function tensor2odd_momentum @ \subsection{Outer Products} <>= interface operator (.wedge.) module procedure momentum_wedge_momentum, & momentum_wedge_vector, vector_wedge_momentum, vector_wedge_vector end interface private :: momentum_wedge_momentum, momentum_wedge_vector, & vector_wedge_momentum, vector_wedge_vector @ <>= pure function momentum_wedge_momentum (x, y) result (t2) type(momentum), intent(in) :: x type(momentum), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function momentum_wedge_momentum pure function momentum_wedge_vector (x, y) result (t2) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function momentum_wedge_vector pure function vector_wedge_momentum (x, y) result (t2) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function vector_wedge_momentum pure function vector_wedge_vector (x, y) result (t2) type(vector), intent(in) :: x type(vector), intent(in) :: y type(tensor2odd) :: t2 t2%e = x%t * y%x - x%x * y%t t2%b(1) = x%x(2) * y%x(3) - x%x(3) * y%x(2) t2%b(2) = x%x(3) * y%x(1) - x%x(1) * y%x(3) t2%b(3) = x%x(1) * y%x(2) - x%x(2) * y%x(1) end function vector_wedge_vector @ \subsection{Vector Space} <>= interface set_zero module procedure set_zero_vector, set_zero_momentum, & set_zero_tensor2odd, set_zero_real, set_zero_complex end interface private :: set_zero_vector, set_zero_momentum, set_zero_tensor2odd @ <>= elemental subroutine set_zero_vector (x) type(vector), intent(out) :: x x%t = 0 x%x = 0 end subroutine set_zero_vector @ <>= elemental subroutine set_zero_momentum (x) type(momentum), intent(out) :: x x%t = 0 x%x = 0 end subroutine set_zero_momentum @ <>= elemental subroutine set_zero_tensor2odd (x) type(tensor2odd), intent(out) :: x x%e = 0 x%b = 0 end subroutine set_zero_tensor2odd @ Doesn't really belong here, but there is no better place \ldots <>= elemental subroutine set_zero_real (x) real(kind=default), intent(out) :: x x = 0 end subroutine set_zero_real @ <>= elemental subroutine set_zero_complex (x) complex(kind=default), intent(out) :: x x = 0 end subroutine set_zero_complex @ \subsubsection{Scalar Multiplication} <>= interface operator (*) module procedure integer_momentum, real_momentum, double_momentum, & complex_momentum, dcomplex_momentum, & integer_vector, real_vector, double_vector, & complex_vector, dcomplex_vector, & integer_tensor2odd, real_tensor2odd, double_tensor2odd, & complex_tensor2odd, dcomplex_tensor2odd, & momentum_integer, momentum_real, momentum_double, & momentum_complex, momentum_dcomplex, & vector_integer, vector_real, vector_double, & vector_complex, vector_dcomplex, & tensor2odd_integer, tensor2odd_real, tensor2odd_double, & tensor2odd_complex, tensor2odd_dcomplex end interface private :: integer_momentum, real_momentum, double_momentum, & complex_momentum, dcomplex_momentum, integer_vector, real_vector, & double_vector, complex_vector, dcomplex_vector, & integer_tensor2odd, real_tensor2odd, double_tensor2odd, & complex_tensor2odd, dcomplex_tensor2odd, momentum_integer, & momentum_real, momentum_double, momentum_complex, & momentum_dcomplex, vector_integer, vector_real, vector_double, & vector_complex, vector_dcomplex, tensor2odd_integer, & tensor2odd_real, tensor2odd_double, tensor2odd_complex, & tensor2odd_dcomplex @ <>= pure function integer_momentum (x, y) result (xy) integer, intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function integer_momentum pure function real_momentum (x, y) result (xy) real(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function real_momentum pure function double_momentum (x, y) result (xy) real(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function double_momentum pure function complex_momentum (x, y) result (xy) complex(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function complex_momentum pure function dcomplex_momentum (x, y) result (xy) complex(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function dcomplex_momentum @ <>= pure function integer_vector (x, y) result (xy) integer, intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function integer_vector pure function real_vector (x, y) result (xy) real(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function real_vector pure function double_vector (x, y) result (xy) real(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function double_vector pure function complex_vector (x, y) result (xy) complex(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function complex_vector pure function dcomplex_vector (x, y) result (xy) complex(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function dcomplex_vector @ <>= pure function integer_tensor2odd (x, t2) result (xt2) integer, intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function integer_tensor2odd pure function real_tensor2odd (x, t2) result (xt2) real(kind=single), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function real_tensor2odd pure function double_tensor2odd (x, t2) result (xt2) real(kind=default), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function double_tensor2odd pure function complex_tensor2odd (x, t2) result (xt2) complex(kind=single), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function complex_tensor2odd pure function dcomplex_tensor2odd (x, t2) result (xt2) complex(kind=default), intent(in) :: x type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: xt2 xt2%e = x * t2%e xt2%b = x * t2%b end function dcomplex_tensor2odd @ <>= pure function momentum_integer (y, x) result (xy) integer, intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_integer pure function momentum_real (y, x) result (xy) real(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_real pure function momentum_double (y, x) result (xy) real(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(momentum) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_double pure function momentum_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_complex pure function momentum_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function momentum_dcomplex @ <>= pure function vector_integer (y, x) result (xy) integer, intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_integer pure function vector_real (y, x) result (xy) real(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_real pure function vector_double (y, x) result (xy) real(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_double pure function vector_complex (y, x) result (xy) complex(kind=single), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_complex pure function vector_dcomplex (y, x) result (xy) complex(kind=default), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x * y%t xy%x = x * y%x end function vector_dcomplex @ <>= pure function tensor2odd_integer (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 integer, intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_integer pure function tensor2odd_real (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 real(kind=single), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_real pure function tensor2odd_double (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 real(kind=default), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_double pure function tensor2odd_complex (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 complex(kind=single), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_complex pure function tensor2odd_dcomplex (t2, x) result (t2x) type(tensor2odd), intent(in) :: t2 complex(kind=default), intent(in) :: x type(tensor2odd) :: t2x t2x%e = x * t2%e t2x%b = x * t2%b end function tensor2odd_dcomplex @ \subsubsection{Unary Plus and Minus} <>= interface operator (+) module procedure plus_momentum, plus_vector, plus_tensor2odd end interface private :: plus_momentum, plus_vector, plus_tensor2odd interface operator (-) module procedure neg_momentum, neg_vector, neg_tensor2odd end interface private :: neg_momentum, neg_vector, neg_tensor2odd @ <>= pure function plus_momentum (x) result (plus_x) type(momentum), intent(in) :: x type(momentum) :: plus_x plus_x = x end function plus_momentum pure function neg_momentum (x) result (neg_x) type(momentum), intent(in) :: x type(momentum) :: neg_x neg_x%t = - x%t neg_x%x = - x%x end function neg_momentum @ <>= pure function plus_vector (x) result (plus_x) type(vector), intent(in) :: x type(vector) :: plus_x plus_x = x end function plus_vector pure function neg_vector (x) result (neg_x) type(vector), intent(in) :: x type(vector) :: neg_x neg_x%t = - x%t neg_x%x = - x%x end function neg_vector @ <>= pure function plus_tensor2odd (x) result (plus_x) type(tensor2odd), intent(in) :: x type(tensor2odd) :: plus_x plus_x = x end function plus_tensor2odd pure function neg_tensor2odd (x) result (neg_x) type(tensor2odd), intent(in) :: x type(tensor2odd) :: neg_x neg_x%e = - x%e neg_x%b = - x%b end function neg_tensor2odd @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure add_momentum, add_vector, & add_vector_momentum, add_momentum_vector, add_tensor2odd end interface private :: add_momentum, add_vector, add_vector_momentum, & add_momentum_vector, add_tensor2odd interface operator (-) module procedure sub_momentum, sub_vector, & sub_vector_momentum, sub_momentum_vector, sub_tensor2odd end interface private :: sub_momentum, sub_vector, sub_vector_momentum, & sub_momentum_vector, sub_tensor2odd @ <>= pure function add_momentum (x, y) result (xy) type(momentum), intent(in) :: x, y type(momentum) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_momentum pure function add_vector (x, y) result (xy) type(vector), intent(in) :: x, y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_vector pure function add_momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_momentum_vector pure function add_vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x%t + y%t xy%x = x%x + y%x end function add_vector_momentum pure function add_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x, y type(tensor2odd) :: xy xy%e = x%e + y%e xy%b = x%b + y%b end function add_tensor2odd @ <>= pure function sub_momentum (x, y) result (xy) type(momentum), intent(in) :: x, y type(momentum) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_momentum pure function sub_vector (x, y) result (xy) type(vector), intent(in) :: x, y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_vector pure function sub_momentum_vector (x, y) result (xy) type(momentum), intent(in) :: x type(vector), intent(in) :: y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_momentum_vector pure function sub_vector_momentum (x, y) result (xy) type(vector), intent(in) :: x type(momentum), intent(in) :: y type(vector) :: xy xy%t = x%t - y%t xy%x = x%x - y%x end function sub_vector_momentum pure function sub_tensor2odd (x, y) result (xy) type(tensor2odd), intent(in) :: x, y type(tensor2odd) :: xy xy%e = x%e - y%e xy%b = x%b - y%b end function sub_tensor2odd @ \subsection{Norm} \emph{Not} the covariant length! <>= interface abs module procedure abs_momentum, abs_vector, abs_tensor2odd end interface private :: abs_momentum, abs_vector, abs_tensor2odd @ <>= pure function abs_momentum (x) result (absx) type(momentum), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (x%t*x%t + dot_product (x%x, x%x))) end function abs_momentum pure function abs_vector (x) result (absx) type(vector), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (conjg(x%t)*x%t + dot_product (x%x, x%x))) end function abs_vector pure function abs_tensor2odd (x) result (absx) type(tensor2odd), intent(in) :: x real(kind=default) :: absx absx = sqrt (real (dot_product (x%e, x%e) + dot_product (x%b, x%b))) end function abs_tensor2odd @ \subsection{Conjugation} <>= interface conjg module procedure conjg_momentum, conjg_vector, conjg_tensor2odd end interface private :: conjg_momentum, conjg_vector, conjg_tensor2odd @ <>= pure function conjg_momentum (x) result (conjg_x) type(momentum), intent(in) :: x type(momentum) :: conjg_x conjg_x = x end function conjg_momentum pure function conjg_vector (x) result (conjg_x) type(vector), intent(in) :: x type(vector) :: conjg_x conjg_x%t = conjg (x%t) conjg_x%x = conjg (x%x) end function conjg_vector pure function conjg_tensor2odd (t2) result (conjg_t2) type(tensor2odd), intent(in) :: t2 type(tensor2odd) :: conjg_t2 conjg_t2%e = conjg (t2%e) conjg_t2%b = conjg (t2%b) end function conjg_tensor2odd @ \subsection{$\epsilon$-Tensors} \begin{equation} \epsilon_{0123} = 1 = - \epsilon^{0123} \end{equation} in particular \begin{equation} \epsilon(p_1,p_2,p_3,p_4) = \epsilon_{\mu_1\mu_2\mu_3\mu_4} p_1^{\mu_1}p_2^{\mu_2}p_3^{\mu_3}p_4^{\mu_4} = p_1^0 p_2^1 p_3^2 p_4^3 \pm \ldots \end{equation} <>= interface pseudo_scalar module procedure pseudo_scalar_momentum, pseudo_scalar_vector, & pseudo_scalar_vec_mom end interface public :: pseudo_scalar private :: pseudo_scalar_momentum, pseudo_scalar_vector @ <>= pure function pseudo_scalar_momentum (p1, p2, p3, p4) result (eps1234) type(momentum), intent(in) :: p1, p2, p3, p4 real(kind=default) :: eps1234 eps1234 = & p1%t * p2%x(1) * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%t * p2%x(2) * (p3%x(3) * p4%x(1) - p3%x(1) * p4%x(3)) & + p1%t * p2%x(3) * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(1) * p2%x(2) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(1) * p2%x(3) * (p3%t * p4%x(2) - p3%x(2) * p4%t ) & - p1%x(1) * p2%t * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%x(2) * p2%x(3) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) & + p1%x(2) * p2%t * (p3%x(1) * p4%x(3) - p3%x(3) * p4%x(1)) & + p1%x(2) * p2%x(1) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(3) * p2%t * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(3) * p2%x(1) * (p3%x(2) * p4%t - p3%t * p4%x(2)) & - p1%x(3) * p2%x(2) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) end function pseudo_scalar_momentum @ <>= pure function pseudo_scalar_vector (p1, p2, p3, p4) result (eps1234) type(vector), intent(in) :: p1, p2, p3, p4 complex(kind=default) :: eps1234 eps1234 = & p1%t * p2%x(1) * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%t * p2%x(2) * (p3%x(3) * p4%x(1) - p3%x(1) * p4%x(3)) & + p1%t * p2%x(3) * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(1) * p2%x(2) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(1) * p2%x(3) * (p3%t * p4%x(2) - p3%x(2) * p4%t ) & - p1%x(1) * p2%t * (p3%x(2) * p4%x(3) - p3%x(3) * p4%x(2)) & + p1%x(2) * p2%x(3) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) & + p1%x(2) * p2%t * (p3%x(1) * p4%x(3) - p3%x(3) * p4%x(1)) & + p1%x(2) * p2%x(1) * (p3%x(3) * p4%t - p3%t * p4%x(3)) & - p1%x(3) * p2%t * (p3%x(1) * p4%x(2) - p3%x(2) * p4%x(1)) & - p1%x(3) * p2%x(1) * (p3%x(2) * p4%t - p3%t * p4%x(2)) & - p1%x(3) * p2%x(2) * (p3%t * p4%x(1) - p3%x(1) * p4%t ) end function pseudo_scalar_vector @ <>= pure function pseudo_scalar_vec_mom (p1, v1, p2, v2) result (eps1234) type(momentum), intent(in) :: p1, p2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: eps1234 eps1234 = & p1%t * v1%x(1) * (p2%x(2) * v2%x(3) - p2%x(3) * v2%x(2)) & + p1%t * v1%x(2) * (p2%x(3) * v2%x(1) - p2%x(1) * v2%x(3)) & + p1%t * v1%x(3) * (p2%x(1) * v2%x(2) - p2%x(2) * v2%x(1)) & - p1%x(1) * v1%x(2) * (p2%x(3) * v2%t - p2%t * v2%x(3)) & - p1%x(1) * v1%x(3) * (p2%t * v2%x(2) - p2%x(2) * v2%t ) & - p1%x(1) * v1%t * (p2%x(2) * v2%x(3) - p2%x(3) * v2%x(2)) & + p1%x(2) * v1%x(3) * (p2%t * v2%x(1) - p2%x(1) * v2%t ) & + p1%x(2) * v1%t * (p2%x(1) * v2%x(3) - p2%x(3) * v2%x(1)) & + p1%x(2) * v1%x(1) * (p2%x(3) * v2%t - p2%t * v2%x(3)) & - p1%x(3) * v1%t * (p2%x(1) * v2%x(2) - p2%x(2) * v2%x(1)) & - p1%x(3) * v1%x(1) * (p2%x(2) * v2%t - p2%t * v2%x(2)) & - p1%x(3) * v1%x(2) * (p2%t * v2%x(1) - p2%x(1) * v2%t ) end function pseudo_scalar_vec_mom @ \begin{equation} \epsilon_\mu(p_1,p_2,p_3) = \epsilon_{\mu\mu_1\mu_2\mu_3} p_1^{\mu_1}p_2^{\mu_2}p_3^{\mu_3} \end{equation} i.\,e. \begin{subequations} \begin{align} \epsilon_0(p_1,p_2,p_3) &= p_1^1 p_2^2 p_3^3 \pm \ldots \\ \epsilon_1(p_1,p_2,p_3) &= p_1^2 p_2^3 p_3^0 \pm \ldots \\ \epsilon_2(p_1,p_2,p_3) &= - p_1^3 p_2^0 p_3^1 \pm \ldots \\ \epsilon_3(p_1,p_2,p_3) &= p_1^0 p_2^1 p_3^2 \pm \ldots \end{align} \end{subequations} <>= interface pseudo_vector module procedure pseudo_vector_momentum, pseudo_vector_vector, & pseudo_vector_vec_mom end interface public :: pseudo_vector private :: pseudo_vector_momentum, pseudo_vector_vector @ <>= pure function pseudo_vector_momentum (p1, p2, p3) result (eps123) type(momentum), intent(in) :: p1, p2, p3 type(momentum) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) & + p1%x(2) * (p2%x(3) * p3%x(1) - p2%x(1) * p3%x(3)) & + p1%x(3) * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * p3%t - p2%t * p3%x(3)) & + p1%x(3) * (p2%t * p3%x(2) - p2%x(2) * p3%t ) & + p1%t * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) & - p1%t * (p2%x(1) * p3%x(3) - p2%x(3) * p3%x(1)) & - p1%x(1) * (p2%x(3) * p3%t - p2%t * p3%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) & + p1%x(1) * (p2%x(2) * p3%t - p2%t * p3%x(2)) & + p1%x(2) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) end function pseudo_vector_momentum @ <>= pure function pseudo_vector_vector (p1, p2, p3) result (eps123) type(vector), intent(in) :: p1, p2, p3 type(vector) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) & + p1%x(2) * (p2%x(3) * p3%x(1) - p2%x(1) * p3%x(3)) & + p1%x(3) * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * p3%t - p2%t * p3%x(3)) & + p1%x(3) * (p2%t * p3%x(2) - p2%x(2) * p3%t ) & + p1%t * (p2%x(2) * p3%x(3) - p2%x(3) * p3%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) & - p1%t * (p2%x(1) * p3%x(3) - p2%x(3) * p3%x(1)) & - p1%x(1) * (p2%x(3) * p3%t - p2%t * p3%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * p3%x(2) - p2%x(2) * p3%x(1)) & + p1%x(1) * (p2%x(2) * p3%t - p2%t * p3%x(2)) & + p1%x(2) * (p2%t * p3%x(1) - p2%x(1) * p3%t ) end function pseudo_vector_vector @ <>= pure function pseudo_vector_vec_mom (p1, p2, v) result (eps123) type(momentum), intent(in) :: p1, p2 type(vector), intent(in) :: v type(vector) :: eps123 eps123%t = & + p1%x(1) * (p2%x(2) * v%x(3) - p2%x(3) * v%x(2)) & + p1%x(2) * (p2%x(3) * v%x(1) - p2%x(1) * v%x(3)) & + p1%x(3) * (p2%x(1) * v%x(2) - p2%x(2) * v%x(1)) eps123%x(1) = & + p1%x(2) * (p2%x(3) * v%t - p2%t * v%x(3)) & + p1%x(3) * (p2%t * v%x(2) - p2%x(2) * v%t ) & + p1%t * (p2%x(2) * v%x(3) - p2%x(3) * v%x(2)) eps123%x(2) = & - p1%x(3) * (p2%t * v%x(1) - p2%x(1) * v%t ) & - p1%t * (p2%x(1) * v%x(3) - p2%x(3) * v%x(1)) & - p1%x(1) * (p2%x(3) * v%t - p2%t * v%x(3)) eps123%x(3) = & + p1%t * (p2%x(1) * v%x(2) - p2%x(2) * v%x(1)) & + p1%x(1) * (p2%x(2) * v%t - p2%t * v%x(2)) & + p1%x(2) * (p2%t * v%x(1) - p2%x(1) * v%t ) end function pseudo_vector_vec_mom @ \subsection{Utilities} <>= @ <>= subroutine random_momentum (p, pabs, m) type(momentum), intent(out) :: p real(kind=default), intent(in) :: pabs, m real(kind=default), dimension(2) :: r real(kind=default) :: phi, cos_th call random_number (r) phi = 2*PI * r(1) cos_th = 2 * r(2) - 1 p%t = sqrt (pabs**2 + m**2) p%x = pabs * (/ cos_th * cos(phi), cos_th * sin(phi), sqrt (1 - cos_th**2) /) end subroutine random_momentum @ \section{Polarization vectors} <<[[omega_polarizations.f90]]>>= <> module omega_polarizations use kinds use constants use omega_vectors implicit none private <> integer, parameter, public :: omega_polarizations_2010_01_A = 0 contains <> end module omega_polarizations @ Here we use a phase convention for the polarization vectors compatible with the angular momentum coupling to spin 3/2 and spin 2. \begin{subequations} \begin{align} \epsilon^\mu_1(k) &= \frac{1}{|\vec k|\sqrt{k_x^2+k_y^2}} \left(0; k_z k_x, k_y k_z, - k_x^2 - k_y^2\right) \\ \epsilon^\mu_2(k) &= \frac{1}{\sqrt{k_x^2+k_y^2}} \left(0; -k_y, k_x, 0\right) \\ \epsilon^\mu_3(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} and \begin{subequations} \begin{align} \epsilon^\mu_\pm(k) &= \frac{1}{\sqrt{2}} (\epsilon^\mu_1(k) \pm \ii\epsilon^\mu_2(k) ) \\ \epsilon^\mu_0(k) &= \epsilon^\mu_3(k) \end{align} \end{subequations} i.\,e. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} - \ii k_y, \frac{k_yk_z}{|\vec k|} + \ii k_x, - \frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_-(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} + \ii k_y, \frac{k_yk_z}{|\vec k|} - \ii k_x, -\frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_0(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. <>= public :: eps @ <>= pure function eps (m, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kt, kabs, kabs2, sqrt2 sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) e%t = 0 e%x = 0 if (kabs2 > 0) then kabs = sqrt (kabs2) select case (s) case (1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 else e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & - k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (-1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( -1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (3) e = (0,1) * k case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction select case (s) case (1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ \section{Polarization vectors revisited} <<[[omega_polarizations_madgraph.f90]]>>= <> module omega_polarizations_madgraph use kinds use constants use omega_vectors implicit none private <> integer, parameter, public :: omega_pols_madgraph_2010_01_A = 0 contains <> end module omega_polarizations_madgraph @ This set of polarization vectors is compatible with HELAS~\cite{HELAS}: \begin{subequations} \begin{align} \epsilon^\mu_1(k) &= \frac{1}{|\vec k|\sqrt{k_x^2+k_y^2}} \left(0; k_z k_x, k_y k_z, - k_x^2 - k_y^2\right) \\ \epsilon^\mu_2(k) &= \frac{1}{\sqrt{k_x^2+k_y^2}} \left(0; -k_y, k_x, 0\right) \\ \epsilon^\mu_3(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} and \begin{subequations} \begin{align} \epsilon^\mu_\pm(k) &= \frac{1}{\sqrt{2}} (\mp \epsilon^\mu_1(k) - \ii\epsilon^\mu_2(k) ) \\ \epsilon^\mu_0(k) &= \epsilon^\mu_3(k) \end{align} \end{subequations} i.\,e. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; -\frac{k_zk_x}{|\vec k|} + \ii k_y, -\frac{k_yk_z}{|\vec k|} - \ii k_x, \frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_-(k) &= \frac{1}{\sqrt{2}\sqrt{k_x^2+k_y^2}} \left(0; \frac{k_zk_x}{|\vec k|} + \ii k_y, \frac{k_yk_z}{|\vec k|} - \ii k_x, -\frac{k_x^2+k_y^2}{|\vec k|}\right) \\ \epsilon^\mu_0(k) &= \frac{k_0}{m|\vec k|} \left({\vec k}^2/k_0; k_x, k_y, k_z\right) \end{align} \end{subequations} Fortunately, for comparing with squared matrix generated by Madgraph we can also use the modified version, since the difference is only a phase and does \emph{not} mix helicity states. @ Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. <>= public :: eps @ <>= pure function eps (m, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kt, kabs, kabs2, sqrt2 sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) e%t = 0 e%x = 0 if (kabs2 > 0) then kabs = sqrt (kabs2) select case (s) case (1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( - k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( - k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = kt / kabs / sqrt2 end if case (-1) kt = sqrt (k%x(1)**2 + k%x(2)**2) if (abs(kt) <= epsilon(kt) * kabs) then if (k%x(3) > 0) then e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 else e%x(1) = cmplx ( -1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 end if else e%x(1) = cmplx ( k%x(3)*k%x(1)/kabs, & k%x(2), kind=default) / kt / sqrt2 e%x(2) = cmplx ( k%x(2)*k%x(3)/kabs, & - k%x(1), kind=default) / kt / sqrt2 e%x(3) = - kt / kabs / sqrt2 end if case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (3) e = (0,1) * k case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction select case (s) case (1) e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, - 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ \section{Symmetric Tensors} Spin-2 polarization tensors are symmetric, transversal and traceless \begin{subequations} \begin{align} \epsilon^{\mu\nu}_{m}(k) &= \epsilon^{\nu\mu}_{m}(k) \\ k_\mu \epsilon^{\mu\nu}_{m}(k) &= k_\nu \epsilon^{\mu\nu}_{m}(k) = 0 \\ \epsilon^{\mu}_{m,\mu}(k) &= 0 \end{align} \end{subequations} with $m=1,2,3,4,5$. Our current representation is redundant and does \emph{not} enforce symmetry or tracelessness. <<[[omega_tensors.f90]]>>= <> module omega_tensors use kinds use constants use omega_vectors implicit none private public :: operator (*), operator (+), operator (-), & operator (.tprod.) public :: abs, conjg, set_zero <<[[intrinsic :: abs]]>> <<[[intrinsic :: conjg]]>> type, public :: tensor ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(0:3,0:3) :: t end type tensor <> integer, parameter, public :: omega_tensors_2010_01_A = 0 contains <> end module omega_tensors @ \subsection{Vector Space} <>= interface set_zero module procedure set_zero_tensor end interface private :: set_zero_tensor @ <>= elemental subroutine set_zero_tensor (x) type(tensor), intent(out) :: x x%t = 0 end subroutine set_zero_tensor @ \subsubsection{Scalar Multliplication} <>= interface operator (*) module procedure integer_tensor, real_tensor, double_tensor, & complex_tensor, dcomplex_tensor end interface private :: integer_tensor, real_tensor, double_tensor private :: complex_tensor, dcomplex_tensor @ <>= pure function integer_tensor (x, y) result (xy) integer, intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function integer_tensor pure function real_tensor (x, y) result (xy) real(kind=single), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function real_tensor pure function double_tensor (x, y) result (xy) real(kind=default), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function double_tensor pure function complex_tensor (x, y) result (xy) complex(kind=single), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function complex_tensor pure function dcomplex_tensor (x, y) result (xy) complex(kind=default), intent(in) :: x type(tensor), intent(in) :: y type(tensor) :: xy xy%t = x * y%t end function dcomplex_tensor @ \subsubsection{Addition and Subtraction} <>= interface operator (+) module procedure plus_tensor end interface private :: plus_tensor interface operator (-) module procedure neg_tensor end interface private :: neg_tensor @ <>= pure function plus_tensor (t1) result (t2) type(tensor), intent(in) :: t1 type(tensor) :: t2 t2 = t1 end function plus_tensor pure function neg_tensor (t1) result (t2) type(tensor), intent(in) :: t1 type(tensor) :: t2 t2%t = - t1%t end function neg_tensor @ <>= interface operator (+) module procedure add_tensor end interface private :: add_tensor interface operator (-) module procedure sub_tensor end interface private :: sub_tensor @ <>= pure function add_tensor (x, y) result (xy) type(tensor), intent(in) :: x, y type(tensor) :: xy xy%t = x%t + y%t end function add_tensor pure function sub_tensor (x, y) result (xy) type(tensor), intent(in) :: x, y type(tensor) :: xy xy%t = x%t - y%t end function sub_tensor @ <>= interface operator (.tprod.) module procedure out_prod_vv, out_prod_vm, & out_prod_mv, out_prod_mm end interface private :: out_prod_vv, out_prod_vm, & out_prod_mv, out_prod_mm @ <>= pure function out_prod_vv (v, w) result (t) type(tensor) :: t type(vector), intent(in) :: v, w integer :: i, j t%t(0,0) = v%t * w%t t%t(0,1:3) = v%t * w%x t%t(1:3,0) = v%x * w%t do i = 1, 3 do j = 1, 3 t%t(i,j) = v%x(i) * w%x(j) end do end do end function out_prod_vv @ <>= pure function out_prod_vm (v, m) result (t) type(tensor) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: m integer :: i, j t%t(0,0) = v%t * m%t t%t(0,1:3) = v%t * m%x t%t(1:3,0) = v%x * m%t do i = 1, 3 do j = 1, 3 t%t(i,j) = v%x(i) * m%x(j) end do end do end function out_prod_vm @ <>= pure function out_prod_mv (m, v) result (t) type(tensor) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: m integer :: i, j t%t(0,0) = m%t * v%t t%t(0,1:3) = m%t * v%x t%t(1:3,0) = m%x * v%t do i = 1, 3 do j = 1, 3 t%t(i,j) = m%x(i) * v%x(j) end do end do end function out_prod_mv @ <>= pure function out_prod_mm (m, n) result (t) type(tensor) :: t type(momentum), intent(in) :: m, n integer :: i, j t%t(0,0) = m%t * n%t t%t(0,1:3) = m%t * n%x t%t(1:3,0) = m%x * n%t do i = 1, 3 do j = 1, 3 t%t(i,j) = m%x(i) * n%x(j) end do end do end function out_prod_mm @ <>= interface abs module procedure abs_tensor end interface private :: abs_tensor @ <>= pure function abs_tensor (t) result (abs_t) type(tensor), intent(in) :: t real(kind=default) :: abs_t abs_t = sqrt (sum ((abs (t%t))**2)) end function abs_tensor @ <>= interface conjg module procedure conjg_tensor end interface private :: conjg_tensor @ <>= pure function conjg_tensor (t) result (conjg_t) type(tensor), intent(in) :: t type(tensor) :: conjg_t conjg_t%t = conjg (t%t) end function conjg_tensor @ <>= interface operator (*) module procedure tensor_tensor, vector_tensor, tensor_vector, & momentum_tensor, tensor_momentum end interface private :: tensor_tensor, vector_tensor, tensor_vector, & momentum_tensor, tensor_momentum @ <>= pure function tensor_tensor (t1, t2) result (t1t2) type(tensor), intent(in) :: t1 type(tensor), intent(in) :: t2 complex(kind=default) :: t1t2 integer :: i1, i2 t1t2 = t1%t(0,0)*t2%t(0,0) & - dot_product (conjg (t1%t(0,1:)), t2%t(0,1:)) & - dot_product (conjg (t1%t(1:,0)), t2%t(1:,0)) do i1 = 1, 3 do i2 = 1, 3 t1t2 = t1t2 + t1%t(i1,i2)*t2%t(i1,i2) end do end do end function tensor_tensor @ <>= pure function tensor_vector (t, v) result (tv) type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv tv%t = t%t(0,0) * v%t - dot_product (conjg (t%t(0,1:)), v%x) tv%x(1) = t%t(0,1) * v%t - dot_product (conjg (t%t(1,1:)), v%x) tv%x(2) = t%t(0,2) * v%t - dot_product (conjg (t%t(2,1:)), v%x) tv%x(3) = t%t(0,3) * v%t - dot_product (conjg (t%t(3,1:)), v%x) end function tensor_vector @ <>= pure function vector_tensor (v, t) result (vt) type(vector), intent(in) :: v type(tensor), intent(in) :: t type(vector) :: vt vt%t = v%t * t%t(0,0) - dot_product (conjg (v%x), t%t(1:,0)) vt%x(1) = v%t * t%t(0,1) - dot_product (conjg (v%x), t%t(1:,1)) vt%x(2) = v%t * t%t(0,2) - dot_product (conjg (v%x), t%t(1:,2)) vt%x(3) = v%t * t%t(0,3) - dot_product (conjg (v%x), t%t(1:,3)) end function vector_tensor @ <>= pure function tensor_momentum (t, p) result (tp) type(tensor), intent(in) :: t type(momentum), intent(in) :: p type(vector) :: tp tp%t = t%t(0,0) * p%t - dot_product (conjg (t%t(0,1:)), p%x) tp%x(1) = t%t(0,1) * p%t - dot_product (conjg (t%t(1,1:)), p%x) tp%x(2) = t%t(0,2) * p%t - dot_product (conjg (t%t(2,1:)), p%x) tp%x(3) = t%t(0,3) * p%t - dot_product (conjg (t%t(3,1:)), p%x) end function tensor_momentum @ <>= pure function momentum_tensor (p, t) result (pt) type(momentum), intent(in) :: p type(tensor), intent(in) :: t type(vector) :: pt pt%t = p%t * t%t(0,0) - dot_product (p%x, t%t(1:,0)) pt%x(1) = p%t * t%t(0,1) - dot_product (p%x, t%t(1:,1)) pt%x(2) = p%t * t%t(0,2) - dot_product (p%x, t%t(1:,2)) pt%x(3) = p%t * t%t(0,3) - dot_product (p%x, t%t(1:,3)) end function momentum_tensor @ \section{Symmetric Polarization Tensors} \begin{subequations} \begin{align} \epsilon^{\mu\nu}_{+2}(k) &= \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{+}(k) \\ \epsilon^{\mu\nu}_{+1}(k) &= \frac{1}{\sqrt{2}} \left( \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{0}(k) + \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{+}(k) \right) \\ \epsilon^{\mu\nu}_{0}(k) &= \frac{1}{\sqrt{6}} \left( \epsilon^{\mu}_{+}(k)\epsilon^{\nu}_{-}(k) + \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{+}(k) - 2 \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{0}(k) \right) \\ \epsilon^{\mu\nu}_{-1}(k) &= \frac{1}{\sqrt{2}} \left( \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{0}(k) + \epsilon^{\mu}_{0}(k)\epsilon^{\nu}_{-}(k) \right) \\ \epsilon^{\mu\nu}_{-2}(k) &= \epsilon^{\mu}_{-}(k)\epsilon^{\nu}_{-}(k) \end{align} \end{subequations} Note that~$\epsilon^{\mu}_{\pm2,\mu}(k) = \epsilon^{\mu}_{\pm}(k)\epsilon_{\pm,\mu}(k) \propto \epsilon^{\mu}_{\pm}(k)\epsilon_{\mp,\mu}^{*}(k) = 0$ and that the sign in $\epsilon^{\mu\nu}_{0}(k)$ insures its tracelessness\footnote{ On the other hand, with the shift operator $L_{-}\ket{+}=\ee^{\ii\phi}\ket{0}$ and $L_{-}\ket{0}=\ee^{\ii\chi}\ket{-}$, we find \begin{equation*} L_{-}^{2}\ket{++} = 2\ee^{2\ii\phi}\ket{00} + \ee^{\ii(\phi+\chi)}(\ket{+-}+\ket{-+}) \end{equation*} i.\,e.~$\chi-\phi=\pi$, if we want to identify $\epsilon^{\mu}_{-,0,+}$ with $\ket{-,0,+}$.}. <<[[omega_tensor_polarizations.f90]]>>= <> module omega_tensor_polarizations use kinds use constants use omega_vectors use omega_tensors use omega_polarizations implicit none private <> integer, parameter, public :: omega_tensor_pols_2010_01_A = 0 contains <> end module omega_tensor_polarizations @ <>= public :: eps2 @ <>= pure function eps2 (m, k, s) result (t) type(tensor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s type(vector) :: ep, em, e0 t%t = 0 select case (s) case (2) ep = eps (m, k, 1) t = ep.tprod.ep case (1) ep = eps (m, k, 1) e0 = eps (m, k, 0) t = (1 / sqrt (2.0_default)) & * ((ep.tprod.e0) + (e0.tprod.ep)) case (0) ep = eps (m, k, 1) e0 = eps (m, k, 0) em = eps (m, k, -1) t = (1 / sqrt (6.0_default)) & * ((ep.tprod.em) + (em.tprod.ep) - 2*(e0.tprod.e0)) case (-1) e0 = eps (m, k, 0) em = eps (m, k, -1) t = (1 / sqrt (2.0_default)) & * ((em.tprod.e0) + (e0.tprod.em)) case (-2) em = eps (m, k, -1) t = em.tprod.em end select end function eps2 @ \section{Couplings} <<[[omega_couplings.f90]]>>= <> module omega_couplings use kinds use constants use omega_vectors use omega_tensors implicit none private <> <> integer, parameter, public :: omega_couplings_2010_01_A = 0 contains <> <> end module omega_couplings @ <>= public :: wd_tl @ <>= public :: wd_run @ <>= public :: gauss @ \begin{equation} \Theta(p^2)\Gamma \end{equation} <>= pure function wd_tl (p, w) result (width) real(kind=default) :: width type(momentum), intent(in) :: p real(kind=default), intent(in) :: w if (p*p > 0) then width = w else width = 0 end if end function wd_tl @ \begin{equation} \frac{p^2}{m^2} \Gamma \end{equation} <>= pure function wd_run (p, m, w) result (width) real(kind=default) :: width type(momentum), intent(in) :: p real(kind=default), intent(in) :: m real(kind=default), intent(in) :: w if (p*p > 0) then width = w * (p*p) / m**2 else width = 0 end if end function wd_run @ <>= pure function gauss (x, mu, w) result (gg) real(kind=default) :: gg real(kind=default), intent(in) :: x, mu, w if (w > 0) then gg = exp(-(x - mu**2)**2/4.0_default/mu**2/w**2) * & sqrt(sqrt(PI/2)) / w / mu else gg = 1.0_default end if end function gauss @ <>= public :: pr_phi, pr_unitarity, pr_feynman, pr_gauge, pr_rxi public :: pr_vector_pure public :: pj_phi, pj_unitarity public :: pg_phi, pg_unitarity @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma}\phi \end{equation} <>= pure function pr_phi (p, m, w, phi) result (pphi) complex(kind=default) :: pphi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = (1 / cmplx (p*p - m**2, m*w, kind=default)) * phi end function pr_phi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \phi \end{equation} <>= pure function pj_phi (m, w, phi) result (pphi) complex(kind=default) :: pphi real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = (0, -1) * sqrt (PI / m / w) * phi end function pj_phi @ <>= pure function pg_phi (p, m, w, phi) result (pphi) complex(kind=default) :: pphi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w complex(kind=default), intent(in) :: phi pphi = ((0, 1) * gauss (p*p, m, w)) * phi end function pg_phi @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} + \frac{p_\mu p_\nu}{m^2} \right) \epsilon^\nu(p) \end{equation} NB: the explicit cast to [[vector]] is required here, because a specific [[complex_momentum]] procedure for [[operator (*)]] would introduce ambiguities. NB: we used to use the constructor [[vector (p%t, p%x)]] instead of the temporary variable, but the Intel Fortran Compiler choked on it. <>= pure function pr_unitarity (p, m, w, cms, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e logical, intent(in) :: cms type(vector) :: pv complex(kind=default) :: c_mass2 pv = p if (cms) then c_mass2 = cmplx (m**2, -m*w, kind=default) else c_mass2 = m**2 end if pe = - (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (e - (p*e / c_mass2) * pv) end function pr_unitarity @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \left( -g_{\mu\nu} + \frac{p_\mu p_\nu}{m^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pj_unitarity (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e type(vector) :: pv pv = p pe = (0, 1) * sqrt (PI / m / w) * (e - (p*e / m**2) * pv) end function pj_unitarity @ <>= pure function pg_unitarity (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e type(vector) :: pv pv = p pe = - gauss (p*p, m, w) & * (e - (p*e / m**2) * pv) end function pg_unitarity @ \begin{equation} \frac{-i}{p^2} \epsilon^\nu(p) \end{equation} <>= pure function pr_feynman (p, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p type(vector), intent(in) :: e pe = - (1 / (p*p)) * e end function pr_feynman @ \begin{equation} \frac{\ii}{p^2} \left( -g_{\mu\nu} + (1-\xi)\frac{p_\mu p_\nu}{p^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_gauge (p, xi, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: xi type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / p2) * (e - ((1 - xi) * (p*e) / p2) * pv) end function pr_gauge @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} + (1-\xi)\frac{p_\mu p_\nu}{p^2-\xi m^2} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_rxi (p, m, w, xi, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w, xi type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / cmplx (p2 - m**2, m*w, kind=default)) & * (e - ((1 - xi) * (p*e) / (p2 - xi * m**2)) * pv) end function pr_rxi @ \begin{equation} \frac{\ii}{p^2-m^2+\ii m\Gamma} \left( -g_{\mu\nu} \right) \epsilon^\nu(p) \end{equation} <>= pure function pr_vector_pure (p, m, w, e) result (pe) type(vector) :: pe type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vector), intent(in) :: e real(kind=default) :: p2 type(vector) :: pv p2 = p*p pv = p pe = - (1 / cmplx (p2 - m**2, m*w, kind=default)) * e end function pr_vector_pure @ <>= public :: pr_tensor, pr_tensor_pure @ \begin{subequations} \begin{equation} \frac{\ii P^{\mu\nu,\rho\sigma}(p,m)}{p^2-m^2+\ii m\Gamma} T_{\rho\sigma} \end{equation} with \begin{multline} P^{\mu\nu,\rho\sigma}(p,m) = \frac{1}{2} \left(g^{\mu\rho}-\frac{p^{\mu}p^{\nu}}{m^2}\right) \left(g^{\nu\sigma}-\frac{p^{\nu}p^{\sigma}}{m^2}\right) + \frac{1}{2} \left(g^{\mu\sigma}-\frac{p^{\mu}p^{\sigma}}{m^2}\right) \left(g^{\nu\rho}-\frac{p^{\nu}p^{\rho}}{m^2}\right) \\ - \frac{1}{3} \left(g^{\mu\nu}-\frac{p^{\mu}p^{\nu}}{m^2}\right) \left(g^{\rho\sigma}-\frac{p^{\rho}p^{\sigma}}{m^2}\right) \end{multline} \end{subequations} Be careful with raising and lowering of indices: \begin{subequations} \begin{align} g^{\mu\nu}-\frac{k^{\mu}k^{\nu}}{m^2} &= \begin{pmatrix} 1 - k^0k^0 / m^2 & - k^0 \vec k / m^2 \\ - \vec k k^0 / m^2 & - \mathbf{1} - \vec k \otimes \vec k / m^2 \end{pmatrix} \\ g^{\mu}_{\hphantom{\mu}\nu}-\frac{k^{\mu}k_{\nu}}{m^2} &= \begin{pmatrix} 1 - k^0k^0 / m^2 & k^0 \vec k / m^2 \\ - \vec k k^0 / m^2 & \mathbf{1} + \vec k \otimes \vec k / m^2 \end{pmatrix} \end{align} \end{subequations} <>= pure function pr_tensor (p, m, w, t) result (pt) type(tensor) :: pt type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(tensor), intent(in) :: t complex(kind=default) :: p_dd_t real(kind=default), dimension(0:3,0:3) :: p_uu, p_ud, p_du, p_dd integer :: i, j p_uu(0,0) = 1 - p%t * p%t / m**2 p_uu(0,1:3) = - p%t * p%x / m**2 p_uu(1:3,0) = p_uu(0,1:3) do i = 1, 3 do j = 1, 3 p_uu(i,j) = - p%x(i) * p%x(j) / m**2 end do end do do i = 1, 3 p_uu(i,i) = - 1 + p_uu(i,i) end do p_ud(:,0) = p_uu(:,0) p_ud(:,1:3) = - p_uu(:,1:3) p_du = transpose (p_ud) p_dd(:,0) = p_du(:,0) p_dd(:,1:3) = - p_du(:,1:3) p_dd_t = 0 do i = 0, 3 do j = 0, 3 p_dd_t = p_dd_t + p_dd(i,j) * t%t(i,j) end do end do pt%t = matmul (p_ud, matmul (0.5_default * (t%t + transpose (t%t)), p_du)) & - (p_dd_t / 3.0_default) * p_uu pt%t = pt%t / cmplx (p*p - m**2, m*w, kind=default) end function pr_tensor @ \begin{subequations} \begin{equation} \frac{\ii P_p^{\mu\nu,\rho\sigma}}{p^2-m^2+\ii m\Gamma} T_{\rho\sigma} \end{equation} with \begin{multline} P_p^{\mu\nu,\rho\sigma} = \frac{1}{2} g^{\mu\rho} g^{\nu\sigma} + \frac{1}{2} g^{\mu\sigma} g^{\nu\rho} - \frac{1}{2} g^{\mu\nu}g^{\rho\sigma} \end{multline} \end{subequations} <>= pure function pr_tensor_pure (p, m, w, t) result (pt) type(tensor) :: pt type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(tensor), intent(in) :: t complex(kind=default) :: p_dd_t real(kind=default), dimension(0:3,0:3) :: g_uu integer :: i, j g_uu(0,0) = 1 g_uu(0,1:3) = 0 g_uu(1:3,0) = g_uu(0,1:3) do i = 1, 3 do j = 1, 3 g_uu(i,j) = 0 end do end do do i = 1, 3 g_uu(i,i) = - 1 end do p_dd_t = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) pt%t = 0.5_default * ((t%t + transpose (t%t)) & - p_dd_t * g_uu ) pt%t = pt%t / cmplx (p*p - m**2, m*w, kind=default) end function pr_tensor_pure @ \subsection{Triple Gauge Couplings} <>= public :: g_gg @ According to~(\ref{eq:fuse-gauge}) \begin{multline} A^{a,\mu}(k_1+k_2) = - \ii g \bigl( (k_1^{\mu}-k_2^{\mu})A^{a_1}(k_1) \cdot A^{a_2}(k_2) \\ + (2k_2+k_1)\cdot A^{a_1}(k_1)A^{a_2,\mu}(k_2) - A^{a_1,\mu}(k_1)A^{a_2}(k_2)\cdot(2k_1+k_2) \bigr) \end{multline} <>= pure function g_gg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a a = (0, -1) * g * ((k1 - k2) * (a1 * a2) & + ((2*k2 + k1) * a1) * a2 - a1 * ((2*k1 + k2) * a2)) end function g_gg @ \subsection{Quadruple Gauge Couplings} <>= public :: x_gg, g_gx @ \begin{equation} T^{a,\mu\nu}(k_1+k_2) = g \bigl( A^{a_1,\mu}(k_1) A^{a_2,\nu}(k_2) - A^{a_1,\nu}(k_1) A^{a_2,\mu}(k_2) \bigr) \end{equation} <>= pure function x_gg (g, a1, a2) result (x) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(tensor2odd) :: x x = g * (a1 .wedge. a2) end function x_gg @ \begin{equation} A^{a,\mu}(k_1+k_2) = g A^{a_1}_\nu(k_1) T^{a_2,\nu\mu}(k_2) \end{equation} <>= pure function g_gx (g, a1, x) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1 type(tensor2odd), intent(in) :: x type(vector) :: a a = g * (a1 * x) end function g_gx @ \subsection{Scalar Current} <>= public :: v_ss, s_vs @ \begin{equation} V^\mu(k_1+k_2) = g(k_1^\mu - k_2^\mu)\phi_1(k_1)\phi_2(k_2) \end{equation} <>= pure function v_ss (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 - k2) * (g * phi1 * phi2) end function v_ss @ \begin{equation} \phi(k_1+k_2) = g(k_1^\mu + 2k_2^\mu)V_\mu(k_1)\phi(k_2) \end{equation} <>= pure function s_vs (g, v1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ((k1 + 2*k2) * v1) * phi2 end function s_vs @ \subsection{Transversal Scalar-Vector Coupling} <>= public :: s_vv_t, v_sv_t @ \begin{equation} phi(k_1+k_2) = g((V_1(k_1) V_2(k_2))(k_1 k_2) - (V_1(k_1) k_2)(V_2(k_2) k_1)) \end{equation} <>= pure function s_vv_t (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ((v1*v2) * (k1*k2) - (v1*k2) * (v2*k1)) end function s_vv_t @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi(((k_\phi+k_V)k_V)V_2^\mu- (k_\phi+k_V)V_2)k_V^\mu ) \end{equation} <>= pure function v_sv_t (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = g * phi * ((kout*kv) * v - (v * kout) * kv) end function v_sv_t @ \subsection{Transversal TensorScalar-Vector Coupling} <>= public :: tphi_vv, tphi_vv_cf, v_tphiv, v_tphiv_cf @ \begin{equation} phi(k_1 + k_2) = g (V_1(k_1) (k_1 +k_2)) * ( V_2(k_2) (k_1 + k_2)) \end{equation} <>= pure function tphi_vv (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi type(momentum) :: k k = - (k1 + k2) phi = 2 * g * (v1*k) * (v2*k) end function tphi_vv @ \begin{equation} phi(k_1+k_2) = g((V_1(k_1) V_2(k_2))(k_1 + k_2)^2) \end{equation} <>= pure function tphi_vv_cf (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi type(momentum) :: k k = - (k1 + k2) phi = - g/2 * (v1*v2) * (k*k) end function tphi_vv_cf @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi ((k_\phi+k_V)V_2) (k_\phi+k_V)^\mu \end{equation} <>= pure function v_tphiv (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = 2 * g * phi * ((v * kout) * kout) end function v_tphiv @ \begin{equation} V_1^\mu(k_\phi+k_V) = g phi((k_\phi+k_V)(k_\phi+k_V))V_2^\mu \end{equation} <>= pure function v_tphiv_cf (g, phi, kphi,v, kv) result (vout) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: kv, kphi type(momentum) :: kout type(vector) :: vout kout = - (kv + kphi) vout = -g/2 * phi * (kout*kout) * v end function v_tphiv_cf @ \subsection{Triple Vector Couplings} <>= public :: tkv_vv, lkv_vv, tv_kvv, lv_kvv, kg_kgkg public :: t5kv_vv, l5kv_vv, t5v_kvv, l5v_kvv, kg5_kgkg, kg_kg5kg public :: dv_vv, v_dvv, dv_vv_cf, v_dvv_cf @ \begin{equation} V^\mu(k_1+k_2) = \ii g(k_1-k_2)^\mu V_1^\nu(k_1)V_{2,\nu}(k_2) \end{equation} <>= pure function tkv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 - k2) * ((0, 1) * g * (v1*v2)) end function tkv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (k_1-k_2)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function t5kv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 - k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function t5kv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g(k_1+k_2)^\mu V_1^\nu(k_1)V_{2,\nu}(k_2) \end{equation} <>= pure function lkv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = (k1 + k2) * ((0, 1) * g * (v1*v2)) end function lkv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (k_1+k_2)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function l5kv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 + k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function l5kv_vv @ \begin{equation} V^\mu(k_1+k_2) = \ii g (k_2-k)^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) = \ii g (2k_2+k_1)^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) \end{equation} using $k=-k_1-k_2$ <>= pure function tv_kvv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = v2 * ((0, 1) * g * ((2*k2 + k1)*v1)) end function tv_kvv @ \begin{equation} V^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} (2k_2+k_1)_{\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function t5v_kvv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = k1 + 2*k2 v = (0, 1) * g * pseudo_vector (k, v1, v2) end function t5v_kvv @ \begin{equation} V^\mu(k_1+k_2) = - \ii g k_1^\nu V_{1,\nu}(k_1)V_2^\mu(k_2) \end{equation} using $k=-k_1-k_2$ <>= pure function lv_kvv (g, v1, k1, v2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1 type(vector) :: v v = v2 * ((0, -1) * g * (k1*v1)) end function lv_kvv @ \begin{equation} V^\mu(k_1+k_2) = - \ii g \epsilon^{\mu\nu\rho\sigma} k_{1,\nu} V_{1,\rho}(k_1)V_{2,\sigma}(k_2) \end{equation} <>= pure function l5v_kvv (g, v1, k1, v2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1 type(vector) :: v type(vector) :: k k = k1 v = (0, -1) * g * pseudo_vector (k, v1, v2) end function l5v_kvv @ \begin{equation} A^\mu(k_1+k_2) = \ii g k^\nu \Bigl( F_{1,\nu}^{\hphantom{1,\nu}\rho}(k_1)F_{2,\rho\mu}(k_2) - F_{1,\mu}^{\hphantom{1,\mu}\rho}(k_1)F_{2,\rho\nu}(k_2) \Bigr) \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -\ii g \Bigl( [(kk_2)(k_1A_2) - (k_1k_2)(kA_2)] A_1^\mu \\ + [(k_1k_2)(kA_1) - (kk_1)(k_2A_1)] A_2^\mu \\ + [(k_2A_1)(kA_2) - (kk_2)(A_1A_2)] k_1^\mu \\ + [(kk_1)(A_1A_2) - (kA_1)(k_1A_2)] k_2^\mu \Bigr) \end{multline} <>= pure function kg_kgkg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a real(kind=default) :: k1k1, k2k2, k1k2, kk1, kk2 complex(kind=default) :: a1a2, k2a1, ka1, k1a2, ka2 k1k1 = k1 * k1 k1k2 = k1 * k2 k2k2 = k2 * k2 kk1 = k1k1 + k1k2 kk2 = k1k2 + k2k2 k2a1 = k2 * a1 ka1 = k2a1 + k1 * a1 k1a2 = k1 * a2 ka2 = k1a2 + k2 * a2 a1a2 = a1 * a2 a = (0, -1) * g * ( (kk2 * k1a2 - k1k2 * ka2 ) * a1 & + (k1k2 * ka1 - kk1 * k2a1) * a2 & + (ka2 * k2a1 - kk2 * a1a2) * k1 & + (kk1 * a1a2 - ka1 * k1a2) * k2 ) end function kg_kgkg @ \begin{equation} A^\mu(k_1+k_2) = \ii g \epsilon^{\mu\nu\rho\sigma} k_{\nu} F_{1,\rho}^{\hphantom{1,\rho}\lambda}(k_1)F_{2,\lambda\sigma}(k_2) \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -2\ii g \epsilon^{\mu\nu\rho\sigma} k_{\nu} \Bigl( (k_2A_1) k_{1,\rho} A_{2,\sigma} + (k_1A_2) A_{1,\rho} k_{2,\sigma} \\ - (A_1A_2) k_{1,\rho} k_{2,\sigma} - (k_1k_2) A_{1,\rho} A_{2,\sigma} \Bigr) \end{multline} <>= pure function kg5_kgkg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a type(vector) :: kv, k1v, k2v kv = - k1 - k2 k1v = k1 k2v = k2 a = (0, -2) * g * ( (k2*A1) * pseudo_vector (kv, k1v, a2 ) & + (k1*A2) * pseudo_vector (kv, A1 , k2v) & - (A1*A2) * pseudo_vector (kv, k1v, k2v) & - (k1*k2) * pseudo_vector (kv, a1 , a2 ) ) end function kg5_kgkg @ \begin{equation} A^\mu(k_1+k_2) = \ii g k_{\nu} \Bigl( \epsilon^{\mu\rho\lambda\sigma} F_{1,\hphantom{\nu}\rho}^{\hphantom{1,}\nu} - \epsilon^{\nu\rho\lambda\sigma} F_{1,\hphantom{\mu}\rho}^{\hphantom{1,}\mu} \Bigr) \frac{1}{2} F_{1,\lambda\sigma} \end{equation} with $k=-k_1-k_2$, i.\,e. \begin{multline} A^\mu(k_1+k_2) = -\ii g \Bigl( \epsilon^{\mu\rho\lambda\sigma} (kk_2) A_{2,\rho} - \epsilon^{\mu\rho\lambda\sigma} (kA_2) k_{2,\rho} - k_2^\mu \epsilon^{\nu\rho\lambda\sigma} k_nu A_{2,\rho} + A_2^\mu \epsilon^{\nu\rho\lambda\sigma} k_nu k_{2,\rho} \Bigr) k_{1,\lambda} A_{1,\sigma} \end{multline} \begin{dubious} This is not the most efficienct way of doing it: $\epsilon^{\mu\nu\rho\sigma}F_{1,\rho\sigma}$ should be cached! \end{dubious} <>= pure function kg_kg5kg (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a type(vector) :: kv, k1v, k2v kv = - k1 - k2 k1v = k1 k2v = k2 a = (0, -1) * g * ( (kv*k2v) * pseudo_vector (a2 , k1v, a1) & - (kv*a2 ) * pseudo_vector (k2v, k1v, a1) & - k2v * pseudo_scalar (kv, a2, k1v, a1) & + a2 * pseudo_scalar (kv, k2v, k1v, a1) ) end function kg_kg5kg @ \begin{equation} V^\mu(k_1+k_2) = - g ((k_1+k_2) V_{1}) V_{2}^\mu + ((k_1+k_2) V_{2}) V_{1}^\mu \end{equation} <>= pure function dv_vv (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = -(k1 + k2) v = g * ((k * v1) * v2 + (k * v2) * v1) end function dv_vv @ \begin{equation} V^\mu(k_1+k_2) = \frac{g}{2} ( V_{1} (k_{1}) V_{2} (k_{2}) ) (k_{1}+k_{2})^\mu \end{equation} <>= pure function dv_vv_cf (g, v1, k1, v2, k2) result (v) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: v type(vector) :: k k = -(k1 + k2) v = - g/2 * (v1 * v2) * k end function dv_vv_cf @ \begin{equation} V_{1}^\mu = g * ( k V_{2}) V (k) + ( V V_{2}) k \end{equation} <>= pure function v_dvv (g, v, k, v2) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v, v2 type(momentum), intent(in) :: k type(vector) :: v1 v1 = g * ((v * v2) * k + (k * v2) * v) end function v_dvv @ \begin{equation} V_{1}^\mu = -\frac{g}{2} ( V (k) k ) V_{2}^\mu \end{equation} <>= pure function v_dvv_cf (g, v, k, v2) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v, v2 type(momentum), intent(in) :: k type(vector) :: v1 v1 = - g/2 * (v * k) * v2 end function v_dvv_cf @ \section{Tensorvector - Scalar coupling } <>= public :: dv_phi2,phi_dvphi, dv_phi2_cf, phi_dvphi_cf @ \begin{equation} V^\mu (k_1 + k_2 ) = g* ((k_1 k_2 + k_2 k_2) k_1^\mu + (k_1 k_2 + k_1 k_1) k_2^\mu ) * phi_1 (k_1) phi_2 (k_2) \end{equation} <>= pure function dv_phi2 (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = g * phi1 * phi2 * ( & (k1 * k2 + k2 * k2 ) * k1 + & (k1 * k2 + k1 * k1 ) * k2 ) end function dv_phi2 @ \begin{equation} V^\mu (k_1 + k_2 ) = - \frac{g}{2} * (k_1 k_2) * (k_1 + k_2 )^\mu * phi_1 (k_1) phi_2 (k_2) \end{equation} <>= pure function dv_phi2_cf (g, phi1, k1, phi2, k2) result (v) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector) :: v v = - g/2 * phi1 * phi2 * (k1 * k2) * (k1 + k2) end function dv_phi2_cf @ \begin{equation} phi_1 (k_1) = g * ((k_1 k_2 + k_2 k_2) (k_1 * V(-k_1 - k_2) ) + (k_1 k_2 + k_1 k_1) (k_2 * V(-k_1 - k_2) ) ) * phi_2 (k_2) \end{equation} <>= pure function phi_dvphi (g, v, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - (k + k2) phi1 = g * phi2 * ( & (k1 * k2 + k2 * k2 ) * ( k1 * V ) + & (k1 * k2 + k1 * k1 ) * ( k2 * V ) ) end function phi_dvphi @ \begin{equation} phi_1 (k_1 ) = - \frac{g}{2} * (k_1 k_2) * ((k_1 + k_2 ) V(- k_1 - k_2)) \end{equation} <>= pure function phi_dvphi_cf (g, v, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(vector), intent(in) :: v type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = -(k + k2) phi1 = - g/2 * phi2 * (k1 * k2) * ((k1 + k2) * v) end function phi_dvphi_cf @ \section{Scalar-Vector Dim-5 Couplings} <>= public :: phi_vv, v_phiv, phi_u_vv, v_u_phiv @ <>= pure function phi_vv (g, k1, k2, v1, v2) result (phi) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi phi = g * pseudo_scalar (k1, v1, k2, v2) end function phi_vv @ <>= pure function v_phiv (g, phi, k1, k2, v) result (w) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: k1, k2 type(vector) :: w w = g * phi * pseudo_vector (k1, k2, v) end function v_phiv @ <>= pure function phi_u_vv (g, k1, k2, v1, v2) result (phi) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi phi = g * ((k1*v2)*((-(k1+k2))*v1) + & (k2*v1)*((-(k1+k2))*v2) + & (((k1+k2)*(k1+k2)) * (v1*v2))) end function phi_u_vv @ <>= pure function v_u_phiv (g, phi, k1, k2, v) result (w) complex(kind=default), intent(in) :: g, phi type(vector), intent(in) :: v type(momentum), intent(in) :: k1, k2 type(vector) :: w w = g * phi * ((k1*v)*k2 + & ((-(k1+k2))*v)*k1 + & ((k1*k1)*v)) end function v_u_phiv @ \section{Dim-6 Anoumalous Couplings with Higgs} <>= public :: s_vv_6D, v_sv_6D, s_vv_6DP, v_sv_6DP, a_hz_D, h_az_D, z_ah_D, & a_hz_DP, h_az_DP, z_ah_DP, h_hh_6 <>= pure function s_vv_6D (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * (-(k1 * v1) * (k1 * v2) - (k2 * v1) * (k2 * v2) & + ((k1 * k1) + (k2 * k2)) * (v1 * v2)) end function s_vv_6D <>= pure function v_sv_6D (g, phi, kphi, v, kv) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vector), intent(in) :: v type(momentum), intent(in) :: kphi, kv type(vector) :: vout vout = g * ( - phi * (kv * v) * kv - phi * ((kphi + kv) * v) * (kphi + kv) & + phi * (kv * kv) * v + phi * ((kphi + kv)*(kphi + kv)) * v) end function v_sv_6D <>= pure function s_vv_6DP (g, v1, k1, v2, k2) result (phi) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = g * ( (-(k1+k2)*v1) * (k1*v2) - ((k1+k2)*v2) * (k2*v1) + & ((k1+k2)*(k1+k2))*(v1*v2) ) end function s_vv_6DP <>= pure function v_sv_6DP (g, phi, kphi, v, kv) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vector), intent(in) :: v type(momentum), intent(in) :: kphi, kv type(vector) :: vout vout = g * phi * ((-(kphi + kv)*v) * kphi + (kphi * v) * kv + & (kphi*kphi) * v ) end function v_sv_6DP <>= pure function a_hz_D (g, h1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h1 * (((k1 + k2) * v2) * (k1 + k2) + & ((k1 + k2) * (k1 + k2)) * v2) end function a_hz_D <>= pure function h_az_D (g, v1, k1, v2, k2) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * ((k1 * v1) * (k1 * v2) + (k1 * k1) * (v1 * v2)) end function h_az_D <>= pure function z_ah_D (g, v1, k1, h2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h2 * ((k1 * v1) * k1 + ((k1 * k1)) *v1) end function z_ah_D <>= pure function a_hz_DP (g, h1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ((- h1 * (k1 + k2) * v2) * (k1) & + h1 * ((k1 + k2) * (k1)) *v2) end function a_hz_DP <>= pure function h_az_DP (g, v1, k1, v2, k2) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * (- (k1 * v2) * ((k1 + k2) * v1) + (k1 * (k1 + k2)) * (v1 * v2)) end function h_az_DP <>= pure function z_ah_DP (g, v1, k1, h2, k2) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * h2* ((k2 * v1) * k1 - (k1 * k2) * v1) end function z_ah_DP <>= pure function h_hh_6 (g, h1, k1, h2, k2) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: hout hout = g * ((k1* k1) + (k2 * k2) + (k1* k2)) * h1 * h2 end function h_hh_6 @ \section{Dim-6 Anoumalous Couplings without Higgs} <>= public :: g_gg_13, g_gg_23, g_gg_6, kg_kgkg_i <>= pure function g_gg_23 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (-2*(k1*v2)) + v2 * (2*k2 * v1) + (k1 - k2) * (v1*v2)) end function g_gg_23 <>= pure function g_gg_13 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (2*(k1 + k2)*v2) - v2 * ((k1 + 2*k2) * v1) + 2*k2 * (v1 * v2)) end function g_gg_13 <>= pure function g_gg_6 (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * & ( k1 * ((-(k1 + k2) * v2) * (k2 * v1) + ((k1 + k2) * k2) * (v1 * v2)) & + k2 * (((k1 + k2) * v1) * (k1 * v2) - ((k1 + k2) * k1) * (v1 * v2)) & + v1 * (-((k1 + k2) * k2) * (k1 * v2) + (k1 * k2) * ((k1 + k2) * v2)) & + v2 * (((k1 + k2) * k1) * (k2 * v1) - (k1 * k2) * ((k1 + k2) * v1))) end function g_gg_6 <>= pure function kg_kgkg_i (g, a1, k1, a2, k2) result (a) complex(kind=default), intent(in) :: g type(vector), intent(in) :: a1, a2 type(momentum), intent(in) :: k1, k2 type(vector) :: a real(kind=default) :: k1k1, k2k2, k1k2, kk1, kk2 complex(kind=default) :: a1a2, k2a1, ka1, k1a2, ka2 k1k1 = k1 * k1 k1k2 = k1 * k2 k2k2 = k2 * k2 kk1 = k1k1 + k1k2 kk2 = k1k2 + k2k2 k2a1 = k2 * a1 ka1 = k2a1 + k1 * a1 k1a2 = k1 * a2 ka2 = k1a2 + k2 * a2 a1a2 = a1 * a2 a = (-1) * g * ( (kk2 * k1a2 - k1k2 * ka2 ) * a1 & + (k1k2 * ka1 - kk1 * k2a1) * a2 & + (ka2 * k2a1 - kk2 * a1a2) * k1 & + (kk1 * a1a2 - ka1 * k1a2) * k2 ) end function kg_kgkg_i @ \section{Dim-6 Anoumalous Couplings with AWW} <>= public ::a_ww_DP, w_aw_DP, a_ww_DW <>= pure function a_ww_DP (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ( - ((k1 + k2) * v2) * v1 + ((k1 + k2) * v1) * v2) end function a_ww_DP <>= pure function w_aw_DP (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * ((k1 * v2) * v1 - (v1 * v2) * k1) end function w_aw_DP <>= pure function a_ww_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (- (4*k1 + 2*k2) * v2) & + v2 * ( (2*k1 + 4*k2) * v1) & + (k1 - k2) * (2*v1*v2)) end function a_ww_DW <>= public :: w_wz_DPW, z_ww_DPW, w_wz_DW, z_ww_DW, w_wz_D, z_ww_D <>= pure function w_wz_DPW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (-(k1+k2)*v2 - k1*v2) + v2 * ((k1+k2)*v1) + k1 * (v1*v2)) end function w_wz_DPW <>= pure function z_ww_DPW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (k1*(v1*v2) - k2*(v1*v2) - v1*(k1*v2) + v2*(k2*v1)) end function z_ww_DPW <>= pure function w_wz_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v2 * (v1 * k2) - k2 * (v1 * v2)) end function w_wz_DW <>= pure function z_ww_DW (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * ((-1)*(k1+k2) * v2) + v2 * ((k1+k2) * v1)) end function z_ww_DW <>= pure function w_wz_D (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v2 * (k2*v1) - k2 * (v1*v2)) end function w_wz_D <>= pure function z_ww_D (g, v1, k1, v2, k2) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(vector) :: vout vout = g * (v1 * (- (k1 + k2) * v2) + v2 * ((k1 + k2) * v1)) end function z_ww_D @ \section{Dim-6 Quartic Couplings} <>= public :: hhhh_p2, a_hww_DPB, h_aww_DPB, w_ahw_DPB, a_hww_DPW, h_aww_DPW, & w_ahw_DPW, a_hww_DW, h_aww_DW, w3_ahw_DW, w4_ahw_DW <>= pure function hhhh_p2 (g, h1, k1, h2, k2, h3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2, h3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1*h2*h3* (k1*k1 + k2*k2 +k3*k3 + k1*k3 + k1*k2 + k2*k3) end function hhhh_p2 <>= pure function a_hww_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (v3*((k1+k2+k3)*v2) - v2*((k1+k2+k3)*v3)) end function a_hww_DPB <>= pure function h_aww_DPB (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((k1 * v3) * (v1 * v2) - (k1 * v2) * (v1 * v3)) end function h_aww_DPB <>= pure function w_ahw_DPB (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * (k1 * v3) - k1 * (v1 * v3)) end function w_ahw_DPB <>= pure function a_hww_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (v3 * ((2*k1+k2+k3)*v2) - v2 * ((2*k1+k2+k3)*v3)) end function a_hww_DPW <>= pure function h_aww_DPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((-(2*k1+k2+k3)*v2)*(v1*v3)+((2*k1+k2+k3)*v3)*(v1*v2)) end function h_aww_DPW <>= pure function w_ahw_DPW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * ((k2 - k1) * (v1 * v3) + v1 * ((k1 - k2) * v3)) end function w_ahw_DPW <>= pure function a_hww_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ( v2 * (-(3*k1 + 4*k2 + 4*k3) * v3) & + v3 * ((3*k1 + 2*k2 + 4*k3) * v2) & + (k2 - k3) *2*(v2 * v3)) end function a_hww_DW <>= pure function h_aww_DW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((v1*v2) * ((3*k1 - k2 - k3)*v3) & + (v1*v3) * ((-3*k1 - k2 + k3)*v2) & + (v2*v3) * (2*(k2-k3)*v1)) end function h_aww_DW <>= pure function w3_ahw_DW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * ((4*k1 + k2) * v3) & +v3 * (-2*(k1 + k2 + 2*k3) * v1) & +(-2*k1 + k2 + 2*k3) * (v1*v3)) end function w3_ahw_DW <>= pure function w4_ahw_DW (g, v1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * (v1 * (-(4*k1 + k2 + 2*k3) * v3) & + v3 * (2*(k1 + k2 + 2*k3) * v1) & +(4*k1 + k2) * (v1*v3)) end function w4_ahw_DW <>= public ::a_aww_DW, w_aaw_DW, a_aww_W, w_aaw_W <>= pure function a_aww_DW (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (2*v1*(v2*v3) - v2*(v1*v3) - v3*(v1*v2)) end function a_aww_DW pure function w_aaw_DW (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * (2*v3*(v1*v2) - v2*(v1*v3) - v1*(v2*v3)) end function w_aaw_DW pure function a_aww_W (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout !!! Recalculated WK 2018-08-24 type(momentum) :: k4 k4 = -(k1+k2+k3) !!! negative sign (-g) causes expected gauge cancellation vout = (-g) * ( & + (k1*v3)*(k3*v2)*v1 - (k3*v2)*(v1*v3)*k1 & - (k1*k3)*(v2*v3)*v1 + (k3*v1)*(v2*v3)*k1 & - (k1*v3)*(v1*v2)*k3 + (k1*v2)*(v1*v3)*k3 & + (k1*k3)*(v1*v2)*v3 - (k3*v1)*(k1*v2)*v3 & + (k3*v2)*(k4*v3)*v1 - (k3*v2)*(k4*v1)*v3 & - (k3*k4)*(v2*v3)*v1 + (k4*v1)*(v2*v3)*k3 & - (k3*v1)*(k4*v3)*v2 + (k3*v1)*(k4*v2)*v3 & + (k3*k4)*(v1*v3)*v2 - (k4*v2)*(v1*v3)*k3 & + (k1*v2)*(k2*v3)*v1 - (k2*v3)*(v1*v2)*k1 & - (k1*k2)*(v2*v3)*v1 + (k2*v1)*(v2*v3)*k1 & - (k1*v2)*(v1*v3)*k2 + (k1*v3)*(v1*v2)*k2 & + (k1*k2)*(v1*v3)*v2 - (k2*v1)*(k1*v3)*v2 & + (k2*v3)*(k4*v2)*v1 - (k2*v3)*(k4*v1)*v2 & - (k2*k4)*(v2*v3)*v1 + (k4*v1)*(v2*v3)*k2 & - (k2*v1)*(k4*v2)*v3 + (k2*v1)*(k4*v3)*v2 & + (k2*k4)*(v1*v2)*v3 - (k4*v3)*(v1*v2)*k2 & ) !!! Original Version ! vout = g * (v1*((-(k2+k3)*v2)*(k2*v3) + (-(k2+k3)*v3)*(k3*v2)) & ! +v2*((-((k2-k3)*v1)*(k1+k2+k3)*v3) - (k1*v3)*(k2*v1) & ! + ((k1+k2+k3)*v1)*(k2*v3)) & ! +v3*(((k2-k3)*v1)*((k1+k2+k3)*v2) - (k1*v2)*(k3*v1) & ! + ((k1+k2+k3)*v1)*(k3*v2)) & ! +(v1*v2)*(((2*k1+k2+k3)*v3)*k2 - (k2*v3)*k1 -(k1*v3)*k3) & ! +(v1*v3)*(((2*k1+k2+k3)*v2)*k3 - (k3*v2)*k1 - (k1*v2)*k3) & ! +(v2*v3)*((-(k1+k2+k3)*v1)*(k2+k3) + ((k2+k3)*v1)*k1) & ! +(-(k1+k2+k3)*k3 +k1*k2)*((v1*v3)*v2 - (v2*v3)*v1) & ! +(-(k1+k2+k3)*k2 + k1*k3)*((v1*v2)*v3 - (v2*v3)*v1)) end function a_aww_W pure function w_aaw_W (g, v1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout !!! Recalculated WK 2018-08-25 type(momentum) :: k4 k4 = -(k1+k2+k3) !!! negative sign (-g) causes expected gauge cancellation vout = (-g) * ( & + (k3*v1)*(k1*v2)*v3 - (k1*v2)*(v3*v1)*k3 & - (k3*k1)*(v2*v1)*v3 + (k1*v3)*(v2*v1)*k3 & - (k3*v1)*(v3*v2)*k1 + (k3*v2)*(v3*v1)*k1 & + (k3*k1)*(v3*v2)*v1 - (k1*v3)*(k3*v2)*v1 & + (k1*v2)*(k4*v1)*v3 - (k1*v2)*(k4*v3)*v1 & - (k1*k4)*(v2*v1)*v3 + (k4*v3)*(v2*v1)*k1 & - (k1*v3)*(k4*v1)*v2 + (k1*v3)*(k4*v2)*v1 & + (k1*k4)*(v3*v1)*v2 - (k4*v2)*(v3*v1)*k1 & + (k3*v2)*(k2*v1)*v3 - (k2*v1)*(v3*v2)*k3 & - (k3*k2)*(v2*v1)*v3 + (k2*v3)*(v2*v1)*k3 & - (k3*v2)*(v3*v1)*k2 + (k3*v1)*(v3*v2)*k2 & + (k3*k2)*(v3*v1)*v2 - (k2*v3)*(k3*v1)*v2 & + (k2*v1)*(k4*v2)*v3 - (k2*v1)*(k4*v3)*v2 & - (k2*k4)*(v2*v1)*v3 + (k4*v3)*(v2*v1)*k2 & - (k2*v3)*(k4*v2)*v1 + (k2*v3)*(k4*v1)*v2 & + (k2*k4)*(v3*v2)*v1 - (k4*v1)*(v3*v2)*k2 & ) !!! Original Version ! vout = g * (v1*((k1*v3)*(-(k1+k2+2*k3)*v2) + (k2*v3)*((k1+k2+k3)*v2) & ! + (k1*v2)*((k1+k2+k3)*v3)) & ! + v2*(((k1-k2)*v3)*((k1+k2+k3)*v1) - (k2*v3)*(k3*v1) & ! + (k2*v1)*((k1+k2+k3)*v3)) & ! + v3*((k1*v2)*(-(k1+k2)*v1) + (k2*v1)*(-(k1+k2)*v2)) & ! + (v1*v2)*((k1+k2)*(-(k1+k2+k3)*v3) + k3*((k1+k2)*v3))& ! + (v1*v3)*(-k2*(k3*v2) - k3*(k1*v2) + k1*((k1+k2+2*k3)*v2)) & ! + (v2*v3)*(-k1*(k3*v1) - k3*(k2*v1) + k2*((k1+k2+2*k3)*v1)) & ! + (-k2*(k1+k2+k3) + k1*k3)*(v1*(v2*v3) - v3*(v1*v2)) & ! + (-k1*(k1+k2+k3) + k2*k3)*(v2*(v1*v3) - v3*(v1*v2)) ) end function w_aaw_W <>= public :: h_hww_D, w_hhw_D, h_hww_DP, w_hhw_DP, h_hvv_PB, v_hhv_PB <>= pure function h_hww_D (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * ((v2*v3)*((k2*k2)+(k3*k3)) - (k2*v2)*(k2*v3) & - (k3*v2)*(k3*v3)) end function h_hww_D <>= pure function w_hhw_D (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (v3 * ((k1+k2+k3)*(k1+k2+k3)+(k3*k3)) & - (k1+k2+k3) * ((k1+k2+k3)*v3) - k3 * (k3*v3)) end function w_hhw_D <>= pure function h_hww_DP (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * (-((k2+k3)*v2)*(k2*v3) - & ((k2+k3)*v3)*(k3*v2)+ (v2*v3)*((k2+k3)*(k2+k3))) end function h_hww_DP <>= pure function w_hhw_DP (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (k3*((k1+k2)*v3) + (k1+k2)*(-(k1+k2+k3)*v3) & + v3*((k1+k2)*(k1+k2))) end function w_hhw_DP <>= pure function h_hvv_PB (g, h1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h1 * ((k2*v3)*(k3*v2) - (k2*k3)*(v2*v3)) end function h_hvv_PB <>= pure function v_hhv_PB (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((-(k1+k2+k3)*v3)*k3 + ((k1+k2+k3)*k3)*v3) end function v_hhv_PB <>= public :: a_hhz_D, h_ahz_D, z_ahh_D, a_hhz_DP, h_ahz_DP, z_ahh_DP, & a_hhz_PB, h_ahz_PB, z_ahh_PB <>= pure function a_hhz_D (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((k1+k2+k3) * ((k1+k2+k3)*v3) & - v3 * ((k1+k2+k3)*(k1+k2+k3))) end function a_hhz_D <>= pure function h_ahz_D (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ((k1*v1)*(k1*v3) - (k1*k1)*(v1*v3)) end function h_ahz_D <>= pure function z_ahh_D (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * ((k1*v1)*k1 - (k1*k1)*v1) end function z_ahh_D <>= pure function a_hhz_DP (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * ((-(k1+k2+k3)*v3)*(k1+k2) + ((k1+k2+k3)*(k1+k2))*v3) end function a_hhz_DP <>= pure function h_ahz_DP (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ( (k1*v3)*(-(k1+k3)*v1) + (k1*(k1+k3))*(v1*v3) ) end function h_ahz_DP <>= pure function z_ahh_DP (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * (k1*((k2+k3)*v1) - v1*(k1*(k2+k3))) end function z_ahh_DP <>= pure function a_hhz_PB (g, h1, k1, h2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1, h2 type(vector), intent(in) :: v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * h2 * (k3*((k1+k2+k3)*v3) - v3*((k1+k2+k3)*k3)) end function a_hhz_PB <>= pure function h_ahz_PB (g, v1, k1, h2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h2 type(vector), intent(in) :: v1, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * h2 * ((-k1*v3)*(k3*v1) + (k1*k3)*(v1*v3)) end function h_ahz_PB <>= pure function z_ahh_PB (g, v1, k1, h2, k2, h3, k3) result (vout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1 complex(kind=default), intent(in) :: h2, h3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h2 * h3 * (k1*((k1+k2+k3)*v1) - v1*(k1*(k1+k2+k3))) end function z_ahh_PB <>= public :: h_wwz_DW, w_hwz_DW, z_hww_DW, h_wwz_DPB, w_hwz_DPB, z_hww_DPB public :: h_wwz_DDPW, w_hwz_DDPW, z_hww_DDPW, h_wwz_DPW, w_hwz_DPW, z_hww_DPW <>= pure function h_wwz_DW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2)-((2*k1+k2)*v2)*(v1*v3) + & ((k1+2*k2)*v1)*(v2*v3)) end function h_wwz_DW <>= pure function w_hwz_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ( v2*(-(k1+2*k2+k3)*v3) + v3*((2*k1+k2+2*k3)*v2) - & (k1 - k2 + k3)*(v2*v3)) end function w_hwz_DW <>= pure function z_hww_DW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((k2-k3)*(v2*v3) - v2*((2*k2+k3)*v3) + v3*((k2+2*k3)*v2)) end function z_hww_DW <>= pure function h_wwz_DPB (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * ((k3*v1)*(v2*v3) - (k3*v2)*(v1*v3)) end function h_wwz_DPB <>= pure function w_hwz_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (k3*(v2*v3) - v3*(k3*v2)) end function w_hwz_DPB <>= pure function z_hww_DPB (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * (((k1+k2+k3)*v3)*v2 - ((k1+k2+k3)*v2)*v3) end function z_hww_DPB <>= pure function h_wwz_DDPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2)-((k1-k3)*v2)*(v1*v3)+((k2-k3)*v1)*(v2*v3)) end function h_wwz_DDPW <>= pure function w_hwz_DDPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((-(k1+2*k2+k3)*v3)*v2 + ((k1+k2+2*k3)*v2)*v3 + & (v2*v3)*(k2-k3)) end function w_hwz_DDPW <>= pure function z_hww_DDPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((v2*v3)*(k2-k3) - ((k1+2*k2+k3)*v3) *v2 + & ((k1+k2+2*k3)*v2)*v3 ) end function z_hww_DDPW <>= pure function h_wwz_DPW (g, v1, k1, v2, k2, v3, k3) result (hout) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2, v3 type(momentum), intent(in) :: k1, k2, k3 complex(kind=default) :: hout hout = g * (((k1-k2)*v3)*(v1*v2) + (-(2*k1+k2+k3)*v2)*(v1*v3) + & ((k1+2*k2+k3)*v1)*(v2*v3)) end function h_wwz_DPW <>= pure function w_hwz_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((-(k1+2*k2+k3)*v3)*v2 + ((2*k1+k2+k3)*v2)*v3 + & (v2*v3)*(k2-k1)) end function w_hwz_DPW <>= pure function z_hww_DPW (g, h1, k1, v2, k2, v3, k3) result (vout) complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: h1 type(vector), intent(in) :: v2, v3 type(momentum), intent(in) :: k1, k2, k3 type(vector) :: vout vout = g * h1 * ((v2*v3)*(k2-k3) + ((k1-k2)*v3)*v2 + ((k3-k1)*v2)*v3) end function z_hww_DPW @ \section{Scalar3 Dim-5 Couplings} <>= public :: phi_dim5s2 @ \begin{equation} \phi_1(k_1) = g (k_2 \cdot k_3) \phi_2 (k_2) \phi_3 (k_3) \end{equation} <>= pure function phi_dim5s2 (g, phi2, k2, phi3, k3) result (phi1) complex(kind=default), intent(in) :: g, phi2, phi3 type(momentum), intent(in) :: k2, k3 complex(kind=default) :: phi1 phi1 = g * phi2 * phi3 * (k2 * k3) end function phi_dim5s2 @ \section{Tensorscalar-Scalar Couplings} <>= public :: tphi_ss, tphi_ss_cf, s_tphis, s_tphis_cf @ \begin{equation} \phi(k_1 + k_2) = 2 g ((k_1 \cdot k_2) + (k_1 \cdot k_1)) ((k_1 \cdot k_2) + (k_2 \cdot k_2)) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function tphi_ss (g, phi1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = 2 * g * phi1 * phi2 * & ((k1 * k2)+ (k1 * k1)) * & ((k1 * k2)+ (k2 * k2)) end function tphi_ss @ \begin{equation} \phi(k_1 + k_2) = - g/2 (k_1 \cdot k_2) ((k_1 + k_2) \cdot (k_1 + k_2)) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function tphi_ss_cf (g, phi1, k1, phi2, k2) result (phi) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 complex(kind=default) :: phi phi = - g/2 * phi1 * phi2 * & (k1 * k2) * & ((k1 + k2) * (k1 + k2)) end function tphi_ss_cf @ \begin{equation} \phi_1(k_1) = 2 g ((k_1 \cdot k_2) + (k_1 \cdot k_1)) ((k_1 \cdot k_2) + (k_2 \cdot k_2)) \phi(k_2-k_1) \phi_2 (k_2) \end{equation} <>= pure function s_tphis (g, phi, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi, phi2 type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - ( k + k2) phi1 = 2 * g * phi * phi2 * & ((k1 * k2)+ (k1 * k1)) * & ((k1 * k2)+ (k2 * k2)) end function s_tphis @ \begin{equation} \phi_1(k_1) = - g/2 (k_1 \cdot k_2) ((k_1 + k_2) \cdot (k_1 + k_2)) \phi (k_2 -k_1) \phi_2 (k_2) \end{equation} <>= pure function s_tphis_cf (g, phi, k, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi, phi2 type(momentum), intent(in) :: k, k2 complex(kind=default) :: phi1 type(momentum) :: k1 k1 = - ( k + k2) phi1 = - g/2 * phi * phi2 * & (k1 * k2) * & ((k1 + k2) * (k1 + k2)) end function s_tphis_cf @ \section{Scalar2-Vector2 Dim-8 Couplings} <>= public :: phi_phi2v_1, v_phi2v_1, phi_phi2v_2, v_phi2v_2 @ \begin{equation} \phi_2(k_2) = g \left (\left ( k_1 \cdot V_1 \right ) \left ( k_2 \cdot V_2 \right ) + \left ( k_1 \cdot V_1 \right )\left ( k_1 \cdot V_2 \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_1 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (k1 * v1) * (k2 * v2) + (k1 * v2) * (k2 * v1) ) end function phi_phi2v_1 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( k_2 \cdot V_1 \right ) + k_2^\mu \left ( k_1 \cdot V_1 \right ) \right ) \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_1 (g, phi1, k1, phi2, k2, v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1 type(vector) :: v2 v2 = g * phi1 * phi2 * & ( k1 * (k2 * v1) + k2 * (k1 * v1) ) end function v_phi2v_1 @ \begin{equation} \phi_2(k_2) = g \left ( k_1 \cdot k_2 \right ) \left ( V_1\cdot V_2 \right) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_2 (g, phi1, k1, v1,k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(vector), intent(in) :: v1, v2 type(momentum) :: k2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * (k1 * k2) * (v1 * v2) end function phi_phi2v_2 @ \begin{equation} V_2^\mu = g V_1^\mu \left ( k_1 \cdot k_2 \right ) \phi_1 \phi_2 \end{equation} <>= pure function v_phi2v_2 (g, phi1, k1, phi2, k2, v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v1 type(vector) :: v2 v2 = g * phi1 * phi2 * & ( k1 * k2 ) * v1 end function v_phi2v_2 @ \section{Scalar4 Dim-8 Couplings} <>= public :: s_dim8s3 @ \begin{equation} \phi(k_1) = g \left [ \left ( k_1 \cdot k_2 \right ) \left ( k_3 \cdot k_4 \right )+ \left ( k_1 \cdot k_3 \right ) \left ( k_2 \cdot k_4 \right ) + \left ( k_1 \cdot k_4 \right )\left ( k_2 \cdot k_3 \right ) \right ] \phi_2 (k_2) \phi_3 (k_3) \phi_4 (k_4) \end{equation} <>= pure function s_dim8s3 (g, phi2, k2, phi3, k3, phi4, k4) result (phi1) complex(kind=default), intent(in) :: g, phi2, phi3, phi4 type(momentum), intent(in) :: k2, k3, k4 type(momentum) :: k1 complex(kind=default) :: phi1 k1 = - k2 - k3 - k4 phi1 = g * ( (k1 * k2) * (k3 * k4) + (k1 * k3) * (k2 * k4) & + (k1 * k4) * (k2 * k3) ) * phi2 * phi3 * phi4 end function s_dim8s3 @ \section{Mixed Scalar2-Vector2 Dim-8 Couplings} <>= public :: phi_phi2v_m_0, v_phi2v_m_0, phi_phi2v_m_1, v_phi2v_m_1, phi_phi2v_m_7, v_phi2v_m_7 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_2 \right ) - (\left ( V_1 \cdot V_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_0 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * k_v2) * (v2 * k_v1) * (k1 * k2) & - (v1 * v2) * (k_v1 * k_v2) * (k1 * k2) ) end function phi_phi2v_m_0 @ \begin{equation} V_2^\mu =g \left ( k_{V_1}^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) - V_1^\mu \left ( k_{V_1} \cdot k_{V_2} \right ) \left ( k_1 \cdot k_2 \right ) \right ) \phi_1 (k_1) \phi_2 (k_2)) \end{equation} <>= pure function v_phi2v_m_0 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k_v1 * (v1 * k_v2) * (k1 * k2) & - v1 * (k_v2 * k_v1) * (k1 * k2) ) end function v_phi2v_m_0 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) + (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) + (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_{V_2} \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_2 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_1 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * v2) * (k1 * k_v2) * (k2 * k_v1) & + (v1 * v2) * (k1 * k_v1) * (k2 * k_v2) & + (v1 * k2) * (v2 * k1) * (k_v1 * k_v2) & + (v1 * k1) * (v2 * k2) * (k_v1 * k_v2) & - (v1 * k_v2) * (v2 * k2) * (k1 * k_v1) & - (v1 * k2) * (v2 * k_v1) * (k1 * k_v2) & - (v1 * k_v2) * (v2 * k1) * (k2 * k_v1) & - (v1 * k1) * (v2 * k_v1) * (k2 * k_v2) ) end function phi_phi2v_m_1 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ + k_2^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ + V_1^\mu \left ( k_{V_1} \cdot k_1 \right ) \left ( k_{V_2} \cdot k_2 \right ) \\ + V_1^\mu \left ( k_{V_1} \cdot k_2 \right ) \left ( k_{V_2} \cdot k_1 \right ) \\ - k_1^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_{V_1} \cdot k_2 \right ) \\ - k_2^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_{V_1} \cdot k_1 \right ) \\ - k_{V_1}^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_2} \cdot k_2 \right ) \\ - k_{V_1}^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_2} \cdot k_1 \right ) \right ) \\ \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_m_1 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k1 * (v1 * k2) * (k_v1 * k_v2) & + k2 * (v1 * k1) * (k_v1 * k_v2) & + v1 * (k_v1 * k1) * (k_v2 * k2) & + v1 * (k_v1 * k2) * (k_v2 * k1) & - k1 * (v1 * k_v2) * (k_v1 * k2) & - k2 * (v1 * k_v2) * (k_v1 * k1) & - k_v1 * (v1 * k1) * (k_v2 * k2) & - k_v1 * (v1 * k2) * (k_v2 * k1) ) end function v_phi2v_m_1 @ \begin{equation} \phi_2(k_2) = g \left (\left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot V_2 \right ) \left ( k_2 \cdot k_{V_1} \right ) + (\left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) + (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_{V_1} \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) - (\left ( V_1 \cdot V_2 \right ) \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ - (\left ( V_1 \cdot k_2 \right ) \left ( V_2 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) - (\left ( V_1 \cdot k_1 \right ) \left ( V_2 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \right ) \phi_1 (k_1) \end{equation} <>= pure function phi_phi2v_m_7 (g, phi1, k1, v1, k_v1, v2, k_v2) result (phi2) complex(kind=default), intent(in) :: g, phi1 type(momentum), intent(in) :: k1, k_v1, k_v2 type(momentum) :: k2 type(vector), intent(in) :: v1, v2 complex(kind=default) :: phi2 k2 = - k1 - k_v1 - k_v2 phi2 = g * phi1 * & ( (v1 * k_v2) * (k1 * v2) * (k2 * k_v1) & + (v1 * k_v2) * (k1 * k_v1) * (k2 * v2) & + (v1 * k1) * (v2 * k_v1) * (k2 * k_v2) & + (v1 * k2) * (v2 * k_v1) * (k1 * k_v2) & - (v1 * v2) * (k1 * k_v2) * (k2 * k_v1) & - (v1 * v2) * (k1 * k_v1) * (k2 * k_v2) & - (v1 * k2) * (v2 * k1) * (k_v1 * k_v2) & - (v1 * k1) * (v2 * k2) * (k_v1 * k_v2) ) end function phi_phi2v_m_7 @ \begin{equation} V_2^\mu =g \left ( k_1^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) \\ + k_2^\mu \left ( V_1 \cdot k_{V_2} \right ) \left ( k_1 \cdot k_{V_1} \right ) \\ + k_{V_1}^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_2 \cdot k_{V_2} \right ) \\ + k_{V_1}^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_1 \cdot k_{V_2} \right ) \\ - k_1^\mu \left ( V_1 \cdot k_2 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - k_2^\mu \left ( V_1 \cdot k_1 \right ) \left ( k_{V_1} \cdot k_{V_2} \right ) \\ - k_{V_1}^\mu \left ( k_1 \cdot k_{V_2} \right ) \left ( k_2 \cdot k_{V_1} \right ) \\ - k_{V_1}^\mu \left ( k_1 \cdot k_{V_1} \right ) \left ( k_2 \cdot k_{V_2} \right ) \right ) \\ \phi_1 (k_1) \phi_2 (k_2) \end{equation} <>= pure function v_phi2v_m_7 (g, phi1, k1, phi2, k2, v1, k_v1) result (v2) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2, k_v1 type(vector), intent(in) :: v1 type(momentum) :: k_v2 type(vector) :: v2 k_v2 = - k_v1 - k1 - k2 v2 = g * phi1 * phi2 * & ( k1 * (v1 * k_v2) * (k2 * k_v1) & + k2 * (v1 * k_v2) * (k1 * k_v1) & + k_v1 * (v1 * k1) * (k2 * k_v2) & + k_v1 * (v1 * k2) * (k1 * k_v2) & - k1 * (v1 * k2) * (k_v1 * k_v2) & - k2 * (v1 * k1) * (k_v1 * k_v2) & - v1 * (k1 * k_v2) * (k2 * k_v1) & - v1 * (k1 * k_v1) * (k2 * k_v2) ) end function v_phi2v_m_7 @ \section{Transversal Gauge4 Dim-8 Couplings} <>= public :: g_dim8g3_t_0, g_dim8g3_t_1, g_dim8g3_t_2 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left ( k_1 \cdot V_2 \right ) - V_2^\mu \left ( k_1 \cdot k_2 \right ) \right ] \left [ \left ( k_3 \cdot V_4 \right) \left ( k_4 \cdot V_3 \right ) - \left (V_3 \cdot V_4 \right ) \left ( k_3 \cdot k_4 \right ) \right ] \end{equation} <>= pure function g_dim8g3_t_0 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (k2 * (k1 * v2) - v2 * (k1 * k2)) & * ((k3 * v4) * (k4 * v3) - (v3 * v4) * (k3 * k4)) end function g_dim8g3_t_0 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left ( k_1 \cdot V_2 \right ) - V_2^\mu \left ( k_1 \cdot k_2 \right ) \right ] \left [ \left ( k_3 \cdot V_4 \right) \left ( k_4 \cdot V_3 \right ) - \left (V_3 \cdot V_4 \right ) \left ( k_3 \cdot k_4 \right ) \right ] \end{equation} <>= pure function g_dim8g3_t_1 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (v3 * (v2 * k4) * (k1 * k3) * (k2 * v4) & + v4 * (v2 * k3) * (k1 * k4) * (k2 * v3) & + k3 * (v2 * v4) * (k1 * v3) * (k2 * k4) & + k4 * (v2 * v3) * (k1 * v4) * (k2 * k3) & - v3 * (v2 * v4) * (k1 * k3) * (k2 * k4) & - v4 * (v2 * v3) * (k1 * k4) * (k2 * k3) & - k3 * (v2 * k4) * (k1 * v3) * (k2 * v4) & - k4 * (v2 * k3) * (k1 * v4) * (k2 * v3)) end function g_dim8g3_t_1 @ \begin{equation} V_1^\mu = g \left [ k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ + k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \\ + k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ + k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \\ + k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ + k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \\ + k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \left (k_1 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \left (k_1 \cdot k_3\right ) \\ - k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ + k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \left (k_1 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \left (k_2 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \left (k_2 \cdot k_3\right ) \\ + V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \left (k_2 \cdot k_3\right ) \\ - k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \left (k_2 \cdot k_4\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \left (k_3 \cdot k_4\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \left (k_3 \cdot k_4\right ) \right ] \end{equation} <>= pure function g_dim8g3_t_2 (g, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g * (k2 * (v2 * k3) * (v3 * k4) * (v4 * k1) & + k3 * (v2 * k1) * (v3 * k4) * (v4 * k2) & + k2 * (v2 * k4) * (v3 * k1) * (v4 * k3) & + k4 * (v2 * k1) * (v3 * k2) * (v4 * k3) & + k4 * (v2 * k3) * (v3 * v4) * (k1 * k2) & + k3 * (v2 * k4) * (v3 * v4) * (k1 * k2) & - k3 * (v2 * v4) * (v3 * k4) * (k1 * k2) & - v4 * (v2 * k3) * (v3 * k4) * (k1 * k2) & - k4 * (v2 * v3) * (v4 * k3) * (k1 * k2) & - v3 * (v2 * k4) * (v4 * k3) * (k1 * k2) & - k2 * (v2 * k4) * (v3 * v4) * (k1 * k3) & + k2 * (v2 * v4) * (v3 * k4) * (k1 * k3) & - v2 * (v3 * k4) * (v4 * k2) * (k1 * k3) & - k2 * (v2 * k3) * (v3 * v4) * (k1 * k4) & + k2 * (v2 * v3) * (v4 * k3) * (k1 * k4) & - v2 * (v3 * k2) * (v4 * k3) * (k1 * k4) & - k4 * (v2 * k1) * (v3 * v4) * (k2 * k3) & + v4 * (v2 * k1) * (v3 * k4) * (k2 * k3) & - v2 * (v3 * k4) * (v4 * k1) * (k2 * k3) & + v2 * (v3 * v4) * (k1 * k4) * (k2 * k3) & - k3 * (v2 * k1) * (v3 * v4) * (k2 * k4) & + v3 * (v2 * k1) * (v4 * k3) * (k2 * k4) & - v2 * (v3 * k1) * (v4 * k3) * (k2 * k4) & + v2 * (v3 * v4) * (k1 * k3) * (k2 * k4) & - k2 * (v2 * v4) * (v3 * k1) * (k3 * k4) & - v4 * (v2 * k1) * (v3 * k2) * (k3 * k4) & - k2 * (v2 * v3) * (v4 * k1) * (k3 * k4) & + v2 * (v3 * k2) * (v4 * k1) * (k3 * k4) & - v3 * (v2 * k1) * (v4 * k2) * (k3 * k4) & + v2 * (v3 * k1) * (v4 * k2) * (k3 * k4) & + v4 * (v2 * v3) * (k1 * k2) * (k3 * k4) & + v3 * (v2 * v4) * (k1 * k2) * (k3 * k4)) end function g_dim8g3_t_2 @ \section{Mixed Gauge4 Dim-8 Couplings} <>= public :: g_dim8g3_m_0, g_dim8g3_m_1, g_dim8g3_m_7 @ \begin{equation} V_1^\mu = g_1 \left [ V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ \right ] \\ + g_2 \left [ V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_0 (g1, g2, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (v2 * (v3 * v4) * (k1 * k2) & - k2 * (v2 * k1) * (v3 * v4)) & + g2 * (v2 * (v3 * v4) * (k3 * k4) & - v2 * (v3 * k4) * (v4 * k3)) end function g_dim8g3_m_0 @ \begin{equation} V_1^\mu = g_1 \left [ k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ + V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \\ + k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ + V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ - V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \\ - V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ \right ] \\ + g_2 \left [ k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ - k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \\ + k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ + V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ - V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_3 \cdot k_4\right ) \\ - V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_1 (g1, g2, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (k2 * (v2 * v4) * (v3 * k1) & + v4 * (v2 * k1) * (v3 * k2) & + k2 * (v2 * v3) * (v4 * k1) & + v3 * (v2 * k1) * (v4 * k2) & - v2 * (v3 * k2) * (v4 * k1) & - v2 * (v3 * k1) * (v4 * k2) & - v4 * (v2 * v3) * (k1 * k2) & - v3 * (v2 * v4) * (k1 * k2)) & + g2 * (k3 * (v2 * v4) * (v3 * k4) & - k4 * (v2 * k3) * (v3 * v4) & - k3 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * k3) * (v3 * k4) & + k4 * (v2 * v3) * (v4 * k3) & + v3 * (v2 * k4) * (v4 * k3) & - v4 * (v2 * v3) * (k3 * k4) & - v3 * (v2 * v4) * (k3 * k4)) end function g_dim8g3_m_1 @ \begin{equation} V_1^\mu = g_1 \left [ V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_1\right ) \\ + V_2^\mu \left (V_4 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_2\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_2\right ) \\ \right ] \\ + g_2 \left [ k_3^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ + k_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot V_4\right ) \\ + k_2^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ + k_2^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_1\right ) \\ + k_4^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_2\right ) \\ + V_3^\mu \left (V_2 \cdot k_3\right ) \left (V_4 \cdot k_1\right ) \\ + V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ + V_3^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_2\right ) \\ + V_2^\mu \left (V_3 \cdot k_4\right ) \left (V_4 \cdot k_2\right ) \\ + V_2^\mu \left (V_3 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ + V_2^\mu \left (V_3 \cdot k_2\right ) \left (V_4 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_1 \cdot k_3\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_2 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_1\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_1\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_2\right ) \\ - V_4^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_1\right ) \left (V_3 \cdot k_4\right ) \\ - k_3^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_1\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_1\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_2\right ) \\ - V_3^\mu \left (V_2 \cdot k_3\right ) \left (V_4 \cdot k_2\right ) \\ - k_2^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ - V_3^\mu \left (V_2 \cdot k_1\right ) \left (V_4 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_1 \cdot k_4\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_3\right ) \\ - V_2^\mu \left (V_3 \cdot V_4\right ) \left (k_2 \cdot k_4\right ) \\ \right ] + g_3 \left [ k_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot V_4\right ) \\ + k_3^\mu \left (V_2 \cdot k_4\right ) \left (V_3 \cdot V_4\right ) \\ + V_4^\mu \left (V_2 \cdot V_3\right ) \left (k_3 \cdot k_4\right ) \\ + V_3^\mu \left (V_2 \cdot V_4\right ) \left (k_3 \cdot k_4\right ) \\ - k_3^\mu \left (V_2 \cdot V_4\right ) \left (V_3 \cdot k_4\right ) \\ - V_4^\mu \left (V_2 \cdot k_3\right ) \left (V_3 \cdot k_4\right ) \\ - k_4^\mu \left (V_2 \cdot V_3\right ) \left (V_4 \cdot k_3\right ) \\ - V_3^\mu \left (V_2 \cdot k_4\right ) \left (V_4 \cdot k_3\right ) \\ \right ] \end{equation} <>= pure function g_dim8g3_m_7 (g1, g2, g3, v2, k2, v3, k3, v4, k4) result (v1) complex(kind=default), intent(in) :: g1, g2, g3 type(vector), intent(in) :: v2, v3, v4 type(momentum), intent(in) :: k2, k3, k4 type(vector) :: v1 type(momentum) :: k1 k1 = - k2 - k3 - k4 v1 = g1 * (v2 * (v3 * k2) * (v4 * k1) & + v2 * (v3 * k1) * (v4 * k2) & + v4 * (v2 * v3) * (k1 * k2) & + v3 * (v2 * v4) * (k1 * k2) & - k2 * (v2 * v4) * (v3 * k1) & - v4 * (v2 * k1) * (v3 * k2) & - k2 * (v2 * v3) * (v4 * k1) & - v3 * (v2 * k1) * (v4 * k2)) & + g2 * (k3 * (v2 * k1) * (v3 * v4) & + k4 * (v2 * k1) * (v3 * v4) & + k2 * (v2 * k3) * (v3 * v4) & + k2 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * k4) * (v3 * k1) & + k4 * (v2 * v4) * (v3 * k2) & + v3 * (v2 * k3) * (v4 * k1) & + v2 * (v3 * k4) * (v4 * k1) & + k3 * (v2 * v3) * (v4 * k2) & + v2 * (v3 * k4) * (v4 * k2) & + v2 * (v3 * k1) * (v4 * k3) & + v2 * (v3 * k2) * (v4 * k3) & + v4 * (v2 * v3) * (k1 * k3) & + v3 * (v2 * v4) * (k1 * k4) & + v3 * (v2 * v4) * (k2 * k3) & + v4 * (v2 * v3) * (k2 * k4) & - k4 * (v2 * v4) * (v3 * k1) & - v4 * (v2 * k3) * (v3 * k1) & - k3 * (v2 * v4) * (v3 * k2) & - v4 * (v2 * k4) * (v3 * k2) & - k2 * (v2 * v4) * (v3 * k4) & - v4 * (v2 * k1) * (v3 * k4) & - k3 * (v2 * v3) * (v4 * k1) & - v3 * (v2 * k4) * (v4 * k1) & - k4 * (v2 * v3) * (v4 * k2) & - v3 * (v2 * k3) * (v4 * k2) & - k2 * (v2 * v3) * (v4 * k3) & - v3 * (v2 * k1) * (v4 * k3) & - v2 * (v3 * v4) * (k1 * k3) & - v2 * (v3 * v4) * (k1 * k4) & - v2 * (v3 * v4) * (k2 * k3) & - v2 * (v3 * v4) * (k2 * k4)) & + g3 * (k4 * (v2 * k3) * (v3 * v4) & + k3 * (v2 * k4) * (v3 * v4) & + v4 * (v2 * v3) * (k3 * k4) & + v3 * (v2 * v4) * (k3 * k4) & - k3 * (v2 * v4) * (v3 * k4) & - v4 * (v2 * k3) * (v3 * k4) & - k4 * (v2 * v3) * (v4 * k3) & - v3 * (v2 * k4) * (v4 * k3)) end function g_dim8g3_m_7 @ \section{Graviton Couplings} <>= public :: s_gravs, v_gravv, grav_ss, grav_vv @ <>= pure function s_gravs (g, m, k1, k2, t, s) result (phi) complex(kind=default), intent(in) :: g, s real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(tensor), intent(in) :: t complex(kind=default) :: phi, t_tr t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) phi = g * s * (((t*k1)*k2) + ((t*k2)*k1) & - g * (m**2 + (k1*k2))*t_tr)/2.0_default end function s_gravs @ <>= pure function grav_ss (g, m, k1, k2, s1, s2) result (t) complex(kind=default), intent(in) :: g, s1, s2 real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default t = g*s1*s2/2.0_default * (-(m**2 + (k1*k2)) * t_metric & + (k1.tprod.k2) + (k2.tprod.k1)) end function grav_ss @ <>= pure function v_gravv (g, m, k1, k2, t, v) result (vec) complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(momentum), intent(in) :: k1, k2 type(vector), intent(in) :: v type(tensor), intent(in) :: t complex(kind=default) :: t_tr real(kind=default) :: xi type(vector) :: vec xi = 1.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) vec = (-g)/ 2.0_default * (((k1*k2) + m**2) * & (t*v + v*t - t_tr * v) + t_tr * (k1*v) * k2 & - (k1*v) * ((k2*t) + (t*k2)) & - ((k1*(t*v)) + (v*(t*k1))) * k2 & + ((k1*(t*k2)) + (k2*(t*k1))) * v) !!! Unitarity gauge: xi -> Infinity !!! + (1.0_default/xi) * (t_tr * ((k1*v)*k2) + & !!! (k2*v)*k2 + (k2*v)*k1 - (k1*(t*v))*k1 + & !!! (k2*v)*(k2*t) - (v*(t*k1))*k1 - (k2*v)*(t*k2))) end function v_gravv @ <>= pure function grav_vv (g, m, k1, k2, v1, v2) result (t) complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k1, k2 real(kind=default), intent(in) :: m real(kind=default) :: xi type(vector), intent (in) :: v1, v2 type(tensor) :: t_metric, t xi = 0.00001_default t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default t = (-g)/2.0_default * ( & ((k1*k2) + m**2) * ( & (v1.tprod.v2) + (v2.tprod.v1) - (v1*v2) * t_metric) & + (v1*k2)*(v2*k1)*t_metric & - (k2*v1)*((v2.tprod.k1) + (k1.tprod.v2)) & - (k1*v2)*((v1.tprod.k2) + (k2.tprod.v1)) & + (v1*v2)*((k1.tprod.k2) + (k2.tprod.k1))) !!! Unitarity gauge: xi -> Infinity !!! + (1.0_default/xi) * ( & !!! ((k1*v1)*(k1*v2) + (k2*v1)*(k2*v2) + (k1*v1)*(k2*v2))* & !!! t_metric) - (k1*v1) * ((k1.tprod.v2) + (v2.tprod.k1)) & !!! - (k2*v2) * ((k2.tprod.v1) + (v1.tprod.k2))) end function grav_vv @ \section{Tensor Couplings} <>= public :: t2_vv, v_t2v, t2_vv_cf, v_t2v_cf, & t2_vv_1, v_t2v_1, t2_vv_t, v_t2v_t, & t2_phi2, phi_t2phi, t2_phi2_cf, phi_t2phi_cf @ \begin{equation} T_{\mu\nu} = g * V_{1 \,\mu} V_{2\,\nu} + V_{1\,\nu} V_{2\,\mu} \end{equation} <>= pure function t2_vv (g, v1, v2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(tensor) :: t type(tensor) :: tmp tmp = v1.tprod.v2 t%t = g * (tmp%t + transpose (tmp%t)) end function t2_vv @ \begin{equation} V_{1\,\mu} = g * T_{\mu \nu} V_{2}^{\nu}+ T_{\nu \mu} V_{2}^{\nu} \end{equation} <>= pure function v_t2v (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv type(tensor) :: tmp tmp%t = t%t + transpose (t%t) tv = g * (tmp * v) end function v_t2v @ \begin{equation} T_{\mu\nu} =- \frac{g}{2} V_1^\rho V_{2 \,\rho} \end{equation} <>= pure function t2_vv_cf (g, v1, v2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp_s = v1 * v2 t%t = - (g /2.0_default) * tmp_s * t_metric%t end function t2_vv_cf @ \begin{equation} V_{1\,\mu} = -\frac{g}{2} T^{\nu}_{ \nu} V_{2}^{\mu} \end{equation} <>= pure function v_t2v_cf (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv, tmp_tv tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tv = - ( g /2.0_default) * tmp_tv end function v_t2v_cf @ \begin{equation} T_{\mu\nu} = g * \left ( k_{1 \,\mu} k_{2\,\nu} + k_{1\,\nu} k_{2\,\mu} \right ) \phi_1 \left ( k_1 \right ) \phi_1 \left ( k_2 \right ) \end{equation} <>= pure function t2_phi2 (g, phi1, k1, phi2, k2) result (t) complex(kind=default), intent(in) :: g, phi1, phi2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t type(tensor) :: tmp tmp = k1.tprod.k2 t%t = g * (tmp%t + transpose (tmp%t)) * phi1 * phi2 end function t2_phi2 @ \begin{equation} \phi_{1} (k_1) =g * \left ( T_{\mu \nu} k_{1}^{\mu}k_{2}^{\nu} + T_{\nu \mu} k_{2}^{\mu}k_{1}^{\nu} \right ) \phi_2 \left (k_2 \right ) \end{equation} <>= pure function phi_t2phi (g, t, kt, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(tensor), intent(in) :: t type(momentum), intent(in) :: kt, k2 type(momentum) :: k1 complex(kind=default) :: phi1 type(tensor) :: tmp k1 = -kt - k2 tmp%t = t%t + transpose (t%t) phi1 = g * ( (tmp * k2) * k1) * phi2 end function phi_t2phi @ \begin{equation} T_{\mu\nu} =- \frac{g}{2} k_1^\rho k_{2 \,\rho} \phi_1 \left ( k_1 \right ) \phi_2 \left ( k_2 \right ) \end{equation} <>= pure function t2_phi2_cf (g, phi1, k1, phi2, k2) result (t) complex(kind=default), intent(in) :: g, phi1, phi2 complex(kind=default) :: tmp_s type(momentum), intent(in) :: k1, k2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp_s = (k1 * k2) * phi1 * phi2 t%t = - (g /2.0_default) * tmp_s * t_metric%t end function t2_phi2_cf @ \begin{equation} \phi_1 (k_1) = - \frac{g}{2} T^{\nu}_{ \nu} \left (k_1 \cdot k_2 \right ) \phi_2 (k_2) \end{equation} <>= pure function phi_t2phi_cf (g, t, kt, phi2, k2) result (phi1) complex(kind=default), intent(in) :: g, phi2 type(tensor), intent(in) :: t type(momentum), intent(in) :: kt, k2 type(momentum) :: k1 complex(kind=default) :: tmp_ts, phi1 k1 = - kt - k2 tmp_ts = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) phi1 = - ( g /2.0_default) * tmp_ts * (k1 * k2) * phi2 end function phi_t2phi_cf @ <>= pure function t2_vv_1 (g, v1, v2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(tensor) :: tmp type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp = v1.tprod.v2 tmp_s = v1 * v2 t%t = g * (tmp%t + transpose (tmp%t) - tmp_s * t_metric%t ) end function t2_vv_1 @ <>= pure function v_t2v_1 (g, t, v) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(vector) :: tv, tmp_tv type(tensor) :: tmp tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tmp%t = t%t + transpose (t%t) tv = g * (tmp * v - tmp_tv) end function v_t2v_1 @ <>= pure function t2_vv_t (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g complex(kind=default) :: tmp_s type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: tmp, tmp_v1k2, tmp_v2k1, tmp_k1k2, tmp2 type(tensor) :: t_metric, t t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default tmp = v1.tprod.v2 tmp_s = v1 * v2 tmp_v1k2 = (v2 * k1) * (v1.tprod.k2) tmp_v2k1 = (v1 * k2) * (v2.tprod.k1) tmp_k1k2 = tmp_s * (k1.tprod.k2) tmp2%t = tmp_v1k2%t + tmp_v2k1%t - tmp_k1k2%t t%t = g * ( (k1*k2) * (tmp%t + transpose (tmp%t) - tmp_s * t_metric%t ) & + ((v1 * k2) * (v2 * k1)) * t_metric%t & - tmp2%t - transpose(tmp2%t)) end function t2_vv_t @ <>= pure function v_t2v_t (g, t, kt, v, kv) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t type(vector), intent(in) :: v type(momentum), intent(in) :: kt, kv type(momentum) :: kout type(vector) :: tv, tmp_tv type(tensor) :: tmp kout = - (kt + kv) tmp_tv = ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * v tmp%t = t%t + transpose (t%t) tv = g * ( (tmp * v - tmp_tv) * (kv * kout )& + ( t%t(0,0)-t%t(1,1)-t%t(2,2)-t%t(3,3) ) * (kout * v ) * kv & - (kout * v) * ( tmp * kv) & - (v* (t * kout) + kout * (t * v)) * kv & + (kout* (t * kv) + kv * (t * kout)) * v) end function v_t2v_t @ <>= public :: t2_vv_d5_1, v_t2v_d5_1 @ <>= pure function t2_vv_d5_1 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (v1 * v2)) * (k1-k2).tprod.(k1-k2) end function t2_vv_d5_1 @ <>= pure function v_t2v_d5_1 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv tv = (g * ((k1+2*k2).tprod.(k1+2*k2) * t1)) * v2 end function v_t2v_d5_1 @ <>= public :: t2_vv_d5_2, v_t2v_d5_2 @ <>= pure function t2_vv_d5_2 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (k2 * v1)) * (k2-k1).tprod.v2 t%t = t%t + transpose (t%t) end function t2_vv_d5_2 @ <>= pure function v_t2v_d5_2 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv type(tensor) :: tmp type(momentum) :: k1_k2, k1_2k2 k1_k2 = k1 + k2 k1_2k2 = k1_k2 + k2 tmp%t = t1%t + transpose (t1%t) tv = (g * (k1_k2 * v2)) * (k1_2k2 * tmp) end function v_t2v_d5_2 @ <>= public :: t2_vv_d7, v_t2v_d7 @ <>= pure function t2_vv_d7 (g, v1, k1, v2, k2) result (t) complex(kind=default), intent(in) :: g type(vector), intent(in) :: v1, v2 type(momentum), intent(in) :: k1, k2 type(tensor) :: t t = (g * (k2 * v1) * (k1 * v2)) * (k1-k2).tprod.(k1-k2) end function t2_vv_d7 @ <>= pure function v_t2v_d7 (g, t1, k1, v2, k2) result (tv) complex(kind=default), intent(in) :: g type(tensor), intent(in) :: t1 type(vector), intent(in) :: v2 type(momentum), intent(in) :: k1, k2 type(vector) :: tv type(vector) :: k1_k2, k1_2k2 k1_k2 = k1 + k2 k1_2k2 = k1_k2 + k2 tv = (- g * (k1_k2 * v2) * (k1_2k2.tprod.k1_2k2 * t1)) * k2 end function v_t2v_d7 @ \section{Spinor Couplings} <<[[omega_spinor_couplings.f90]]>>= <> module omega_spinor_couplings use kinds use constants use omega_spinors use omega_vectors use omega_tensors use omega_couplings implicit none private <> <> <> <> integer, parameter, public :: omega_spinor_cpls_2010_01_A = 0 contains <> <> <> <> end module omega_spinor_couplings @ See table~\ref{tab:fermionic-currents} for the names of Fortran functions. We could have used long names instead, but this would increase the chance of running past continuation line limits without adding much to the legibility. @ \subsection{Fermionic Vector and Axial Couplings} There's more than one chiral representation. This one is compatible with HELAS~\cite{HELAS}. \begin{equation} \gamma^0 = \begin{pmatrix} 0 & \mathbf{1} \\ \mathbf{1} & 0 \end{pmatrix},\; \gamma^i = \begin{pmatrix} 0 & \sigma^i \\ -\sigma^i & 0 \end{pmatrix},\; \gamma_5 = i\gamma^0\gamma^1\gamma^2\gamma^3 = \begin{pmatrix} -\mathbf{1} & 0 \\ 0 & \mathbf{1} \end{pmatrix} \end{equation} Therefore \begin{subequations} \begin{align} g_S + g_P\gamma_5 &= \begin{pmatrix} g_S - g_P & 0 & 0 & 0 \\ 0 & g_S - g_P & 0 & 0 \\ 0 & 0 & g_S + g_P & 0 \\ 0 & 0 & 0 & g_S + g_P \end{pmatrix} \\ g_V\gamma^0 - g_A\gamma^0\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & g_V - g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \\ g_V\gamma^1 - g_A\gamma^1\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & g_V - g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^2 - g_A\gamma^2\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & -\ii(g_V - g_A) \\ 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \\ -\ii(g_V + g_A) & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^3 - g_A\gamma^3\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ - g_V - g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \end{align} \end{subequations} \begin{table} \begin{center} \begin{tabular}{>{$}l<{$}|>{$}l<{$}} \bar\psi(g_V\gamma^\mu - g_A\gamma^\mu\gamma_5)\psi & \text{\texttt{va\_ff}}(g_V,g_A,\bar\psi,\psi) \\ g_V\bar\psi\gamma^\mu\psi & \text{\texttt{v\_ff}}(g_V,\bar\psi,\psi) \\ g_A\bar\psi\gamma_5\gamma^\mu\psi & \text{\texttt{a\_ff}}(g_A,\bar\psi,\psi) \\ g_L\bar\psi\gamma^\mu(1-\gamma_5)\psi & \text{\texttt{vl\_ff}}(g_L,\bar\psi,\psi) \\ g_R\bar\psi\gamma^\mu(1+\gamma_5)\psi & \text{\texttt{vr\_ff}}(g_R,\bar\psi,\psi) \\\hline \fmslash{V}(g_V - g_A\gamma_5)\psi & \text{\texttt{f\_vaf}}(g_V,g_A,V,\psi) \\ g_V\fmslash{V}\psi & \text{\texttt{f\_vf}}(g_V,V,\psi) \\ g_A\gamma_5\fmslash{V}\psi & \text{\texttt{f\_af}}(g_A,V,\psi) \\ g_L\fmslash{V}(1-\gamma_5)\psi & \text{\texttt{f\_vlf}}(g_L,V,\psi) \\ g_R\fmslash{V}(1+\gamma_5)\psi & \text{\texttt{f\_vrf}}(g_R,V,\psi) \\\hline \bar\psi\fmslash{V}(g_V - g_A\gamma_5) & \text{\texttt{f\_fva}}(g_V,g_A,\bar\psi,V) \\ g_V\bar\psi\fmslash{V} & \text{\texttt{f\_fv}}(g_V,\bar\psi,V) \\ g_A\bar\psi\gamma_5\fmslash{V} & \text{\texttt{f\_fa}}(g_A,\bar\psi,V) \\ g_L\bar\psi\fmslash{V}(1-\gamma_5) & \text{\texttt{f\_fvl}}(g_L,\bar\psi,V) \\ g_R\bar\psi\fmslash{V}(1+\gamma_5) & \text{\texttt{f\_fvr}}(g_R,\bar\psi,V) \end{tabular} \end{center} \caption{\label{tab:fermionic-currents} Mnemonically abbreviated names of Fortran functions implementing fermionic vector and axial currents.} \end{table} \begin{table} \begin{center} \begin{tabular}{>{$}l<{$}|>{$}l<{$}} \bar\psi(g_S + g_P\gamma_5)\psi & \text{\texttt{sp\_ff}}(g_S,g_P,\bar\psi,\psi) \\ g_S\bar\psi\psi & \text{\texttt{s\_ff}}(g_S,\bar\psi,\psi) \\ g_P\bar\psi\gamma_5\psi & \text{\texttt{p\_ff}}(g_P,\bar\psi,\psi) \\ g_L\bar\psi(1-\gamma_5)\psi & \text{\texttt{sl\_ff}}(g_L,\bar\psi,\psi) \\ g_R\bar\psi(1+\gamma_5)\psi & \text{\texttt{sr\_ff}}(g_R,\bar\psi,\psi) \\\hline \phi(g_S + g_P\gamma_5)\psi & \text{\texttt{f\_spf}}(g_S,g_P,\phi,\psi) \\ g_S\phi\psi & \text{\texttt{f\_sf}}(g_S,\phi,\psi) \\ g_P\phi\gamma_5\psi & \text{\texttt{f\_pf}}(g_P,\phi,\psi) \\ g_L\phi(1-\gamma_5)\psi & \text{\texttt{f\_slf}}(g_L,\phi,\psi) \\ g_R\phi(1+\gamma_5)\psi & \text{\texttt{f\_srf}}(g_R,\phi,\psi) \\\hline \bar\psi\phi(g_S + g_P\gamma_5) & \text{\texttt{f\_fsp}}(g_S,g_P,\bar\psi,\phi) \\ g_S\bar\psi\phi & \text{\texttt{f\_fs}}(g_S,\bar\psi,\phi) \\ g_P\bar\psi\phi\gamma_5 & \text{\texttt{f\_fp}}(g_P,\bar\psi,\phi) \\ g_L\bar\psi\phi(1-\gamma_5) & \text{\texttt{f\_fsl}}(g_L,\bar\psi,\phi) \\ g_R\bar\psi\phi(1+\gamma_5) & \text{\texttt{f\_fsr}}(g_R,\bar\psi,\phi) \end{tabular} \end{center} \caption{\label{tab:fermionic-scalar currents} Mnemonically abbreviated names of Fortran functions implementing fermionic scalar and pseudo scalar ``currents''.} \end{table} <>= public :: va_ff, v_ff, a_ff, vl_ff, vr_ff, vlr_ff, grav_ff, va2_ff, & tva_ff, tlr_ff, trl_ff, tvam_ff, tlrm_ff, trlm_ff, va3_ff @ <>= pure function va_ff (gv, ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gv + ga gr = gv - ga g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gr * ( g13 + g24) + gl * ( g31 + g42) j%x(1) = gr * ( g14 + g23) - gl * ( g32 + g41) j%x(2) = (gr * ( - g14 + g23) + gl * ( g32 - g41)) * (0, 1) j%x(3) = gr * ( g13 - g24) + gl * ( - g31 + g42) end function va_ff @ <>= pure function va2_ff (gva, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in), dimension(2) :: gva type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gva(1) + gva(2) gr = gva(1) - gva(2) g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gr * ( g13 + g24) + gl * ( g31 + g42) j%x(1) = gr * ( g14 + g23) - gl * ( g32 + g41) j%x(2) = (gr * ( - g14 + g23) + gl * ( g32 - g41)) * (0, 1) j%x(3) = gr * ( g13 - g24) + gl * ( - g31 + g42) end function va2_ff @ <>= pure function va3_ff (gv, ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = va_ff (gv, ga, psibar, psi) j%t = 0.0_default end function va3_ff @ <>= pure function tva_ff (gv, ga, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g12, g21, g1m2, g34, g43, g3m4 gr = gv + ga gl = gv - ga g12 = psibar%a(1)*psi%a(2) g21 = psibar%a(2)*psi%a(1) g1m2 = psibar%a(1)*psi%a(1) - psibar%a(2)*psi%a(2) g34 = psibar%a(3)*psi%a(4) g43 = psibar%a(4)*psi%a(3) g3m4 = psibar%a(3)*psi%a(3) - psibar%a(4)*psi%a(4) t%e(1) = (gl * ( - g12 - g21) + gr * ( g34 + g43)) * (0, 1) t%e(2) = gl * ( - g12 + g21) + gr * ( g34 - g43) t%e(3) = (gl * ( - g1m2 ) + gr * ( g3m4 )) * (0, 1) t%b(1) = gl * ( g12 + g21) + gr * ( g34 + g43) t%b(2) = (gl * ( - g12 + g21) + gr * ( - g34 + g43)) * (0, 1) t%b(3) = gl * ( g1m2 ) + gr * ( g3m4 ) end function tva_ff @ <>= pure function tlr_ff (gl, gr, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function tlr_ff @ <>= pure function trl_ff (gr, gl, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function trl_ff @ <>= pure function tvam_ff (gv, ga, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = (tva_ff(gv, ga, psibar, psi) * p) * (0,1) end function tvam_ff @ <>= pure function tlrm_ff (gl, gr, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function tlrm_ff @ <>= pure function trlm_ff (gr, gl, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function trlm_ff @ Special cases that avoid some multiplications <>= pure function v_ff (gv, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gv * ( g13 + g24 + g31 + g42) j%x(1) = gv * ( g14 + g23 - g32 - g41) j%x(2) = gv * ( - g14 + g23 + g32 - g41) * (0, 1) j%x(3) = gv * ( g13 - g24 - g31 + g42) end function v_ff @ <>= pure function a_ff (ga, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: ga type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = ga * ( - g13 - g24 + g31 + g42) j%x(1) = - ga * ( g14 + g23 + g32 + g41) j%x(2) = ga * ( g14 - g23 + g32 - g41) * (0, 1) j%x(3) = ga * ( - g13 + g24 - g31 + g42) end function a_ff @ <>= pure function vl_ff (gl, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: g31, g32, g41, g42 gl2 = 2 * gl g31 = psibar%a(3)*psi%a(1) g32 = psibar%a(3)*psi%a(2) g41 = psibar%a(4)*psi%a(1) g42 = psibar%a(4)*psi%a(2) j%t = gl2 * ( g31 + g42) j%x(1) = - gl2 * ( g32 + g41) j%x(2) = gl2 * ( g32 - g41) * (0, 1) j%x(3) = gl2 * ( - g31 + g42) end function vl_ff @ <>= pure function vr_ff (gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: g13, g14, g23, g24 gr2 = 2 * gr g13 = psibar%a(1)*psi%a(3) g14 = psibar%a(1)*psi%a(4) g23 = psibar%a(2)*psi%a(3) g24 = psibar%a(2)*psi%a(4) j%t = gr2 * ( g13 + g24) j%x(1) = gr2 * ( g14 + g23) j%x(2) = gr2 * ( - g14 + g23) * (0, 1) j%x(3) = gr2 * ( g13 - g24) end function vr_ff @ <>= pure function grav_ff (g, m, kb, k, psibar, psi) result (j) type(tensor) :: j complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi type(momentum), intent(in) :: kb, k complex(kind=default) :: g2, g8, c_dum type(vector) :: v_dum type(tensor) :: t_metric t_metric%t = 0 t_metric%t(0,0) = 1.0_default t_metric%t(1,1) = - 1.0_default t_metric%t(2,2) = - 1.0_default t_metric%t(3,3) = - 1.0_default g2 = g/2.0_default g8 = g/8.0_default v_dum = v_ff(g8, psibar, psi) c_dum = (- m) * s_ff (g2, psibar, psi) - (kb+k)*v_dum j = c_dum*t_metric - (((kb+k).tprod.v_dum) + & (v_dum.tprod.(kb+k))) end function grav_ff @ \begin{equation} g_L\gamma_\mu(1-\gamma_5) + g_R\gamma_\mu(1+\gamma_5) = (g_L+g_R)\gamma_\mu - (g_L-g_R)\gamma_\mu\gamma_5 = g_V\gamma_\mu - g_A\gamma_\mu\gamma_5 \end{equation} \ldots{} give the compiler the benefit of the doubt that it will optimize the function all. If not, we could inline it \ldots <>= pure function vlr_ff (gl, gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = va_ff (gl+gr, gl-gr, psibar, psi) end function vlr_ff @ and \begin{equation} \fmslash{v} - \fmslash{a}\gamma_5 = \begin{pmatrix} 0 & 0 & v_- - a_- & - v^* + a^* \\ 0 & 0 & - v + a & v_+ - a_+ \\ v_+ + a_+ & v^* + a^* & 0 & 0 \\ v + a & v_- + a_- & 0 & 0 \end{pmatrix} \end{equation} with $v_\pm=v_0\pm v_3$, $a_\pm=a_0\pm a_3$, $v=v_1+\ii v_2$, $v^*=v_1-\ii v_2$, $a=a_1+\ii a_2$, and $a^*=a_1-\ii a_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$v_\mu$ or~$a_\mu$. <>= public :: f_vaf, f_vf, f_af, f_vlf, f_vrf, f_vlrf, f_va2f, & f_tvaf, f_tlrf, f_trlf, f_tvamf, f_tlrmf, f_trlmf, f_va3f @ <>= pure function f_vaf (gv, ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vaf @ <>= pure function f_va2f (gva, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in), dimension(2) :: gva type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va2f @ <>= pure function f_va3f (gv, ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%x(3) !+ v%t vm = - v%x(3) !+ v%t v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va3f @ <>= pure function f_tvaf (gv, ga, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gv, ga type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) tpsi%a(1) = 2*gl * ( psi%a(1) * be3 + psi%a(2) * ( e21 +b12s)) tpsi%a(2) = 2*gl * ( - psi%a(2) * be3 + psi%a(1) * (-e21s+b12 )) tpsi%a(3) = 2*gr * ( psi%a(3) * be3s + psi%a(4) * (-e21 +b12s)) tpsi%a(4) = 2*gr * ( - psi%a(4) * be3s + psi%a(3) * ( e21s+b12 )) end function f_tvaf @ <>= pure function f_tlrf (gl, gr, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_tlrf @ <>= pure function f_trlf (gr, gl, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(spinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_trlf @ <>= pure function f_tvamf (gv, ga, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) vpsi = f_tvaf(gv, ga, t, psi) end function f_tvamf @ <>= pure function f_tlrmf (gl, gr, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_tlrmf @ <>= pure function f_trlmf (gr, gl, v, psi, k) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_trlmf @ <>= pure function f_vf (gv, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gv type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gv * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gv * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gv * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gv * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vf @ <>= pure function f_af (ga, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = ga * ( - vm * psi%a(3) + v12s * psi%a(4)) vpsi%a(2) = ga * ( v12 * psi%a(3) - vp * psi%a(4)) vpsi%a(3) = ga * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = ga * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_af @ <>= pure function f_vlf (gl, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = 0 vpsi%a(2) = 0 vpsi%a(3) = gl2 * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl2 * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vlf @ <>= pure function f_vrf (gr, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr2 * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr2 * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = 0 vpsi%a(4) = 0 end function f_vrf @ <>= pure function f_vlrf (gl, gr, v, psi) result (vpsi) type(spinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(spinor), intent(in) :: psi vpsi = f_vaf (gl+gr, gl-gr, v, psi) end function f_vlrf @ <>= public :: f_fva, f_fv, f_fa, f_fvl, f_fvr, f_fvlr, f_fva2, & f_ftva, f_ftlr, f_ftrl, f_ftvam, f_ftlrm, f_ftrlm, f_fva3 @ <>= pure function f_fva (gv, ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva @ <>= pure function f_fva2 (gva, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in), dimension(2) :: gva type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva2 @ <>= pure function f_fva3 (gv, ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%x(3) !+ v%t vm = - v%x(3) !+ v%t v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gr * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fva3 @ <>= pure function f_ftva (gv, ga, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) psibart%a(1) = 2*gl * ( psibar%a(1) * be3 + psibar%a(2) * (-e21s+b12 )) psibart%a(2) = 2*gl * ( - psibar%a(2) * be3 + psibar%a(1) * ( e21 +b12s)) psibart%a(3) = 2*gr * ( psibar%a(3) * be3s + psibar%a(4) * ( e21s+b12 )) psibart%a(4) = 2*gr * ( - psibar%a(4) * be3s + psibar%a(3) * (-e21 +b12s)) end function f_ftva @ <>= pure function f_ftlr (gl, gr, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t psibart = f_ftva (gr+gl, gr-gl, psibar, t) end function f_ftlr @ <>= pure function f_ftrl (gr, gl, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(tensor2odd), intent(in) :: t psibart = f_ftva (gr+gl, gr-gl, psibar, t) end function f_ftrl @ <>= pure function f_ftvam (gv, ga, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv, ga type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) psibarv = f_ftva(gv, ga, psibar, t) end function f_ftvam @ <>= pure function f_ftlrm (gl, gr, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k psibarv = f_ftvam (gr+gl, gr-gl, psibar, v, k) end function f_ftlrm @ <>= pure function f_ftrlm (gr, gl, psibar, v, k) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v type(momentum), intent(in) :: k psibarv = f_ftvam (gr+gl, gr-gl, psibar, v, k) end function f_ftrlm @ <>= pure function f_fv (gv, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gv type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gv * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gv * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = gv * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gv * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fv @ <>= pure function f_fa (ga, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(conjspinor), intent(in) :: psibar complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = ga * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = ga * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = ga * ( - psibar%a(1) * vm + psibar%a(2) * v12) psibarv%a(4) = ga * ( psibar%a(1) * v12s - psibar%a(2) * vp ) end function f_fa @ <>= pure function f_fvl (gl, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = gl2 * ( psibar%a(3) * vp + psibar%a(4) * v12) psibarv%a(2) = gl2 * ( psibar%a(3) * v12s + psibar%a(4) * vm ) psibarv%a(3) = 0 psibarv%a(4) = 0 end function f_fvl @ <>= pure function f_fvr (gr, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) psibarv%a(1) = 0 psibarv%a(2) = 0 psibarv%a(3) = gr2 * ( psibar%a(1) * vm - psibar%a(2) * v12) psibarv%a(4) = gr2 * ( - psibar%a(1) * v12s + psibar%a(2) * vp ) end function f_fvr @ <>= pure function f_fvlr (gl, gr, psibar, v) result (psibarv) type(conjspinor) :: psibarv complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(vector), intent(in) :: v psibarv = f_fva (gl+gr, gl-gr, psibar, v) end function f_fvlr @ \subsection{Fermionic Scalar and Pseudo Scalar Couplings} <>= public :: sp_ff, s_ff, p_ff, sl_ff, sr_ff, slr_ff @ <>= pure function sp_ff (gs, gp, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs, gp type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = (gs - gp) * (psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2)) & + (gs + gp) * (psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4)) end function sp_ff @ <>= pure function s_ff (gs, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = gs * (psibar * psi) end function s_ff @ <>= pure function p_ff (gp, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gp type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = gp * ( psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4) & - psibar%a(1)*psi%a(1) - psibar%a(2)*psi%a(2)) end function p_ff @ <>= pure function sl_ff (gl, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = 2 * gl * (psibar%a(1)*psi%a(1) + psibar%a(2)*psi%a(2)) end function sl_ff @ <>= pure function sr_ff (gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = 2 * gr * (psibar%a(3)*psi%a(3) + psibar%a(4)*psi%a(4)) end function sr_ff @ \begin{equation} g_L(1-\gamma_5) + g_R(1+\gamma_5) = (g_R+g_L) + (g_R-g_L)\gamma_5 = g_S + g_P\gamma_5 \end{equation} <>= pure function slr_ff (gl, gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar type(spinor), intent(in) :: psi j = sp_ff (gr+gl, gr-gl, psibar, psi) end function slr_ff @ <>= public :: f_spf, f_sf, f_pf, f_slf, f_srf, f_slrf @ <>= pure function f_spf (gs, gp, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gs, gp complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = ((gs - gp) * phi) * psi%a(1:2) phipsi%a(3:4) = ((gs + gp) * phi) * psi%a(3:4) end function f_spf @ <>= pure function f_sf (gs, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gs complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a = (gs * phi) * psi%a end function f_sf @ <>= pure function f_pf (gp, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gp complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = (- gp * phi) * psi%a(1:2) phipsi%a(3:4) = ( gp * phi) * psi%a(3:4) end function f_pf @ <>= pure function f_slf (gl, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = (2 * gl * phi) * psi%a(1:2) phipsi%a(3:4) = 0 end function f_slf @ <>= pure function f_srf (gr, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi%a(1:2) = 0 phipsi%a(3:4) = (2 * gr * phi) * psi%a(3:4) end function f_srf @ <>= pure function f_slrf (gl, gr, phi, psi) result (phipsi) type(spinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(spinor), intent(in) :: psi phipsi = f_spf (gr+gl, gr-gl, phi, psi) end function f_slrf @ <>= public :: f_fsp, f_fs, f_fp, f_fsl, f_fsr, f_fslr @ <>= pure function f_fsp (gs, gp, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gs, gp type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = ((gs - gp) * phi) * psibar%a(1:2) psibarphi%a(3:4) = ((gs + gp) * phi) * psibar%a(3:4) end function f_fsp @ <>= pure function f_fs (gs, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gs type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a = (gs * phi) * psibar%a end function f_fs @ <>= pure function f_fp (gp, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gp type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = (- gp * phi) * psibar%a(1:2) psibarphi%a(3:4) = ( gp * phi) * psibar%a(3:4) end function f_fp @ <>= pure function f_fsl (gl, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gl type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = (2 * gl * phi) * psibar%a(1:2) psibarphi%a(3:4) = 0 end function f_fsl @ <>= pure function f_fsr (gr, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gr type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi%a(1:2) = 0 psibarphi%a(3:4) = (2 * gr * phi) * psibar%a(3:4) end function f_fsr @ <>= pure function f_fslr (gl, gr, psibar, phi) result (psibarphi) type(conjspinor) :: psibarphi complex(kind=default), intent(in) :: gl, gr type(conjspinor), intent(in) :: psibar complex(kind=default), intent(in) :: phi psibarphi = f_fsp (gr+gl, gr-gl, psibar, phi) end function f_fslr <>= public :: f_gravf, f_fgrav @ <>= pure function f_gravf (g, m, kb, k, t, psi) result (tpsi) type(spinor) :: tpsi complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(spinor), intent(in) :: psi type(tensor), intent(in) :: t type(momentum), intent(in) :: kb, k complex(kind=default) :: g2, g8, t_tr type(vector) :: kkb kkb = k + kb g2 = g / 2.0_default g8 = g / 8.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) tpsi = (- f_sf (g2, cmplx (m,0.0, kind=default), psi) & - f_vf ((g8*m), kkb, psi)) * t_tr - & f_vf (g8,(t*kkb + kkb*t),psi) end function f_gravf @ <>= pure function f_fgrav (g, m, kb, k, psibar, t) result (psibart) type(conjspinor) :: psibart complex(kind=default), intent(in) :: g real(kind=default), intent(in) :: m type(conjspinor), intent(in) :: psibar type(tensor), intent(in) :: t type(momentum), intent(in) :: kb, k type(vector) :: kkb complex(kind=default) :: g2, g8, t_tr kkb = k + kb g2 = g / 2.0_default g8 = g / 8.0_default t_tr = t%t(0,0) - t%t(1,1) - t%t(2,2) - t%t(3,3) psibart = (- f_fs (g2, psibar, cmplx (m, 0.0, kind=default)) & - f_fv ((g8 * m), psibar, kkb)) * t_tr - & f_fv (g8,psibar,(t*kkb + kkb*t)) end function f_fgrav @ \subsection{On Shell Wave Functions} <>= public :: u, ubar, v, vbar private :: chi_plus, chi_minus @ \begin{subequations} \begin{align} \chi_+(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} |\vec p|+p_3 \\ p_1 + \ii p_2 \end{pmatrix} \\ \chi_-(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} - p_1 + \ii p_2 \\ |\vec p|+p_3 \end{pmatrix} \end{align} \end{subequations} <>= pure function chi_plus (p) result (chi) complex(kind=default), dimension(2) :: chi type(momentum), intent(in) :: p real(kind=default) :: pabs pabs = sqrt (dot_product (p%x, p%x)) if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chi = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) else chi = 1 / sqrt (2*pabs*(pabs + p%x(3))) & * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) end if end function chi_plus @ <>= pure function chi_minus (p) result (chi) complex(kind=default), dimension(2) :: chi type(momentum), intent(in) :: p real(kind=default) :: pabs pabs = sqrt (dot_product (p%x, p%x)) if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chi = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else chi = 1 / sqrt (2*pabs*(pabs + p%x(3))) & * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if end function chi_minus @ \begin{equation} u_\pm(p,|m|) = \begin{pmatrix} \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix}\qquad u_\pm(p,-|m|) = \begin{pmatrix} - i \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ + i \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix} \end{equation} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. Even if the mass is not used in the chiral representation, we do so for symmetry with polarization vectors and to be prepared for other representations. <>= pure function u (mass, p, s) result (psi) type(spinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chi real(kind=default) :: pabs, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if select case (s) case (1) chi = chi_plus (p) psi%a(1:2) = delta * chi psi%a(3:4) = sqrt (p%t + pabs) * chi case (-1) chi = chi_minus (p) psi%a(1:2) = sqrt (p%t + pabs) * chi psi%a(3:4) = delta * chi case default pabs = m ! make the compiler happy and use m psi%a = 0 end select if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function u @ <>= pure function ubar (m, p, s) result (psibar) type(conjspinor) :: psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(spinor) :: psi psi = u (m, p, s) psibar%a(1:2) = conjg (psi%a(3:4)) psibar%a(3:4) = conjg (psi%a(1:2)) end function ubar @ \begin{equation} v_\pm(p) = \begin{pmatrix} \mp\sqrt{p_0\pm|\vec p|} \cdot \chi_\mp(\vec p) \\ \pm\sqrt{p_0\mp|\vec p|} \cdot \chi_\mp(\vec p) \end{pmatrix} \end{equation} <>= pure function v (mass, p, s) result (psi) type(spinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chi real(kind=default) :: pabs, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if select case (s) case (1) chi = chi_minus (p) psi%a(1:2) = - sqrt (p%t + pabs) * chi psi%a(3:4) = delta * chi case (-1) chi = chi_plus (p) psi%a(1:2) = delta * chi psi%a(3:4) = - sqrt (p%t + pabs) * chi case default pabs = m ! make the compiler happy and use m psi%a = 0 end select if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function v @ <>= pure function vbar (m, p, s) result (psibar) type(conjspinor) :: psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(spinor) :: psi psi = v (m, p, s) psibar%a(1:2) = conjg (psi%a(3:4)) psibar%a(3:4) = conjg (psi%a(1:2)) end function vbar @ \subsection{Off Shell Wave Functions} I've just taken this over from Christian Schwinn's version. <>= public :: brs_u, brs_ubar, brs_v, brs_vbar @ The off-shell wave functions needed for gauge checking are obtained from the LSZ-formulas: \begin{subequations} \begin{align} \Braket{\text{Out}|d^\dagger|\text{In}}&=i\int d^4x \bar v e^{-ikx}(i\fmslash\partial-m)\Braket{\text{Out}|\psi|\text{In}}\\ \Braket{\text{Out}|b|\text{In}}&=-i\int d^4x \bar u e^{ikx}(i\fmslash\partial-m)\Braket{\text{Out}|\psi|\text{In}}\\ \Braket{\text{Out}|d|\text{In}}&= i\int d^4x \Braket{\text{Out}|\bar \psi| \text{In}}(-i\fmslash{\overleftarrow\partial}-m)v e^{ikx}\\ \Braket{\text{Out}|b^\dagger|\text{In}}&= -i\int d^4x \Braket{\text{Out}|\bar \psi| \text{In}}(-i\fmslash{\overleftarrow\partial}-m)u e^{-ikx} \end{align} \end{subequations} Since the relative sign between fermions and antifermions is ignored for on-shell amplitudes we must also ignore it here, so all wavefunctions must have a $(-i)$ factor. In momentum space we have: \begin{equation} brs u(p)=(-i) (\fmslash p-m)u(p) \end{equation} <>= pure function brs_u (m, p, s) result (dpsi) type(spinor) :: dpsi,psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=u(m,p,s) dpsi=cmplx(0.0,-1.0)*(f_vf(one,vp,psi)-m*psi) end function brs_u @ \begin{equation} brs v(p)=i (\fmslash p+m)v(p) \end{equation} <>= pure function brs_v (m, p, s) result (dpsi) type(spinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=v(m,p,s) dpsi=cmplx(0.0,1.0)*(f_vf(one,vp,psi)+m*psi) end function brs_v @ \begin{equation} brs \bar{u}(p)=(-i)\bar u(p)(\fmslash p-m) \end{equation} <>= pure function brs_ubar (m, p, s)result (dpsibar) type(conjspinor) :: dpsibar, psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psibar=ubar(m,p,s) dpsibar=cmplx(0.0,-1.0)*(f_fv(one,psibar,vp)-m*psibar) end function brs_ubar @ \begin{equation} brs \bar{v}(p)=(i)\bar v(p)(\fmslash p+m) \end{equation} <>= pure function brs_vbar (m, p, s) result (dpsibar) type(conjspinor) :: dpsibar,psibar real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type(vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psibar=vbar(m,p,s) dpsibar=cmplx(0.0,1.0)*(f_fv(one,psibar,vp)+m*psibar) end function brs_vbar @ NB: The remarks on momentum flow in the propagators don't apply here since the incoming momenta are flipped for the wave functions. @ \subsection{Propagators} NB: the common factor of~$\ii$ is extracted: <>= public :: pr_psi, pr_psibar public :: pj_psi, pj_psibar public :: pg_psi, pg_psibar @ \begin{equation} \frac{i(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the particle charge flow is therefore opposite to the momentum. <>= pure function pr_psi (p, m, w, cms, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsi = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (- f_vf (one, vp, psi) + num_mass * psi) end function pr_psi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} (-\fmslash{p}+m)\psi \end{equation} <>= pure function pj_psi (p, m, w, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = (0, -1) * sqrt (PI / m / w) * (- f_vf (one, vp, psi) + m * psi) end function pj_psi @ <>= pure function pg_psi (p, m, w, psi) result (ppsi) type(spinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = gauss(p*p, m, w) * (- f_vf (one, vp, psi) + m * psi) end function pg_psi @ \begin{equation} \bar\psi \frac{i(\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the antiparticle charge flow is therefore parallel to the momentum. <>= pure function pr_psibar (p, m, w, cms, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsibar = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (f_fv (one, psibar, vp) + num_mass * psibar) end function pr_psibar @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} \bar\psi (\fmslash{p}+m) \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the antiparticle charge flow is therefore parallel to the momentum. <>= pure function pj_psibar (p, m, w, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsibar = (0, -1) * sqrt (PI / m / w) * (f_fv (one, psibar, vp) + m * psibar) end function pj_psibar @ <>= pure function pg_psibar (p, m, w, psibar) result (ppsibar) type(conjspinor) :: ppsibar type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(conjspinor), intent(in) :: psibar type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsibar = gauss (p*p, m, w) * (f_fv (one, psibar, vp) + m * psibar) end function pg_psibar @ \begin{equation} \frac{i(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \sum_n \psi_n\otimes\bar\psi_n \end{equation} NB: the temporary variables [[psi(1:4)]] are not nice, but the compilers should be able to optimize the unnecessary copies away. In any case, even if the copies are performed, they are (probably) negligible compared to the floating point multiplications anyway \ldots <<(Not used yet) Declaration of operations for spinors>>= type, public :: spinordyad ! private (omegalib needs access, but DON'T TOUCH IT!) complex(kind=default), dimension(4,4) :: a end type spinordyad @ <<(Not used yet) Implementation of spinor propagators>>= pure function pr_dyadleft (p, m, w, psipsibar) result (psipsibarp) type(spinordyad) :: psipsibarp type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinordyad), intent(in) :: psipsibar integer :: i type(vector) :: vp type(spinor), dimension(4) :: psi complex(kind=default) :: pole complex(kind=default), parameter :: one = (1, 0) vp = p pole = 1 / cmplx (p*p - m**2, m*w, kind=default) do i = 1, 4 psi(i)%a = psipsibar%a(:,i) psi(i) = pole * (- f_vf (one, vp, psi(i)) + m * psi(i)) psipsibarp%a(:,i) = psi(i)%a end do end function pr_dyadleft @ \begin{equation} \sum_n \psi_n\otimes\bar\psi_n \frac{i(\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma} \end{equation} <<(Not used yet) Implementation of spinor propagators>>= pure function pr_dyadright (p, m, w, psipsibar) result (psipsibarp) type(spinordyad) :: psipsibarp type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(spinordyad), intent(in) :: psipsibar integer :: i type(vector) :: vp type(conjspinor), dimension(4) :: psibar complex(kind=default) :: pole complex(kind=default), parameter :: one = (1, 0) vp = p pole = 1 / cmplx (p*p - m**2, m*w, kind=default) do i = 1, 4 psibar(i)%a = psipsibar%a(i,:) psibar(i) = pole * (f_fv (one, psibar(i), vp) + m * psibar(i)) psipsibarp%a(i,:) = psibar(i)%a end do end function pr_dyadright @ \section{Spinor Couplings Revisited} <<[[omega_bispinor_couplings.f90]]>>= <> module omega_bispinor_couplings use kinds use constants use omega_bispinors use omega_vectorspinors use omega_vectors use omega_couplings implicit none private <> <> <> <> integer, parameter, public :: omega_bispinor_cpls_2010_01_A = 0 contains <> <> <> <> end module omega_bispinor_couplings @ See table~\ref{tab:fermionic-currents} for the names of Fortran functions. We could have used long names instead, but this would increase the chance of running past continuation line limits without adding much to the legibility. @ \subsection{Fermionic Vector and Axial Couplings} \label{sec:dirac-matrices-jrr} There's more than one chiral representation. This one is compatible with HELAS~\cite{HELAS}. \begin{subequations} \begin{align} & \gamma^0 = \begin{pmatrix} 0 & \mathbf{1} \\ \mathbf{1} & 0 \end{pmatrix},\; \gamma^i = \begin{pmatrix} 0 & \sigma^i \\ -\sigma^i & 0 \end{pmatrix},\; \gamma_5 = i\gamma^0\gamma^1\gamma^2\gamma^3 = \begin{pmatrix} -\mathbf{1} & 0 \\ 0 & \mathbf{1} \end{pmatrix}, \\ & C = \begin{pmatrix} \epsilon & 0 \\ 0 & - \epsilon \end{pmatrix} \; , \qquad \epsilon = \begin{pmatrix} 0 & 1 \\ -1 & 0 \end{pmatrix} . \end{align} \end{subequations} Therefore \begin{subequations} \begin{align} g_S + g_P\gamma_5 &= \begin{pmatrix} g_S - g_P & 0 & 0 & 0 \\ 0 & g_S - g_P & 0 & 0 \\ 0 & 0 & g_S + g_P & 0 \\ 0 & 0 & 0 & g_S + g_P \end{pmatrix} \\ g_V\gamma^0 - g_A\gamma^0\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & g_V - g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \\ g_V\gamma^1 - g_A\gamma^1\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & g_V - g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^2 - g_A\gamma^2\gamma_5 &= \begin{pmatrix} 0 & 0 & 0 & -\ii(g_V - g_A) \\ 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \\ -\ii(g_V + g_A) & 0 & 0 & 0 \end{pmatrix} \\ g_V\gamma^3 - g_A\gamma^3\gamma_5 &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ - g_V - g_A & 0 & 0 & 0 \\ 0 & g_V + g_A & 0 & 0 \end{pmatrix} \end{align} \end{subequations} and \begin{subequations} \begin{align} C(g_S + g_P\gamma_5) &= \begin{pmatrix} 0 & g_S - g_P & 0 & 0 \\ - g_S + g_P & 0 & 0 & 0 \\ 0 & 0 & 0 & - g_S - g_P \\ 0 & 0 & g_S + g_P & 0 \end{pmatrix} \\ C(g_V\gamma^0 - g_A\gamma^0\gamma_5) &= \begin{pmatrix} 0 & 0 & 0 & g_V - g_A \\ 0 & 0 & - g_V + g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ g_V + g_A & 0 & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^1 - g_A\gamma^1\gamma_5) &= \begin{pmatrix} 0 & 0 & g_V - g_A & 0 \\ 0 & 0 & 0 & - g_V + g_A \\ g_V + g_A & 0 & 0 & 0 \\ 0 & - g_V - g_A & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^2 - g_A\gamma^2\gamma_5) &= \begin{pmatrix} 0 & 0 & \ii(g_V - g_A) & 0 \\ 0 & 0 & 0 & \ii(g_V - g_A) \\ \ii(g_V + g_A) & 0 & 0 & 0 \\ 0 & \ii(g_V + g_A) & 0 & 0 \end{pmatrix} \\ C(g_V\gamma^3 - g_A\gamma^3\gamma_5) &= \begin{pmatrix} 0 & 0 & 0 & - g_V + g_A \\ 0 & 0 & - g_V + g_A & 0 \\ 0 & - g_V - g_A & 0 & 0 \\ - g_V - g_A & 0 & 0 & 0 \end{pmatrix} \end{align} \end{subequations} <>= public :: va_ff, v_ff, a_ff, vl_ff, vr_ff, vlr_ff, va2_ff, tva_ff, tvam_ff, & tlr_ff, tlrm_ff @ <>= pure function va_ff (gv, ga, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gv + ga gr = gv - ga g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gr * ( g14 - g23) + gl * ( - g32 + g41) j%x(1) = gr * ( g13 - g24) + gl * ( g31 - g42) j%x(2) = (gr * ( g13 + g24) + gl * ( g31 + g42)) * (0, 1) j%x(3) = gr * ( - g14 - g23) + gl * ( - g32 - g41) end function va_ff @ <>= pure function va2_ff (gva, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in), dimension(2) :: gva type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl, gr complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 gl = gva(1) + gva(2) gr = gva(1) - gva(2) g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gr * ( g14 - g23) + gl * ( - g32 + g41) j%x(1) = gr * ( g13 - g24) + gl * ( g31 - g42) j%x(2) = (gr * ( g13 + g24) + gl * ( g31 + g42)) * (0, 1) j%x(3) = gr * ( - g14 - g23) + gl * ( - g32 - g41) end function va2_ff @ <>= pure function v_ff (gv, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv type(bispinor), intent(in) :: psil, psir complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gv * ( g14 - g23 - g32 + g41) j%x(1) = gv * ( g13 - g24 + g31 - g42) j%x(2) = gv * ( g13 + g24 + g31 + g42) * (0, 1) j%x(3) = gv * ( - g14 - g23 - g32 - g41) end function v_ff @ <>= pure function a_ff (ga, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: ga type(bispinor), intent(in) :: psil, psir complex(kind=default) :: g13, g14, g23, g24, g31, g32, g41, g42 g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = -ga * ( g14 - g23 + g32 - g41) j%x(1) = -ga * ( g13 - g24 - g31 + g42) j%x(2) = -ga * ( g13 + g24 - g31 - g42) * (0, 1) j%x(3) = -ga * ( - g14 - g23 + g32 + g41) end function a_ff @ <>= pure function vl_ff (gl, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gl2 complex(kind=default) :: g31, g32, g41, g42 gl2 = 2 * gl g31 = psil%a(3)*psir%a(1) g32 = psil%a(3)*psir%a(2) g41 = psil%a(4)*psir%a(1) g42 = psil%a(4)*psir%a(2) j%t = gl2 * ( - g32 + g41) j%x(1) = gl2 * ( g31 - g42) j%x(2) = gl2 * ( g31 + g42) * (0, 1) j%x(3) = gl2 * ( - g32 - g41) end function vl_ff @ <>= pure function vr_ff (gr, psil, psir) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psil, psir complex(kind=default) :: gr2 complex(kind=default) :: g13, g14, g23, g24 gr2 = 2 * gr g13 = psil%a(1)*psir%a(3) g14 = psil%a(1)*psir%a(4) g23 = psil%a(2)*psir%a(3) g24 = psil%a(2)*psir%a(4) j%t = gr2 * ( g14 - g23) j%x(1) = gr2 * ( g13 - g24) j%x(2) = gr2 * ( g13 + g24) * (0, 1) j%x(3) = gr2 * ( - g14 - g23) end function vr_ff @ <>= pure function vlr_ff (gl, gr, psibar, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi j = va_ff (gl+gr, gl-gr, psibar, psi) end function vlr_ff @ <>= pure function tva_ff (gv, ga, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: g11, g22, g33, g44, g1p2, g3p4 gr = gv + ga gl = gv - ga g11 = psibar%a(1)*psi%a(1) g22 = psibar%a(2)*psi%a(2) g1p2 = psibar%a(1)*psi%a(2) + psibar%a(2)*psi%a(1) g3p4 = psibar%a(3)*psi%a(4) + psibar%a(4)*psi%a(3) g33 = psibar%a(3)*psi%a(3) g44 = psibar%a(4)*psi%a(4) t%e(1) = (gl * ( - g11 + g22) + gr * ( - g33 + g44)) * (0, 1) t%e(2) = gl * ( g11 + g22) + gr * ( g33 + g44) t%e(3) = (gl * ( g1p2 ) + gr * ( g3p4 )) * (0, 1) t%b(1) = gl * ( g11 - g22) + gr * ( - g33 + g44) t%b(2) = (gl * ( g11 + g22) + gr * ( - g33 - g44)) * (0, 1) t%b(3) = gl * ( - g1p2 ) + gr * ( g3p4 ) end function tva_ff @ <>= pure function tlr_ff (gl, gr, psibar, psi) result (t) type(tensor2odd) :: t complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi t = tva_ff (gr+gl, gr-gl, psibar, psi) end function tlr_ff @ <>= pure function tvam_ff (gv, ga, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gv, ga type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: p j = (tva_ff(gv, ga, psibar, psi) * p) * (0,1) end function tvam_ff @ <>= pure function tlrm_ff (gl, gr, psibar, psi, p) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: p j = tvam_ff (gr+gl, gr-gl, psibar, psi, p) end function tlrm_ff @ and \begin{equation} \fmslash{v} - \fmslash{a}\gamma_5 = \begin{pmatrix} 0 & 0 & v_- - a_- & - v^* + a^* \\ 0 & 0 & - v + a & v_+ - a_+ \\ v_+ + a_+ & v^* + a^* & 0 & 0 \\ v + a & v_- + a_- & 0 & 0 \end{pmatrix} \end{equation} with $v_\pm=v_0\pm v_3$, $a_\pm=a_0\pm a_3$, $v=v_1+\ii v_2$, $v^*=v_1-\ii v_2$, $a=a_1+\ii a_2$, and $a^*=a_1-\ii a_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$v_\mu$ or~$a_\mu$. <>= public :: f_vaf, f_vf, f_af, f_vlf, f_vrf, f_vlrf, f_va2f, & f_tvaf, f_tlrf, f_tvamf, f_tlrmf @ <>= pure function f_vaf (gv, ga, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gv + ga gr = gv - ga vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vaf @ <>= pure function f_va2f (gva, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in), dimension(2) :: gva type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: vp, vm, v12, v12s gl = gva(1) + gva(2) gr = gva(1) - gva(2) vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gl * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_va2f @ <>= pure function f_vf (gv, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gv * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gv * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = gv * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gv * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vf @ <>= pure function f_af (ga, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: vp, vm, v12, v12s vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = ga * ( - vm * psi%a(3) + v12s * psi%a(4)) vpsi%a(2) = ga * ( v12 * psi%a(3) - vp * psi%a(4)) vpsi%a(3) = ga * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = ga * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_af @ <>= pure function f_vlf (gl, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gl2 complex(kind=default) :: vp, vm, v12, v12s gl2 = 2 * gl vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = 0 vpsi%a(2) = 0 vpsi%a(3) = gl2 * ( vp * psi%a(1) + v12s * psi%a(2)) vpsi%a(4) = gl2 * ( v12 * psi%a(1) + vm * psi%a(2)) end function f_vlf @ <>= pure function f_vrf (gr, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi complex(kind=default) :: gr2 complex(kind=default) :: vp, vm, v12, v12s gr2 = 2 * gr vp = v%t + v%x(3) vm = v%t - v%x(3) v12 = v%x(1) + (0,1)*v%x(2) v12s = v%x(1) - (0,1)*v%x(2) vpsi%a(1) = gr2 * ( vm * psi%a(3) - v12s * psi%a(4)) vpsi%a(2) = gr2 * ( - v12 * psi%a(3) + vp * psi%a(4)) vpsi%a(3) = 0 vpsi%a(4) = 0 end function f_vrf @ <>= pure function f_vlrf (gl, gr, v, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi vpsi = f_vaf (gl+gr, gl-gr, v, psi) end function f_vlrf @ <>= pure function f_tvaf (gv, ga, t, psi) result (tpsi) type(bispinor) :: tpsi complex(kind=default), intent(in) :: gv, ga type(tensor2odd), intent(in) :: t type(bispinor), intent(in) :: psi complex(kind=default) :: gl, gr complex(kind=default) :: e21, e21s, b12, b12s, be3, be3s gr = gv + ga gl = gv - ga e21 = t%e(2) + t%e(1)*(0,1) e21s = t%e(2) - t%e(1)*(0,1) b12 = t%b(1) + t%b(2)*(0,1) b12s = t%b(1) - t%b(2)*(0,1) be3 = t%b(3) + t%e(3)*(0,1) be3s = t%b(3) - t%e(3)*(0,1) tpsi%a(1) = 2*gl * ( psi%a(1) * be3 + psi%a(2) * ( e21 +b12s)) tpsi%a(2) = 2*gl * ( - psi%a(2) * be3 + psi%a(1) * (-e21s+b12 )) tpsi%a(3) = 2*gr * ( psi%a(3) * be3s + psi%a(4) * (-e21 +b12s)) tpsi%a(4) = 2*gr * ( - psi%a(4) * be3s + psi%a(3) * ( e21s+b12 )) end function f_tvaf @ <>= pure function f_tlrf (gl, gr, t, psi) result (tpsi) type(bispinor) :: tpsi complex(kind=default), intent(in) :: gl, gr type(tensor2odd), intent(in) :: t type(bispinor), intent(in) :: psi tpsi = f_tvaf (gr+gl, gr-gl, t, psi) end function f_tlrf @ <>= pure function f_tvamf (gv, ga, v, psi, k) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gv, ga type(vector), intent(in) :: v type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(tensor2odd) :: t t = (v.wedge.k) * (0, 0.5) vpsi = f_tvaf(gv, ga, t, psi) end function f_tvamf @ <>= pure function f_tlrmf (gl, gr, v, psi, k) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: gl, gr type(vector), intent(in) :: v type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k vpsi = f_tvamf (gr+gl, gr-gl, v, psi, k) end function f_tlrmf @ \subsection{Fermionic Scalar and Pseudo Scalar Couplings} <>= public :: sp_ff, s_ff, p_ff, sl_ff, sr_ff, slr_ff @ <>= pure function sp_ff (gs, gp, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs, gp type(bispinor), intent(in) :: psil, psir j = (gs - gp) * (psil%a(1)*psir%a(2) - psil%a(2)*psir%a(1)) & + (gs + gp) * (- psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function sp_ff @ <>= pure function s_ff (gs, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gs type(bispinor), intent(in) :: psil, psir j = gs * (psil * psir) end function s_ff @ <>= pure function p_ff (gp, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gp type(bispinor), intent(in) :: psil, psir j = gp * (- psil%a(1)*psir%a(2) + psil%a(2)*psir%a(1) & - psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function p_ff @ <>= pure function sl_ff (gl, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psil, psir j = 2 * gl * (psil%a(1)*psir%a(2) - psil%a(2)*psir%a(1)) end function sl_ff @ <>= pure function sr_ff (gr, psil, psir) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psil, psir j = 2 * gr * (- psil%a(3)*psir%a(4) + psil%a(4)*psir%a(3)) end function sr_ff @ <>= pure function slr_ff (gl, gr, psibar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor), intent(in) :: psi j = sp_ff (gr+gl, gr-gl, psibar, psi) end function slr_ff @ <>= public :: f_spf, f_sf, f_pf, f_slf, f_srf, f_slrf @ <>= pure function f_spf (gs, gp, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gs, gp complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = ((gs - gp) * phi) * psi%a(1:2) phipsi%a(3:4) = ((gs + gp) * phi) * psi%a(3:4) end function f_spf @ <>= pure function f_sf (gs, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gs complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a = (gs * phi) * psi%a end function f_sf @ <>= pure function f_pf (gp, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gp complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = (- gp * phi) * psi%a(1:2) phipsi%a(3:4) = ( gp * phi) * psi%a(3:4) end function f_pf @ <>= pure function f_slf (gl, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = (2 * gl * phi) * psi%a(1:2) phipsi%a(3:4) = 0 end function f_slf @ <>= pure function f_srf (gr, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%a(1:2) = 0 phipsi%a(3:4) = (2 * gr * phi) * psi%a(3:4) end function f_srf @ <>= pure function f_slrf (gl, gr, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi = f_spf (gr+gl, gr-gl, phi, psi) end function f_slrf @ \subsection{Couplings for BRST Transformations} \subsubsection{3-Couplings} The lists of needed gamma matrices can be found in the next subsection with the gravitino couplings. <>= private :: vv_ff, f_vvf @ <>= public :: vmom_ff, mom_ff, mom5_ff, moml_ff, momr_ff, lmom_ff, rmom_ff @ <>= pure function vv_ff (psibar, psi, k) result (psibarpsi) type(vector) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: k complex(kind=default) :: kp, km, k12, k12s type(bispinor) :: kgpsi1, kgpsi2, kgpsi3, kgpsi4 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kgpsi1%a(1) = -k%x(3) * psi%a(1) - k12s * psi%a(2) kgpsi1%a(2) = -k12 * psi%a(1) + k%x(3) * psi%a(2) kgpsi1%a(3) = k%x(3) * psi%a(3) + k12s * psi%a(4) kgpsi1%a(4) = k12 * psi%a(3) - k%x(3) * psi%a(4) kgpsi2%a(1) = ((0,-1) * k%x(2)) * psi%a(1) - km * psi%a(2) kgpsi2%a(2) = - kp * psi%a(1) + ((0,1) * k%x(2)) * psi%a(2) kgpsi2%a(3) = ((0,-1) * k%x(2)) * psi%a(3) + kp * psi%a(4) kgpsi2%a(4) = km * psi%a(3) + ((0,1) * k%x(2)) * psi%a(4) kgpsi3%a(1) = (0,1) * (k%x(1) * psi%a(1) + km * psi%a(2)) kgpsi3%a(2) = (0,-1) * (kp * psi%a(1) + k%x(1) * psi%a(2)) kgpsi3%a(3) = (0,1) * (k%x(1) * psi%a(3) - kp * psi%a(4)) kgpsi3%a(4) = (0,1) * (km * psi%a(3) - k%x(1) * psi%a(4)) kgpsi4%a(1) = -k%t * psi%a(1) - k12s * psi%a(2) kgpsi4%a(2) = k12 * psi%a(1) + k%t * psi%a(2) kgpsi4%a(3) = k%t * psi%a(3) - k12s * psi%a(4) kgpsi4%a(4) = k12 * psi%a(3) - k%t * psi%a(4) psibarpsi%t = 2 * (psibar * kgpsi1) psibarpsi%x(1) = 2 * (psibar * kgpsi2) psibarpsi%x(2) = 2 * (psibar * kgpsi3) psibarpsi%x(3) = 2 * (psibar * kgpsi4) end function vv_ff @ <>= pure function f_vvf (v, psi, k) result (kvpsi) type(bispinor) :: kvpsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: k, v complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = (0,1) * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = (0,1) * (k%t * v%x(2) - k%x(2) * v%t) kv32 = (0,1) * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * (-kv30 + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) kvpsi%a(1) = am * psi%a(1) + bms * psi%a(2) kvpsi%a(2) = bp * psi%a(1) - am * psi%a(2) kvpsi%a(3) = ap * psi%a(3) - bps * psi%a(4) kvpsi%a(4) = -bm * psi%a(3) - ap * psi%a(4) end function f_vvf @ <>= pure function vmom_ff (g, psibar, psi, k) result (psibarpsi) type(vector) :: psibarpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k type(vector) :: vk vk = k psibarpsi = g * vv_ff (psibar, psi, vk) end function vmom_ff @ <>= pure function mom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: kmpsi complex(kind=default) :: kp, km, k12, k12s kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kmpsi%a(1) = km * psi%a(3) - k12s * psi%a(4) kmpsi%a(2) = kp * psi%a(4) - k12 * psi%a(3) kmpsi%a(3) = kp * psi%a(1) + k12s * psi%a(2) kmpsi%a(4) = k12 * psi%a(1) + km * psi%a(2) psibarpsi = g * (psibar * kmpsi) + s_ff (m, psibar, psi) end function mom_ff @ <>= pure function mom5_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: g5psi g5psi%a(1:2) = - psi%a(1:2) g5psi%a(3:4) = psi%a(3:4) psibarpsi = mom_ff (g, m, psibar, g5psi, k) end function mom5_ff @ <>= pure function moml_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: leftpsi leftpsi%a(1:2) = 2 * psi%a(1:2) leftpsi%a(3:4) = 0 psibarpsi = mom_ff (g, m, psibar, leftpsi, k) end function moml_ff @ <>= pure function momr_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m type(bispinor) :: rightpsi rightpsi%a(1:2) = 0 rightpsi%a(3:4) = 2 * psi%a(3:4) psibarpsi = mom_ff (g, m, psibar, rightpsi, k) end function momr_ff @ <>= pure function lmom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m psibarpsi = mom_ff (g, m, psibar, psi, k) + & mom5_ff (g,-m, psibar, psi, k) end function lmom_ff @ <>= pure function rmom_ff (g, m, psibar, psi, k) result (psibarpsi) complex(kind=default) :: psibarpsi type(bispinor), intent(in) :: psibar, psi type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g, m psibarpsi = mom_ff (g, m, psibar, psi, k) - & mom5_ff (g,-m, psibar, psi, k) end function rmom_ff @ <>= public :: f_vmomf, f_momf, f_mom5f, f_momlf, f_momrf, f_lmomf, f_rmomf @ <>= pure function f_vmomf (g, v, psi, k) result (kvpsi) type(bispinor) :: kvpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: g type(momentum), intent(in) :: k type(vector), intent(in) :: v type(vector) :: vk vk = k kvpsi = g * f_vvf (v, psi, vk) end function f_vmomf @ <>= pure function f_momf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k complex(kind=default) :: kp, km, k12, k12s kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kmpsi%a(1) = km * psi%a(3) - k12s * psi%a(4) kmpsi%a(2) = -k12 * psi%a(3) + kp * psi%a(4) kmpsi%a(3) = kp * psi%a(1) + k12s * psi%a(2) kmpsi%a(4) = k12 * psi%a(1) + km * psi%a(2) kmpsi = g * (phi * kmpsi) + f_sf (m, phi, psi) end function f_momf @ <>= pure function f_mom5f (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: g5psi g5psi%a(1:2) = - psi%a(1:2) g5psi%a(3:4) = psi%a(3:4) kmpsi = f_momf (g, m, phi, g5psi, k) end function f_mom5f @ <>= pure function f_momlf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: leftpsi leftpsi%a(1:2) = 2 * psi%a(1:2) leftpsi%a(3:4) = 0 kmpsi = f_momf (g, m, phi, leftpsi, k) end function f_momlf @ <>= pure function f_momrf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k type(bispinor) :: rightpsi rightpsi%a(1:2) = 0 rightpsi%a(3:4) = 2 * psi%a(3:4) kmpsi = f_momf (g, m, phi, rightpsi, k) end function f_momrf @ <>= pure function f_lmomf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k kmpsi = f_momf (g, m, phi, psi, k) + & f_mom5f (g,-m, phi, psi, k) end function f_lmomf @ <>= pure function f_rmomf (g, m, phi, psi, k) result (kmpsi) type(bispinor) :: kmpsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: phi, g, m type(momentum), intent(in) :: k kmpsi = f_momf (g, m, phi, psi, k) - & f_mom5f (g,-m, phi, psi, k) end function f_rmomf @ \subsubsection{4-Couplings} <>= public :: v2_ff, sv1_ff, sv2_ff, pv1_ff, pv2_ff, svl1_ff, svl2_ff, & svr1_ff, svr2_ff, svlr1_ff, svlr2_ff @ <>= pure function v2_ff (g, psibar, v, psi) result (v2) type(vector) :: v2 complex (kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v v2 = (-g) * vv_ff (psibar, psi, v) end function v2_ff @ <>= pure function sv1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vf (g, v, psi) end function sv1_ff @ <>= pure function sv2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * v_ff (g, psibar, psi) end function sv2_ff @ <>= pure function pv1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = - (psibar * f_af (g, v, psi)) end function pv1_ff @ <>= pure function pv2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = -(phi * a_ff (g, psibar, psi)) end function pv2_ff @ <>= pure function svl1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vlf (g, v, psi) end function svl1_ff @ <>= pure function svl2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * vl_ff (g, psibar, psi) end function svl2_ff @ <>= pure function svr1_ff (g, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g phi = psibar * f_vrf (g, v, psi) end function svr1_ff @ <>= pure function svr2_ff (g, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, g type(bispinor), intent(in) :: psibar, psi v = phi * vr_ff (g, psibar, psi) end function svr2_ff @ <>= pure function svlr1_ff (gl, gr, psibar, v, psi) result (phi) complex(kind=default) :: phi type(bispinor), intent(in) :: psibar, psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr phi = psibar * f_vlrf (gl, gr, v, psi) end function svlr1_ff @ <>= pure function svlr2_ff (gl, gr, psibar, phi, psi) result (v) type(vector) :: v complex(kind=default), intent(in) :: phi, gl, gr type(bispinor), intent(in) :: psibar, psi v = phi * vlr_ff (gl, gr, psibar, psi) end function svlr2_ff @ <>= public :: f_v2f, f_svf, f_pvf, f_svlf, f_svrf, f_svlrf @ <>= pure function f_v2f (g, v1, v2, psi) result (vpsi) type(bispinor) :: vpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psi type(vector), intent(in) :: v1, v2 vpsi = g * f_vvf (v2, psi, v1) end function f_v2f @ <>= pure function f_svf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vf (g, v, psi) end function f_svf @ <>= pure function f_pvf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = -(phi * f_af (g, v, psi)) end function f_pvf @ <>= pure function f_svlf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vlf (g, v, psi) end function f_svlf @ <>= pure function f_svrf (g, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vrf (g, v, psi) end function f_svrf @ <>= pure function f_svlrf (gl, gr, phi, v, psi) result (pvpsi) type(bispinor) :: pvpsi complex(kind=default), intent(in) :: gl, gr, phi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v pvpsi = phi * f_vlrf (gl, gr, v, psi) end function f_svlrf @ \subsection{Gravitino Couplings} <>= public :: pot_grf, pot_fgr, s_grf, s_fgr, p_grf, p_fgr, & sl_grf, sl_fgr, sr_grf, sr_fgr, slr_grf, slr_fgr @ <>= private :: fgvgr, fgvg5gr, fggvvgr, grkgf, grkggf, grkkggf, & fgkgr, fg5gkgr, grvgf, grg5vgf, grkgggf, fggkggr @ <>= pure function pot_grf (g, gravbar, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vectorspinor) :: gamma_psi gamma_psi%psi(1)%a(1) = psi%a(3) gamma_psi%psi(1)%a(2) = psi%a(4) gamma_psi%psi(1)%a(3) = psi%a(1) gamma_psi%psi(1)%a(4) = psi%a(2) gamma_psi%psi(2)%a(1) = psi%a(4) gamma_psi%psi(2)%a(2) = psi%a(3) gamma_psi%psi(2)%a(3) = - psi%a(2) gamma_psi%psi(2)%a(4) = - psi%a(1) gamma_psi%psi(3)%a(1) = (0,-1) * psi%a(4) gamma_psi%psi(3)%a(2) = (0,1) * psi%a(3) gamma_psi%psi(3)%a(3) = (0,1) * psi%a(2) gamma_psi%psi(3)%a(4) = (0,-1) * psi%a(1) gamma_psi%psi(4)%a(1) = psi%a(3) gamma_psi%psi(4)%a(2) = - psi%a(4) gamma_psi%psi(4)%a(3) = - psi%a(1) gamma_psi%psi(4)%a(4) = psi%a(2) j = g * (gravbar * gamma_psi) end function pot_grf @ <>= pure function pot_fgr (g, psibar, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(bispinor) :: gamma_grav gamma_grav%a(1) = grav%psi(1)%a(3) - grav%psi(2)%a(4) + & ((0,1)*grav%psi(3)%a(4)) - grav%psi(4)%a(3) gamma_grav%a(2) = grav%psi(1)%a(4) - grav%psi(2)%a(3) - & ((0,1)*grav%psi(3)%a(3)) + grav%psi(4)%a(4) gamma_grav%a(3) = grav%psi(1)%a(1) + grav%psi(2)%a(2) - & ((0,1)*grav%psi(3)%a(2)) + grav%psi(4)%a(1) gamma_grav%a(4) = grav%psi(1)%a(2) + grav%psi(2)%a(1) + & ((0,1)*grav%psi(3)%a(1)) - grav%psi(4)%a(2) j = g * (psibar * gamma_grav) end function pot_fgr @ <>= pure function grvgf (gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default) :: kp, km, k12, k12s type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: k type(vectorspinor) :: kg_psi kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) !!! Since we are taking the spinor product here, NO explicit !!! charge conjugation matrix is needed! kg_psi%psi(1)%a(1) = km * psi%a(1) - k12s * psi%a(2) kg_psi%psi(1)%a(2) = (-k12) * psi%a(1) + kp * psi%a(2) kg_psi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kg_psi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kg_psi%psi(2)%a(1) = k12s * psi%a(1) - km * psi%a(2) kg_psi%psi(2)%a(2) = (-kp) * psi%a(1) + k12 * psi%a(2) kg_psi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kg_psi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kg_psi%psi(3)%a(1) = (0,1) * (k12s * psi%a(1) + km * psi%a(2)) kg_psi%psi(3)%a(2) = (0,1) * (- kp * psi%a(1) - k12 * psi%a(2)) kg_psi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kg_psi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kg_psi%psi(4)%a(1) = (-km) * psi%a(1) - k12s * psi%a(2) kg_psi%psi(4)%a(2) = k12 * psi%a(1) + kp * psi%a(2) kg_psi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kg_psi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) j = gravbar * kg_psi end function grvgf @ <>= pure function grg5vgf (gravbar, psi, k) result (j) complex(kind=default) :: j type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: k type(bispinor) :: g5_psi g5_psi%a(1:2) = - psi%a(1:2) g5_psi%a(3:4) = psi%a(3:4) j = grvgf (gravbar, g5_psi, k) end function grg5vgf @ <>= pure function s_grf (g, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grvgf (gravbar, psi, vk) end function s_grf @ <>= pure function sl_grf (gl, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(momentum), intent(in) :: k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = s_grf (gl, gravbar, psi_l, k) end function sl_grf @ <>= pure function sr_grf (gr, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(momentum), intent(in) :: k psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = s_grf (gr, gravbar, psi_r, k) end function sr_grf @ <>= pure function slr_grf (gl, gr, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k j = sl_grf (gl, gravbar, psi, k) + sr_grf (gr, gravbar, psi, k) end function slr_grf @ <>= pure function fgkgr (psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: k type(bispinor) :: gk_grav kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) !!! Since we are taking the spinor product here, NO explicit !!! charge conjugation matrix is needed! gk_grav%a(1) = kp * grav%psi(1)%a(1) + k12s * grav%psi(1)%a(2) & - k12 * grav%psi(2)%a(1) - km * grav%psi(2)%a(2) & + (0,1) * k12 * grav%psi(3)%a(1) & + (0,1) * km * grav%psi(3)%a(2) & - kp * grav%psi(4)%a(1) - k12s * grav%psi(4)%a(2) gk_grav%a(2) = k12 * grav%psi(1)%a(1) + km * grav%psi(1)%a(2) & - kp * grav%psi(2)%a(1) - k12s * grav%psi(2)%a(2) & - (0,1) * kp * grav%psi(3)%a(1) & - (0,1) * k12s * grav%psi(3)%a(2) & + k12 * grav%psi(4)%a(1) + km * grav%psi(4)%a(2) gk_grav%a(3) = km * grav%psi(1)%a(3) - k12s * grav%psi(1)%a(4) & - k12 * grav%psi(2)%a(3) + kp * grav%psi(2)%a(4) & + (0,1) * k12 * grav%psi(3)%a(3) & - (0,1) * kp * grav%psi(3)%a(4) & + km * grav%psi(4)%a(3) - k12s * grav%psi(4)%a(4) gk_grav%a(4) = - k12 * grav%psi(1)%a(3) + kp * grav%psi(1)%a(4) & + km * grav%psi(2)%a(3) - k12s * grav%psi(2)%a(4) & + (0,1) * km * grav%psi(3)%a(3) & - (0,1) * k12s * grav%psi(3)%a(4) & + k12 * grav%psi(4)%a(3) - kp * grav%psi(4)%a(4) j = psibar * gk_grav end function fgkgr @ <>= pure function fg5gkgr (psibar, grav, k) result (j) complex(kind=default) :: j type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: k type(bispinor) :: psibar_g5 psibar_g5%a(1:2) = - psibar%a(1:2) psibar_g5%a(3:4) = psibar%a(3:4) j = fgkgr (psibar_g5, grav, k) end function fg5gkgr @ <>= pure function s_fgr (g, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fgkgr (psibar, grav, vk) end function s_fgr @ <>= pure function sl_fgr (gl, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = s_fgr (gl, psibar_l, grav, k) end function sl_fgr @ <>= pure function sr_fgr (gr, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = s_fgr (gr, psibar_r, grav, k) end function sr_fgr @ @ <>= pure function slr_fgr (gl, gr, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k j = sl_fgr (gl, psibar, grav, k) + sr_fgr (gr, psibar, grav, k) end function slr_fgr @ <>= pure function p_grf (g, gravbar, psi, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grg5vgf (gravbar, psi, vk) end function p_grf @ <>= pure function p_fgr (g, psibar, grav, k) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fg5gkgr (psibar, grav, vk) end function p_fgr @ <>= public :: f_potgr, f_sgr, f_pgr, f_vgr, f_vlrgr, f_slgr, f_srgr, f_slrgr @ <>= pure function f_potgr (g, phi, psi) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(vectorspinor), intent(in) :: psi phipsi%a(1) = (g * phi) * (psi%psi(1)%a(3) - psi%psi(2)%a(4) + & ((0,1)*psi%psi(3)%a(4)) - psi%psi(4)%a(3)) phipsi%a(2) = (g * phi) * (psi%psi(1)%a(4) - psi%psi(2)%a(3) - & ((0,1)*psi%psi(3)%a(3)) + psi%psi(4)%a(4)) phipsi%a(3) = (g * phi) * (psi%psi(1)%a(1) + psi%psi(2)%a(2) - & ((0,1)*psi%psi(3)%a(2)) + psi%psi(4)%a(1)) phipsi%a(4) = (g * phi) * (psi%psi(1)%a(2) + psi%psi(2)%a(1) + & ((0,1)*psi%psi(3)%a(1)) - psi%psi(4)%a(2)) end function f_potgr @ The slashed notation: \begin{equation} \fmslash{k} = \begin{pmatrix} 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \\ k_+ & k^* & 0 & 0 \\ k & k_- & 0 & 0 \end{pmatrix} , \qquad \fmslash{k}\gamma_5 = \begin{pmatrix} 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \\ - k_+ & - k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \end{pmatrix} \end{equation} with $k_\pm=k_0\pm k_3$, $k=k_1+\ii k_2$, $k^*=k_1-\ii k_2$. But note that~$\cdot^*$ is \emph{not} complex conjugation for complex~$k_\mu$. \begin{subequations} \begin{alignat}{2} \gamma^0 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} , & \qquad \gamma^0 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} \\ \gamma^1 \fmslash{k} &= \begin{pmatrix} k & k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix}, & \qquad \gamma^1 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k & - k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix} \\ \gamma^2 \fmslash{k} &= \begin{pmatrix} - \ii k & - \ii k_- & 0 & 0 \\ \ii k_+ & \ii k^* & 0 & 0 \\ 0 & 0 & - \ii k & \ii k_+ \\ 0 & 0 & - \ii k_- & \ii k^* \end{pmatrix}, & \qquad \gamma^2 \fmslash{k} \gamma^5 & = \begin{pmatrix} \ii k & \ii k_- & 0 & 0 \\ - \ii k_+ & - \ii k^* & 0 & 0 \\ 0 & 0 & - \ii k & \ii k_+ \\ 0 & 0 & - \ii k_- & \ii k^* \end{pmatrix} \\ \gamma^3 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & - k_- & k^* \\ 0 & 0 & - k & k_+ \end{pmatrix}, & \qquad \gamma^3 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & - k_- & k^* \\ 0 & 0 & - k & k_+ \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} \fmslash{k} \gamma^0&= \begin{pmatrix} k_- & - k^* & 0 & 0 \\ - k & k_+ & 0 & 0 \\ 0 & 0 & k_+ & k^* \\ 0 & 0 & k & k_- \end{pmatrix} , & \qquad \fmslash{k} \gamma^0 \gamma^5 & = \begin{pmatrix} - k_- & k^* & 0 & 0 \\ k & - k_+ & 0 & 0 \\ 0 & 0 & k_+ & k^* \\ 0 & 0 & k & k_- \end{pmatrix} \\ \fmslash{k} \gamma^1 &= \begin{pmatrix} k^* & - k_- & 0 & 0 \\ - k_+ & k & 0 & 0 \\ 0 & 0 & k^* & k_+ \\ 0 & 0 & k_- & k \end{pmatrix}, & \qquad \fmslash{k} \gamma^1 \gamma^5 & = \begin{pmatrix} - k^* & k_- & 0 & 0 \\ k_+ & - k & 0 & 0 \\ 0 & 0 & k^* & k_+ \\ 0 & 0 & k_- & k \end{pmatrix} \\ \fmslash{k} \gamma^2 &= \begin{pmatrix} \ii k^* & \ii k_- & 0 & 0 \\ - \ii k_+ & - \ii k & 0 & 0 \\ 0 & 0 & \ii k^* & - \ii k_+ \\ 0 & 0 & \ii k_- & - \ii k \end{pmatrix}, & \qquad \fmslash{k} \gamma^2 \gamma^5 & = \begin{pmatrix} - \ii k^* & - \ii k_- & 0 & 0 \\ \ii k_+ & \ii k & 0 & 0 \\ 0 & 0 & \ii k^* & - \ii k_+ \\ 0 & 0 & \ii k_- & - \ii k \end{pmatrix} \\ \fmslash{k} \gamma^3 &= \begin{pmatrix} - k_- & - k^* & 0 & 0 \\ k & k_+ & 0 & 0 \\ 0 & 0 & k_+ & - k^* \\ 0 & 0 & k & - k_- \end{pmatrix}, & \qquad \fmslash{k} \gamma^3 \gamma^5 & = \begin{pmatrix} k_- & k^* & 0 & 0 \\ - k & - k_+ & 0 & 0 \\ 0 & 0 & k_+ & - k^* \\ 0 & 0 & k & - k_- \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} C \gamma^0 \fmslash{k} &= \begin{pmatrix} k & k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & k_- & - k^* \end{pmatrix} , & \qquad C \gamma^0 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k & - k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & k_- & - k^* \end{pmatrix} \\ C \gamma^1 \fmslash{k} &= \begin{pmatrix} k_+ & k^* & 0 & 0 \\ - k & - k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & k & - k_+ \end{pmatrix}, & \qquad C \gamma^1 \fmslash{k} \gamma^5 & = \begin{pmatrix} - k_+ & - k^* & 0 & 0 \\ k & k_- & 0 & 0 \\ 0 & 0 & k_- & - k^* \\ 0 & 0 & k & - k_+ \end{pmatrix} \\ C \gamma^2 \fmslash{k} &= \begin{pmatrix} \ii k_+ & \ii k^* & 0 & 0 \\ \ii k & \ii k_- & 0 & 0 \\ 0 & 0 & \ii k_- & - \ii k^* \\ 0 & 0 & - \ii k & \ii k_+ \end{pmatrix}, & \qquad C \gamma^2 \fmslash{k} \gamma^5 & = \begin{pmatrix} - \ii k_+ & - \ii k^* & 0 & 0 \\ - \ii k & - \ii k_- & 0 & 0 \\ 0 & 0 & \ii k_- & - \ii k^* \\ 0 & 0 & - \ii k & \ii k_+ \end{pmatrix} \\ C \gamma^3 \fmslash{k} &= \begin{pmatrix} - k & - k_- & 0 & 0 \\ - k_+ & - k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix}, & \qquad C \gamma^3 \fmslash{k} \gamma^5 & = \begin{pmatrix} k & k_- & 0 & 0 \\ k_+ & k^* & 0 & 0 \\ 0 & 0 & k & - k_+ \\ 0 & 0 & - k_- & k^* \end{pmatrix} \end{alignat} \end{subequations} and \begin{subequations} \begin{alignat}{2} C \fmslash{k} \gamma^0&= \begin{pmatrix} - k & k^+ & 0 & 0 \\ - k_- & k^* & 0 & 0 \\ 0 & 0 & - k & - k_- \\ 0 & 0 & k_+ & k^* \end{pmatrix} , & \qquad C \fmslash{k} \gamma^0 \gamma^5 & = \begin{pmatrix} k & - k_+ & 0 & 0 \\ k_- & - k^* & 0 & 0 \\ 0 & 0 & - k & - k_- \\ 0 & 0 & k_+ & k^* \end{pmatrix} \\ C \fmslash{k} \gamma^1 &= \begin{pmatrix} - k_+ & k & 0 & 0 \\ - k^* & k_- & 0 & 0 \\ 0 & 0 & - k_- & - k \\ 0 & 0 & k^* & k_+ \end{pmatrix}, & \qquad C \fmslash{k} \gamma^1 \gamma^5 & = \begin{pmatrix} k_+ & - k & 0 & 0 \\ k^* & - k_- & 0 & 0 \\ 0 & 0 & - k_- & - k \\ 0 & 0 & k^* & k_+ \end{pmatrix} \\ C \fmslash{k} \gamma^2 &= \begin{pmatrix} - \ii k_+ & - \ii k & 0 & 0 \\ - \ii k^* & - \ii k_- & 0 & 0 \\ 0 & 0 & - \ii k_- & \ii k \\ 0 & 0 & \ii k^* & - \ii k_+ \end{pmatrix}, & \qquad C \fmslash{k} \gamma^2 \gamma^5 & = \begin{pmatrix} \ii k_+ & \ii k & 0 & 0 \\ \ii k^* & \ii k_- & 0 & 0 \\ 0 & 0 & - \ii k_- & \ii k \\ 0 & 0 & \ii k^* & - \ii k_+ \end{pmatrix} \\ C \fmslash{k} \gamma^3 &= \begin{pmatrix} k & k_+ & 0 & 0 \\ k_- & k^* & 0 & 0 \\ 0 & 0 & - k & k_- \\ 0 & 0 & k_+ & - k^* \end{pmatrix}, & \qquad C \fmslash{k} \gamma^3 \gamma^5 & = \begin{pmatrix} - k & - k_+ & 0 & 0 \\ - k_- & - k^* & 0 & 0 \\ 0 & 0 & - k & k_- \\ 0 & 0 & k_+ & - k^* \end{pmatrix} \end{alignat} \end{subequations} <>= pure function fgvgr (psi, k) result (kpsi) type(bispinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(vector), intent(in) :: k type(vectorspinor), intent(in) :: psi kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%a(1) = kp * psi%psi(1)%a(1) + k12s * psi%psi(1)%a(2) & - k12 * psi%psi(2)%a(1) - km * psi%psi(2)%a(2) & + (0,1) * k12 * psi%psi(3)%a(1) + (0,1) * km * psi%psi(3)%a(2) & - kp * psi%psi(4)%a(1) - k12s * psi%psi(4)%a(2) kpsi%a(2) = k12 * psi%psi(1)%a(1) + km * psi%psi(1)%a(2) & - kp * psi%psi(2)%a(1) - k12s * psi%psi(2)%a(2) & - (0,1) * kp * psi%psi(3)%a(1) - (0,1) * k12s * psi%psi(3)%a(2) & + k12 * psi%psi(4)%a(1) + km * psi%psi(4)%a(2) kpsi%a(3) = km * psi%psi(1)%a(3) - k12s * psi%psi(1)%a(4) & - k12 * psi%psi(2)%a(3) + kp * psi%psi(2)%a(4) & + (0,1) * k12 * psi%psi(3)%a(3) - (0,1) * kp * psi%psi(3)%a(4) & + km * psi%psi(4)%a(3) - k12s * psi%psi(4)%a(4) kpsi%a(4) = - k12 * psi%psi(1)%a(3) + kp * psi%psi(1)%a(4) & + km * psi%psi(2)%a(3) - k12s * psi%psi(2)%a(4) & + (0,1) * km * psi%psi(3)%a(3) - (0,1) * k12s * psi%psi(3)%a(4) & + k12 * psi%psi(4)%a(3) - kp * psi%psi(4)%a(4) end function fgvgr @ <>= pure function f_sgr (g, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi type(vector) :: vk vk = k phipsi = (g * phi) * fgvgr (psi, vk) end function f_sgr @ <>= pure function f_slgr (gl, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi = f_sgr (gl, phi, psi, k) phipsi%a(3:4) = 0 end function f_slgr @ <>= pure function f_srgr (gr, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi = f_sgr (gr, phi, psi, k) phipsi%a(1:2) = 0 end function f_srgr @ <>= pure function f_slrgr (gl, gr, phi, psi, k) result (phipsi) type(bispinor) :: phipsi, phipsi_l, phipsi_r complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi phipsi_l = f_slgr (gl, phi, psi, k) phipsi_r = f_srgr (gr, phi, psi, k) phipsi%a(1:2) = phipsi_l%a(1:2) phipsi%a(3:4) = phipsi_r%a(3:4) end function f_slrgr @ <>= pure function fgvg5gr (psi, k) result (kpsi) type(bispinor) :: kpsi type(vector), intent(in) :: k type(vectorspinor), intent(in) :: psi type(bispinor) :: kpsi_dum kpsi_dum = fgvgr (psi, k) kpsi%a(1:2) = - kpsi_dum%a(1:2) kpsi%a(3:4) = kpsi_dum%a(3:4) end function fgvg5gr @ <>= pure function f_pgr (g, phi, psi, k) result (phipsi) type(bispinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(momentum), intent(in) :: k type(vectorspinor), intent(in) :: psi type(vector) :: vk vk = k phipsi = (g * phi) * fgvg5gr (psi, vk) end function f_pgr @ The needed construction of gamma matrices involving the commutator of two gamma matrices. For the slashed terms we use as usual the abbreviations $k_\pm=k_0\pm k_3$, $k=k_1+\ii k_2$, $k^*=k_1-\ii k_2$ and analogous expressions for the vector $v^\mu$. We remind you that~$\cdot^*$ is \emph{not} complex conjugation for complex~$k_\mu$. Furthermore we introduce (in what follows the brackets around the vector indices have the usual meaning of antisymmetrizing with respect to the indices inside the brackets, here without a factor two in the denominator) \begin{subequations} \begin{alignat}{2} a_+ &= \; k_+ v_- + k v^* - k_- v_+ - k^* v & \; = & \; 2 (k_{[3} v_{0]} + \ii k_{[2} v_{1]}) \\ a_- &= \; k_- v_+ + k v^* - k_+ v_- - k^* v & \; = & \; 2 (-k_{[3} v_{0]} + \ii k_{[2} v_{1]}) \\ b_+ &= \; 2 (k_+ v - k v_+) & \; = & \; 2 (k_{[0} v_{1]} + k_{[3} v_{1]} + \ii k_{[0} v_{2]} + \ii k_{[3} v_{2]}) \\ b_- &= \; 2 (k_- v - k v_-) & \; = & \; 2 (k_{[0} v_{1]} - k_{[3} v_{1]} + \ii k_{[0} v_{2]} - \ii k_{[3} v_{2]}) \\ b_{+*} &= \; 2 (k_+ v^* - k^* v_+) & \; = & \; 2 (k_{[0} v_{1]} + k_{[3} v_{1]} - \ii k_{[0} v_{2]} - \ii k_{[3} v_{2]}) \\ b_{-*} &= \; 2 (k_- v^* - k^* v_-) & \; = & \; 2 (k_{[0} v_{1]} - k_{[3} v_{1]} - \ii k_{[0} v_{2]} + \ii k_{[3} v_{2]}) \end{alignat} \end{subequations} Of course, one could introduce a more advanced notation, but we don't want to become confused. \begin{subequations} \begin{align} \lbrack \fmslash{k} , \gamma^0 \rbrack &= \begin{pmatrix} -2k_3 & -2 k^* & 0 & 0 \\ -2k & 2k_3 & 0 & 0 \\ 0 & 0 & 2k_3 & 2k^* \\ 0 & 0 & 2k & -2k_3 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^1 \rbrack &= \begin{pmatrix} -2\ii k_2 & -2k_- & 0 & 0 \\ -2k_+ & 2\ii k_2 & 0 & 0 \\ 0 & 0 & -2\ii k_2 & 2k_+ \\ 0 & 0 & 2k_- & 2\ii k_2 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^2 \rbrack &= \begin{pmatrix} 2\ii k_1 & 2\ii k_- & 0 & 0 \\ -2\ii k_+ & -2\ii k_1 & 0 & 0 \\ 0 & 0 & 2\ii k_1 & -2\ii k_+ \\ 0 & 0 & 2\ii k_- & -2\ii k_1 \end{pmatrix} \\ \lbrack \fmslash{k} , \gamma^3 \rbrack &= \begin{pmatrix} -2k_0 & -2k^* & 0 & 0 \\ 2k & 2k_0 & 0 & 0 \\ 0 & 0 & 2k_0 & -2k^* \\ 0 & 0 & 2k & -2k_0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} a_- & b_{-*} & 0 & 0 \\ b_+ & -a_- & 0 & 0 \\ 0 & 0 & a_+ & -b_{+*} \\ 0 & 0 & -b_- & -a_+ \end{pmatrix} \\ \gamma^5\gamma^0 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & - a_+ & b_{+*} \\ 0 & 0 & b_- & a_+ \\ a_- & b_{-*} & 0 & 0 \\ b_+ & - a_- & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^1 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & b_- & a_+ \\ 0 & 0 & -a_+ & b_{+*} \\ -b_+ & a_- & 0 & 0 & \\ -a_- & -b_{-*} & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^2 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & -\ii b_- & -\ii a_+ \\ 0 & 0 & -\ii a_+ & \ii b_{+*} \\ \ii b_+ & -\ii a_- & 0 & 0 \\ -\ii a_- & -\ii b_{-*} & 0 & 0 \end{pmatrix} \\ \gamma^5\gamma^3 \lbrack \fmslash{k} , \fmslash{V} \rbrack &= \begin{pmatrix} 0 & 0 & -a_+ & b_{+*} \\ 0 & 0 & -b_- & -a_+ \\ -a_- & -b_{-*} & 0 & 0 \\ b_+ & -a_- & 0 & 0 \end{pmatrix} \end{align} \end{subequations} and \begin{subequations} \begin{align} \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^0 \gamma^5 &= \begin{pmatrix} 0 & 0 & a_- & b_{-*} \\ 0 & 0 & b_+ & -a_- \\ -a_+ & b_{+*} & 0 & 0 \\ b_- & a_+ & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^1 \gamma^5 &= \begin{pmatrix} 0 & 0 & b_{-*} & a_- \\ 0 & 0 & -a_- & b_+ \\ -b_{+*} & a_+ & 0 & 0 \\ -a_+ & -b_- & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^2 \gamma^5 &= \begin{pmatrix} 0 & 0 & \ii b_{-*} & -\ii a_- \\ 0 & 0 & -\ii a_- & -\ii b_+ \\ -\ii b_{+*} & -\ii a_+ & 0 & 0 \\ -\ii a_+ & \ii b_- & 0 & 0 \end{pmatrix} \\ \lbrack \fmslash{k} , \fmslash{V} \rbrack \gamma^3 \gamma^5 &= \begin{pmatrix} 0 & 0 & a_- & - b_{-*} \\ 0 & 0 & b_+ & a_- \\ a_+ & b_{+*} & 0 & 0 \\ -b_- & a_+ & 0 & 0 \end{pmatrix} \end{align} \end{subequations} In what follows $l$ always means twice the value of $k$, e.g. $l_+$ = $2 k_+$. We use the abbreviation $C^{\mu\nu} \equiv C \lbrack \fmslash{k}, \gamma^\mu \rbrack \gamma^\nu \gamma^5$. \begin{subequations} \begin{alignat}{2} C^{00} &= \begin{pmatrix} 0 & 0 & -l & -l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ -l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad C^{20} &= \begin{pmatrix} 0 & 0 & -\ii l_+ & -\ii l_1 \\ 0 & 0 & -\ii l_1 & -\ii l_- \\ \ii l_- & -\ii l_1 & 0 & 0 \\ -\ii l_1 & \ii l_+ & 0 & 0 \end{pmatrix} \\ C^{01} &= \begin{pmatrix} 0 & 0 & l_3 & -l \\ 0 & 0 & l^* & l_3 \\ l_3 & -l & 0 & 0 \\ l^* & l_3 & 0 & 0 \end{pmatrix} , & \qquad C^{21} &= \begin{pmatrix} 0 & 0 & -\ii l_1 & -\ii l_+ \\ 0 & 0 & -\ii l_- & -\ii l_1 \\ \ii l_1 & -\ii l_- & 0 & 0 \\ -\ii l_+ & \ii l_1 & 0 & 0 \end{pmatrix} \\ C^{02} &= \begin{pmatrix} 0 & 0 & \ii l_3 & \ii l \\ 0 & 0 & \ii l^* & -\ii l_3 \\ \ii l_3 & \ii l & 0 & 0 \\ \ii l^* & -\ii l_3 & 0 & 0 \end{pmatrix} , & \qquad C^{22} &= \begin{pmatrix} 0 & 0 & l_1 & -l_+ \\ 0 & 0 & l_- & -l_1 \\ -l_1 & -l_- & 0 & 0 \\ l_+ & l_1 & 0 & 0 \end{pmatrix} \\ C^{03} &= \begin{pmatrix} 0 & 0 & -l & -l_3 \\ 0 & 0 & l_3 & -l^* \\ -l & -l_3 & 0 & 0 \\ l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad C^{23} &= \begin{pmatrix} 0 & 0 & -\ii l_+ & \ii l_1 \\ 0 & 0 & -\ii l_1 & \ii l_- \\ -\ii l_- & -\ii l_1 & 0 & 0 \\ \ii l_1 & \ii l_+ & 0 & 0 \end{pmatrix} \\ C^{10} &= \begin{pmatrix} 0 & 0 & -l_+ & \ii l_2 \\ 0 & 0 & \ii l_2 & l_- \\ l_- & \ii l_2 & 0 & 0 \\ \ii l_2 & -l_+ & 0 & 0 \end{pmatrix} , & \qquad C^{30} &= \begin{pmatrix} 0 & 0 & l & l_0 \\ 0 & 0 & l_0 & l^* \\ l & -l_0 & 0 & 0 \\ -l_0 & l^* & 0 & 0 \end{pmatrix} \\ C^{11} &= \begin{pmatrix} 0 & 0 & \ii l_2 & -l_+ \\ 0 & 0 & l_- & \ii l_2 \\ -\ii l_2 & -l_- & 0 & 0 \\ l_+ & -\ii l_2 & 0 & 0 \end{pmatrix} , & \qquad C^{31} &= \begin{pmatrix} 0 & 0 & l_0 & l \\ 0 & 0 & l^* & l_0 \\ l_0 & -l & 0 & 0 \\ -l^* & l_0 & 0 & 0 \end{pmatrix} \\ C^{12} &= \begin{pmatrix} 0 & 0 & -l_2 & \ii l_+ \\ 0 & 0 & \ii l_- & l_2 \\ l_2 & \ii l_- & 0 & 0 \\ \ii l_+ & -l_2 & 0 & 0 \end{pmatrix} , & \qquad C^{32} &= \begin{pmatrix} 0 & 0 & \ii l_0 & -\ii l \\ 0 & 0 & \ii l^* & -\ii l_0 \\ \ii l_0 & \ii l & 0 & 0 \\ -\ii l^* & -\ii l_0 & 0 & 0 \end{pmatrix} \\ C^{13} &= \begin{pmatrix} 0 & 0 & -l_+ & -\ii l_2 \\ 0 & 0 & \ii l_2 & - l_- \\ -l_- & \ii l_2 & 0 & 0 \\ -\ii l_2 & -l_+ & 0 & 0 \end{pmatrix} , & \qquad C^{33} &= \begin{pmatrix} 0 & 0 & l & -l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ l_0 & l^* & 0 & 0 \end{pmatrix} \end{alignat} \end{subequations} and, with the abbreviation $\tilde{C}^{\mu\nu} \equiv C \gamma^5 \gamma^\nu \lbrack \fmslash{k} , \gamma^\mu \rbrack$ (note the reversed order of the indices!) \begin{subequations} \begin{alignat}{2} \tilde{C}^{00} &= \begin{pmatrix} 0 & 0 & -l & l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ -l_3 & -l^* & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{20} &= \begin{pmatrix} 0 & 0 & -\ii l_- & \ii l_1 \\ 0 & 0 & \ii l_1 & -\ii l_+ \\ \ii l_+ & \ii l_1 & 0 & 0 \\ \ii l_1 & \ii l_- & 0 & 0 \end{pmatrix} \\ \tilde{C}^{01} &= \begin{pmatrix} 0 & 0 & -l_3 & -l^* \\ 0 & 0 & l & -l_3 \\ -l_3 & -l^* & 0 & 0 \\ l & -l_3 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{21} &= \begin{pmatrix} 0 & 0 & -\ii l_1 & \ii l_+ \\ 0 & 0 & \ii l_- & -\ii l_1 \\ \ii l_1 & \ii l_- & 0 & 0 \\ \ii l_+ & \ii l_1 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{02} &= \begin{pmatrix} 0 & 0 & -\ii l_3 & -\ii l^* \\ 0 & 0 & -\ii l & \ii l_3 \\ -\ii l_3 & -\ii l^* & 0 & 0 \\ -\ii l & \ii l_3 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{22} &= \begin{pmatrix} 0 & 0 & l_1 & -l_+ \\ 0 & 0 & l_- & -l_1 \\ -l_1 & -l_- & 0 & 0 \\ l_+ & l_1 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{03} &= \begin{pmatrix} 0 & 0 & l & -l_3 \\ 0 & 0 & l_3 & l^* \\ l & -l_3 & 0 & 0 \\ l_3 & l^* & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{23} &= \begin{pmatrix} 0 & 0 & \ii l_- & -\ii l_1 \\ 0 & 0 & \ii l_1 & -\ii l_+ \\ \ii l_+ & \ii l_1 & 0 & 0 \\ -\ii l_1 & -\ii l_- & 0 & 0 \end{pmatrix} \\ \tilde{C}^{10} &= \begin{pmatrix} 0 & 0 & -l_- & -\ii l_2 \\ 0 & 0 & -\ii l_2 & l_+ \\ l_+ & -\ii l_2 & 0 & 0 \\ -\ii l_2 & -l_- & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{30} &= \begin{pmatrix} 0 & 0 & -l & l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ -l_0 & -l^* & 0 & 0 \end{pmatrix} \\ \tilde{C}^{11} &= \begin{pmatrix} 0 & 0 & \ii l_2 & -l_+ \\ 0 & 0 & l_- & \ii l_2 \\ -\ii l_2 & -l_- & 0 & 0 \\ l_+ & -\ii l_2 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{31} &= \begin{pmatrix} 0 & 0 & -l_0 & l^* \\ 0 & 0 & l & -l_0 \\ -l_0 & -l^* & 0 & 0 \\ -l & -l_0 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{12} &= \begin{pmatrix} 0 & 0 & -l_2 & -\ii l_+ \\ 0 & 0 & -\ii l_- & l_2 \\ l_2 & -\ii l_- & 0 & 0 \\ -\ii l_+ & -l_2 & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{32} &= \begin{pmatrix} 0 & 0 & -\ii l_0 & \ii l^* \\ 0 & 0 & -\ii l & \ii l_0 \\ -\ii l_0 & -\ii l^* & 0 & 0 \\ \ii l & \ii l_0 & 0 & 0 \end{pmatrix} \\ \tilde{C}^{13} &= \begin{pmatrix} 0 & 0 & l_- & \ii l_2 \\ 0 & 0 & -\ii l_2 & l_+ \\ l_+ & -\ii l_2 & 0 & 0 \\ \ii l_2 & l_- & 0 & 0 \end{pmatrix} , & \qquad \tilde{C}^{33} &= \begin{pmatrix} 0 & 0 & l & -l_0 \\ 0 & 0 & l_0 & -l^* \\ -l & -l_0 & 0 & 0 \\ l_0 & l^* & 0 & 0 \end{pmatrix} \end{alignat} \end{subequations} <>= pure function fggvvgr (v, psi, k) result (psikv) type(bispinor) :: psikv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v, k complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = (0,1) * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = (0,1) * (k%t * v%x(2) - k%x(2) * v%t) kv32 = (0,1) * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * (-kv30 + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) psikv%a(1) = (-ap) * psi%psi(1)%a(3) + bps * psi%psi(1)%a(4) & + (-bm) * psi%psi(2)%a(3) + (-ap) * psi%psi(2)%a(4) & + (0,1) * (bm * psi%psi(3)%a(3) + ap * psi%psi(3)%a(4)) & + ap * psi%psi(4)%a(3) + (-bps) * psi%psi(4)%a(4) psikv%a(2) = bm * psi%psi(1)%a(3) + ap * psi%psi(1)%a(4) & + ap * psi%psi(2)%a(3) + (-bps) * psi%psi(2)%a(4) & + (0,1) * (ap * psi%psi(3)%a(3) - bps * psi%psi(3)%a(4)) & + bm * psi%psi(4)%a(3) + ap * psi%psi(4)%a(4) psikv%a(3) = am * psi%psi(1)%a(1) + bms * psi%psi(1)%a(2) & + bp * psi%psi(2)%a(1) + (-am) * psi%psi(2)%a(2) & + (0,-1) * (bp * psi%psi(3)%a(1) + (-am) * psi%psi(3)%a(2)) & + am * psi%psi(4)%a(1) + bms * psi%psi(4)%a(2) psikv%a(4) = bp * psi%psi(1)%a(1) + (-am) * psi%psi(1)%a(2) & + am * psi%psi(2)%a(1) + bms * psi%psi(2)%a(2) & + (0,1) * (am * psi%psi(3)%a(1) + bms * psi%psi(3)%a(2)) & + (-bp) * psi%psi(4)%a(1) + am * psi%psi(4)%a(2) end function fggvvgr @ <>= pure function f_vgr (g, v, psi, k) result (psikkkv) type(bispinor) :: psikkkv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g type(vector) :: vk vk = k psikkkv = g * (fggvvgr (v, psi, vk)) end function f_vgr @ <>= pure function f_vlrgr (gl, gr, v, psi, k) result (psikv) type(bispinor) :: psikv type(vectorspinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: gl, gr type(vector) :: vk vk = k psikv = fggvvgr (v, psi, vk) psikv%a(1:2) = gl * psikv%a(1:2) psikv%a(3:4) = gr * psikv%a(3:4) end function f_vlrgr @ <>= public :: gr_potf, gr_sf, gr_pf, gr_vf, gr_vlrf, gr_slf, gr_srf, gr_slrf @ <>= pure function gr_potf (g, phi, psi) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi phipsi%psi(1)%a(1) = (g * phi) * psi%a(3) phipsi%psi(1)%a(2) = (g * phi) * psi%a(4) phipsi%psi(1)%a(3) = (g * phi) * psi%a(1) phipsi%psi(1)%a(4) = (g * phi) * psi%a(2) phipsi%psi(2)%a(1) = (g * phi) * psi%a(4) phipsi%psi(2)%a(2) = (g * phi) * psi%a(3) phipsi%psi(2)%a(3) = ((-g) * phi) * psi%a(2) phipsi%psi(2)%a(4) = ((-g) * phi) * psi%a(1) phipsi%psi(3)%a(1) = ((0,-1) * g * phi) * psi%a(4) phipsi%psi(3)%a(2) = ((0,1) * g * phi) * psi%a(3) phipsi%psi(3)%a(3) = ((0,1) * g * phi) * psi%a(2) phipsi%psi(3)%a(4) = ((0,-1) * g * phi) * psi%a(1) phipsi%psi(4)%a(1) = (g * phi) * psi%a(3) phipsi%psi(4)%a(2) = ((-g) * phi) * psi%a(4) phipsi%psi(4)%a(3) = ((-g) * phi) * psi%a(1) phipsi%psi(4)%a(4) = (g * phi) * psi%a(2) end function gr_potf @ <>= pure function grkgf (psi, k) result (kpsi) type(vectorspinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psi type(vector), intent(in) :: k kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%psi(1)%a(1) = km * psi%a(1) - k12s * psi%a(2) kpsi%psi(1)%a(2) = (-k12) * psi%a(1) + kp * psi%a(2) kpsi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kpsi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kpsi%psi(2)%a(1) = k12s * psi%a(1) - km * psi%a(2) kpsi%psi(2)%a(2) = (-kp) * psi%a(1) + k12 * psi%a(2) kpsi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kpsi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kpsi%psi(3)%a(1) = (0,1) * (k12s * psi%a(1) + km * psi%a(2)) kpsi%psi(3)%a(2) = (0,-1) * (kp * psi%a(1) + k12 * psi%a(2)) kpsi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kpsi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kpsi%psi(4)%a(1) = -(km * psi%a(1) + k12s * psi%a(2)) kpsi%psi(4)%a(2) = k12 * psi%a(1) + kp * psi%a(2) kpsi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kpsi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) end function grkgf @ <>= pure function gr_sf (g, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k phipsi = (g * phi) * grkgf (psi, vk) end function gr_sf @ <>= pure function gr_slf (gl, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gl complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(momentum), intent(in) :: k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 phipsi = gr_sf (gl, phi, psi_l, k) end function gr_slf @ <>= pure function gr_srf (gr, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(momentum), intent(in) :: k psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) phipsi = gr_sf (gr, phi, psi_r, k) end function gr_srf @ <>= pure function gr_slrf (gl, gr, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: gl, gr complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k phipsi = gr_slf (gl, phi, psi, k) + gr_srf (gr, phi, psi, k) end function gr_slrf @ <>= pure function grkggf (psi, k) result (kpsi) type(vectorspinor) :: kpsi complex(kind=default) :: kp, km, k12, k12s type(bispinor), intent(in) :: psi type(vector), intent(in) :: k kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) kpsi%psi(1)%a(1) = (-km) * psi%a(1) + k12s * psi%a(2) kpsi%psi(1)%a(2) = k12 * psi%a(1) - kp * psi%a(2) kpsi%psi(1)%a(3) = kp * psi%a(3) + k12s * psi%a(4) kpsi%psi(1)%a(4) = k12 * psi%a(3) + km * psi%a(4) kpsi%psi(2)%a(1) = (-k12s) * psi%a(1) + km * psi%a(2) kpsi%psi(2)%a(2) = kp * psi%a(1) - k12 * psi%a(2) kpsi%psi(2)%a(3) = k12s * psi%a(3) + kp * psi%a(4) kpsi%psi(2)%a(4) = km * psi%a(3) + k12 * psi%a(4) kpsi%psi(3)%a(1) = (0,-1) * (k12s * psi%a(1) + km * psi%a(2)) kpsi%psi(3)%a(2) = (0,1) * (kp * psi%a(1) + k12 * psi%a(2)) kpsi%psi(3)%a(3) = (0,1) * (k12s * psi%a(3) - kp * psi%a(4)) kpsi%psi(3)%a(4) = (0,1) * (km * psi%a(3) - k12 * psi%a(4)) kpsi%psi(4)%a(1) = km * psi%a(1) + k12s * psi%a(2) kpsi%psi(4)%a(2) = -(k12 * psi%a(1) + kp * psi%a(2)) kpsi%psi(4)%a(3) = kp * psi%a(3) - k12s * psi%a(4) kpsi%psi(4)%a(4) = k12 * psi%a(3) - km * psi%a(4) end function grkggf @ <>= pure function gr_pf (g, phi, psi, k) result (phipsi) type(vectorspinor) :: phipsi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi type(bispinor), intent(in) :: psi type(momentum), intent(in) :: k type(vector) :: vk vk = k phipsi = (g * phi) * grkggf (psi, vk) end function gr_pf @ <>= pure function grkkggf (v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(vector), intent(in) :: v, k complex(kind=default) :: kv30, kv21, kv01, kv31, kv02, kv32 complex(kind=default) :: ap, am, bp, bm, bps, bms, imago imago = (0.0_default,1.0_default) kv30 = k%x(3) * v%t - k%t * v%x(3) kv21 = imago * (k%x(2) * v%x(1) - k%x(1) * v%x(2)) kv01 = k%t * v%x(1) - k%x(1) * v%t kv31 = k%x(3) * v%x(1) - k%x(1) * v%x(3) kv02 = imago * (k%t * v%x(2) - k%x(2) * v%t) kv32 = imago * (k%x(3) * v%x(2) - k%x(2) * v%x(3)) ap = 2 * (kv30 + kv21) am = 2 * ((-kv30) + kv21) bp = 2 * (kv01 + kv31 + kv02 + kv32) bm = 2 * (kv01 - kv31 + kv02 - kv32) bps = 2 * (kv01 + kv31 - kv02 - kv32) bms = 2 * (kv01 - kv31 - kv02 + kv32) psikv%psi(1)%a(1) = am * psi%a(3) + bms * psi%a(4) psikv%psi(1)%a(2) = bp * psi%a(3) + (-am) * psi%a(4) psikv%psi(1)%a(3) = (-ap) * psi%a(1) + bps * psi%a(2) psikv%psi(1)%a(4) = bm * psi%a(1) + ap * psi%a(2) psikv%psi(2)%a(1) = bms * psi%a(3) + am * psi%a(4) psikv%psi(2)%a(2) = (-am) * psi%a(3) + bp * psi%a(4) psikv%psi(2)%a(3) = (-bps) * psi%a(1) + ap * psi%a(2) psikv%psi(2)%a(4) = (-ap) * psi%a(1) + (-bm) * psi%a(2) psikv%psi(3)%a(1) = imago * (bms * psi%a(3) - am * psi%a(4)) psikv%psi(3)%a(2) = (-imago) * (am * psi%a(3) + bp * psi%a(4)) psikv%psi(3)%a(3) = (-imago) * (bps * psi%a(1) + ap * psi%a(2)) psikv%psi(3)%a(4) = imago * ((-ap) * psi%a(1) + bm * psi%a(2)) psikv%psi(4)%a(1) = am * psi%a(3) + (-bms) * psi%a(4) psikv%psi(4)%a(2) = bp * psi%a(3) + am * psi%a(4) psikv%psi(4)%a(3) = ap * psi%a(1) + bps * psi%a(2) psikv%psi(4)%a(4) = (-bm) * psi%a(1) + ap * psi%a(2) end function grkkggf @ <>= pure function gr_vf (g, v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: g type(vector) :: vk vk = k psikv = g * (grkkggf (v, psi, vk)) end function gr_vf @ <>= pure function gr_vlrf (gl, gr, v, psi, k) result (psikv) type(vectorspinor) :: psikv type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v type(momentum), intent(in) :: k complex(kind=default), intent(in) :: gl, gr type(vector) :: vk vk = k psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) psikv = gl * grkkggf (v, psi_l, vk) + gr * grkkggf (v, psi_r, vk) end function gr_vlrf @ <>= public :: v_grf, v_fgr @ <>= public :: vlr_grf, vlr_fgr @ $V^\mu = \psi_\rho^T C^{\mu\rho} \psi$ <>= pure function grkgggf (psil, psir, k) result (j) type(vector) :: j type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(vector), intent(in) :: k type(vectorspinor) :: c_psir0, c_psir1, c_psir2, c_psir3 complex(kind=default) :: kp, km, k12, k12s, ik2 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = (k%x(1) + (0,1)*k%x(2)) k12s = (k%x(1) - (0,1)*k%x(2)) ik2 = (0,1) * k%x(2) !!! New version: c_psir0%psi(1)%a(1) = (-k%x(3)) * psir%a(3) + (-k12s) * psir%a(4) c_psir0%psi(1)%a(2) = (-k12) * psir%a(3) + k%x(3) * psir%a(4) c_psir0%psi(1)%a(3) = (-k%x(3)) * psir%a(1) + (-k12s) * psir%a(2) c_psir0%psi(1)%a(4) = (-k12) * psir%a(1) + k%x(3) * psir%a(2) c_psir0%psi(2)%a(1) = (-k12s) * psir%a(3) + (-k%x(3)) * psir%a(4) c_psir0%psi(2)%a(2) = k%x(3) * psir%a(3) + (-k12) * psir%a(4) c_psir0%psi(2)%a(3) = k12s * psir%a(1) + k%x(3) * psir%a(2) c_psir0%psi(2)%a(4) = (-k%x(3)) * psir%a(1) + k12 * psir%a(2) c_psir0%psi(3)%a(1) = (0,1) * ((-k12s) * psir%a(3) + k%x(3) * psir%a(4)) c_psir0%psi(3)%a(2) = (0,1) * (k%x(3) * psir%a(3) + k12 * psir%a(4)) c_psir0%psi(3)%a(3) = (0,1) * (k12s * psir%a(1) + (-k%x(3)) * psir%a(2)) c_psir0%psi(3)%a(4) = (0,1) * ((-k%x(3)) * psir%a(1) + (-k12) * psir%a(2)) c_psir0%psi(4)%a(1) = (-k%x(3)) * psir%a(3) + k12s * psir%a(4) c_psir0%psi(4)%a(2) = (-k12) * psir%a(3) + (-k%x(3)) * psir%a(4) c_psir0%psi(4)%a(3) = k%x(3) * psir%a(1) + (-k12s) * psir%a(2) c_psir0%psi(4)%a(4) = k12 * psir%a(1) + k%x(3) * psir%a(2) !!! c_psir1%psi(1)%a(1) = (-ik2) * psir%a(3) + (-km) * psir%a(4) c_psir1%psi(1)%a(2) = (-kp) * psir%a(3) + ik2 * psir%a(4) c_psir1%psi(1)%a(3) = ik2 * psir%a(1) + (-kp) * psir%a(2) c_psir1%psi(1)%a(4) = (-km) * psir%a(1) + (-ik2) * psir%a(2) c_psir1%psi(2)%a(1) = (-km) * psir%a(3) + (-ik2) * psir%a(4) c_psir1%psi(2)%a(2) = ik2 * psir%a(3) + (-kp) * psir%a(4) c_psir1%psi(2)%a(3) = kp * psir%a(1) + (-ik2) * psir%a(2) c_psir1%psi(2)%a(4) = ik2 * psir%a(1) + km * psir%a(2) c_psir1%psi(3)%a(1) = ((0,-1) * km) * psir%a(3) + (-k%x(2)) * psir%a(4) c_psir1%psi(3)%a(2) = (-k%x(2)) * psir%a(3) + ((0,1) * kp) * psir%a(4) c_psir1%psi(3)%a(3) = ((0,1) * kp) * psir%a(1) + (-k%x(2)) * psir%a(2) c_psir1%psi(3)%a(4) = (-k%x(2)) * psir%a(1) + ((0,-1) * km) * psir%a(2) c_psir1%psi(4)%a(1) = (-ik2) * psir%a(3) + km * psir%a(4) c_psir1%psi(4)%a(2) = (-kp) * psir%a(3) + (-ik2) * psir%a(4) c_psir1%psi(4)%a(3) = (-ik2) * psir%a(1) + (-kp) * psir%a(2) c_psir1%psi(4)%a(4) = km * psir%a(1) + (-ik2) * psir%a(2) !!! c_psir2%psi(1)%a(1) = (0,1) * (k%x(1) * psir%a(3) + km * psir%a(4)) c_psir2%psi(1)%a(2) = (0,-1) * (kp * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(1)%a(3) = (0,1) * ((-k%x(1)) * psir%a(1) + kp * psir%a(2)) c_psir2%psi(1)%a(4) = (0,1) * ((-km) * psir%a(1) + k%x(1) * psir%a(2)) c_psir2%psi(2)%a(1) = (0,1) * (km * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(2)%a(2) = (0,-1) * (k%x(1) * psir%a(3) + kp * psir%a(4)) c_psir2%psi(2)%a(3) = (0,-1) * (kp * psir%a(1) + (-k%x(1)) * psir%a(2)) c_psir2%psi(2)%a(4) = (0,-1) * (k%x(1) * psir%a(1) + (-km) * psir%a(2)) c_psir2%psi(3)%a(1) = (-km) * psir%a(3) + k%x(1) * psir%a(4) c_psir2%psi(3)%a(2) = k%x(1) * psir%a(3) + (-kp) * psir%a(4) c_psir2%psi(3)%a(3) = kp * psir%a(1) + k%x(1) * psir%a(2) c_psir2%psi(3)%a(4) = k%x(1) * psir%a(1) + km * psir%a(2) c_psir2%psi(4)%a(1) = (0,1) * (k%x(1) * psir%a(3) + (-km) * psir%a(4)) c_psir2%psi(4)%a(2) = (0,1) * ((-kp) * psir%a(3) + k%x(1) * psir%a(4)) c_psir2%psi(4)%a(3) = (0,1) * (k%x(1) * psir%a(1) + kp * psir%a(2)) c_psir2%psi(4)%a(4) = (0,1) * (km * psir%a(1) + k%x(1) * psir%a(2)) !!! c_psir3%psi(1)%a(1) = (-k%t) * psir%a(3) - k12s * psir%a(4) c_psir3%psi(1)%a(2) = k12 * psir%a(3) + k%t * psir%a(4) c_psir3%psi(1)%a(3) = (-k%t) * psir%a(1) + k12s * psir%a(2) c_psir3%psi(1)%a(4) = (-k12) * psir%a(1) + k%t * psir%a(2) c_psir3%psi(2)%a(1) = (-k12s) * psir%a(3) + (-k%t) * psir%a(4) c_psir3%psi(2)%a(2) = k%t * psir%a(3) + k12 * psir%a(4) c_psir3%psi(2)%a(3) = (-k12s) * psir%a(1) + k%t * psir%a(2) c_psir3%psi(2)%a(4) = (-k%t) * psir%a(1) + k12 * psir%a(2) c_psir3%psi(3)%a(1) = (0,-1) * (k12s * psir%a(3) + (-k%t) * psir%a(4)) c_psir3%psi(3)%a(2) = (0,1) * (k%t * psir%a(3) + (-k12) * psir%a(4)) c_psir3%psi(3)%a(3) = (0,-1) * (k12s * psir%a(1) + k%t * psir%a(2)) c_psir3%psi(3)%a(4) = (0,-1) * (k%t * psir%a(1) + k12 * psir%a(2)) c_psir3%psi(4)%a(1) = (-k%t) * psir%a(3) + k12s * psir%a(4) c_psir3%psi(4)%a(2) = k12 * psir%a(3) + (-k%t) * psir%a(4) c_psir3%psi(4)%a(3) = k%t * psir%a(1) + k12s * psir%a(2) c_psir3%psi(4)%a(4) = k12 * psir%a(1) + k%t * psir%a(2) j%t = 2 * (psil * c_psir0) j%x(1) = 2 * (psil * c_psir1) j%x(2) = 2 * (psil * c_psir2) j%x(3) = 2 * (psil * c_psir3) end function grkgggf @ <>= pure function v_grf (g, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * grkgggf (psil, psir, vk) end function v_grf @ <>= pure function vlr_grf (gl, gr, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: psil type(bispinor), intent(in) :: psir type(bispinor) :: psir_l, psir_r type(momentum), intent(in) :: k type(vector) :: vk vk = k psir_l%a(1:2) = psir%a(1:2) psir_l%a(3:4) = 0 psir_r%a(1:2) = 0 psir_r%a(3:4) = psir%a(3:4) j = gl * grkgggf (psil, psir_l, vk) + gr * grkgggf (psil, psir_r, vk) end function vlr_grf @ $V^\mu = \psi^T \tilde{C}^{\mu\rho} \psi_\rho$; remember the reversed index order in $\tilde{C}$. <>= pure function fggkggr (psil, psir, k) result (j) type(vector) :: j type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(vector), intent(in) :: k type(bispinor) :: c_psir0, c_psir1, c_psir2, c_psir3 complex(kind=default) :: kp, km, k12, k12s, ik1, ik2 kp = k%t + k%x(3) km = k%t - k%x(3) k12 = k%x(1) + (0,1)*k%x(2) k12s = k%x(1) - (0,1)*k%x(2) ik1 = (0,1) * k%x(1) ik2 = (0,1) * k%x(2) c_psir0%a(1) = k%x(3) * (psir%psi(1)%a(4) + psir%psi(4)%a(4) & + psir%psi(2)%a(3) + (0,1) * psir%psi(3)%a(3)) & - k12 * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) & + k12s * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir0%a(2) = k%x(3) * (psir%psi(1)%a(3) - psir%psi(4)%a(3) + & psir%psi(2)%a(4) - (0,1) * psir%psi(3)%a(4)) + & k12s * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & k12 * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir0%a(3) = k%x(3) * (-psir%psi(1)%a(2) + psir%psi(4)%a(2) + & psir%psi(2)%a(1) + (0,1) * psir%psi(3)%a(1)) + & k12 * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & k12s * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir0%a(4) = k%x(3) * (-psir%psi(1)%a(1) - psir%psi(4)%a(1) + & psir%psi(2)%a(2) - (0,1) * psir%psi(3)%a(2)) - & k12s * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & k12 * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! c_psir1%a(1) = ik2 * (-psir%psi(1)%a(4) - psir%psi(4)%a(4) - & psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) - & km * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) + & kp * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir1%a(2) = ik2 * (-psir%psi(1)%a(3) - psir%psi(2)%a(4) + & psir%psi(4)%a(3) + (0,1) * psir%psi(3)%a(4)) + & kp * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & km * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir1%a(3) = ik2 * (-psir%psi(1)%a(2) + psir%psi(2)%a(1) + & psir%psi(4)%a(2) + (0,1) * psir%psi(3)%a(1)) + & kp * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & km * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir1%a(4) = ik2 * (-psir%psi(1)%a(1) + psir%psi(2)%a(2) - & psir%psi(4)%a(1) - (0,1) * psir%psi(3)%a(2)) - & km * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & kp * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! c_psir2%a(1) = ik1 * (psir%psi(2)%a(3) + psir%psi(1)%a(4) & + psir%psi(4)%a(4) + (0,1) * psir%psi(3)%a(3)) - & ((0,1)*km) * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) & + kp * (psir%psi(3)%a(4) - (0,1) * psir%psi(2)%a(4)) c_psir2%a(2) = ik1 * (psir%psi(1)%a(3) + psir%psi(2)%a(4) - & psir%psi(4)%a(3) - (0,1) * psir%psi(3)%a(4)) - & ((0,1)*kp) * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) & - km * (psir%psi(3)%a(3) + (0,1) * psir%psi(2)%a(3)) c_psir2%a(3) = ik1 * (psir%psi(1)%a(2) - psir%psi(2)%a(1) - & psir%psi(4)%a(2) - (0,1) * psir%psi(3)%a(1)) + & ((0,1)*kp) * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) & + km * (psir%psi(3)%a(2) - (0,1) * psir%psi(2)%a(2)) c_psir2%a(4) = ik1 * (psir%psi(1)%a(1) - psir%psi(2)%a(2) + & psir%psi(4)%a(1) + (0,1) * psir%psi(3)%a(2)) + & ((0,1)*km) * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) - & kp * (psir%psi(3)%a(1) + (0,1) * psir%psi(2)%a(1)) !!! c_psir3%a(1) = k%t * (psir%psi(1)%a(4) + psir%psi(4)%a(4) + & psir%psi(2)%a(3) + (0,1) * psir%psi(3)%a(3)) - & k12 * (psir%psi(1)%a(3) + psir%psi(4)%a(3)) - & k12s * (psir%psi(2)%a(4) + (0,1) * psir%psi(3)%a(4)) c_psir3%a(2) = k%t * (psir%psi(1)%a(3) - psir%psi(4)%a(3) + & psir%psi(2)%a(4) - (0,1) * psir%psi(3)%a(4)) - & k12s * (psir%psi(1)%a(4) - psir%psi(4)%a(4)) - & k12 * (psir%psi(2)%a(3) - (0,1) * psir%psi(3)%a(3)) c_psir3%a(3) = k%t * (-psir%psi(1)%a(2) + psir%psi(2)%a(1) + & psir%psi(4)%a(2) + (0,1) * psir%psi(3)%a(1)) - & k12 * (psir%psi(1)%a(1) - psir%psi(4)%a(1)) + & k12s * (psir%psi(2)%a(2) + (0,1) * psir%psi(3)%a(2)) c_psir3%a(4) = k%t * (-psir%psi(1)%a(1) + psir%psi(2)%a(2) - & psir%psi(4)%a(1) - (0,1) * psir%psi(3)%a(2)) - & k12s * (psir%psi(1)%a(2) + psir%psi(4)%a(2)) + & k12 * (psir%psi(2)%a(1) - (0,1) * psir%psi(3)%a(1)) !!! Because we explicitly multiplied the charge conjugation matrix !!! we have to omit it from the spinor product and take the !!! ordinary product! j%t = 2 * dot_product (conjg (psil%a), c_psir0%a) j%x(1) = 2 * dot_product (conjg (psil%a), c_psir1%a) j%x(2) = 2 * dot_product (conjg (psil%a), c_psir2%a) j%x(3) = 2 * dot_product (conjg (psil%a), c_psir3%a) end function fggkggr @ <>= pure function v_fgr (g, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(momentum), intent(in) :: k type(vector) :: vk vk = k j = g * fggkggr (psil, psir, vk) end function v_fgr @ <>= pure function vlr_fgr (gl, gr, psil, psir, k) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: psir type(bispinor), intent(in) :: psil type(bispinor) :: psil_l type(bispinor) :: psil_r type(momentum), intent(in) :: k type(vector) :: vk vk = k psil_l%a(1:2) = psil%a(1:2) psil_l%a(3:4) = 0 psil_r%a(1:2) = 0 psil_r%a(3:4) = psil%a(3:4) j = gl * fggkggr (psil_l, psir, vk) + gr * fggkggr (psil_r, psir, vk) end function vlr_fgr @ \subsection{Gravitino 4-Couplings} <>= public :: f_s2gr, f_svgr, f_slvgr, f_srvgr, f_slrvgr, f_pvgr, f_v2gr, f_v2lrgr @ <>= pure function f_s2gr (g, phi1, phi2, psi) result (phipsi) type(bispinor) :: phipsi type(vectorspinor), intent(in) :: psi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi1, phi2 phipsi = phi2 * f_potgr (g, phi1, psi) end function f_s2gr @ <>= pure function f_svgr (g, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phigrav = (g * phi) * fgvg5gr (grav, v) end function f_svgr @ <>= pure function f_slvgr (gl, phi, v, grav) result (phigrav) type(bispinor) :: phigrav, phidum type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, phi phidum = (gl * phi) * fgvg5gr (grav, v) phigrav%a(1:2) = phidum%a(1:2) phigrav%a(3:4) = 0 end function f_slvgr @ <>= pure function f_srvgr (gr, phi, v, grav) result (phigrav) type(bispinor) :: phigrav, phidum type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gr, phi phidum = (gr * phi) * fgvg5gr (grav, v) phigrav%a(1:2) = 0 phigrav%a(3:4) = phidum%a(3:4) end function f_srvgr @ <>= pure function f_slrvgr (gl, gr, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr, phi phigrav = f_slvgr (gl, phi, v, grav) + f_srvgr (gr, phi, v, grav) end function f_slrvgr @ <>= pure function f_pvgr (g, phi, v, grav) result (phigrav) type(bispinor) :: phigrav type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phigrav = (g * phi) * fgvgr (grav, v) end function f_pvgr @ <>= pure function f_v2gr (g, v1, v2, grav) result (psi) type(bispinor) :: psi complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v1, v2 psi = g * fggvvgr (v2, grav, v1) end function f_v2gr @ <>= pure function f_v2lrgr (gl, gr, v1, v2, grav) result (psi) type(bispinor) :: psi complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v1, v2 psi = fggvvgr (v2, grav, v1) psi%a(1:2) = gl * psi%a(1:2) psi%a(3:4) = gr * psi%a(3:4) end function f_v2lrgr @ <>= public :: gr_s2f, gr_svf, gr_pvf, gr_slvf, gr_srvf, gr_slrvf, gr_v2f, gr_v2lrf @ <>= pure function gr_s2f (g, phi1, phi2, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi complex(kind=default), intent(in) :: g complex(kind=default), intent(in) :: phi1, phi2 phipsi = phi2 * gr_potf (g, phi1, psi) end function gr_s2f @ <>= pure function gr_svf (g, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phipsi = (g * phi) * grkggf (psi, v) end function gr_svf @ <>= pure function gr_slvf (gl, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, phi psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 phipsi = (gl * phi) * grkggf (psi_l, v) end function gr_slvf @ <>= pure function gr_srvf (gr, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(vector), intent(in) :: v complex(kind=default), intent(in) :: gr, phi psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) phipsi = (gr * phi) * grkggf (psi_r, v) end function gr_srvf @ <>= pure function gr_slrvf (gl, gr, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: gl, gr, phi phipsi = gr_slvf (gl, phi, v, psi) + gr_srvf (gr, phi, v, psi) end function gr_slrvf @ <>= pure function gr_pvf (g, phi, v, psi) result (phipsi) type(vectorspinor) :: phipsi type(bispinor), intent(in) :: psi type(vector), intent(in) :: v complex(kind=default), intent(in) :: g, phi phipsi = (g * phi) * grkgf (psi, v) end function gr_pvf @ <>= pure function gr_v2f (g, v1, v2, psi) result (vvpsi) type(vectorspinor) :: vvpsi complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psi type(vector), intent(in) :: v1, v2 vvpsi = g * grkkggf (v2, psi, v1) end function gr_v2f @ <>= pure function gr_v2lrf (gl, gr, v1, v2, psi) result (vvpsi) type(vectorspinor) :: vvpsi complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v1, v2 psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) vvpsi = gl * grkkggf (v2, psi_l, v1) + gr * grkkggf (v2, psi_r, v1) end function gr_v2lrf @ <>= public :: s2_grf, s2_fgr, sv1_grf, sv2_grf, sv1_fgr, sv2_fgr, & slv1_grf, slv2_grf, slv1_fgr, slv2_fgr, & srv1_grf, srv2_grf, srv1_fgr, srv2_fgr, & slrv1_grf, slrv2_grf, slrv1_fgr, slrv2_fgr, & pv1_grf, pv2_grf, pv1_fgr, pv2_fgr, v2_grf, v2_fgr, & v2lr_grf, v2lr_fgr @ <>= pure function s2_grf (g, gravbar, phi, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi j = phi * pot_grf (g, gravbar, psi) end function s2_grf @ <>= pure function s2_fgr (g, psibar, phi, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav j = phi * pot_fgr (g, psibar, grav) end function s2_fgr @ <>= pure function sv1_grf (g, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = g * grg5vgf (gravbar, psi, v) end function sv1_grf @ <>= pure function slv1_grf (gl, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = gl * grg5vgf (gravbar, psi_l, v) end function slv1_grf @ <>= pure function srv1_grf (gr, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r type(vector), intent(in) :: v psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = gr * grg5vgf (gravbar, psi_r, v) end function srv1_grf @ <>= pure function slrv1_grf (gl, gr, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = gl * grg5vgf (gravbar, psi_l, v) + gr * grg5vgf (gravbar, psi_r, v) end function slrv1_grf @ \begin{subequations} \begin{align} C \gamma^0 \gamma^0 = - C \gamma^1 \gamma^1 = - C \gamma^2 \gamma^2 = C \gamma^3 \gamma^3 = C &= \begin{pmatrix} 0 & 1 & 0 & 0 \\ -1 & 0 & 0 & 0 \\ 0 & 0 & 0 & -1 \\ 0 & 0 & 1 & 0 \end{pmatrix} \\ C \gamma^0 \gamma^1 = - C \gamma^1 \gamma^0 &= \begin{pmatrix} -1 & 0 & 0 & 0 \\ 0 & 1 & 0 & 0 \\ 0 & 0 & -1 & 0 \\ 0 & 0 & 0 & 1 \end{pmatrix} \\ C \gamma^0 \gamma^2 = - C \gamma^2 \gamma^0 &= \begin{pmatrix} -\ii & 0 & 0 & 0 \\ 0 & -\ii & 0 & 0 \\ 0 & 0 & -\ii & 0 \\ 0 & 0 & 0 & -\ii \end{pmatrix} \\ C \gamma^0 \gamma^3 = - C \gamma^3 \gamma^0 &= \begin{pmatrix} 0 & 1 & 0 & 0 \\ 1 & 0 & 0 & 0 \\ 0 & 0 & 0 & 1 \\ 0 & 0 & 1 & 0 \end{pmatrix} \\ C \gamma^1 \gamma^2 = - C \gamma^2 \gamma^1 &= \begin{pmatrix} 0 & \ii & 0 & 0 \\ \ii & 0 & 0 & 0 \\ 0 & 0 & 0 & -\ii \\ 0 & 0 & -\ii & 0 \end{pmatrix} \\ C \gamma^1 \gamma^3 = - C \gamma^3 \gamma^1 &= \begin{pmatrix} -1 & 0 & 0 & 0 \\ 0 & -1 & 0 & 0 \\ 0 & 0 & 1 & 0 \\ 0 & 0 & 0 & 1 \end{pmatrix} \\ C \gamma^2 \gamma^3 = - C \gamma^3 \gamma^2 &= \begin{pmatrix} -\ii & 0 & 0 & 0 \\ 0 & \ii & 0 & 0 \\ 0 & 0 & \ii & 0 \\ 0 & 0 & 0 & -\ii \end{pmatrix} \end{align} \end{subequations} @ <>= pure function sv2_grf (g, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vectorspinor) :: g0_psi, g1_psi, g2_psi, g3_psi g0_psi%psi(1)%a(1:2) = - psi%a(1:2) g0_psi%psi(1)%a(3:4) = psi%a(3:4) g0_psi%psi(2)%a(1) = psi%a(2) g0_psi%psi(2)%a(2) = psi%a(1) g0_psi%psi(2)%a(3) = psi%a(4) g0_psi%psi(2)%a(4) = psi%a(3) g0_psi%psi(3)%a(1) = (0,-1) * psi%a(2) g0_psi%psi(3)%a(2) = (0,1) * psi%a(1) g0_psi%psi(3)%a(3) = (0,-1) * psi%a(4) g0_psi%psi(3)%a(4) = (0,1) * psi%a(3) g0_psi%psi(4)%a(1) = psi%a(1) g0_psi%psi(4)%a(2) = - psi%a(2) g0_psi%psi(4)%a(3) = psi%a(3) g0_psi%psi(4)%a(4) = - psi%a(4) g1_psi%psi(1)%a(1:4) = - g0_psi%psi(2)%a(1:4) g1_psi%psi(2)%a(1:4) = - g0_psi%psi(1)%a(1:4) g1_psi%psi(3)%a(1) = (0,1) * psi%a(1) g1_psi%psi(3)%a(2) = (0,-1) * psi%a(2) g1_psi%psi(3)%a(3) = (0,-1) * psi%a(3) g1_psi%psi(3)%a(4) = (0,1) * psi%a(4) g1_psi%psi(4)%a(1) = - psi%a(2) g1_psi%psi(4)%a(2) = psi%a(1) g1_psi%psi(4)%a(3) = psi%a(4) g1_psi%psi(4)%a(4) = - psi%a(3) g2_psi%psi(1)%a(1:4) = - g0_psi%psi(3)%a(1:4) g2_psi%psi(2)%a(1:4) = - g1_psi%psi(3)%a(1:4) g2_psi%psi(3)%a(1:4) = - g0_psi%psi(1)%a(1:4) g2_psi%psi(4)%a(1) = (0,1) * psi%a(2) g2_psi%psi(4)%a(2) = (0,1) * psi%a(1) g2_psi%psi(4)%a(3) = (0,-1) * psi%a(4) g2_psi%psi(4)%a(4) = (0,-1) * psi%a(3) g3_psi%psi(1)%a(1:4) = - g0_psi%psi(4)%a(1:4) g3_psi%psi(2)%a(1:4) = - g1_psi%psi(4)%a(1:4) g3_psi%psi(3)%a(1:4) = - g2_psi%psi(4)%a(1:4) g3_psi%psi(4)%a(1:4) = - g0_psi%psi(1)%a(1:4) j%t = (g * phi) * (gravbar * g0_psi) j%x(1) = (g * phi) * (gravbar * g1_psi) j%x(2) = (g * phi) * (gravbar * g2_psi) j%x(3) = (g * phi) * (gravbar * g3_psi) end function sv2_grf @ <>= pure function slv2_grf (gl, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 j = sv2_grf (gl, gravbar, phi, psi_l) end function slv2_grf @ <>= pure function srv2_grf (gr, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_r psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = sv2_grf (gr, gravbar, phi, psi_r) end function srv2_grf @ <>= pure function slrv2_grf (gl, gr, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = sv2_grf (gl, gravbar, phi, psi_l) + sv2_grf (gr, gravbar, phi, psi_r) end function slrv2_grf @ <>= pure function sv1_fgr (g, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v j = g * fg5gkgr (psibar, grav, v) end function sv1_fgr @ <>= pure function slv1_fgr (gl, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = gl * fg5gkgr (psibar_l, grav, v) end function slv1_fgr @ <>= pure function srv1_fgr (gr, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = gr * fg5gkgr (psibar_r, grav, v) end function srv1_fgr @ <>= pure function slrv1_fgr (gl, gr, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: gl, gr type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = gl * fg5gkgr (psibar_l, grav, v) + gr * fg5gkgr (psibar_r, grav, v) end function slrv1_fgr @ <>= pure function sv2_fgr (g, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(bispinor) :: g0_grav, g1_grav, g2_grav, g3_grav g0_grav%a(1) = -grav%psi(1)%a(1) + grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) + grav%psi(4)%a(1) g0_grav%a(2) = -grav%psi(1)%a(2) + grav%psi(2)%a(1) + & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g0_grav%a(3) = grav%psi(1)%a(3) + grav%psi(2)%a(4) - & (0,1) * grav%psi(3)%a(4) + grav%psi(4)%a(3) g0_grav%a(4) = grav%psi(1)%a(4) + grav%psi(2)%a(3) + & (0,1) * grav%psi(3)%a(3) - grav%psi(4)%a(4) !!! g1_grav%a(1) = grav%psi(1)%a(2) - grav%psi(2)%a(1) + & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g1_grav%a(2) = grav%psi(1)%a(1) - grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) + grav%psi(4)%a(1) g1_grav%a(3) = grav%psi(1)%a(4) + grav%psi(2)%a(3) - & (0,1) * grav%psi(3)%a(3) + grav%psi(4)%a(4) g1_grav%a(4) = grav%psi(1)%a(3) + grav%psi(2)%a(4) + & (0,1) * grav%psi(3)%a(4) - grav%psi(4)%a(3) !!! g2_grav%a(1) = (0,1) * (-grav%psi(1)%a(2) - grav%psi(2)%a(1) + & grav%psi(4)%a(2)) - grav%psi(3)%a(1) g2_grav%a(2) = (0,1) * (grav%psi(1)%a(1) + grav%psi(2)%a(2) + & grav%psi(4)%a(1)) - grav%psi(3)%a(2) g2_grav%a(3) = (0,1) * (-grav%psi(1)%a(4) + grav%psi(2)%a(3) - & grav%psi(4)%a(4)) + grav%psi(3)%a(3) g2_grav%a(4) = (0,1) * (grav%psi(1)%a(3) - grav%psi(2)%a(4) - & grav%psi(4)%a(3)) + grav%psi(3)%a(4) !!! g3_grav%a(1) = -grav%psi(1)%a(2) + grav%psi(2)%a(2) - & (0,1) * grav%psi(3)%a(2) - grav%psi(4)%a(1) g3_grav%a(2) = grav%psi(1)%a(1) - grav%psi(2)%a(1) - & (0,1) * grav%psi(3)%a(1) - grav%psi(4)%a(2) g3_grav%a(3) = -grav%psi(1)%a(2) - grav%psi(2)%a(4) + & (0,1) * grav%psi(3)%a(4) + grav%psi(4)%a(3) g3_grav%a(4) = -grav%psi(1)%a(4) + grav%psi(2)%a(3) + & (0,1) * grav%psi(3)%a(3) + grav%psi(4)%a(4) j%t = (g * phi) * (psibar * g0_grav) j%x(1) = (g * phi) * (psibar * g1_grav) j%x(2) = (g * phi) * (psibar * g2_grav) j%x(3) = (g * phi) * (psibar * g3_grav) end function sv2_fgr @ <>= pure function slv2_fgr (gl, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l type(vectorspinor), intent(in) :: grav psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 j = sv2_fgr (gl, psibar_l, phi, grav) end function slv2_fgr @ <>= pure function srv2_fgr (gr, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gr, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_r type(vectorspinor), intent(in) :: grav psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = sv2_fgr (gr, psibar_r, phi, grav) end function srv2_fgr @ <>= pure function slrv2_fgr (gl, gr, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr, phi type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vectorspinor), intent(in) :: grav psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = sv2_fgr (gl, psibar_l, phi, grav) + sv2_fgr (gr, psibar_r, phi, grav) end function slrv2_fgr @ <>= pure function pv1_grf (g, gravbar, v, psi) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = g * grvgf (gravbar, psi, v) end function pv1_grf @ <>= pure function pv2_grf (g, gravbar, phi, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: g5_psi g5_psi%a(1:2) = - psi%a(1:2) g5_psi%a(3:4) = psi%a(3:4) j = sv2_grf (g, gravbar, phi, g5_psi) end function pv2_grf @ <>= pure function pv1_fgr (g, psibar, v, grav) result (j) complex(kind=default) :: j complex(kind=default), intent(in) :: g type(bispinor), intent(in) :: psibar type(vectorspinor), intent(in) :: grav type(vector), intent(in) :: v j = g * fgkgr (psibar, grav, v) end function pv1_fgr @ <>= pure function pv2_fgr (g, psibar, phi, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g, phi type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_g5 psibar_g5%a(1:2) = - psibar%a(1:2) psibar_g5%a(3:4) = psibar%a(3:4) j = sv2_fgr (g, psibar_g5, phi, grav) end function pv2_fgr @ <>= pure function v2_grf (g, gravbar, v, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(vector), intent(in) :: v j = -g * grkgggf (gravbar, psi, v) end function v2_grf @ <>= pure function v2lr_grf (gl, gr, gravbar, v, psi) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: gravbar type(bispinor), intent(in) :: psi type(bispinor) :: psi_l, psi_r type(vector), intent(in) :: v psi_l%a(1:2) = psi%a(1:2) psi_l%a(3:4) = 0 psi_r%a(1:2) = 0 psi_r%a(3:4) = psi%a(3:4) j = -(gl * grkgggf (gravbar, psi_l, v) + gr * grkgggf (gravbar, psi_r, v)) end function v2lr_grf @ <>= pure function v2_fgr (g, psibar, v, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: g type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(vector), intent(in) :: v j = -g * fggkggr (psibar, grav, v) end function v2_fgr @ <>= pure function v2lr_fgr (gl, gr, psibar, v, grav) result (j) type(vector) :: j complex(kind=default), intent(in) :: gl, gr type(vectorspinor), intent(in) :: grav type(bispinor), intent(in) :: psibar type(bispinor) :: psibar_l, psibar_r type(vector), intent(in) :: v psibar_l%a(1:2) = psibar%a(1:2) psibar_l%a(3:4) = 0 psibar_r%a(1:2) = 0 psibar_r%a(3:4) = psibar%a(3:4) j = -(gl * fggkggr (psibar_l, grav, v) + gr * fggkggr (psibar_r, grav, v)) end function v2lr_fgr @ \subsection{On Shell Wave Functions} <>= public :: u, v, ghost @ \begin{subequations} \begin{align} \chi_+(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} |\vec p|+p_3 \\ p_1 + \ii p_2 \end{pmatrix} \\ \chi_-(\vec p) &= \frac{1}{\sqrt{2|\vec p|(|\vec p|+p_3)}} \begin{pmatrix} - p_1 + \ii p_2 \\ |\vec p|+p_3 \end{pmatrix} \end{align} \end{subequations} @ \begin{equation} u_\pm(p) = \begin{pmatrix} \sqrt{p_0\mp|\vec p|} \cdot \chi_\pm(\vec p) \\ \sqrt{p_0\pm|\vec p|} \cdot \chi_\pm(\vec p) \end{pmatrix} \end{equation} <>= pure function u (mass, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chip, chim real(kind=default) :: pabs, norm, delta, m m = abs(mass) pabs = sqrt (dot_product (p%x, p%x)) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chip = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) chim = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else norm = 1 / sqrt (2*pabs*(pabs + p%x(3))) chip = norm * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) chim = norm * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if if (s > 0) then psi%a(1:2) = delta * chip psi%a(3:4) = sqrt (p%t + pabs) * chip else psi%a(1:2) = sqrt (p%t + pabs) * chim psi%a(3:4) = delta * chim end if pabs = m ! make the compiler happy and use m if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function u @ \begin{equation} v_\pm(p) = \begin{pmatrix} \mp\sqrt{p_0\pm|\vec p|} \cdot \chi_\mp(\vec p) \\ \pm\sqrt{p_0\mp|\vec p|} \cdot \chi_\mp(\vec p) \end{pmatrix} \end{equation} <>= pure function v (mass, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: mass type(momentum), intent(in) :: p integer, intent(in) :: s complex(kind=default), dimension(2) :: chip, chim real(kind=default) :: pabs, norm, delta, m pabs = sqrt (dot_product (p%x, p%x)) m = abs(mass) if (m < epsilon (m) * pabs) then delta = 0 else delta = sqrt (max (p%t - pabs, 0._default)) end if if (pabs + p%x(3) <= 1000 * epsilon (pabs) * pabs) then chip = (/ cmplx ( 0.0, 0.0, kind=default), & cmplx ( 1.0, 0.0, kind=default) /) chim = (/ cmplx (-1.0, 0.0, kind=default), & cmplx ( 0.0, 0.0, kind=default) /) else norm = 1 / sqrt (2*pabs*(pabs + p%x(3))) chip = norm * (/ cmplx (pabs + p%x(3), kind=default), & cmplx (p%x(1), p%x(2), kind=default) /) chim = norm * (/ cmplx (-p%x(1), p%x(2), kind=default), & cmplx (pabs + p%x(3), kind=default) /) end if if (s > 0) then psi%a(1:2) = - sqrt (p%t + pabs) * chim psi%a(3:4) = delta * chim else psi%a(1:2) = delta * chip psi%a(3:4) = - sqrt (p%t + pabs) * chip end if pabs = m ! make the compiler happy and use m if (mass < 0) then psi%a(1:2) = - imago * psi%a(1:2) psi%a(3:4) = + imago * psi%a(3:4) end if end function v @ <>= pure function ghost (m, p, s) result (psi) type(bispinor) :: psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s psi%a(:) = 0 select case (s) case (1) psi%a(1) = 1 psi%a(2:4) = 0 case (2) psi%a(1) = 0 psi%a(2) = 1 psi%a(3:4) = 0 case (3) psi%a(1:2) = 0 psi%a(3) = 1 psi%a(4) = 0 case (4) psi%a(1:3) = 0 psi%a(4) = 1 case (5) psi%a(1) = 1.4 psi%a(2) = - 2.3 psi%a(3) = - 71.5 psi%a(4) = 0.1 end select end function ghost @ \subsection{Off Shell Wave Functions} This is the same as for the Dirac fermions except that the expressions for [ubar] and [vbar] are missing. <>= public :: brs_u, brs_v @ In momentum space we have: \begin{equation} brs u(p)=(-i) (\fmslash p-m)u(p) \end{equation} <>= pure function brs_u (m, p, s) result (dpsi) type(bispinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=u(m,p,s) dpsi=cmplx(0.0,-1.0)*(f_vf(one,vp,psi)-m*psi) end function brs_u @ \begin{equation} brs v(p)=i (\fmslash p+m)v(p) \end{equation} <>= pure function brs_v (m, p, s) result (dpsi) type(bispinor) :: dpsi, psi real(kind=default), intent(in) :: m type(momentum), intent(in) :: p integer, intent(in) :: s type (vector)::vp complex(kind=default), parameter :: one = (1, 0) vp=p psi=v(m,p,s) dpsi=cmplx(0.0,1.0)*(f_vf(one,vp,psi)+m*psi) end function brs_v @ \subsection{Propagators} <>= public :: pr_psi, pr_grav public :: pj_psi, pg_psi @ \begin{equation} \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi \end{equation} NB: the sign of the momentum comes about because all momenta are treated as \emph{outgoing} and the particle charge flow is therefore opposite to the momentum. <>= pure function pr_psi (p, m, w, cms, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi logical, intent(in) :: cms type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) complex(kind=default) :: num_mass vp = p if (cms) then num_mass = sqrt(cmplx(m**2, -m*w, kind=default)) else num_mass = cmplx (m, 0, kind=default) end if ppsi = (1 / cmplx (p*p - m**2, m*w, kind=default)) & * (- f_vf (one, vp, psi) + num_mass * psi) end function pr_psi @ \begin{equation} \sqrt{\frac{\pi}{M\Gamma}} (-\fmslash{p}+m)\psi \end{equation} <>= pure function pj_psi (p, m, w, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = (0, -1) * sqrt (PI / m / w) * (- f_vf (one, vp, psi) + m * psi) end function pj_psi @ <>= pure function pg_psi (p, m, w, psi) result (ppsi) type(bispinor) :: ppsi type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(bispinor), intent(in) :: psi type(vector) :: vp complex(kind=default), parameter :: one = (1, 0) vp = p ppsi = gauss (p*p, m, w) * (- f_vf (one, vp, psi) + m * psi) end function pg_psi @ \begin{equation} \dfrac{\ii\biggl\{(-\fmslash{p} + m)\left(-\eta_{\mu\nu} + \dfrac{p_\mu p_\nu}{m^2}\right) + \dfrac{1}{3} \left(\gamma_\mu -\dfrac{p_\mu}{m}\right) (\fmslash{p} + m)\left(\gamma_\nu - \dfrac{p_\nu}{m}\right)\biggr\}}{p^2 - m^2 + \ii m \Gamma} \; \psi^\nu \end{equation} <>= pure function pr_grav (p, m, w, grav) result (propgrav) type(vectorspinor) :: propgrav type(momentum), intent(in) :: p real(kind=default), intent(in) :: m, w type(vectorspinor), intent(in) :: grav type(vector) :: vp type(bispinor) :: pgrav, ggrav, ggrav1, ggrav2, ppgrav type(vectorspinor) :: etagrav_dum, etagrav, pppgrav, & gg_grav_dum, gg_grav complex(kind=default), parameter :: one = (1, 0) real(kind=default) :: minv integer :: i vp = p minv = 1/m pgrav = p%t * grav%psi(1) - p%x(1) * grav%psi(2) - & p%x(2) * grav%psi(3) - p%x(3) * grav%psi(4) ggrav%a(1) = grav%psi(1)%a(3) - grav%psi(2)%a(4) + (0,1) * & grav%psi(3)%a(4) - grav%psi(4)%a(3) ggrav%a(2) = grav%psi(1)%a(4) - grav%psi(2)%a(3) - (0,1) * & grav%psi(3)%a(3) + grav%psi(4)%a(4) ggrav%a(3) = grav%psi(1)%a(1) + grav%psi(2)%a(2) - (0,1) * & grav%psi(3)%a(2) + grav%psi(4)%a(1) ggrav%a(4) = grav%psi(1)%a(2) + grav%psi(2)%a(1) + (0,1) * & grav%psi(3)%a(1) - grav%psi(4)%a(2) ggrav1 = ggrav - minv * pgrav ggrav2 = f_vf (one, vp, ggrav1) + m * ggrav - pgrav ppgrav = (-minv**2) * f_vf (one, vp, pgrav) + minv * pgrav do i = 1, 4 etagrav_dum%psi(i) = f_vf (one, vp, grav%psi(i)) end do etagrav = etagrav_dum - m * grav pppgrav%psi(1) = p%t * ppgrav pppgrav%psi(2) = p%x(1) * ppgrav pppgrav%psi(3) = p%x(2) * ppgrav pppgrav%psi(4) = p%x(3) * ppgrav gg_grav_dum%psi(1) = p%t * ggrav2 gg_grav_dum%psi(2) = p%x(1) * ggrav2 gg_grav_dum%psi(3) = p%x(2) * ggrav2 gg_grav_dum%psi(4) = p%x(3) * ggrav2 gg_grav = gr_potf (one, one, ggrav2) - minv * gg_grav_dum propgrav = (1 / cmplx (p*p - m**2, m*w, kind=default)) * & (etagrav + pppgrav + (1/3.0_default) * gg_grav) end function pr_grav @ \section{Polarization vectorspinors} Here we construct the wavefunctions for (massive) gravitinos out of the wavefunctions of (massive) vectorbosons and (massive) Majorana fermions. \begin{subequations} \begin{align} \psi^\mu_{(u; 3/2)} (k) &= \; \epsilon^\mu_+ (k) \cdot u (k, +) \\ \psi^\mu_{(u; 1/2)} (k) &= \; \sqrt{\dfrac{1}{3}} \, \epsilon^\mu_+ (k) \cdot u (k, -) + \sqrt{\dfrac{2}{3}} \, \epsilon^\mu_0 (k) \cdot u (k, +) \\ \psi^\mu_{(u; -1/2)} (k) &= \; \sqrt{\dfrac{2}{3}} \, \epsilon^\mu_0 (k) \cdot u (k, -) + \sqrt{\dfrac{1}{3}} \, \epsilon^\mu_- (k) \cdot u (k, +) \\ \psi^\mu_{(u; -3/2)} (k) &= \; \epsilon^\mu_- (k) \cdot u (k, -) \end{align} \end{subequations} and in the same manner for $\psi^\mu_{(v; s)}$ with $u$ replaced by $v$ and with the conjugated polarization vectors. These gravitino wavefunctions obey the Dirac equation, they are transverse and they fulfill the irreducibility condition \begin{equation} \gamma_\mu \psi^\mu_{(u/v; s)} = 0 . \end{equation} <<[[omega_vspinor_polarizations.f90]]>>= <> module omega_vspinor_polarizations use kinds use constants use omega_vectors use omega_bispinors use omega_bispinor_couplings use omega_vectorspinors implicit none <> integer, parameter, public :: omega_vspinor_pols_2010_01_A = 0 contains <> end module omega_vspinor_polarizations @ <>= public :: ueps, veps private :: eps private :: outer_product @ Here we implement the polarization vectors for vectorbosons with trigonometric functions, without the rotating of components done in HELAS~\cite{HELAS}. These are only used for generating the polarization vectorspinors. \begin{subequations} \begin{align} \epsilon^\mu_+(k) &= \frac{- e^{+\ii\phi}}{\sqrt{2}} \left(0; \cos\theta\cos\phi - \ii\sin\phi, \cos\theta\sin\phi + \ii\cos\phi, -\sin\theta \right) \\ \epsilon^\mu_-(k) &= \frac{e^{-\ii\phi}}{\sqrt{2}} \left(0; \cos\theta\cos\phi + \ii \sin\phi, \cos\theta\sin\phi - \ii \cos\phi, - \sin\theta \right) \\ \epsilon^\mu_0(k) &= \frac{1}{m} \left(|\vec k|; k^0\sin\theta\cos\phi, k^0\sin\theta\sin\phi, k^0\cos\theta\right) \end{align} \end{subequations} Determining the mass from the momenta is a numerically haphazardous for light particles. Therefore, we accept some redundancy and pass the mass explicitely. For the case that the momentum lies totally in the $z$-direction we take the convention $\cos\phi=1$ and $\sin\phi=0$. <>= pure function eps (mass, k, s) result (e) type(vector) :: e real(kind=default), intent(in) :: mass type(momentum), intent(in) :: k integer, intent(in) :: s real(kind=default) :: kabs, kabs2, sqrt2, m real(kind=default) :: cos_phi, sin_phi, cos_th, sin_th complex(kind=default) :: epiphi, emiphi sqrt2 = sqrt (2.0_default) kabs2 = dot_product (k%x, k%x) m = abs(mass) if (kabs2 > 0) then kabs = sqrt (kabs2) if ((k%x(1) == 0) .and. (k%x(2) == 0)) then cos_phi = 1 sin_phi = 0 else cos_phi = k%x(1) / sqrt(k%x(1)**2 + k%x(2)**2) sin_phi = k%x(2) / sqrt(k%x(1)**2 + k%x(2)**2) end if cos_th = k%x(3) / kabs sin_th = sqrt(1 - cos_th**2) epiphi = cos_phi + (0,1) * sin_phi emiphi = cos_phi - (0,1) * sin_phi e%t = 0 e%x = 0 select case (s) case (1) e%x(1) = epiphi * (-cos_th * cos_phi + (0,1) * sin_phi) / sqrt2 e%x(2) = epiphi * (-cos_th * sin_phi - (0,1) * cos_phi) / sqrt2 e%x(3) = epiphi * ( sin_th / sqrt2) case (-1) e%x(1) = emiphi * ( cos_th * cos_phi + (0,1) * sin_phi) / sqrt2 e%x(2) = emiphi * ( cos_th * sin_phi - (0,1) * cos_phi) / sqrt2 e%x(3) = emiphi * (-sin_th / sqrt2) case (0) if (m > 0) then e%t = kabs / m e%x = k%t / (m*kabs) * k%x end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select else !!! for particles in their rest frame defined to be !!! polarized along the 3-direction e%t = 0 e%x = 0 select case (s) case (1) e%x(1) = cmplx ( - 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (-1) e%x(1) = cmplx ( 1, 0, kind=default) / sqrt2 e%x(2) = cmplx ( 0, 1, kind=default) / sqrt2 case (0) if (m > 0) then e%x(3) = 1 end if case (4) if (m > 0) then e = (1 / m) * k else e = (1 / k%t) * k end if end select end if end function eps @ <>= pure function ueps (m, k, s) result (t) type(vectorspinor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s integer :: i type(vector) :: ep, e0, em type(bispinor) :: up, um do i = 1, 4 t%psi(i)%a = 0 end do select case (s) case (2) ep = eps (m, k, 1) up = u (m, k, 1) t = outer_product (ep, up) case (1) ep = eps (m, k, 1) e0 = eps (m, k, 0) up = u (m, k, 1) um = u (m, k, -1) t = (1 / sqrt (3.0_default)) * (outer_product (ep, um) & + sqrt (2.0_default) * outer_product (e0, up)) case (-1) e0 = eps (m, k, 0) em = eps (m, k, -1) up = u (m, k, 1) um = u (m, k, -1) t = (1 / sqrt (3.0_default)) * (sqrt (2.0_default) * & outer_product (e0, um) + outer_product (em, up)) case (-2) em = eps (m, k, -1) um = u (m, k, -1) t = outer_product (em, um) end select end function ueps @ <>= pure function veps (m, k, s) result (t) type(vectorspinor) :: t real(kind=default), intent(in) :: m type(momentum), intent(in) :: k integer, intent(in) :: s integer :: i type(vector) :: ep, e0, em type(bispinor) :: vp, vm do i = 1, 4 t%psi(i)%a = 0 end do select case (s) case (2) ep = conjg(eps (m, k, 1)) vp = v (m, k, 1) t = outer_product (ep, vp) case (1) ep = conjg(eps (m, k, 1)) e0 = conjg(eps (m, k, 0)) vp = v (m, k, 1) vm = v (m, k, -1) t = (1 / sqrt (3.0_default)) * (outer_product (ep, vm) & + sqrt (2.0_default) * outer_product (e0, vp)) case (-1) e0 = conjg(eps (m, k, 0)) em = conjg(eps (m, k, -1)) vp = v (m, k, 1) vm = v (m, k, -1) t = (1 / sqrt (3.0_default)) * (sqrt (2.0_default) & * outer_product (e0, vm) + outer_product (em, vp)) case (-2) em = conjg(eps (m, k, -1)) vm = v (m, k, -1) t = outer_product (em, vm) end select end function veps @ <>= pure function outer_product (ve, sp) result (vs) type(vectorspinor) :: vs type(vector), intent(in) :: ve type(bispinor), intent(in) :: sp integer :: i vs%psi(1)%a(1:4) = ve%t * sp%a(1:4) do i = 1, 3 vs%psi((i+1))%a(1:4) = ve%x(i) * sp%a(1:4) end do end function outer_product @ \section{Color} <<[[omega_color.f90]]>>= <> module omega_color use kinds implicit none private <> <> integer, parameter, public :: omega_color_2010_01_A = 0 contains <> end module omega_color @ \subsection{Color Sum} <>= public :: omega_color_factor type omega_color_factor integer :: i1, i2 real(kind=default) :: factor end type omega_color_factor @ <>= public :: omega_color_sum @ The [[!$omp]] instruction will result in parallel code if compiled with support for OpenMP otherwise it is ignored. @ <>= <<[[pure]] unless OpenMP>> function omega_color_sum (flv, hel, amp, cf) result (amp2) complex(kind=default) :: amp2 integer, intent(in) :: flv, hel complex(kind=default), dimension(:,:,:), intent(in) :: amp type(omega_color_factor), dimension(:), intent(in) :: cf integer :: n amp2 = 0 !$omp parallel do reduction(+:amp2) do n = 1, size (cf) amp2 = amp2 + cf(n)%factor * & amp(flv,cf(n)%i1,hel) * conjg (amp(flv,cf(n)%i2,hel)) end do !$omp end parallel do end function omega_color_sum @ In the bytecode for the OVM, we only save the symmetric part of the color factor table. This almost halves the size of $n$ gluon amplitudes for $n>6$. For $2\,\to\,(5,6)\,g$ the reduced color factor table still amounts for $\sim(75,93)\%$ of the bytecode, making it desirable to omit it completely by computing it dynamically to reduce memory requirements. Note that $2\text{Re}(A_{i_1}A_{i_2}^*)=A_{i_1}A_{i_2}^*+A_{i_2}A_{i_1}^*$. <>= public :: ovm_color_sum @ <>= <<[[pure]] unless OpenMP>> function ovm_color_sum (flv, hel, amp, cf) result (amp2) real(kind=default) :: amp2 integer, intent(in) :: flv, hel complex(kind=default), dimension(:,:,:), intent(in) :: amp type(omega_color_factor), dimension(:), intent(in) :: cf integer :: n amp2 = 0 !$omp parallel do reduction(+:amp2) do n = 1, size (cf) if (cf(n)%i1 == cf(n)%i2) then amp2 = amp2 + cf(n)%factor * & real(amp(flv,cf(n)%i1,hel) * conjg(amp(flv,cf(n)%i2,hel))) else amp2 = amp2 + cf(n)%factor * 2 * & real(amp(flv,cf(n)%i1,hel) * conjg(amp(flv,cf(n)%i2,hel))) end if end do !$omp end parallel do end function ovm_color_sum +@ \section{Birdtracks} +This module is part of the interface to WHIZARD, describing the color flows. +Wolfgang wants short identifiers \ldots +<<[[omega_birdtracks.f90]]>>= +<> +module omega_birdtracks + use kinds + implicit none + private + <<[[omega_birdtracks]] declarations>> +contains + <> +end module omega_birdtracks +@ Application programs can assume that all arrays are allocated +and may test for empy array using the [[size]] intrinsic without +using [[allocated]] first. +@ \subsection{External Particles} +[[color_state]] describes the color flow lines for one external particle. +Its components are +\begin{itemize} + \item the arrays [[i]] and [[o]] contain the numbers denoting the lines + starting and ending here + \item since we must distinguish color states without inflowing + and outflowing lines representing a color scalar from those + representing a ghost, we need the [[g]] flag + \item if [[i(n) < 0]], the line in slot [[n]] in the array [[i]] is not + connected to the slot containg the same number in the array [[o]] of + another [[color_state]]. Instead, this slot is connected to an $\epsilon_{ijk}$. + Analogously, if [[o(n) < 0]], the slot [[n]] in the array [[o]] + is connected to an $\bar\epsilon^{ijk}$. +\end{itemize} +<<[[omega_birdtracks]] declarations>>= +public :: color_state +type :: color_state + integer, dimension(:), allocatable :: i, o + logical :: g = .false. +contains + procedure :: check => color_state_check + procedure :: to_string => color_state_to_string + procedure :: conjugate => color_state_conjugate + procedure :: rank_inflowing, rank_outflowing + procedure :: contains_epsilons => color_state_contains_epsilons +end type color_state +@ Test the invariants of [[color_state]] and return [[CS_OK]] (ie.~0) +if they are satisfied. If not, return a negative error code (see below). +<>= +impure elemental function color_state_check (cs) result (rc) + class(color_state), intent(in) :: cs + integer :: rc + character(*), parameter :: my_name = "omega_birdtracks%color_state_check" + type(color_state) :: cs_tmp + if (cs%g .and. (size (cs%i) > 0 .or. size (cs%o) > 0)) then + cs_tmp = cs + cs_tmp%g = .false. + print *, my_name, ": ghost with open lines ", cs_tmp%to_string () + rc = CS_GHOST + else + rc = CS_OK + end if +end function color_state_check +@ These are the return codes +<<[[omega_birdtracks]] declarations>>= +integer, parameter, public :: CS_OK = 0 +integer, parameter, public :: CS_GHOST = -1 +@ Find the minimum number of characters for representing the integer [[i]]. +This algorithm is inefficient for large [[abs(i)]], but we're only using it +for small numbers. In fact, we even require the modulus of [[i]] to be less +than 1000000, to avoid overflows in [[abs]]. +<>= +elemental function integer_width (i) result (w) + integer, intent(in) :: i + integer :: ii, w + if (i < 1000000 .and. i > -1000000) then + if (i < 0) then + w = 2 + else + w = 1 + end if + ii = abs (i) + do while (ii >= 10) + w = w + 1 + ii = ii / 10 + end do + else + w = 0 + end if +end function integer_width +@ More concise and completely portable, but probably less efficient: +<>= +elemental function integer_width (i) result (w) + integer, intent(in) :: i + integer :: w + character(IO_BUFFER_SIZE) :: buffer + write (unit = buffer, fmt = "(I0)") i + w = len_trim (buffer) +end function integer_width +@ Find the minimum number of characters for representing the integer in the +array [[a]] that requires the most. +<>= +pure function max_integer_width (a) result (w) + integer, dimension(:), intent(in) :: a + integer :: w + w = max (integer_width (minval (a)), integer_width (maxval (a))) +end function max_integer_width +@ +Construct a composable format substring for arrays of small integers with the +same width for each member. Note that the resulting +format strings are \emph{not} complete: the initial [['(']] and final [[')']] +are missing in order to make them composable. By default, the element will be +enclosed by square brackets [['[']] and [[']']]. These can be changed by +[[prefix]] and [[postfix]], for writing lists as function arguments. + +Note that it is not strictly necessary to to calculate the exact size of [[fmt]] +and to [[allocate]] it by hand. Instead, a stack allocated +[[character(IO_BUFFER_SIZE) :: buffer]] suffices for all practical purposes and +we can then use allocate-on-assignment in [[fmt = trim (buffer)]] at the end. +<<[[omega_birdtracks]] declarations>>= +integer, parameter :: IO_BUFFER_SIZE = 1000 +@ +\begin{dubious} + Also note that below there is a different approach that first constructs an array + of characters representing the integers and concatenates the members subsequently. + This approach needs less wizardry with unreadable and potentially overflowing format + strings, but GNU Fortran produces (spurious?) warnings about my implementation. +\end{dubious} +<>= +pure function integer_array_format (a, min_width, prefix, postfix) result (fmt) + integer, dimension(:), intent(in) :: a + integer, intent(in), optional :: min_width + character(*), intent(in), optional :: prefix, postfix + character(:), allocatable :: fmt + character(:), allocatable :: pre, post + character(IO_BUFFER_SIZE) :: buffer + integer :: w + w = max_integer_width (a) + if (present (min_width)) then + w = max (w, min_width) + end if + if (present (prefix)) then + pre = prefix + else + pre = "[" + endif + if (present (postfix)) then + post = postfix + else + post = "]" + endif + select case (size (a)) + case (0) + fmt = "'" // pre // post // "'" + case (1) + write (buffer, "(3A,I0,3A)") "'", pre, "', I", w, ", '", post, "'" + fmt = trim (buffer) + case default + write (buffer, "(3A,3(I0,A),2A)") "'", pre, "',", size(a) - 1, "(I", w, ", ','), I", w, ", '", post, "'" + fmt = trim (buffer) + end select +end function integer_array_format +@ +<>= +pure function integer_array_format (a, min_width, prefix, postfix) result (fmt) + integer, dimension(:), intent(in) :: a + integer, intent(in), optional :: min_width + character(*), intent(in), optional :: prefix, postfix + character(:), allocatable :: fmt, pre, post + integer :: w + w = max_integer_width (a) + if (present (min_width)) then + w = max (w, min_width) + end if + if (present (prefix)) then + pre = prefix + else + pre = "[" + endif + if (present (postfix)) then + post = postfix + else + post = "]" + endif + select case (size (a)) + case (0) + allocate (character(len = 4) :: fmt) + fmt = "'" // pre // post // "'" + case (1) + allocate (character(len = 11 + integer_width (w)) :: fmt) + write (fmt, "(3A,I0,3A)") "'", pre, "', I", w, ", '", post, "'" + case default + allocate (character(len = 20 + integer_width (size(a) - 1) + 2*integer_width (w)) :: fmt) + write (fmt, "(3A,3(I0,A),2A)") "'", pre, "',", size(a) - 1, "(I", w, ", ','), I", w, ", '", post, "'" + end select +end function integer_array_format +@ +<>= +pure function color_state_to_string (cs) result (s) + class(color_state), intent(in) :: cs + character(:), allocatable :: s + character(IO_BUFFER_SIZE) :: buffer + integer :: iostat + if (cs%g) then + s = "g" + else + write (unit = buffer, fmt = & + "('(', " // integer_array_format (cs%i) // ", ', ', " & + // integer_array_format (cs%o) // ", ')')", & + iostat = iostat) cs%i, cs%o + if (is_iostat_eor (iostat) .or. is_iostat_end (iostat)) then + s = "color_state_to_string: too long" + else + s = trim (buffer) + endif + end if +end function color_state_to_string +@ +<>= +pure function color_state_conjugate (cs) result (csc) + class(color_state), intent(in) :: cs + type(color_state) :: csc + csc = color_state (i = cs%o, o = cs%i, g = cs%g) +end function color_state_conjugate +@ +<>= +pure subroutine color_state_conjugate (cs) + class(color_state), intent(inout) :: cs + integer, dimension(:), allocatable :: tmpo + tmpo = cs%o + cs%o = cs%i + cs%i = tmpo +end subroutine color_state_conjugate +@ +<>= +pure subroutine color_state_conjugate (cs, csc) + class(color_state), intent(in) :: cs + type(color_state), intent(inout) :: csc + csc%g = cs%g + csc%i = cs%o + csc%o = cs%i +end subroutine color_state_conjugate +@ +<>= +elemental function rank_inflowing (cs) result (n) + class(color_state), intent(in) :: cs + integer :: n + n = size (cs%i) +end function rank_inflowing +elemental function rank_outflowing (cs) result (n) + class(color_state), intent(in) :: cs + integer :: n + n = size (cs%o) +end function rank_outflowing +@ +<>= +elemental function color_state_contains_epsilons (cs) result (yorn) + class(color_state), intent(in) :: cs + logical :: yorn + yorn = min (minval (cs%i), minval (cs%o)) < 0 +end function color_state_contains_epsilons +@ \subsection{Color Flows} +In sections~\ref{sec:arrow}, \ref{sec:birdtracks} and~\ref{sec:su3} we +carefully distinguish~$\epsilon_{ijk}$ from~$\bar\epsilon^{ijk}$. +In the interface to Whizard, we give up this distinction, since the +color flows contain both incoming and outgoing particles. This will +result in $\epsilon$ tensors with mixed upper and lower indices. +Trying to keep track of them with Fortran types would cause more confusion +than clarity. In any case, all variants are \emph{numerically} +identical anyway and upper and lower indices can be distinguished from the +the external lines they are connected to. +<<[[omega_birdtracks]] declarations>>= +public :: epsilon3 +type :: epsilon3 + integer, dimension(3) :: j +contains + procedure :: check => epsilon3_check + procedure :: to_string => epsilon3_to_string +end type epsilon3 +@ +<>= +impure elemental function epsilon3_check (e) result (rc) + class(epsilon3), intent(in) :: e + integer :: rc, n + character(*), parameter :: my_name = "omega_birdtracks%epsilon3_check" + rc = E3_OK + if (any (e%j >= 0)) then + print *, my_name, ": index not negative in ", e%to_string () + rc = E3_NON_NEGATIVE + return + end if + do n = 1, size (e%j) + if (count (e%j == e%j(n)) /= 1) then + print *, my_name, ": duplicate index in ", e%to_string () + rc = E3_DUPLICATE + return + end if + end do +end function epsilon3_check +@ These are the return codes +<<[[omega_birdtracks]] declarations>>= +integer, parameter, public :: E3_OK = 0 +integer, parameter, public :: E3_NON_NEGATIVE = -1 +integer, parameter, public :: E3_DUPLICATE = -2 +@ +<>= +pure function epsilon3_to_string (e) result (s) + class(epsilon3), intent(in) :: e + character(:), allocatable :: s + character(IO_BUFFER_SIZE) :: buffer + integer :: iostat + write (unit = buffer, fmt = & + "('eps'," // integer_array_format (e%j, prefix = "(", postfix = ")") // ")", & + iostat = iostat) e%j + if (is_iostat_eor (iostat) .or. is_iostat_end (iostat)) then + s = "epsilon3_to_string: too long" + else + s = trim (buffer) + endif +end function epsilon3_to_string +@ +<<[[omega_birdtracks]] declarations>>= +public :: color_flow +type :: color_flow + type(color_state), dimension(:), allocatable :: cs + type(epsilon3), dimension(:), allocatable :: e +contains + procedure :: check => color_flow_check + procedure :: to_string => color_flow_to_string + procedure :: max_rank, max_rank_inflowing, max_rank_outflowing + procedure :: contains_epsilons => color_flow_contains_epsilons +end type color_flow +@ Test the invariants of [[color_flow]] and return [[CF_OK]] (ie.~0) +if they are satisfied. If not, return a negative error code (see below) +The application program can inspect the array [[cf%cs%check ()]] for more details +@ Utility function concatenating arrays. +<>= +pure function inflowing_lines (cf, n_incoming) result (inflowing) + class(color_flow), intent(in) :: cf + integer, intent(in) :: n_incoming + integer, dimension(:), allocatable :: inflowing + integer :: i, j, n, num_lines + num_lines = 0 + do n = 1, min (n_incoming, size (cf%cs)) + num_lines = num_lines + size (cf%cs(n)%o) + end do + do n = n_incoming + 1, size (cf%cs) + num_lines = num_lines + size (cf%cs(n)%i) + end do + allocate (inflowing(num_lines)) + j = 0 + do n = 1, min (n_incoming, size (cf%cs)) + i = j + 1 + j = i + size (cf%cs(n)%o) - 1 + inflowing(i:j) = cf%cs(n)%o + end do + do n = n_incoming + 1, size (cf%cs) + i = j + 1 + j = i + size (cf%cs(n)%i) - 1 + inflowing(i:j) = cf%cs(n)%i + end do +end function inflowing_lines +@ This code duplication could only be avoided by replacing [[cs%i]] and [[cs%o]] +by an array or by using accessor functions. A more aggressively object oriented +approach could also work. +<>= +pure function outflowing_lines (cf, n_incoming) result (outflowing) + class(color_flow), intent(in) :: cf + integer, intent(in) :: n_incoming + integer, dimension(:), allocatable :: outflowing + integer :: i, j, n, num_lines + num_lines = 0 + do n = 1, min (n_incoming, size (cf%cs)) + num_lines = num_lines + size (cf%cs(n)%i) + end do + do n = n_incoming + 1, size (cf%cs) + num_lines = num_lines + size (cf%cs(n)%o) + end do + allocate (outflowing(num_lines)) + j = 0 + do n = 1, min (n_incoming, size (cf%cs)) + i = j + 1 + j = i + size (cf%cs(n)%i) - 1 + outflowing(i:j) = cf%cs(n)%i + end do + do n = n_incoming + 1, size (cf%cs) + i = j + 1 + j = i + size (cf%cs(n)%o) - 1 + outflowing(i:j) = cf%cs(n)%o + end do +end function outflowing_lines +@ +<>= +pure function epsilon_lines (cf) result (eps) + class(color_flow), intent(in) :: cf + integer, dimension(:), allocatable :: eps + integer :: i, j, n, num_lines + num_lines = 0 + do n = 1, size (cf%e) + num_lines = num_lines + size (cf%e(n)%j) + end do + allocate (eps(num_lines)) + j = 0 + do n = 1, size (cf%e) + i = j + 1 + j = i + size (cf%e(n)%j) - 1 + eps(i:j) = cf%e(n)%j + end do +end function epsilon_lines +@ +<<[[omega_birdtracks]] declarations>>= +public :: inflowing_lines, outflowing_lines, epsilon_lines +@ Collect everything. +<>= +impure elemental function color_flow_check (cf) result (rc) + class(color_flow), intent(in) :: cf + integer :: rc, n + integer, dimension(:), allocatable :: i, o, e + integer :: n_incoming = 0 + character(*), parameter :: my_name = "omega_birdtracks%color_flow_check" + if (size (cf%cs) > 0) then + rc = minval (cf%cs%check ()) + if (rc /= 0) then + print *, my_name, ": inconsistent color_state in ", cf%to_string () + end if + end if + if (size (cf%e) > 0) then + rc = minval (cf%e%check ()) + if (rc /= 0) then + print *, my_name, ": inconsistent epsilon in ", cf%to_string () + return + end if + end if + i = inflowing_lines (cf, n_incoming) + o = outflowing_lines (cf, n_incoming) + e = epsilon_lines (cf) + do n = 1, size (i) + if (count (i == i(n)) /= 1) then + print *, my_name, ": duplicate inflowing line ", i(n), " in ", cf%to_string () + rc = CF_DUPLICATE + return + end if + if (i(n) > 0) then + if (count (o == i(n)) /= 1) then + print *, my_name, ": inflowing line ", i(n), " not uniquely connected in ", cf%to_string () + rc = CF_LINK + return + end if + else if (i(n) < 0) then + if (count (e == i(n)) /= 1) then + print *, my_name, ": epsilon line ", i(n), " not uniquely connected in ", cf%to_string () + rc = CF_LINK + return + end if + else + print *, my_name, ": line zero in ", cf%to_string () + rc = CF_ZERO + return + end if + end do + do n = 1, size (o) + if (count (o == o(n)) /= 1) then + print *, my_name, ": duplicate outflowing line ", o(n), " in ", cf%to_string () + rc = CF_DUPLICATE + return + end if + if (o(n) > 0) then + if (count (i == o(n)) /= 1) then + print *, my_name, ": outflowing line ", o(n), " not uniquely connected in ", cf%to_string () + rc = CF_LINK + return + end if + else if (o(n) < 0) then + if (count (e == o(n)) /= 1) then + print *, my_name, ": epsilon line ", o(n), " not uniquely connected in ", cf%to_string () + rc = CF_LINK + return + end if + else + print *, my_name, ": line zero in ", cf%to_string () + rc = CF_ZERO + return + end if + end do + do n = 1, size (e) + if (count (i == e(n)) + count (o == e(n)) /= 1) then + print *, my_name, ": epsilon line ", e(n), " not uniquely connected in ", cf%to_string () + rc = CF_LINK + return + end if + end do +end function color_flow_check +@ These are the return codes +<<[[omega_birdtracks]] declarations>>= +integer, parameter, public :: CF_OK = 0 +integer, parameter, public :: CF_GHOST = -1 +integer, parameter, public :: CF_EPS = -2 +integer, parameter, public :: CF_SIZE_EPS = -3 +integer, parameter, public :: CF_DUPLICATE = -4 +integer, parameter, public :: CF_LINK = -5 +integer, parameter, public :: CF_ZERO = -6 +@ +<>= +pure function color_flow_to_string (cf) result (s) + class(color_flow), intent(in) :: cf + character(:), allocatable :: s + character(IO_BUFFER_SIZE) :: buffer + integer :: n, from, to + buffer = "" + if (size (cf%cs) > 0) then + call initial (buffer, from, to, cf%cs(1)%to_string ()) + do n = 2, size (cf%cs) + call append (buffer, from, to, ", ") + call append (buffer, from, to, cf%cs(n)%to_string ()) + end do + if (size (cf%e) > 0) then + call append (buffer, from, to, "; ") + call append (buffer, from, to, cf%e(1)%to_string ()) + do n = 2, size (cf%e) + call append (buffer, from, to, ", ") + call append (buffer, from, to, cf%e(n)%to_string ()) + end do + end if + end if + s = "{" // trim (buffer) // "}" +contains + <> +end function color_flow_to_string +@ +<>= +pure subroutine append (buffer, from, to, s) + character(*), intent(inout) :: buffer + integer, intent(inout) :: from, to + character(*), intent(in) :: s + from = to + 1 + to = from + len (s) - 1 + buffer(from:to) = s +end subroutine append +@ +<>= +pure subroutine initial (buffer, from, to, s) + character(*), intent(inout) :: buffer + integer, intent(inout) :: from + integer, intent(out) :: to + character(*), intent(in) :: s + to = 0 + call append (buffer, from, to, s) +end subroutine initial +@ +<>= +pure function max_rank_inflowing (cf) result (n) + class(color_flow), intent(in) :: cf + integer :: n + n = maxval (cf%cs%rank_inflowing ()) +end function max_rank_inflowing +pure function max_rank_outflowing (cf) result (n) + class(color_flow), intent(in) :: cf + integer :: n + n = maxval (cf%cs%rank_outflowing ()) +end function max_rank_outflowing +pure function max_rank (cf) result (n) + class(color_flow), intent(in) :: cf + integer :: n + n = max (cf%max_rank_inflowing (), cf%max_rank_outflowing ()) +end function max_rank +@ +<>= +pure function color_flow_contains_epsilons (cf) result (yorn) + class(color_flow), intent(in) :: cf + logical :: yorn + yorn = any (cf%cs%contains_epsilons ()) +end function color_flow_contains_epsilons +@ \subsubsection{Implementation of DTIO} +\begin{dubious} + This has been shelved for portability, because the Intel Fortran compiler + appears to have problems in this area. +\end{dubious} +Fortran DTIO (i.\,e.~Defined Type IO) is actually quite powerful +and allows for concise implementations. Unfortunately, there is +absolutely no type checking for the format string and one needs +to do a lot of testing. In addition, the required nesting of +quotes can be hard to read. +@ +<>= +subroutine color_state_write (cs, unit, iotype, vlist, iostat, iomsg) + class(color_state), intent(in) :: cs + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, dimension(:), intent(in) :: vlist + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + integer :: integer_width + if (size (vlist) >= 1) then + integer_width = vlist(1) + else + integer_width = 1 + end if + if (cs%g) then + write (unit = unit, fmt = "(A)", iostat = iostat) "g" + else + write (unit = unit, fmt = & + "('(', " // integer_array_format (cs%i, min_width = integer_width) // ", ', ', " & + // integer_array_format (cs%o, min_width = integer_width) // ", ')')", & + iostat = iostat) cs%i, cs%o + end if +end subroutine color_state_write +@ +<>= +subroutine epsilon3_write (e, unit, iotype, vlist, iostat, iomsg) + class(epsilon3), intent(in) :: e + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, dimension(:), intent(in) :: vlist + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + integer :: integer_width + if (size (vlist) >= 1) then + integer_width = vlist(1) + else + integer_width = 1 + end if + write (unit = unit, fmt = & + "('eps'," // integer_array_format (e%j, min_width = integer_width, & + prefix = "(", postfix = ")") // ")", & + iostat = iostat) e%j +end subroutine epsilon3_write +@ +\begin{dubious} + For the time being, I'm ignoring [[vlist]]. We don't need it + and passing it on to the formats would add too much complexity. +\end{dubious} +<>= +subroutine color_flow_write (cf, unit, iotype, vlist, iostat, iomsg) + class(color_flow), intent(in) :: cf + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, dimension(:), intent(in) :: vlist + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character(len=34) :: fmt + integer :: n_cs, n_eps + n_cs = size (cf%cs) + select case (n_cs) + case (0) + fmt = "X" + case (1) + fmt = "DT" + case default + n_eps = size (cf%e) + select case (n_eps) + case (0) + write (fmt, fmt = "(A,I2,A)") "DT,", n_cs - 1, "(', ',DT)" + case (1) + write (fmt, fmt = "(A,I2,A)") "DT,", n_cs - 1, "(', ',DT),'; ',DT" + case default + write (fmt, fmt = "(A,2(I2,A))") "DT,", n_cs - 1, "(', ',DT),'; ',DT,", n_eps - 1, "(', ',DT)" + end select + end select + write (unit = unit, fmt = "('{'," // trim (fmt) // ",'}')", iostat = iostat) cf%cs, cf%e +end subroutine color_flow_write +@ \subsubsection{Earlier (shelved) Implementations} +Take the elements of the [[character]] array [[sarray]] and concatenate +them, putting a copy of [[padding]] between each pair. Do this by allocating +the result string and copy the source strings to the appropriate substrings. +The case of a zero-length [[sarray]] is treated specially to avoid a spurious +negative padding. +<>= +pure function concat (sarray, padding) result (s) + character(*), dimension(:), intent(in) :: sarray + character(*), intent(in), optional :: padding + character(:), allocatable :: s + integer :: len_s, from, to, n + if (size (sarray) == 0) then + s = "" + else + if (present (padding)) then + len_s = size (sarray) * len (sarray) + (size (sarray) - 1) * len (padding) + else + len_s = size (sarray) * len (sarray) + end if + allocate (character(len=len_s) :: s) + call first (from, to, len (sarray)) + s(from:to) = sarray(1) + do n = 2, size (sarray) + if (present (padding)) then + call next (from, to, len (padding)) + s(from:to) = padding + end if + call next (from, to, len (sarray)) + s(from:to) = sarray(n) + end do + end if +contains + <> +end function concat +@ Move [[from:to]] to the immediately following substring of length [[length]] +<>= +pure subroutine next (from, to, length) + integer, intent(inout) :: from, to + integer, intent(in) :: length + from = to + 1 + to = from + length - 1 +end subroutine next +@ Set [[from:to]] to the first substring of length [[length]] +<>= +pure subroutine first (from, to, length) + integer, intent(out) :: from, to + integer, intent(in) :: length + to = 0 + call next (from, to, length) +end subroutine first +@ Here we assume that the integers need at most 99 digits. +That should be a safe assumption. +<>= +pure function integer_array_to_string (a, min_width) result (s) + integer, dimension(:), intent(in) :: a + integer, intent(in), optional :: min_width + character(:), allocatable :: s + character(:), dimension(:), allocatable :: buffers + character(len=5) :: fmt + integer :: len_s, width, n + width = max_integer_width (a) + if (present (min_width)) then + width = max (width, min_width) + end if + allocate (character(len=width) :: buffers(size(a))) + write (fmt, "(A,I2,A)") "(I", width, ")" + do n = 1, size (a) + write (buffers(n), fmt = fmt) a(n) + end do + s = "[" // concat (buffers, ",") // "]" +end function integer_array_to_string +@ +\begin{dubious} + Iff this is used in another implementation of the [[color_state_write]] procedure, + GNU Fortran version~12.2 complains +\begin{verbatim} + omega_birdtracks.f90:140:54: + + 138 | character(:), dimension(:), allocatable :: buffers + | ^ + Warning: ‘.buffers’ is used uninitialized [-Wuninitialized] + omega_birdtracks.f90:170:34: + + 169 | end subroutine color_state_write + | ^ + note: ‘.buffers’ was declared here +\end{verbatim} +which I don't understand, since [[integer_array_to_string]] compiles +without any warning if it is not referenced in [[color_state_write]]. +\end{dubious} +@ \section{API} +@ \subsection{Version 3} +This module defines the interface to WHIZARD. +<<[[omega_api_v3.f90]]>>= +<> +module omega_api_v3 + use kinds + <> + implicit none + private + <<[[omega_api_v3]] declarations>> +contains + <> +end module omega_api_v3 +@ +<>= +use omega_birdtracks +@ \subsection{Scattering Amplitude} +It is crucial to define a common [[type]] for the amplitudes here +so that WHIZARD can form arrays of them. + +The type [[amplitude]] contains the scattering amplitude evaluated +for the most recent set of momenta. In particular, the component +[[amp]] containes the complex values indexed by +\begin{enumerate} + \item the combination of powers of coupling orders, + \item the combination of external flavors, + \item the color flow, and + \item the combination of external helicities. +These are all represented by indices into the corresponding arrays. +\end{enumerate} +\begin{dubious} + TODO + \begin{enumerate} + \item decide whether to cross the initial or final state. If so, + add the required information + \item add the table of color factors required for computing color sums + \item make sure that the [[amp]] component does not need to be copied + every time the amplitude is evaluated for a new set of momenta. + \end{enumerate} +\end{dubious} +<<[[omega_api_v3]] declarations>>= +public :: amplitude +type :: amplitude + complex(kind=default), dimension(:,:,:,:), allocatable :: amp + character(:), dimension(:), allocatable :: coupling_orders + integer, dimension(:,:), allocatable :: coupling_powers + integer, dimension(:,:), allocatable :: spin_states + integer, dimension(:,:), allocatable :: flavor_states + integer :: n_incoming + type(color_flow), dimension(:), allocatable :: color_flows +contains + ! procedure :: copy => copy_amplitude +end type amplitude +@ \subsection{Moving Data Around} +\begin{dubious} + Note that if I turn this into a function, GNU Fortran complains about uninitialized + internal variables. That's probably a harmless bug, but I decide to avoid the + warning messages. +\end{dubious} +Here we can use allocate-on-assignment for the allocatable components of [[cs]] +<>= +pure subroutine copy_color_state & + (cs, i_prt, i_cf, rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost) + type(color_state), intent(inout) :: cs + integer, intent(in) :: i_prt, i_cf + integer, dimension(:,:), intent(in) :: rank_inflowing, rank_outflowing + integer, dimension(:,:,:), intent(in) :: inflowing, outflowing + logical, dimension(:,:), intent(in) :: is_ghost + cs%g = is_ghost(i_prt,i_cf) + cs%i = inflowing(1:rank_inflowing(i_prt,i_cf),i_prt,i_cf) + cs%o = outflowing(1:rank_outflowing(i_prt,i_cf),i_prt,i_cf) +end subroutine copy_color_state +@ +It would be nice to be able to use only allocate-on-assignment here as well. +Unfortunately, this requires arrays of compatible shapes, not derived +types. Therefore, we can allocate-on-assignment the [[i]], [[o]] and [[g]] of +one [[color_state]] of [[epsilon3]], but not complete +arrays of them. +<>= +pure subroutine copy_color_flow & + (cf, n_cf, n_incoming, rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar) + type(color_flow), intent(inout) :: cf + integer, intent(in) :: n_cf, n_incoming + integer, dimension(:,:), intent(in) :: rank_inflowing, rank_outflowing + integer, dimension(:), intent(in) :: n_eps, n_eps_bar + integer, dimension(:,:,:), intent(in) :: inflowing, outflowing, eps, eps_bar + logical, dimension(:,:), intent(in) :: is_ghost + integer :: n, n_particles + n_particles = size (inflowing, dim=2) + <> + do n = 1, n_particles + call copy_color_state (cf%cs(n), n, n_cf, & + rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost) + end do + <> + do n = 1, n_eps(n_cf) + cf%e(n)%j = eps(:,n,n_cf) + end do + do n = 1, n_eps_bar(n_cf) + cf%e(n+n_eps(n_cf))%j = eps_bar(:,n,n_cf) + end do +end subroutine copy_color_flow +@ +<>= +if (.not. allocated (cf%cs)) then + allocate (cf%cs(n_particles)) +else if (size (cf%cs) /= n_particles) then + deallocate (cf%cs) + allocate (cf%cs(n_particles)) +end if +@ +<>= +if (.not. allocated (cf%e)) then + allocate (cf%e(n_eps(n_cf)+n_eps_bar(n_cf))) +else if (size (cf%e) /= n_eps(n_cf) + n_eps_bar(n_cf)) then + deallocate (cf%e) + allocate (cf%e(n_eps(n_cf)+n_eps_bar(n_cf))) +end if +@ +<>= +pure subroutine copy_color_flows & + (cf, n_incoming, rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar) + type(color_flow), dimension(:), allocatable, intent(inout) :: cf + integer, intent(in) :: n_incoming + integer, dimension(:,:), intent(in) :: rank_inflowing, rank_outflowing + integer, dimension(:), intent(in) :: n_eps, n_eps_bar + integer, dimension(:,:,:), intent(in) :: inflowing, outflowing, eps, eps_bar + logical, dimension(:,:), intent(in) :: is_ghost + integer :: n, n_colorflows + n_colorflows = size (inflowing, dim = 3) + if (.not. allocated (cf)) then + allocate (cf(n_colorflows)) + else if (size (cf) /= n_colorflows) then + deallocate (cf) + allocate (cf(n_colorflows)) + end if + do n = 1, n_colorflows + call copy_color_flow & + (cf(n), n, n_incoming, rank_inflowing, inflowing, rank_outflowing, outflowing, & + is_ghost, n_eps, eps, n_eps_bar, eps_bar) + end do +end subroutine copy_color_flows +@ +<>= +pure subroutine copy_amplitude & + (a, n_incoming, flavor_states, spin_states, & + rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar, & + coupling_orders, coupling_powers, amp) + type(amplitude), intent(inout) :: a + integer, intent(in) :: n_incoming + integer, dimension(:,:), intent(in) :: flavor_states, spin_states + integer, dimension(:,:), intent(in) :: rank_inflowing, rank_outflowing + integer, dimension(:), intent(in) :: n_eps, n_eps_bar + integer, dimension(:,:,:), intent(in) :: inflowing, outflowing, eps, eps_bar + logical, dimension(:,:), intent(in) :: is_ghost + character(*), dimension(:), intent(in) :: coupling_orders + integer, dimension(:,:), intent(in) :: coupling_powers + complex(kind=default), dimension(:,:,:,:), intent(in) :: amp + a%amp = amp + a%coupling_orders = coupling_orders + a%coupling_powers = coupling_powers + a%spin_states = spin_states + a%flavor_states = flavor_states + a%n_incoming = n_incoming + call copy_color_flows & + (a%color_flows, n_incoming, rank_inflowing, inflowing, rank_outflowing, outflowing, & + is_ghost, n_eps, eps, n_eps_bar, eps_bar) +end subroutine copy_amplitude +@ In principle we can export pointers to the static arrays, except for the color flows, +which have to be computed from the static arrays. This would save us from having to copy +the complete [[amp]] array every time it is evaluated for a new set of momenta. +We have to see whether this really makes a difference. For all other components there will +be no difference, because they never change. +\begin{dubious} + We could declare them immutable, but the initialization of big [[parameter]] arrays + requires [[reshape]] and wastes space for intermediate lower rank arrays if we want + to avoid continuation line limitations. Note that [[target]] and [[parameter]] + conflict, so we wouldn't gain anything. Therefore, we will stick with the more + readable [[data]] statements, for the time being. +\end{dubious} +<<[[omega_api_v3]] declarations>>= +public :: amplitude_pointer +type :: amplitude_pointer + complex(kind=default), dimension(:,:,:,:), pointer :: amp + character(:), dimension(:), pointer :: coupling_orders + integer, dimension(:,:), pointer :: coupling_powers + integer, dimension(:,:), pointer :: spin_states + integer, dimension(:,:), pointer :: flavor_states + integer :: n_incoming + type(color_flow), dimension(:), allocatable :: color_flows +end type amplitude_pointer +@ +<>= +subroutine init_amplitude_pointer & + (a, n_incoming, flavor_states, spin_states, & + rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar, & + coupling_orders, coupling_powers, amp) + type(amplitude_pointer), intent(inout) :: a + integer, intent(in) :: n_incoming + integer, dimension(:,:), target :: flavor_states, spin_states + integer, dimension(:,:), intent(in) :: rank_inflowing, rank_outflowing + integer, dimension(:), intent(in) :: n_eps, n_eps_bar + integer, dimension(:,:,:), intent(in) :: inflowing, outflowing, eps, eps_bar + logical, dimension(:,:), intent(in) :: is_ghost + character(*), dimension(:), target :: coupling_orders + integer, dimension(:,:), target :: coupling_powers + complex(kind=default), dimension(:,:,:,:), target :: amp + a%amp => amp + a%coupling_orders => coupling_orders + a%coupling_powers => coupling_powers + a%spin_states => spin_states + a%flavor_states => flavor_states + a%n_incoming = n_incoming + call copy_color_flows & + (a%color_flows, n_incoming, rank_inflowing, inflowing, rank_outflowing, outflowing, & + is_ghost, n_eps, eps, n_eps_bar, eps_bar) +end subroutine init_amplitude_pointer +@ +<<[[omega_api_v3]] declarations>>= +public :: copy_amplitude +@ \subsection{Tests} +\label{sec:API-tests} +<<[[test_omega_api.f90]]>>= +module omega_api_v3_example + use kinds + use omega_birdtracks + use omega_api_v3 + implicit none + private + <> +contains + <> +end module omega_api_v3_example +@ Of course, [[n_incoming + n_outgoing == n_particles]]: +<>= +integer, parameter, public :: n_incoming = 2 +integer, parameter, public :: n_outgoing = 2 +integer, parameter, public :: n_particles = 4 +integer, parameter, public :: n_colorflows = 4 +integer, parameter, public :: n_flavor_states = 1 +integer, parameter, public :: n_spin_states = 1 +integer, parameter, public :: len_coupling_orders = 3 +integer, parameter, public :: n_coupling_orders = 2 +integer, parameter, public :: n_coupling_powers = 1 +@ +<>= +complex(kind=default), dimension(n_coupling_powers,n_flavor_states,n_spin_states,n_colorflows), save :: amp = 0 +@ +<>= +integer, dimension(n_particles,n_flavor_states), save :: flavor_states +integer, dimension(n_particles,n_spin_states), save :: spin_states +@ +<>= +data flavor_states(:,1) / 21, 21, 2, -2 / +data spin_states(:,1) / -1, -1, -1, -1 / +@ +<>= +character(len_coupling_orders), dimension(n_coupling_orders), save :: coupling_orders +integer, dimension(n_coupling_orders,n_coupling_powers), save :: coupling_powers +@ +<>= +data coupling_orders / "QCD", "EW" / +data coupling_powers(:,1) / 2, 0 / +@ +<>= +integer, parameter :: max_rank_inflowing = 1 +integer, parameter :: max_rank_outflowing = 1 +integer, parameter :: max_n_eps = 1 +integer, parameter :: max_n_eps_bar = 1 +integer, dimension(n_particles,n_colorflows), save :: rank_inflowing, rank_outflowing +integer, dimension(n_colorflows), save :: n_eps, n_eps_bar +@ +<>= +integer, dimension(max_rank_inflowing,n_particles,n_colorflows), save :: inflowing, outflowing +logical, dimension(n_particles,n_colorflows), save :: is_ghost +integer, dimension(3,max_n_eps,n_colorflows), save :: eps +integer, dimension(3,max_n_eps_bar,n_colorflows), save :: eps_bar +@ +<>= +character(1000), dimension(n_colorflows), public, save :: color_flows +@ +<>= +data rank_inflowing(:,1) / 0, 1, 0, 1 / +data rank_outflowing(:,1) / 0, 1, 1, 0 / +data n_eps(1) / 0 /, n_eps_bar(1) / 0 / +data inflowing(:,1,1) / 0 /, outflowing(:,1,1) / 0 /, is_ghost(1,1) / .true. / +data inflowing(:,2,1) / 1 /, outflowing(:,2,1) / 2 /, is_ghost(2,1) / .false. / +data inflowing(:,3,1) / 0 /, outflowing(:,3,1) / 1 /, is_ghost(3,1) / .false. / +data inflowing(:,4,1) / 2 /, outflowing(:,4,1) / 0 /, is_ghost(4,1) / .false. / +data eps(:,1,1) / 0, 0, 0 /, eps_bar(:,1,1) / 0, 0, 0 / +@ +<>= +data color_flows(1) / "{g, ([1], [2]), ([], [1]), ([2], [])}" / +@ +<>= +data rank_inflowing(:,2) / 0, 1, 1, 1 / +data rank_outflowing(:,2) / 0, 0, 0, 0 / +data n_eps(2) / 1 /, n_eps_bar(2) / 0 / +data inflowing(:,1,2) / 0 /, outflowing(:,1,2) / 0 /, is_ghost(1,2) / .false. / +data inflowing(:,2,2) / -1 /, outflowing(:,2,2) / 0 /, is_ghost(2,2) / .false. / +data inflowing(:,3,2) / -2 /, outflowing(:,3,2) / 0 /, is_ghost(3,2) / .false. / +data inflowing(:,4,2) / -3 /, outflowing(:,4,2) / 0 /, is_ghost(4,2) / .false. / +data eps(:,1,2) / -1, -2, -3 /, eps_bar(:,1,2) / 0, 0, 0 / +@ +<>= +data color_flows(2) / "{([], []), ([-1], []), ([-2], []), ([-3], []); eps(-1,-2,-3)}" / +@ +<>= +data rank_inflowing(:,3) / 0, 0, 0, 0 / +data rank_outflowing(:,3) / 0, 1, 1, 1 / +data n_eps(3) / 0 /, n_eps_bar(3) / 1 / +data inflowing(:,1,3) / 0 /, outflowing(:,1,3) / 0 /, is_ghost(1,3) / .false. / +data inflowing(:,2,3) / 0 /, outflowing(:,2,3) / -1 /, is_ghost(2,3) / .false. / +data inflowing(:,3,3) / 0 /, outflowing(:,3,3) / -2 /, is_ghost(3,3) / .false. / +data inflowing(:,4,3) / 0 /, outflowing(:,4,3) / -3 /, is_ghost(4,3) / .false. / +data eps(:,1,3) / 0, 0, 0 /, eps_bar(:,1,3) / -1, -2, -3 / +@ +<>= +data color_flows(3) / "{([], []), ([], [-1]), ([], [-2]), ([], [-3]); eps(-1,-2,-3)}" / +@ +<>= +data rank_inflowing(:,4) / 0, 1, 1, 1 / +data rank_outflowing(:,4) / 0, 1, 1, 1 / +data n_eps(4) / 1 /, n_eps_bar(4) / 1 / +data inflowing(:,1,4) / 0 /, outflowing(:,1,4) / 0 /, is_ghost(1,4) / .false. / +data inflowing(:,2,4) / -1 /, outflowing(:,2,4) / -4 /, is_ghost(2,4) / .false. / +data inflowing(:,3,4) / -2 /, outflowing(:,3,4) / -5 /, is_ghost(3,4) / .false. / +data inflowing(:,4,4) / -3 /, outflowing(:,4,4) / -6 /, is_ghost(4,4) / .false. / +data eps(:,1,4) / -1, -2, -3 /, eps_bar(:,1,4) / -4, -5, -6 / +@ +<>= +data color_flows(4) / "{([], []), ([-1], [-4]), ([-2], [-5]), ([-3], [-6]); eps(-1,-2,-3), eps(-4,-5,-6)}" / +@ +<>= +pure subroutine load_amplitude (a) + type(amplitude), intent(inout) :: a + call copy_amplitude & + (a, n_incoming, flavor_states, spin_states, & + rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, & + n_eps, eps, n_eps_bar, eps_bar, & + coupling_orders, coupling_powers, amp) +end subroutine load_amplitude +@ +<>= +public :: load_amplitude +@ +<<[[test_omega_api.f90]]>>= +program test_omega_api + use kinds + use omega_birdtracks + use omega_api_v3 + use omega_api_v3_example + implicit none + integer :: rc + character(:), allocatable :: buffer + type(amplitude) :: a + integer :: n + call load_amplitude (a) + do n = 1, n_colorflows + rc = a%color_flows(n)%check () + if (rc /= 0) then + print *, 'color_flow_check returned ', rc + stop 1 + end if + buffer = "" + buffer = a%color_flows(n)%to_string () + if (trim (buffer) /= trim (color_flows(n))) then + print *, 'color_flow%to_string failed:' + print *, ' expected "', trim (color_flows(n)), '"' + print *, ' got "', trim (buffer), '"' + stop 1 + end if + end do +end program test_omega_api @ \section{Utilities} <<[[omega_utils.f90]]>>= <> module omega_utils use kinds use omega_vectors use omega_polarizations implicit none private <> <> integer, parameter, public :: omega_utils_2010_01_A = 0 contains <> end module omega_utils @ \subsection{Helicity Selection Rule Heuristics} <>= public :: omega_update_helicity_selection @ <>= pure subroutine omega_update_helicity_selection & (count, amp, max_abs, sum_abs, mask, threshold, cutoff, mask_dirty) integer, intent(inout) :: count complex(kind=default), dimension(:,:,:), intent(in) :: amp real(kind=default), dimension(:), intent(inout) :: max_abs real(kind=default), intent(inout) :: sum_abs logical, dimension(:), intent(inout) :: mask real(kind=default), intent(in) :: threshold integer, intent(in) :: cutoff logical, intent(out) :: mask_dirty integer :: h real(kind=default) :: avg mask_dirty = .false. if (threshold > 0) then count = count + 1 if (count <= cutoff) then forall (h = lbound (amp, 3) : ubound (amp, 3)) max_abs(h) = max (max_abs(h), maxval (abs (amp(:,:,h)))) end forall sum_abs = sum_abs + sum (abs (amp)) if (count == cutoff) then avg = sum_abs / size (amp) / cutoff mask = max_abs >= threshold * epsilon (avg) * avg mask_dirty = .true. end if end if end if end subroutine omega_update_helicity_selection @ \subsection{Diagnostics} <>= public :: omega_report_helicity_selection @ We shoul try to use [[msg_message]] from WHIZARD's [[diagnostics]] module, but this would spoil independent builds. <>= subroutine omega_report_helicity_selection (mask, spin_states, threshold, unit) logical, dimension(:), intent(in) :: mask integer, dimension(:,:), intent(in) :: spin_states real(kind=default), intent(in) :: threshold integer, intent(in), optional :: unit integer :: u integer :: h, i if (present(unit)) then u = unit else u = 6 end if if (u >= 0) then write (unit = u, & fmt = "('| ','Contributing Helicity Combinations: ', I5, ' of ', I5)") & count (mask), size (mask) write (unit = u, & fmt = "('| ','Threshold: amp / avg > ', E9.2, ' = ', E9.2, ' * epsilon()')") & threshold * epsilon (threshold), threshold i = 0 do h = 1, size (mask) if (mask(h)) then i = i + 1 write (unit = u, fmt = "('| ',I4,': ',20I4)") i, spin_states (:, h) end if end do end if end subroutine omega_report_helicity_selection @ <>= public :: omega_ward_warn, omega_ward_panic @ The O'Mega amplitudes have only one particle off shell and are the sum of \emph{all} possible diagrams with the other particles on-shell. \begin{dubious} The problem with these gauge checks is that are numerically very small amplitudes that vanish analytically and that violate transversality. The hard part is to determine the thresholds that make threse tests usable. \end{dubious} <>= subroutine omega_ward_warn (name, m, k, e) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e) abs_ek_abs_e = abs (ek) * abs (e) print *, name, ":", abs_eke / abs_ek_abs_e, abs (ek), abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: warning: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) end if end subroutine omega_ward_warn @ <>= subroutine omega_ward_panic (name, m, k, e) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e) abs_ek_abs_e = abs (ek) * abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: panic: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) stop end if end subroutine omega_ward_panic @ <>= public :: omega_slavnov_warn, omega_slavnov_panic @ <>= subroutine omega_slavnov_warn (name, m, k, e, phi) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e complex(kind=default), intent(in) :: phi type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e - phi) abs_ek_abs_e = abs (ek) * abs (e) print *, name, ":", abs_eke / abs_ek_abs_e, abs (ek), abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: warning: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) end if end subroutine omega_slavnov_warn @ <>= subroutine omega_slavnov_panic (name, m, k, e, phi) character(len=*), intent(in) :: name real(kind=default), intent(in) :: m type(momentum), intent(in) :: k type(vector), intent(in) :: e complex(kind=default), intent(in) :: phi type(vector) :: ek real(kind=default) :: abs_eke, abs_ek_abs_e ek = eps (m, k, 4) abs_eke = abs (ek * e - phi) abs_ek_abs_e = abs (ek) * abs (e) if (abs_eke > 1000 * epsilon (abs_ek_abs_e)) then print *, "O'Mega: panic: non-transverse vector field: ", & name, ":", abs_eke / abs_ek_abs_e, abs (e) stop end if end subroutine omega_slavnov_panic @ <>= public :: omega_check_arguments_warn, omega_check_arguments_panic @ <>= subroutine omega_check_arguments_warn (n, k) integer, intent(in) :: n real(kind=default), dimension(0:,:), intent(in) :: k integer :: i i = size(k,dim=1) if (i /= 4) then print *, "O'Mega: warning: wrong # of dimensions:", i end if i = size(k,dim=2) if (i /= n) then print *, "O'Mega: warning: wrong # of momenta:", i, & ", expected", n end if end subroutine omega_check_arguments_warn @ <>= subroutine omega_check_arguments_panic (n, k) integer, intent(in) :: n real(kind=default), dimension(0:,:), intent(in) :: k logical :: error integer :: i error = .false. i = size(k,dim=1) if (i /= n) then print *, "O'Mega: warning: wrong # of dimensions:", i error = .true. end if i = size(k,dim=2) if (i /= n) then print *, "O'Mega: warning: wrong # of momenta:", i, & ", expected", n error = .true. end if if (error) then stop end if end subroutine omega_check_arguments_panic @ <>= public :: omega_check_helicities_warn, omega_check_helicities_panic private :: omega_check_helicity @ <>= function omega_check_helicity (m, smax, s) result (error) real(kind=default), intent(in) :: m integer, intent(in) :: smax, s logical :: error select case (smax) case (0) error = (s /= 0) case (1) error = (abs (s) /= 1) case (2) if (m == 0.0_default) then error = .not. (abs (s) == 1 .or. abs (s) == 4) else error = .not. (abs (s) <= 1 .or. abs (s) == 4) end if case (4) error = .true. case default error = .true. end select end function omega_check_helicity @ <>= subroutine omega_check_helicities_warn (m, smax, s) real(kind=default), dimension(:), intent(in) :: m integer, dimension(:), intent(in) :: smax, s integer :: i do i = 1, size (m) if (omega_check_helicity (m(i), smax(i), s(i))) then print *, "O'Mega: warning: invalid helicity", s(i) end if end do end subroutine omega_check_helicities_warn @ <>= subroutine omega_check_helicities_panic (m, smax, s) real(kind=default), dimension(:), intent(in) :: m integer, dimension(:), intent(in) :: smax, s logical :: error logical :: error1 integer :: i error = .false. do i = 1, size (m) error1 = omega_check_helicity (m(i), smax(i), s(i)) if (error1) then print *, "O'Mega: panic: invalid helicity", s(i) error = .true. end if end do if (error) then stop end if end subroutine omega_check_helicities_panic @ <>= public :: omega_check_momenta_warn, omega_check_momenta_panic private :: check_momentum_conservation, check_mass_shell @ <>= integer, parameter, private :: MOMENTUM_TOLERANCE = 10000 @ <>= function check_momentum_conservation (k) result (error) real(kind=default), dimension(0:,:), intent(in) :: k logical :: error error = any (abs (sum (k(:,3:), dim = 2) - k(:,1) - k(:,2)) > & MOMENTUM_TOLERANCE * epsilon (maxval (abs (k), dim = 2))) if (error) then print *, sum (k(:,3:), dim = 2) - k(:,1) - k(:,2) print *, MOMENTUM_TOLERANCE * epsilon (maxval (abs (k), dim = 2)), & maxval (abs (k), dim = 2) end if end function check_momentum_conservation @ <>= integer, parameter, private :: ON_SHELL_TOLERANCE = 1000000 @ <>= function check_mass_shell (m, k) result (error) real(kind=default), intent(in) :: m real(kind=default), dimension(0:), intent(in) :: k real(kind=default) :: e2 logical :: error e2 = k(1)**2 + k(2)**2 + k(3)**2 + m**2 error = abs (k(0)**2 - e2) > ON_SHELL_TOLERANCE * epsilon (max (k(0)**2, e2)) if (error) then print *, k(0)**2 - e2 print *, ON_SHELL_TOLERANCE * epsilon (max (k(0)**2, e2)), max (k(0)**2, e2) end if end function check_mass_shell @ <>= subroutine omega_check_momenta_warn (m, k) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(in) :: k integer :: i if (check_momentum_conservation (k)) then print *, "O'Mega: warning: momentum not conserved" end if do i = 1, size(m) if (check_mass_shell (m(i), k(:,i))) then print *, "O'Mega: warning: particle #", i, "not on-shell" end if end do end subroutine omega_check_momenta_warn @ <>= subroutine omega_check_momenta_panic (m, k) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:,:), intent(in) :: k logical :: error logical :: error1 integer :: i error = check_momentum_conservation (k) if (error) then print *, "O'Mega: panic: momentum not conserved" end if do i = 1, size(m) error1 = check_mass_shell (m(i), k(0:,i)) if (error1) then print *, "O'Mega: panic: particle #", i, "not on-shell" error = .true. end if end do if (error) then stop end if end subroutine omega_check_momenta_panic @ \subsection{Obsolete Summation} \subsubsection{Spin/Helicity Summation} <>= public :: omega_sum, omega_sum_nonzero, omega_nonzero private :: state_index @ <>= pure function omega_sum (omega, p, states, fixed) result (sigma) real(kind=default) :: sigma real(kind=default), dimension(0:,:), intent(in) :: p integer, dimension(:), intent(in), optional :: states, fixed <<[[interface]] for O'Mega Amplitude>> integer, dimension(size(p,dim=2)) :: s, nstates integer :: j complex(kind=default) :: a if (present (states)) then nstates = states else nstates = 2 end if sigma = 0 s = -1 sum_spins: do if (present (fixed)) then !!! print *, 's = ', s, ', fixed = ', fixed, ', nstates = ', nstates, & !!! ', fixed|s = ', merge (fixed, s, mask = nstates == 0) a = omega (p, merge (fixed, s, mask = nstates == 0)) else a = omega (p, s) end if sigma = sigma + a * conjg(a) <> end do sum_spins sigma = sigma / num_states (2, nstates(1:2)) end function omega_sum @ We're looping over all spins like a $n$-ary numbers $(-1,\ldots,-1,-1)$, $(-1,\ldots,-1,0)$, $(-1,\ldots,-1,1)$, $(-1,\ldots,0,-1)$, \ldots, $(1,\ldots,1,0)$, $(1,\ldots,1,1)$: <>= do j = size (p, dim = 2), 1, -1 select case (nstates (j)) case (3) ! massive vectors s(j) = modulo (s(j) + 2, 3) - 1 case (2) ! spinors, massless vectors s(j) = - s(j) case (1) ! scalars s(j) = -1 case (0) ! fized spin s(j) = -1 case default ! ??? s(j) = -1 end select if (s(j) /= -1) then cycle sum_spins end if end do exit sum_spins @ The dual operation evaluates an $n$-number: <>= pure function state_index (s, states) result (n) integer, dimension(:), intent(in) :: s integer, dimension(:), intent(in), optional :: states integer :: n integer :: j, p n = 1 p = 1 if (present (states)) then do j = size (s), 1, -1 select case (states(j)) case (3) n = n + p * (s(j) + 1) case (2) n = n + p * (s(j) + 1) / 2 end select p = p * states(j) end do else do j = size (s), 1, -1 n = n + p * (s(j) + 1) / 2 p = p * 2 end do end if end function state_index @ <<[[interface]] for O'Mega Amplitude>>= interface pure function omega (p, s) result (me) use kinds implicit none complex(kind=default) :: me real(kind=default), dimension(0:,:), intent(in) :: p integer, dimension(:), intent(in) :: s end function omega end interface @ <>= public :: num_states @ <>= pure function num_states (n, states) result (ns) integer, intent(in) :: n integer, dimension(:), intent(in), optional :: states integer :: ns if (present (states)) then ns = product (states, mask = states == 2 .or. states == 3) else ns = 2**n end if end function num_states @ \section{\texttt{omega95}} <<[[omega95.f90]]>>= <> module omega95 use constants use omega_spinors use omega_vectors use omega_polarizations use omega_tensors use omega_tensor_polarizations use omega_couplings use omega_spinor_couplings use omega_color use omega_utils public end module omega95 @ \section{\texttt{omega95} Revisited} <<[[omega95_bispinors.f90]]>>= <> module omega95_bispinors use constants use omega_bispinors use omega_vectors use omega_vectorspinors use omega_polarizations use omega_vspinor_polarizations use omega_couplings use omega_bispinor_couplings use omega_color use omega_utils public end module omega95_bispinors @ \section{Testing} <<[[omega_testtools.f90]]>>= <> module omega_testtools use kinds implicit none private real(kind=default), parameter, private :: ABS_THRESHOLD_DEFAULT = 1E-17 real(kind=default), parameter, private :: THRESHOLD_DEFAULT = 0.6 real(kind=default), parameter, private :: THRESHOLD_WARN = 0.8 <> contains <> end module omega_testtools @ Quantify the agreement of two real or complex numbers \begin{equation} \text{agreement}(x,y) = \frac{\ln \Delta(x,y)}{\ln\epsilon} \in[0,1] \end{equation} with \begin{equation} \Delta(x,y) = \frac{|x-y|}{\max(|x|,|y|)} \end{equation} and values outside~$[0,1]$ replaced the closed value in the interval. In other words \begin{itemize} \item $1$ for $x-y=\max(|x|,|y|)\cdot\mathcal{O}(\epsilon)$ and \item $0$~for $x-y=\max(|x|,|y|)\cdot\mathcal{O}(1)$ \end{itemize} with logarithmic interpolation. The cases~$x=0$ and~$y=0$ must be treated separately. <>= public :: agreement interface agreement module procedure agreement_real, agreement_complex, & agreement_real_complex, agreement_complex_real, & agreement_integer_complex, agreement_complex_integer, & agreement_integer_real, agreement_real_integer end interface private :: agreement_real, agreement_complex, & agreement_real_complex, agreement_complex_real, & agreement_integer_complex, agreement_complex_integer, & agreement_integer_real, agreement_real_integer @ <>= elemental function agreement_real (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x, y real(kind=default), intent(in), optional :: base real(kind=default) :: scale, dxy if (present (base)) then scale = max (abs (x), abs (y), abs (base)) else scale = max (abs (x), abs (y)) end if if (ieee_is_nan (x) .or. ieee_is_nan (y)) then a = 0 else if (scale <= 0) then a = -1 else dxy = abs (x - y) / scale if (dxy <= 0.0_default) then a = 1 else a = log (dxy) / log (epsilon (scale)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end if end if if (ieee_is_nan (a)) then a = 0 end if end function agreement_real @ Poor man's replacement <>= elemental function ieee_is_nan (x) result (yorn) logical :: yorn real (kind=default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan @ <>= elemental function agreement_complex (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x, y real(kind=default), intent(in), optional :: base real(kind=default) :: scale, dxy if (present (base)) then scale = max (abs (x), abs (y), abs (base)) else scale = max (abs (x), abs (y)) end if if ( ieee_is_nan (real (x, kind=default)) .or. ieee_is_nan (aimag (x)) & .or. ieee_is_nan (real (y, kind=default)) .or. ieee_is_nan (aimag (y))) then a = 0 else if (scale <= 0) then a = -1 else dxy = abs (x - y) / scale if (dxy <= 0.0_default) then a = 1 else a = log (dxy) / log (epsilon (scale)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end if end if if (ieee_is_nan (a)) then a = 0 end if end function agreement_complex @ <>= elemental function agreement_real_complex (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x complex(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (cmplx (x, kind=default), y, base) end function agreement_real_complex @ <>= elemental function agreement_complex_real (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (x, cmplx (y, kind=default), base) end function agreement_complex_real @ <>= elemental function agreement_integer_complex (x, y, base) result (a) real(kind=default) :: a integer, intent(in) :: x complex(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (cmplx (x, kind=default), y, base) end function agreement_integer_complex @ <>= elemental function agreement_complex_integer (x, y, base) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x integer, intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_complex (x, cmplx (y, kind=default), base) end function agreement_complex_integer @ <>= elemental function agreement_integer_real (x, y, base) result (a) real(kind=default) :: a integer, intent(in) :: x real(kind=default), intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_real (real(x, kind=default), y, base) end function agreement_integer_real @ <>= elemental function agreement_real_integer (x, y, base) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x integer, intent(in) :: y real(kind=default), intent(in), optional :: base a = agreement_real (x, real (y, kind=default), base) end function agreement_real_integer @ <>= public:: vanishes interface vanishes module procedure vanishes_real, vanishes_complex end interface private :: vanishes_real, vanishes_complex @ <>= elemental function vanishes_real (x, scale) result (a) real(kind=default) :: a real(kind=default), intent(in) :: x real(kind=default), intent(in), optional :: scale real(kind=default) :: scaled_x if (x == 0.0_default) then a = 1 return else if (ieee_is_nan (x)) then a = 0 return end if scaled_x = x if (present (scale)) then if (scale /= 0) then scaled_x = x / abs (scale) else a = 0 return end if else end if a = log (abs (scaled_x)) / log (epsilon (scaled_x)) a = max (0.0_default, min (1.0_default, a)) if (ieee_is_nan (a)) then a = 0 end if end function vanishes_real @ <>= elemental function vanishes_complex (x, scale) result (a) real(kind=default) :: a complex(kind=default), intent(in) :: x real(kind=default), intent(in), optional :: scale a = vanishes_real (abs (x), scale) end function vanishes_complex @ <>= public :: expect interface expect module procedure expect_integer, expect_real, expect_complex, & expect_real_integer, expect_integer_real, & expect_complex_integer, expect_integer_complex, & expect_complex_real, expect_real_complex end interface private :: expect_integer, expect_real, expect_complex, & expect_real_integer, expect_integer_real, & expect_complex_integer, expect_integer_complex, & expect_complex_real, expect_real_complex @ <>= subroutine expect_integer (x, x0, msg, passed, quiet, buffer, unit) integer, intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet character(len=*), intent(inout), optional :: buffer integer, intent(in), optional :: unit logical :: failed, verbose character(len=*), parameter :: fmt = "(1X,A,': ',A)" character(len=*), parameter :: & fmt_verbose = "(1X,A,': ',A,' [expected ',I6,', got ',I6,']')" failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then if (.not. (present (buffer) .or. present (unit))) then write (unit = *, fmt = fmt) msg, "passed" end if if (present (unit)) then write (unit = unit, fmt = fmt) msg, "passed" end if if (present (buffer)) then write (unit = buffer, fmt = fmt) msg, "passed" end if end if else if (.not. (present (buffer) .or. present (unit))) then write (unit = *, fmt = fmt_verbose) msg, "failed", x0, x end if if (present (unit)) then write (unit = unit, fmt = fmt_verbose) msg, "failed", x0, x end if if (present (buffer)) then write (unit = buffer, fmt = fmt_verbose) msg, "failed", x0, x end if failed = .true. end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_integer @ <>= subroutine expect_real (x, x0, msg, passed, threshold, quiet, abs_threshold) real(kind=default), intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold, abs_agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected ',E10.3,', got ',E10.3,']')" real(kind=default) :: a failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else if (x0 == 0) then a = vanishes (x) else a = agreement (x, x0) end if if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (present (abs_threshold)) then abs_agreement_threshold = abs_threshold else abs_agreement_threshold = ABS_THRESHOLD_DEFAULT end if if (a >= agreement_threshold .or. & max(abs(x), abs(x0)) <= abs_agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), x0, x end if end if else failed = .true. write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), x0, x end if end if if (present (passed)) then passed = passed .and. .not. failed end if end subroutine expect_real @ <>= subroutine expect_complex (x, x0, msg, passed, threshold, quiet, abs_threshold) complex(kind=default), intent(in) :: x, x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold, abs_agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected (',E10.3,',',E10.3,'), got (',E10.3,',',E10.3,')]')" character(len=*), parameter :: fmt_phase = "(1X,A,': ',A,' at ',I4,'%'," // & "' [modulus passed at ',I4,'%',', phases ',F5.3,' vs. ',F5.3,']')" real(kind=default) :: a, a_modulus failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == x0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else if (x0 == 0) then a = vanishes (x) else a = agreement (x, x0) end if if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (present (abs_threshold)) then abs_agreement_threshold = abs_threshold else abs_agreement_threshold = ABS_THRESHOLD_DEFAULT end if if (a >= agreement_threshold .or. & max(abs(x), abs(x0)) <= abs_agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), x0, x end if end if else a_modulus = agreement (abs (x), abs (x0)) if (a_modulus >= agreement_threshold) then write (unit = *, fmt = fmt_phase) msg, "failed", int (a * 100), & int (a_modulus * 100), & atan2 (real (x, kind=default), aimag (x)), & atan2 (real (x0, kind=default), aimag (x0)) else write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), x0, x end if failed = .true. end if end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_complex @ <>= subroutine expect_real_integer (x, x0, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x integer, intent(in) :: x0 character(len=*), intent(in) :: msg real(kind=default), intent(in), optional :: threshold logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet call expect_real (x, real (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_real_integer @ <>= subroutine expect_integer_real (x, x0, msg, passed, threshold, quiet) integer, intent(in) :: x real(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg real(kind=default), intent(in), optional :: threshold logical, intent(inout), optional :: passed logical, intent(in), optional :: quiet call expect_real (real (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_integer_real @ <>= subroutine expect_complex_integer (x, x0, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x integer, intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (x, cmplx (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_complex_integer @ <>= subroutine expect_integer_complex (x, x0, msg, passed, threshold, quiet) integer, intent(in) :: x complex(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (cmplx (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_integer_complex @ <>= subroutine expect_complex_real (x, x0, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (x, cmplx (x0, kind=default), msg, passed, threshold, quiet) end subroutine expect_complex_real @ <>= subroutine expect_real_complex (x, x0, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x complex(kind=default), intent(in) :: x0 character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_complex (cmplx (x, kind=default), x0, msg, passed, threshold, quiet) end subroutine expect_real_complex @ <>= public :: expect_zero interface expect_zero module procedure expect_zero_integer, expect_zero_real, expect_zero_complex end interface private :: expect_zero_integer, expect_zero_real, expect_zero_complex @ <>= subroutine expect_zero_integer (x, msg, passed) integer, intent(in) :: x character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed call expect_integer (x, 0, msg, passed) end subroutine expect_zero_integer @ <>= subroutine expect_zero_real (x, scale, msg, passed, threshold, quiet) real(kind=default), intent(in) :: x, scale character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet logical :: failed, verbose real(kind=default) :: agreement_threshold character(len=*), parameter :: fmt = "(1X,A,': ',A,' at ',I4,'%')" character(len=*), parameter :: fmt_verbose = "(1X,A,': ',A,' at ',I4,'%'," // & "' [expected 0 (relative to ',E10.3,') got ',E10.3,']')" real(kind=default) :: a failed = .false. verbose = .true. if (present (quiet)) then verbose = .not.quiet end if if (x == 0) then if (verbose) then write (unit = *, fmt = fmt) msg, "passed", 100 end if else a = vanishes (x, scale = scale) if (present (threshold)) then agreement_threshold = threshold else agreement_threshold = THRESHOLD_DEFAULT end if if (a >= agreement_threshold) then if (verbose) then if (a >= THRESHOLD_WARN) then write (unit = *, fmt = fmt) msg, "passed", int (a * 100) else write (unit = *, fmt = fmt_verbose) msg, "passed", int (a * 100), scale, x end if end if else failed = .true. write (unit = *, fmt = fmt_verbose) msg, "failed", int (a * 100), scale, x end if end if if (present (passed)) then passed = passed .and. .not.failed end if end subroutine expect_zero_real @ <>= subroutine expect_zero_complex (x, scale, msg, passed, threshold, quiet) complex(kind=default), intent(in) :: x real(kind=default), intent(in) :: scale character(len=*), intent(in) :: msg logical, intent(inout), optional :: passed real(kind=default), intent(in), optional :: threshold logical, intent(in), optional :: quiet call expect_zero_real (abs (x), scale, msg, passed, threshold, quiet) end subroutine expect_zero_complex @ <>= subroutine print_matrix (a) complex(kind=default), dimension(:,:), intent(in) :: a integer :: row do row = 1, size (a, dim=1) write (unit = *, fmt = "(10(tr2, f5.2, '+', f5.2, 'I'))") a(row,:) end do end subroutine print_matrix @ <>= public :: print_matrix @ <<[[test_omega95.f90]]>>= <> program test_omega95 use kinds use omega95 use omega_testtools implicit none real(kind=default) :: m, pabs, qabs, w real(kind=default), dimension(0:3) :: r complex(kind=default) :: c_one, c_nil type(momentum) :: p, q, p0 type(vector) :: vp, vq, vtest, v0 type(tensor) :: ttest type(spinor) :: test_psi, test_spinor1, test_spinor2 type(conjspinor) :: test_psibar, test_conjspinor1, test_conjspinor2 integer, dimension(8) :: date_time integer :: rsize, i logical :: passed call date_and_time (values = date_time) call random_seed (size = rsize) call random_seed (put = spread (product (date_time), dim = 1, ncopies = rsize)) w = 1.4142 c_one = 1.0_default c_nil = 0.0_default m = 13 pabs = 42 qabs = 137 call random_number (r) vtest%t = cmplx (10.0_default * r(0), kind=default) vtest%x(1:3) = cmplx (10.0_default * r(1:3), kind=default) ttest = vtest.tprod.vtest call random_momentum (p, pabs, m) call random_momentum (q, qabs, m) call random_momentum (p0, 0.0_default, m) vp = p vq = q v0 = p0 passed = .true. <> if (.not. passed) then stop 1 end if end program test_omega95 @ <>= print *, "*** Checking the equations of motion ***:" call expect (abs(f_vf(c_one,vp,u(m,p,+1))-m*u(m,p,+1)), 0, "|[p-m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(m,p,-1))-m*u(m,p,-1)), 0, "|[p-m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,+1))+m*v(m,p,+1)), 0, "|[p+m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,-1))+m*v(m,p,-1)), 0, "|[p+m]v(-)|=0", passed) call expect (abs(f_fv(c_one,ubar(m,p,+1),vp)-m*ubar(m,p,+1)), 0, "|ubar(+)[p-m]|=0", passed) call expect (abs(f_fv(c_one,ubar(m,p,-1),vp)-m*ubar(m,p,-1)), 0, "|ubar(-)[p-m]|=0", passed) call expect (abs(f_fv(c_one,vbar(m,p,+1),vp)+m*vbar(m,p,+1)), 0, "|vbar(+)[p+m]|=0", passed) call expect (abs(f_fv(c_one,vbar(m,p,-1),vp)+m*vbar(m,p,-1)), 0, "|vbar(-)[p+m]|=0", passed) print *, "*** Checking the equations of motion for negative mass***:" call expect (abs(f_vf(c_one,vp,u(-m,p,+1))+m*u(-m,p,+1)), 0, "|[p+m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(-m,p,-1))+m*u(-m,p,-1)), 0, "|[p+m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,+1))-m*v(-m,p,+1)), 0, "|[p-m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,-1))-m*v(-m,p,-1)), 0, "|[p-m]v(-)|=0", passed) call expect (abs(f_fv(c_one,ubar(-m,p,+1),vp)+m*ubar(-m,p,+1)), 0, "|ubar(+)[p+m]|=0", passed) call expect (abs(f_fv(c_one,ubar(-m,p,-1),vp)+m*ubar(-m,p,-1)), 0, "|ubar(-)[p+m]|=0", passed) call expect (abs(f_fv(c_one,vbar(-m,p,+1),vp)-m*vbar(-m,p,+1)), 0, "|vbar(+)[p-m]|=0", passed) call expect (abs(f_fv(c_one,vbar(-m,p,-1),vp)-m*vbar(-m,p,-1)), 0, "|vbar(-)[p-m]|=0", passed) @ <>= print *, "*** Spin Sums" test_psi%a = [one, two, three, four] test_spinor1 = f_vf (c_one, vp, test_psi) + m * test_psi test_spinor2 = u (m, p, +1) * (ubar (m, p, +1) * test_psi) + & u (m, p, -1) * (ubar (m, p, -1) * test_psi) do i = 1, 4 call expect (test_spinor1%a(i), test_spinor2%a(i), "(p+m)1=(sum u ubar)1", passed) end do test_spinor1 = f_vf (c_one, vp, test_psi) - m * test_psi test_spinor2 = v (m, p, +1) * (vbar (m, p, +1) * test_psi) + & v (m, p, -1) * (vbar (m, p, -1) * test_psi) do i = 1, 4 call expect (test_spinor1%a(i), test_spinor2%a(i), "(p-m)1=(sum v vbar)1", passed) end do test_psibar%a = [one, two, three, four] test_conjspinor1 = f_fv (c_one, test_psibar, vp) - m * test_psibar test_conjspinor2 = (test_psibar * v (m, p, +1)) * vbar (m, p, +1) + & (test_psibar * v (m, p, -1)) * vbar (m, p, -1) do i = 1, 4 call expect (test_conjspinor1%a(i), test_conjspinor2%a(i), "(p-m)1=(sum v vbar)1", passed) end do @ <>= print *, "*** Checking the normalization ***:" call expect (ubar(m,p,+1)*u(m,p,+1), +2*m, "ubar(+)*u(+)=+2m", passed) call expect (ubar(m,p,-1)*u(m,p,-1), +2*m, "ubar(-)*u(-)=+2m", passed) call expect (vbar(m,p,+1)*v(m,p,+1), -2*m, "vbar(+)*v(+)=-2m", passed) call expect (vbar(m,p,-1)*v(m,p,-1), -2*m, "vbar(-)*v(-)=-2m", passed) call expect (ubar(m,p,+1)*v(m,p,+1), 0, "ubar(+)*v(+)=0 ", passed) call expect (ubar(m,p,-1)*v(m,p,-1), 0, "ubar(-)*v(-)=0 ", passed) call expect (vbar(m,p,+1)*u(m,p,+1), 0, "vbar(+)*u(+)=0 ", passed) call expect (vbar(m,p,-1)*u(m,p,-1), 0, "vbar(-)*u(-)=0 ", passed) print *, "*** Checking the normalization for negative masses***:" call expect (ubar(-m,p,+1)*u(-m,p,+1), -2*m, "ubar(+)*u(+)=-2m", passed) call expect (ubar(-m,p,-1)*u(-m,p,-1), -2*m, "ubar(-)*u(-)=-2m", passed) call expect (vbar(-m,p,+1)*v(-m,p,+1), +2*m, "vbar(+)*v(+)=+2m", passed) call expect (vbar(-m,p,-1)*v(-m,p,-1), +2*m, "vbar(-)*v(-)=+2m", passed) call expect (ubar(-m,p,+1)*v(-m,p,+1), 0, "ubar(+)*v(+)=0 ", passed) call expect (ubar(-m,p,-1)*v(-m,p,-1), 0, "ubar(-)*v(-)=0 ", passed) call expect (vbar(-m,p,+1)*u(-m,p,+1), 0, "vbar(+)*u(+)=0 ", passed) call expect (vbar(-m,p,-1)*u(-m,p,-1), 0, "vbar(-)*u(-)=0 ", passed) @ <>= print *, "*** Checking the currents ***:" call expect (abs(v_ff(c_one,ubar(m,p,+1),u(m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,ubar(m,p,-1),u(m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,vbar(m,p,+1),v(m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,vbar(m,p,-1),v(m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) print *, "*** Checking the currents for negative masses***:" call expect (abs(v_ff(c_one,ubar(-m,p,+1),u(-m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,ubar(-m,p,-1),u(-m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,vbar(-m,p,+1),v(-m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,vbar(-m,p,-1),v(-m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) @ <>= print *, "*** Checking current conservation ***:" call expect ((vp-vq)*v_ff(c_one,ubar(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,ubar(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) print *, "*** Checking current conservation for negative masses***:" call expect ((vp-vq)*v_ff(c_one,ubar(-m,p,+1),u(-m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,ubar(-m,p,-1),u(-m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(-m,p,+1),v(-m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,vbar(-m,p,-1),v(-m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) @ <>= if (m == 0) then print *, "*** Checking axial current conservation ***:" call expect ((vp-vq)*a_ff(c_one,ubar(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).A.u(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,ubar(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).A.u(-))=0", passed) call expect ((vp-vq)*a_ff(c_one,vbar(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).A.v(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,vbar(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).A.v(-))=0", passed) end if @ <>= print *, "*** Checking implementation of the sigma vertex funktions ***:" call expect ((vp*tvam_ff(c_one,c_nil,ubar(m,p,+1),u(m,q,+1),q) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,ubar(m,p,-1),u(m,q,-1),q) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,vbar(m,p,+1),v(m,q,+1),q) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,vbar(m,p,-1),v(m,q,-1),q) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((ubar(m,p,+1)*f_tvamf(c_one,c_nil,vp,u(m,q,+1),q) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "ubar(p,+).[p*(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((ubar(m,p,-1)*f_tvamf(c_one,c_nil,vp,u(m,q,-1),q) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "ubar(p,-).[p*(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vbar(m,p,+1)*f_tvamf(c_one,c_nil,vp,v(m,q,+1),q) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "vbar(p,+).[p*(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vbar(m,p,-1)*f_tvamf(c_one,c_nil,vp,v(m,q,-1),q) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "vbar(p,-).[p*(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((f_ftvam(c_one,c_nil,ubar(m,p,+1),vp,q)*u(m,q,+1) - (p*q-m**2)*(ubar(m,p,+1)*u(m,q,+1))), 0, & "[ubar(p,+).p*(Isigma*q)].u(q,+) - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((f_ftvam(c_one,c_nil,ubar(m,p,-1),vp,q)*u(m,q,-1) - (p*q-m**2)*(ubar(m,p,-1)*u(m,q,-1))), 0, & "[ubar(p,-).p*(Isigma*q)].u(q,-) - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((f_ftvam(c_one,c_nil,vbar(m,p,+1),vp,q)*v(m,q,+1) - (p*q-m**2)*(vbar(m,p,+1)*v(m,q,+1))), 0, & "[vbar(p,+).p*(Isigma*q)].v(q,+) - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((f_ftvam(c_one,c_nil,vbar(m,p,-1),vp,q)*v(m,q,-1) - (p*q-m**2)*(vbar(m,p,-1)*v(m,q,-1))), 0, & "[vbar(p,-).p*(Isigma*q)].v(q,-) - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,ubar(m,p,+1),u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,ubar(m,p,-1),u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,vbar(m,p,+1),v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,vbar(m,p,-1),v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((ubar(m,p,+1)*f_tvamf(c_nil,c_one,vp,u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((ubar(m,p,-1)*f_tvamf(c_nil,c_one,vp,u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vbar(m,p,+1)*f_tvamf(c_nil,c_one,vp,v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vbar(m,p,-1)*f_tvamf(c_nil,c_one,vp,v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((f_ftvam(c_nil,c_one,ubar(m,p,+1),vp,q)*u(m,q,+1) - (p*q+m**2)*p_ff(c_one,ubar(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((f_ftvam(c_nil,c_one,ubar(m,p,-1),vp,q)*u(m,q,-1) - (p*q+m**2)*p_ff(c_one,ubar(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((f_ftvam(c_nil,c_one,vbar(m,p,+1),vp,q)*v(m,q,+1) - (p*q+m**2)*p_ff(c_one,vbar(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((f_ftvam(c_nil,c_one,vbar(m,p,-1),vp,q)*v(m,q,-1) - (p*q+m**2)*p_ff(c_one,vbar(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) @ <>= print *, "*** Checking polarisation vectors: ***" call expect (conjg(eps(m,p, 1))*eps(m,p, 1), -1, "e( 1).e( 1)=-1", passed) call expect (conjg(eps(m,p, 1))*eps(m,p,-1), 0, "e( 1).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 1), 0, "e(-1).e( 1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p,-1), -1, "e(-1).e(-1)=-1", passed) call expect ( p*eps(m,p, 1), 0, " p.e( 1)= 0", passed) call expect ( p*eps(m,p,-1), 0, " p.e(-1)= 0", passed) if (m > 0) then call expect (conjg(eps(m,p, 1))*eps(m,p, 0), 0, "e( 1).e( 0)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 1), 0, "e( 0).e( 1)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 0), -1, "e( 0).e( 0)=-1", passed) call expect (conjg(eps(m,p, 0))*eps(m,p,-1), 0, "e( 0).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 0), 0, "e(-1).e( 0)= 0", passed) call expect ( p*eps(m,p, 0), 0, " p.e( 0)= 0", passed) end if @ <>= print *, "*** Checking epsilon tensor: ***" call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,q,1),eps(m,p,1),eps(m,p,0),eps(m,q,0)), "eps(1<->2)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,0),eps(m,q,1),eps(m,p,1),eps(m,q,0)), "eps(1<->3)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,q,0),eps(m,q,1),eps(m,p,0),eps(m,p,1)), "eps(1<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,p,0),eps(m,q,1),eps(m,q,0)), "eps(2<->3)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,q,0),eps(m,p,0),eps(m,q,1)), "eps(2<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & - pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,q,0),eps(m,p,0)), "eps(3<->4)", passed) call expect ( pseudo_scalar(eps(m,p,1),eps(m,q,1),eps(m,p,0),eps(m,q,0)), & eps(m,p,1)*pseudo_vector(eps(m,q,1),eps(m,p,0),eps(m,q,0)), "eps'", passed) @ \begin{equation} \frac{1}{2} [x\wedge y]^*_{\mu\nu} [x\wedge y]^{\mu\nu} = \frac{1}{2} (x^*_\mu y^*_\nu-x^*_\nu y^*_\mu) (x^\mu y^\nu-x^\nu y^\mu) = (x^*x) (y^*y) - (x^*y) (y^*x) \end{equation} <>= print *, "*** Checking tensors: ***" call expect (conjg(p.wedge.q)*(p.wedge.q), (p*p)*(q*q)-(p*q)**2, & "[p,q].[q,p]=p.p*q.q-p.q^2", passed) call expect (conjg(p.wedge.q)*(q.wedge.p), (p*q)**2-(p*p)*(q*q), & "[p,q].[q,p]=p.q^2-p.p*q.q", passed) @ i.\,e. \begin{equation} \frac{1}{2} [p\wedge\epsilon(p,i)]^*_{\mu\nu} [p\wedge\epsilon(p,j)]^{\mu\nu} = - p^2 \delta_{ij} \end{equation} <>= call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p, 1)), -p*p, & "[p,e( 1)].[p,e( 1)]=-p.p", passed) call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p,-1)), 0, & "[p,e( 1)].[p,e(-1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p, 1)), 0, & "[p,e(-1)].[p,e( 1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p,-1)), -p*p, & "[p,e(-1)].[p,e(-1)]=-p.p", passed) if (m > 0) then call expect (conjg(p.wedge.eps(m,p, 1))*(p.wedge.eps(m,p, 0)), 0, & "[p,e( 1)].[p,e( 0)]=0", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p, 1)), 0, & "[p,e( 0)].[p,e( 1)]=0", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p, 0)), -p*p, & "[p,e( 0)].[p,e( 0)]=-p.p", passed) call expect (conjg(p.wedge.eps(m,p, 0))*(p.wedge.eps(m,p,-1)), 0, & "[p,e( 1)].[p,e(-1)]=0", passed) call expect (conjg(p.wedge.eps(m,p,-1))*(p.wedge.eps(m,p, 0)), 0, & "[p,e(-1)].[p,e( 0)]=0", passed) end if @ also \begin{align} [x\wedge y]_{\mu\nu} z^\nu &= x_\mu (yz) - y_\mu (xz) \\ z_\mu [x\wedge y]^{\mu\nu} &= (zx) y^\nu - (zy) x^\nu \end{align} <>= call expect (abs ((p.wedge.eps(m,p, 1))*p + (p*p)*eps(m,p, 1)), 0, & "[p,e( 1)].p=-p.p*e( 1)]", passed) call expect (abs ((p.wedge.eps(m,p, 0))*p + (p*p)*eps(m,p, 0)), 0, & "[p,e( 0)].p=-p.p*e( 0)]", passed) call expect (abs ((p.wedge.eps(m,p,-1))*p + (p*p)*eps(m,p,-1)), 0, & "[p,e(-1)].p=-p.p*e(-1)]", passed) call expect (abs (p*(p.wedge.eps(m,p, 1)) - (p*p)*eps(m,p, 1)), 0, & "p.[p,e( 1)]=p.p*e( 1)]", passed) call expect (abs (p*(p.wedge.eps(m,p, 0)) - (p*p)*eps(m,p, 0)), 0, & "p.[p,e( 0)]=p.p*e( 0)]", passed) call expect (abs (p*(p.wedge.eps(m,p,-1)) - (p*p)*eps(m,p,-1)), 0, & "p.[p,e(-1)]=p.p*e(-1)]", passed) @ <>= print *, "*** Checking polarisation tensors: ***" call expect (conjg(eps2(m,p, 2))*eps2(m,p, 2), 1, "e2( 2).e2( 2)=1", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p,-2), 0, "e2( 2).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 2), 0, "e2(-2).e2( 2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p,-2), 1, "e2(-2).e2(-2)=1", passed) if (m > 0) then call expect (conjg(eps2(m,p, 2))*eps2(m,p, 1), 0, "e2( 2).e2( 1)=0", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p, 0), 0, "e2( 2).e2( 0)=0", passed) call expect (conjg(eps2(m,p, 2))*eps2(m,p,-1), 0, "e2( 2).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 2), 0, "e2( 1).e2( 2)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 1), 1, "e2( 1).e2( 1)=1", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p, 0), 0, "e2( 1).e2( 0)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p,-1), 0, "e2( 1).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 1))*eps2(m,p,-2), 0, "e2( 1).e2(-2)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 2), 0, "e2( 0).e2( 2)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 1), 0, "e2( 0).e2( 1)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p, 0), 1, "e2( 0).e2( 0)=1", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p,-1), 0, "e2( 0).e2(-1)=0", passed) call expect (conjg(eps2(m,p, 0))*eps2(m,p,-2), 0, "e2( 0).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 2), 0, "e2(-1).e2( 2)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 1), 0, "e2(-1).e2( 1)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p, 0), 0, "e2(-1).e2( 0)=0", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p,-1), 1, "e2(-1).e2(-1)=1", passed) call expect (conjg(eps2(m,p,-1))*eps2(m,p,-2), 0, "e2(-1).e2(-2)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 1), 0, "e2(-2).e2( 1)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p, 0), 0, "e2(-2).e2( 0)=0", passed) call expect (conjg(eps2(m,p,-2))*eps2(m,p,-1), 0, "e2(-2).e2(-1)=0", passed) end if @ <>= call expect ( abs(p*eps2(m,p, 2) ), 0, " |p.e2( 2)| =0", passed) call expect ( abs(eps2(m,p, 2)*p), 0, " |e2( 2).p|=0", passed) call expect ( abs(p*eps2(m,p,-2) ), 0, " |p.e2(-2)| =0", passed) call expect ( abs(eps2(m,p,-2)*p), 0, " |e2(-2).p|=0", passed) if (m > 0) then call expect ( abs(p*eps2(m,p, 1) ), 0, " |p.e2( 1)| =0", passed) call expect ( abs(eps2(m,p, 1)*p), 0, " |e2( 1).p|=0", passed) call expect ( abs(p*eps2(m,p, 0) ), 0, " |p.e2( 0)| =0", passed) call expect ( abs(eps2(m,p, 0)*p), 0, " |e2( 0).p|=0", passed) call expect ( abs(p*eps2(m,p,-1) ), 0, " |p.e2(-1)| =0", passed) call expect ( abs(eps2(m,p,-1)*p), 0, " |e2(-1).p|=0", passed) end if @ <>= print *, " *** Checking the polarization tensors for massive gravitons:" call expect (abs(p * eps2(m,p,2)), 0, "p.e(+2)=0", passed) call expect (abs(p * eps2(m,p,1)), 0, "p.e(+1)=0", passed) call expect (abs(p * eps2(m,p,0)), 0, "p.e( 0)=0", passed) call expect (abs(p * eps2(m,p,-1)), 0, "p.e(-1)=0", passed) call expect (abs(p * eps2(m,p,-2)), 0, "p.e(-2)=0", passed) call expect (abs(trace(eps2 (m,p,2))), 0, "Tr[e(+2)]=0", passed) call expect (abs(trace(eps2 (m,p,1))), 0, "Tr[e(+1)]=0", passed) call expect (abs(trace(eps2 (m,p,0))), 0, "Tr[e( 0)]=0", passed) call expect (abs(trace(eps2 (m,p,-1))), 0, "Tr[e(-1)]=0", passed) call expect (abs(trace(eps2 (m,p,-2))), 0, "Tr[e(-2)]=0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,2)), 1, & "e(2).e(2) = 1", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,1)), 0, & "e(2).e(1) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,0)), 0, & "e(2).e(0) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,-1)), 0, & "e(2).e(-1) = 0", passed) call expect (abs(eps2(m,p,2) * eps2(m,p,-2)), 0, & "e(2).e(-2) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,1)), 1, & "e(1).e(1) = 1", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,0)), 0, & "e(1).e(0) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,-1)), 0, & "e(1).e(-1) = 0", passed) call expect (abs(eps2(m,p,1) * eps2(m,p,-2)), 0, & "e(1).e(-2) = 0", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,0)), 1, & "e(0).e(0) = 1", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,-1)), 0, & "e(0).e(-1) = 0", passed) call expect (abs(eps2(m,p,0) * eps2(m,p,-2)), 0, & "e(0).e(-2) = 0", passed) call expect (abs(eps2(m,p,-1) * eps2(m,p,-1)), 1, & "e(-1).e(-1) = 1", passed) call expect (abs(eps2(m,p,-1) * eps2(m,p,-2)), 0, & "e(-1).e(-2) = 0", passed) call expect (abs(eps2(m,p,-2) * eps2(m,p,-2)), 1, & "e(-2).e(-2) = 1", passed) @ <>= print *, " *** Checking the graviton propagator:" call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,-2)))), 0, "p.pr.e(-2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,-1)))), 0, "p.pr.e(-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,0)))), 0, "p.pr.e(0)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,1)))), 0, "p.pr.e(1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,eps2(m,p,2)))), 0, "p.pr.e(2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_tensor(p,m,w,ttest))), 0, "p.pr.ttest", passed) @ <<[[test_omega95_bispinors.f90]]>>= <> program test_omega95_bispinors use kinds use omega95_bispinors use omega_vspinor_polarizations use omega_testtools implicit none integer :: i, j real(kind=default) :: m, pabs, qabs, tabs, zabs, w real(kind=default), dimension(4) :: r complex(kind=default) :: c_nil, c_one, c_two type(momentum) :: p, q, t, z, p_0 type(vector) :: vp, vq, vt, vz type(vectorspinor) :: testv type(bispinor) :: vv logical :: passed call random_seed () c_nil = 0.0_default c_one = 1.0_default c_two = 2.0_default w = 1.4142 m = 13 pabs = 42 qabs = 137 tabs = 84 zabs = 3.1415 p_0%t = m p_0%x = 0 call random_momentum (p, pabs, m) call random_momentum (q, qabs, m) call random_momentum (t, tabs, m) call random_momentum (z, zabs, m) call random_number (r) do i = 1, 4 testv%psi(1)%a(i) = (0.0_default, 0.0_default) end do do i = 2, 3 do j = 1, 4 testv%psi(i)%a(j) = cmplx (10.0_default * r(j), kind=default) end do end do testv%psi(4)%a(1) = (1.0_default, 0.0_default) testv%psi(4)%a(2) = (0.0_default, 2.0_default) testv%psi(4)%a(3) = (1.0_default, 0.0_default) testv%psi(4)%a(4) = (3.0_default, 0.0_default) vp = p vq = q vt = t vz = z passed = .true. vv%a(1) = (1.0_default, 0.0_default) vv%a(2) = (0.0_default, 2.0_default) vv%a(3) = (1.0_default, 0.0_default) vv%a(4) = (3.0_default, 0.0_default) vv = pr_psi(p, m, w, .false., vv) <> if (.not. passed) then stop 1 end if end program test_omega95_bispinors @ <>= print *, "*** Checking the equations of motion ***:" call expect (abs(f_vf(c_one,vp,u(m,p,+1))-m*u(m,p,+1)), 0, "|[p-m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(m,p,-1))-m*u(m,p,-1)), 0, "|[p-m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,+1))+m*v(m,p,+1)), 0, "|[p+m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(m,p,-1))+m*v(m,p,-1)), 0, "|[p+m]v(-)|=0", passed) print *, "*** Checking the equations of motion for negative masses***:" call expect (abs(f_vf(c_one,vp,u(-m,p,+1))+m*u(-m,p,+1)), 0, "|[p+m]u(+)|=0", passed) call expect (abs(f_vf(c_one,vp,u(-m,p,-1))+m*u(-m,p,-1)), 0, "|[p+m]u(-)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,+1))-m*v(-m,p,+1)), 0, "|[p-m]v(+)|=0", passed) call expect (abs(f_vf(c_one,vp,v(-m,p,-1))-m*v(-m,p,-1)), 0, "|[p-m]v(-)|=0", passed) @ <>= print *, "*** Checking the normalization ***:" call expect (s_ff(c_one,v(m,p,+1),u(m,p,+1)), +2*m, "ubar(+)*u(+)=+2m", passed) call expect (s_ff(c_one,v(m,p,-1),u(m,p,-1)), +2*m, "ubar(-)*u(-)=+2m", passed) call expect (s_ff(c_one,u(m,p,+1),v(m,p,+1)), -2*m, "vbar(+)*v(+)=-2m", passed) call expect (s_ff(c_one,u(m,p,-1),v(m,p,-1)), -2*m, "vbar(-)*v(-)=-2m", passed) call expect (s_ff(c_one,v(m,p,+1),v(m,p,+1)), 0, "ubar(+)*v(+)=0 ", passed) call expect (s_ff(c_one,v(m,p,-1),v(m,p,-1)), 0, "ubar(-)*v(-)=0 ", passed) call expect (s_ff(c_one,u(m,p,+1),u(m,p,+1)), 0, "vbar(+)*u(+)=0 ", passed) call expect (s_ff(c_one,u(m,p,-1),u(m,p,-1)), 0, "vbar(-)*u(-)=0 ", passed) print *, "*** Checking the normalization for negative masses***:" call expect (s_ff(c_one,v(-m,p,+1),u(-m,p,+1)), -2*m, "ubar(+)*u(+)=-2m", passed) call expect (s_ff(c_one,v(-m,p,-1),u(-m,p,-1)), -2*m, "ubar(-)*u(-)=-2m", passed) call expect (s_ff(c_one,u(-m,p,+1),v(-m,p,+1)), +2*m, "vbar(+)*v(+)=+2m", passed) call expect (s_ff(c_one,u(-m,p,-1),v(-m,p,-1)), +2*m, "vbar(-)*v(-)=+2m", passed) call expect (s_ff(c_one,v(-m,p,+1),v(-m,p,+1)), 0, "ubar(+)*v(+)=0 ", passed) call expect (s_ff(c_one,v(-m,p,-1),v(-m,p,-1)), 0, "ubar(-)*v(-)=0 ", passed) call expect (s_ff(c_one,u(-m,p,+1),u(-m,p,+1)), 0, "vbar(+)*u(+)=0 ", passed) call expect (s_ff(c_one,u(-m,p,-1),u(-m,p,-1)), 0, "vbar(-)*u(-)=0 ", passed) @ <>= print *, "*** Checking the currents ***:" call expect (abs(v_ff(c_one,v(m,p,+1),u(m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,v(m,p,-1),u(m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,u(m,p,+1),v(m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,u(m,p,-1),v(m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) print *, "*** Checking the currents for negative masses***:" call expect (abs(v_ff(c_one,v(-m,p,+1),u(-m,p,+1))-2*vp), 0, "ubar(+).V.u(+)=2p", passed) call expect (abs(v_ff(c_one,v(-m,p,-1),u(-m,p,-1))-2*vp), 0, "ubar(-).V.u(-)=2p", passed) call expect (abs(v_ff(c_one,u(-m,p,+1),v(-m,p,+1))-2*vp), 0, "vbar(+).V.v(+)=2p", passed) call expect (abs(v_ff(c_one,u(-m,p,-1),v(-m,p,-1))-2*vp), 0, "vbar(-).V.v(-)=2p", passed) @ <>= print *, "*** Checking current conservation ***:" call expect ((vp-vq)*v_ff(c_one,v(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,v(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) <>= print *, "*** Checking current conservation for negative masses***:" call expect ((vp-vq)*v_ff(c_one,v(-m,p,+1),u(-m,q,+1)), 0, "d(ubar(+).V.u(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,v(-m,p,-1),u(-m,q,-1)), 0, "d(ubar(-).V.u(-))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(-m,p,+1),v(-m,q,+1)), 0, "d(vbar(+).V.v(+))=0", passed) call expect ((vp-vq)*v_ff(c_one,u(-m,p,-1),v(-m,q,-1)), 0, "d(vbar(-).V.v(-))=0", passed) @ <>= if (m == 0) then print *, "*** Checking axial current conservation ***:" call expect ((vp-vq)*a_ff(c_one,v(m,p,+1),u(m,q,+1)), 0, "d(ubar(+).A.u(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,v(m,p,-1),u(m,q,-1)), 0, "d(ubar(-).A.u(-))=0", passed) call expect ((vp-vq)*a_ff(c_one,u(m,p,+1),v(m,q,+1)), 0, "d(vbar(+).A.v(+))=0", passed) call expect ((vp-vq)*a_ff(c_one,u(m,p,-1),v(m,q,-1)), 0, "d(vbar(-).A.v(-))=0", passed) end if <>= print *, "*** Checking implementation of the sigma vertex funktions ***:" call expect ((vp*tvam_ff(c_one,c_nil,v(m,p,+1),u(m,q,+1),q) - (p*q-m**2)*(v(m,p,+1)*u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,v(m,p,-1),u(m,q,-1),q) - (p*q-m**2)*(v(m,p,-1)*u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,u(m,p,+1),v(m,q,+1),q) - (p*q-m**2)*(u(m,p,+1)*v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_one,c_nil,u(m,p,-1),v(m,q,-1),q) - (p*q-m**2)*(u(m,p,-1)*v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((v(m,p,+1)*f_tvamf(c_one,c_nil,vp,u(m,q,+1),q) - (p*q-m**2)*(v(m,p,+1)*u(m,q,+1))), 0, & "ubar(p,+).[p*(Isigma*q).u(q,+)] - (p*q-m^2)*ubar(p,+).u(q,+) = 0", passed) call expect ((v(m,p,-1)*f_tvamf(c_one,c_nil,vp,u(m,q,-1),q) - (p*q-m**2)*(v(m,p,-1)*u(m,q,-1))), 0, & "ubar(p,-).[p*(Isigma*q).u(q,-)] - (p*q-m^2)*ubar(p,-).u(q,-) = 0", passed) call expect ((u(m,p,+1)*f_tvamf(c_one,c_nil,vp,v(m,q,+1),q) - (p*q-m**2)*(u(m,p,+1)*v(m,q,+1))), 0, & "vbar(p,+).[p*(Isigma*q).v(q,+)] - (p*q-m^2)*vbar(p,+).v(q,+) = 0", passed) call expect ((u(m,p,-1)*f_tvamf(c_one,c_nil,vp,v(m,q,-1),q) - (p*q-m**2)*(u(m,p,-1)*v(m,q,-1))), 0, & "vbar(p,-).[p*(Isigma*q).v(q,-)] - (p*q-m^2)*vbar(p,-).v(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,v(m,p,+1),u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,v(m,p,-1),u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,u(m,p,+1),v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((vp*tvam_ff(c_nil,c_one,u(m,p,-1),v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) call expect ((v(m,p,+1)*f_tvamf(c_nil,c_one,vp,u(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,+1),u(m,q,+1))), 0, & "p*[ubar(p,+).(Isigma*q).g5.u(q,+)] - (p*q+m^2)*ubar(p,+).g5.u(q,+) = 0", passed) call expect ((v(m,p,-1)*f_tvamf(c_nil,c_one,vp,u(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,v(m,p,-1),u(m,q,-1))), 0, & "p*[ubar(p,-).(Isigma*q).g5.u(q,-)] - (p*q+m^2)*ubar(p,-).g5.u(q,-) = 0", passed) call expect ((u(m,p,+1)*f_tvamf(c_nil,c_one,vp,v(m,q,+1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,+1),v(m,q,+1))), 0, & "p*[vbar(p,+).(Isigma*q).g5.v(q,+)] - (p*q+m^2)*vbar(p,+).g5.v(q,+) = 0", passed) call expect ((u(m,p,-1)*f_tvamf(c_nil,c_one,vp,v(m,q,-1),q) - (p*q+m**2)*p_ff(c_one,u(m,p,-1),v(m,q,-1))), 0, & "p*[vbar(p,-).(Isigma*q).g5.v(q,-)] - (p*q+m^2)*vbar(p,-).g5.v(q,-) = 0", passed) @ <>= print *, "*** Checking polarization vectors: ***" call expect (conjg(eps(m,p, 1))*eps(m,p, 1), -1, "e( 1).e( 1)=-1", passed) call expect (conjg(eps(m,p, 1))*eps(m,p,-1), 0, "e( 1).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 1), 0, "e(-1).e( 1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p,-1), -1, "e(-1).e(-1)=-1", passed) call expect ( p*eps(m,p, 1), 0, " p.e( 1)= 0", passed) call expect ( p*eps(m,p,-1), 0, " p.e(-1)= 0", passed) if (m > 0) then call expect (conjg(eps(m,p, 1))*eps(m,p, 0), 0, "e( 1).e( 0)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 1), 0, "e( 0).e( 1)= 0", passed) call expect (conjg(eps(m,p, 0))*eps(m,p, 0), -1, "e( 0).e( 0)=-1", passed) call expect (conjg(eps(m,p, 0))*eps(m,p,-1), 0, "e( 0).e(-1)= 0", passed) call expect (conjg(eps(m,p,-1))*eps(m,p, 0), 0, "e(-1).e( 0)= 0", passed) call expect ( p*eps(m,p, 0), 0, " p.e( 0)= 0", passed) end if @ <>= print *, "*** Checking polarization vectorspinors: ***" call expect (abs(p * ueps(m, p, 2)), 0, "p.ueps ( 2)= 0", passed) call expect (abs(p * ueps(m, p, 1)), 0, "p.ueps ( 1)= 0", passed) call expect (abs(p * ueps(m, p, -1)), 0, "p.ueps (-1)= 0", passed) call expect (abs(p * ueps(m, p, -2)), 0, "p.ueps (-2)= 0", passed) call expect (abs(p * veps(m, p, 2)), 0, "p.veps ( 2)= 0", passed) call expect (abs(p * veps(m, p, 1)), 0, "p.veps ( 1)= 0", passed) call expect (abs(p * veps(m, p, -1)), 0, "p.veps (-1)= 0", passed) call expect (abs(p * veps(m, p, -2)), 0, "p.veps (-2)= 0", passed) print *, "*** Checking polarization vectorspinors (neg. masses): ***" call expect (abs(p * ueps(-m, p, 2)), 0, "p.ueps ( 2)= 0", passed) call expect (abs(p * ueps(-m, p, 1)), 0, "p.ueps ( 1)= 0", passed) call expect (abs(p * ueps(-m, p, -1)), 0, "p.ueps (-1)= 0", passed) call expect (abs(p * ueps(-m, p, -2)), 0, "p.ueps (-2)= 0", passed) call expect (abs(p * veps(-m, p, 2)), 0, "p.veps ( 2)= 0", passed) call expect (abs(p * veps(-m, p, 1)), 0, "p.veps ( 1)= 0", passed) call expect (abs(p * veps(-m, p, -1)), 0, "p.veps (-1)= 0", passed) call expect (abs(p * veps(-m, p, -2)), 0, "p.veps (-2)= 0", passed) print *, "*** in the rest frame ***" call expect (abs(p_0 * ueps(m, p_0, 2)), 0, "p0.ueps ( 2)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, 1)), 0, "p0.ueps ( 1)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, -1)), 0, "p0.ueps (-1)= 0", passed) call expect (abs(p_0 * ueps(m, p_0, -2)), 0, "p0.ueps (-2)= 0", passed) call expect (abs(p_0 * veps(m, p_0, 2)), 0, "p0.veps ( 2)= 0", passed) call expect (abs(p_0 * veps(m, p_0, 1)), 0, "p0.veps ( 1)= 0", passed) call expect (abs(p_0 * veps(m, p_0, -1)), 0, "p0.veps (-1)= 0", passed) call expect (abs(p_0 * veps(m, p_0, -2)), 0, "p0.veps (-2)= 0", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (abs(p_0 * ueps(-m, p_0, 2)), 0, "p0.ueps ( 2)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, 1)), 0, "p0.ueps ( 1)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, -1)), 0, "p0.ueps (-1)= 0", passed) call expect (abs(p_0 * ueps(-m, p_0, -2)), 0, "p0.ueps (-2)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, 2)), 0, "p0.veps ( 2)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, 1)), 0, "p0.veps ( 1)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, -1)), 0, "p0.veps (-1)= 0", passed) call expect (abs(p_0 * veps(-m, p_0, -2)), 0, "p0.veps (-2)= 0", passed) @ <>= print *, "*** Checking the irreducibility condition: ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p, -2))), 0, "g.veps (-2)", passed) print *, "*** Checking the irreducibility condition (neg. masses): ***" call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(-m, p, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(-m, p, -2))), 0, "g.veps (-2)", passed) print *, "*** in the rest frame ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -2))), 0, "g.veps (-2)", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 2))), 0, "g.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, 1))), 0, "g.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -1))), 0, "g.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, ueps(m, p_0, -2))), 0, "g.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 2))), 0, "g.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, 1))), 0, "g.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -1))), 0, "g.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, veps(m, p_0, -2))), 0, "g.veps (-2)", passed) @ <>= print *, "*** Testing vectorspinor normalization ***" call expect (veps(m,p, 2)*ueps(m,p, 2), -2*m, "ueps( 2).ueps( 2)= -2m", passed) call expect (veps(m,p, 1)*ueps(m,p, 1), -2*m, "ueps( 1).ueps( 1)= -2m", passed) call expect (veps(m,p,-1)*ueps(m,p,-1), -2*m, "ueps(-1).ueps(-1)= -2m", passed) call expect (veps(m,p,-2)*ueps(m,p,-2), -2*m, "ueps(-2).ueps(-2)= -2m", passed) call expect (ueps(m,p, 2)*veps(m,p, 2), 2*m, "veps( 2).veps( 2)= +2m", passed) call expect (ueps(m,p, 1)*veps(m,p, 1), 2*m, "veps( 1).veps( 1)= +2m", passed) call expect (ueps(m,p,-1)*veps(m,p,-1), 2*m, "veps(-1).veps(-1)= +2m", passed) call expect (ueps(m,p,-2)*veps(m,p,-2), 2*m, "veps(-2).veps(-2)= +2m", passed) call expect (ueps(m,p, 2)*ueps(m,p, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(m,p, 1)*ueps(m,p, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(m,p,-1)*ueps(m,p,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(m,p,-2)*ueps(m,p,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(m,p, 2)*veps(m,p, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(m,p, 1)*veps(m,p, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(m,p,-1)*veps(m,p,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(m,p,-2)*veps(m,p,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** Testing vectorspinor normalization (neg. masses) ***" call expect (veps(-m,p, 2)*ueps(-m,p, 2), +2*m, "ueps( 2).ueps( 2)= +2m", passed) call expect (veps(-m,p, 1)*ueps(-m,p, 1), +2*m, "ueps( 1).ueps( 1)= +2m", passed) call expect (veps(-m,p,-1)*ueps(-m,p,-1), +2*m, "ueps(-1).ueps(-1)= +2m", passed) call expect (veps(-m,p,-2)*ueps(-m,p,-2), +2*m, "ueps(-2).ueps(-2)= +2m", passed) call expect (ueps(-m,p, 2)*veps(-m,p, 2), -2*m, "veps( 2).veps( 2)= -2m", passed) call expect (ueps(-m,p, 1)*veps(-m,p, 1), -2*m, "veps( 1).veps( 1)= -2m", passed) call expect (ueps(-m,p,-1)*veps(-m,p,-1), -2*m, "veps(-1).veps(-1)= -2m", passed) call expect (ueps(-m,p,-2)*veps(-m,p,-2), -2*m, "veps(-2).veps(-2)= -2m", passed) call expect (ueps(-m,p, 2)*ueps(-m,p, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(-m,p, 1)*ueps(-m,p, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(-m,p,-1)*ueps(-m,p,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(-m,p,-2)*ueps(-m,p,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(-m,p, 2)*veps(-m,p, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(-m,p, 1)*veps(-m,p, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(-m,p,-1)*veps(-m,p,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(-m,p,-2)*veps(-m,p,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** in the rest frame ***" call expect (veps(m,p_0, 2)*ueps(m,p_0, 2), -2*m, "ueps( 2).ueps( 2)= -2m", passed) call expect (veps(m,p_0, 1)*ueps(m,p_0, 1), -2*m, "ueps( 1).ueps( 1)= -2m", passed) call expect (veps(m,p_0,-1)*ueps(m,p_0,-1), -2*m, "ueps(-1).ueps(-1)= -2m", passed) call expect (veps(m,p_0,-2)*ueps(m,p_0,-2), -2*m, "ueps(-2).ueps(-2)= -2m", passed) call expect (ueps(m,p_0, 2)*veps(m,p_0, 2), 2*m, "veps( 2).veps( 2)= +2m", passed) call expect (ueps(m,p_0, 1)*veps(m,p_0, 1), 2*m, "veps( 1).veps( 1)= +2m", passed) call expect (ueps(m,p_0,-1)*veps(m,p_0,-1), 2*m, "veps(-1).veps(-1)= +2m", passed) call expect (ueps(m,p_0,-2)*veps(m,p_0,-2), 2*m, "veps(-2).veps(-2)= +2m", passed) call expect (ueps(m,p_0, 2)*ueps(m,p_0, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(m,p_0, 1)*ueps(m,p_0, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(m,p_0,-1)*ueps(m,p_0,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(m,p_0,-2)*ueps(m,p_0,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(m,p_0, 2)*veps(m,p_0, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(m,p_0, 1)*veps(m,p_0, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(m,p_0,-1)*veps(m,p_0,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(m,p_0,-2)*veps(m,p_0,-2), 0, "veps(-2).ueps(-2)= 0", passed) print *, "*** in the rest frame (neg. masses) ***" call expect (veps(-m,p_0, 2)*ueps(-m,p_0, 2), +2*m, "ueps( 2).ueps( 2)= +2m", passed) call expect (veps(-m,p_0, 1)*ueps(-m,p_0, 1), +2*m, "ueps( 1).ueps( 1)= +2m", passed) call expect (veps(-m,p_0,-1)*ueps(-m,p_0,-1), +2*m, "ueps(-1).ueps(-1)= +2m", passed) call expect (veps(-m,p_0,-2)*ueps(-m,p_0,-2), +2*m, "ueps(-2).ueps(-2)= +2m", passed) call expect (ueps(-m,p_0, 2)*veps(-m,p_0, 2), -2*m, "veps( 2).veps( 2)= -2m", passed) call expect (ueps(-m,p_0, 1)*veps(-m,p_0, 1), -2*m, "veps( 1).veps( 1)= -2m", passed) call expect (ueps(-m,p_0,-1)*veps(-m,p_0,-1), -2*m, "veps(-1).veps(-1)= -2m", passed) call expect (ueps(-m,p_0,-2)*veps(-m,p_0,-2), -2*m, "veps(-2).veps(-2)= -2m", passed) call expect (ueps(-m,p_0, 2)*ueps(-m,p_0, 2), 0, "ueps( 2).veps( 2)= 0", passed) call expect (ueps(-m,p_0, 1)*ueps(-m,p_0, 1), 0, "ueps( 1).veps( 1)= 0", passed) call expect (ueps(-m,p_0,-1)*ueps(-m,p_0,-1), 0, "ueps(-1).veps(-1)= 0", passed) call expect (ueps(-m,p_0,-2)*ueps(-m,p_0,-2), 0, "ueps(-2).veps(-2)= 0", passed) call expect (veps(-m,p_0, 2)*veps(-m,p_0, 2), 0, "veps( 2).ueps( 2)= 0", passed) call expect (veps(-m,p_0, 1)*veps(-m,p_0, 1), 0, "veps( 1).ueps( 1)= 0", passed) call expect (veps(-m,p_0,-1)*veps(-m,p_0,-1), 0, "veps(-1).ueps(-1)= 0", passed) call expect (veps(-m,p_0,-2)*veps(-m,p_0,-2), 0, "veps(-2).ueps(-2)= 0", passed) @ <>= print *, "*** Majorana properties of gravitino vertices: ***" call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,2), t) + & !!! ueps(m,p,2) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,1), t) + & !!! ueps(m,p,1) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,1), t) + & !!! ueps(m,p,1) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,-1), t) + & !!! ueps(m,p,-1) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,-1), t) + & !!! ueps(m,p,-1) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,1) * f_sgr (c_one, c_one, ueps(m,p,-2), t) + & !!! ueps(m,p,-2) * gr_sf(c_one,c_one,u(m,q,1),t)), 0, "f_sgr + gr_sf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_sgr (c_one, c_one, ueps(m,p,-2), t) + & !!! ueps(m,p,-2) * gr_sf(c_one,c_one,u(m,q,-1),t)), 0, "f_sgr + gr_sf = 0", passed) call expect (abs(u (m,q,1) * f_slgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_slf(c_one,c_one,u(m,q,1),t)), 0, "f_slgr + gr_slf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_srgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_srf(c_one,c_one,u(m,q,1),t)), 0, "f_srgr + gr_srf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_slrgr (c_one, c_two, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_slrf(c_one,c_two,c_one,u(m,q,1),t)), 0, "f_slrgr + gr_slrf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_pgr (c_one, c_one, ueps(m,p,2), t) + & ueps(m,p,2) * gr_pf(c_one,c_one,u(m,q,1),t)), 0, "f_pgr + gr_pf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,2), p+q) + & ueps(m,p,2) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed, threshold = 0.5_default) call expect (abs(u (m,q,1) * f_vlrgr (c_one, c_two, vt, ueps(m,p,2), p+q) + & ueps(m,p,2) * gr_vlrf(c_one,c_two,vt,u(m,q,1),p+q)), 0, "f_vlrgr + gr_vlrf = 0", & passed, threshold = 0.5_default) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,2), p+q) + & !!! ueps(m,p,2) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,1), p+q) + & !!! ueps(m,p,1) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,1), p+q) + & !!! ueps(m,p,1) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,1) * f_vgr (c_one, vt, ueps(m,p,-1), p+q) + & !!! ueps(m,p,-1) * gr_vf(c_one,vt,u(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, veps(m,p,-1), p+q) + & !!! veps(m,p,-1) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(v (m,q,1) * f_vgr (c_one, vt, ueps(m,p,-2), p+q) + & !!! ueps(m,p,-2) * gr_vf(c_one,vt,v(m,q,1),p+q)), 0, "f_vgr + gr_vf = 0", passed) !!! call expect (abs(u (m,q,-1) * f_vgr (c_one, vt, ueps(m,p,-2), p+q) + & !!! ueps(m,p,-2) * gr_vf(c_one,vt,u(m,q,-1),p+q)), 0, "f_vgr + gr_vf = 0", passed) call expect (abs(s_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & s_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "s_grf + s_fgr = 0", passed) call expect (abs(sl_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & sl_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "sl_grf + sl_fgr = 0", passed) call expect (abs(sr_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & sr_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "sr_grf + sr_fgr = 0", passed) call expect (abs(slr_grf (c_one, c_two, ueps(m,p,2), u(m,q,1),t) + & slr_fgr(c_one,c_two,u(m,q,1),ueps(m,p,2),t)), 0, "slr_grf + slr_fgr = 0", passed) call expect (abs(p_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & p_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "p_grf + p_fgr = 0", passed) call expect (abs(v_grf (c_one, ueps(m,p,2), u(m,q,1),t) + & v_fgr(c_one,u(m,q,1),ueps(m,p,2),t)), 0, "v_grf + v_fgr = 0", passed) call expect (abs(vlr_grf (c_one, c_two, ueps(m,p,2), u(m,q,1),t) + & vlr_fgr(c_one,c_two,u(m,q,1),ueps(m,p,2),t)), 0, "vlr_grf + vlr_fgr = 0", passed) call expect (abs(u(m,p,1) * f_potgr (c_one,c_one,testv) - testv * gr_potf & (c_one,c_one,u (m,p,1))), 0, "f_potgr - gr_potf = 0", passed) call expect (abs (pot_fgr (c_one,u(m,p,1),testv) - pot_grf(c_one, & testv,u(m,p,1))), 0, "pot_fgr - pot_grf = 0", passed) call expect (abs(u(m,p,1) * f_s2gr (c_one,c_one,c_one,testv) - testv * gr_s2f & (c_one,c_one,c_one,u (m,p,1))), 0, "f_s2gr - gr_s2f = 0", passed) call expect (abs (s2_fgr (c_one,u(m,p,1),c_one,testv) - s2_grf(c_one, & testv,c_one,u(m,p,1))), 0, "s2_fgr - s2_grf = 0", passed) call expect (abs(u (m,q,1) * f_svgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_svf(c_one,c_one,vt,u(m,q,1))), 0, "f_svgr + gr_svf = 0", passed) call expect (abs(u (m,q,1) * f_slvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_slvf(c_one,c_one,vt,u(m,q,1))), 0, "f_slvgr + gr_slvf = 0", passed) call expect (abs(u (m,q,1) * f_srvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_srvf(c_one,c_one,vt,u(m,q,1))), 0, "f_srvgr + gr_srvf = 0", passed) call expect (abs(u (m,q,1) * f_slrvgr (c_one, c_two, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_slrvf(c_one,c_two,c_one,vt,u(m,q,1))), 0, "f_slrvgr + gr_slrvf = 0", passed) call expect (abs (sv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + sv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "sv1_fgr + sv1_grf = 0", passed) call expect (abs (sv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + sv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "sv2_fgr + sv2_grf = 0", passed) call expect (abs (slv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + slv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "slv1_fgr + slv1_grf = 0", passed) call expect (abs (srv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + srv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "srv2_fgr + srv2_grf = 0", passed) call expect (abs (slrv1_fgr (c_one,c_two,u(m,p,1),vt,ueps(m,q,2)) + slrv1_grf(c_one,c_two, & ueps(m,q,2),vt,u(m,p,1))), 0, "slrv1_fgr + slrv1_grf = 0", passed) call expect (abs (slrv2_fgr (c_one,c_two,u(m,p,1),c_one,ueps(m,q,2)) + slrv2_grf(c_one, & c_two,ueps(m,q,2),c_one,u(m,p,1))), 0, "slrv2_fgr + slrv2_grf = 0", passed) call expect (abs(u (m,q,1) * f_pvgr (c_one, c_one, vt, ueps(m,p,2)) + & ueps(m,p,2) * gr_pvf(c_one,c_one,vt,u(m,q,1))), 0, "f_pvgr + gr_pvf = 0", passed) call expect (abs (pv1_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + pv1_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "pv1_fgr + pv1_grf = 0", passed) call expect (abs (pv2_fgr (c_one,u(m,p,1),c_one,ueps(m,q,2)) + pv2_grf(c_one, & ueps(m,q,2),c_one,u(m,p,1))), 0, "pv2_fgr + pv2_grf = 0", passed) call expect (abs(u (m,q,1) * f_v2gr (c_one, vt, vz, ueps(m,p,2)) + & ueps(m,p,2) * gr_v2f(c_one,vt,vz,u(m,q,1))), 0, "f_v2gr + gr_v2f = 0", passed) call expect (abs(u (m,q,1) * f_v2lrgr (c_one, c_two, vt, vz, ueps(m,p,2)) + & ueps(m,p,2) * gr_v2lrf(c_one,c_two,vt,vz,u(m,q,1))), 0, "f_v2lrgr + gr_v2lrf = 0", passed) call expect (abs (v2_fgr (c_one,u(m,p,1),vt,ueps(m,q,2)) + v2_grf(c_one, & ueps(m,q,2),vt,u(m,p,1))), 0, "v2_fgr + v2_grf = 0", passed) call expect (abs (v2lr_fgr (c_one,c_two,u(m,p,1),vt,ueps(m,q,2)) + v2lr_grf(c_one, c_two, & ueps(m,q,2),vt,u(m,p,1))), 0, "v2lr_fgr + v2lr_grf = 0", passed) @ <>= print *, "*** Testing the gravitino propagator: ***" print *, "Transversality:" call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,testv))), 0, "p.pr.test", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,2)))), 0, "p.pr.ueps ( 2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,1)))), 0, "p.pr.ueps ( 1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,-1)))), 0, "p.pr.ueps (-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,ueps(m,p,-2)))), 0, "p.pr.ueps (-2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,2)))), 0, "p.pr.veps ( 2)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,1)))), 0, "p.pr.veps ( 1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,-1)))), 0, "p.pr.veps (-1)", passed) call expect (abs(p * (cmplx (p*p - m**2, m*w, kind=default) * & pr_grav(p,m,w,veps(m,p,-2)))), 0, "p.pr.veps (-2)", passed) print *, "Irreducibility:" call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,testv)))), 0, "g.pr.test", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,2))))), 0, & "g.pr.ueps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,1))))), 0, & "g.pr.ueps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,-1))))), 0, & "g.pr.ueps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,ueps(m,p,-2))))), 0, & "g.pr.ueps (-2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,2))))), 0, & "g.pr.veps ( 2)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,1))))), 0, & "g.pr.veps ( 1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,-1))))), 0, & "g.pr.veps (-1)", passed) call expect (abs(f_potgr (c_one, c_one, (cmplx (p*p - m**2, m*w, & kind=default) * pr_grav(p,m,w,veps(m,p,-2))))), 0, & "g.pr.veps (-2)", passed) @ <<[[omega_bundle.f90]]>>= <<[[omega_vectors.f90]]>> <<[[omega_spinors.f90]]>> <<[[omega_bispinors.f90]]>> <<[[omega_vectorspinors.f90]]>> <<[[omega_polarizations.f90]]>> <<[[omega_tensors.f90]]>> <<[[omega_tensor_polarizations.f90]]>> <<[[omega_couplings.f90]]>> <<[[omega_spinor_couplings.f90]]>> <<[[omega_bispinor_couplings.f90]]>> <<[[omega_vspinor_polarizations.f90]]>> <<[[omega_utils.f90]]>> <<[[omega95.f90]]>> <<[[omega95_bispinors.f90]]>> <<[[omega_parameters.f90]]>> <<[[omega_parameters_madgraph.f90]]>> @ <<[[omega_bundle_whizard.f90]]>>= <<[[omega_bundle.f90]]>> <<[[omega_parameters_whizard.f90]]>> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{O'Mega Virtual Machine} This module defines the O'Mega Virtual Machine (OVM) completely, whereby all environmental dependencies like masses, widths and couplings have to be given to the constructor [[vm%init]] at runtime. Support for Majorana particles and vectorspinors is only partially, especially all fusions are missing. Maybe it would be easier to make an additional [[omegavm95_bispinors]] to avoid namespace issues. Non-type specific chunks could be reused <<[[omegavm95.f90]]>>= <> module omegavm95 use kinds, only: default use constants use iso_varying_string, string_t => varying_string use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit use omega95 use omega95_bispinors, only: bispinor, vectorspinor, veps, pr_grav use omega95_bispinors, only: bi_u => u use omega95_bispinors, only: bi_v => v use omega95_bispinors, only: bi_pr_psi => pr_psi use omega_bispinors, only: operator (*), operator (+) use omega_color, only: ovm_color_sum, OCF => omega_color_factor implicit none private <> <> <> contains <> <> end module omegavm95 @ This might not be the proper place but I don't know where to put it <>= integer, parameter, public :: stdin = input_unit integer, parameter, public :: stdout = output_unit integer, parameter, public :: stderr = error_unit integer, parameter :: MIN_UNIT = 11, MAX_UNIT = 99 @ <>= subroutine find_free_unit (u, iostat) integer, intent(out) :: u integer, intent(out), optional :: iostat logical :: exists, is_open integer :: i, status do i = MIN_UNIT, MAX_UNIT inquire (unit = i, exist = exists, opened = is_open, & iostat = status) if (status == 0) then if (exists .and. .not. is_open) then u = i if (present (iostat)) then iostat = 0 end if return end if end if end do if (present (iostat)) then iostat = -1 end if u = -1 end subroutine find_free_unit @ These abstract data types would ideally be the interface to communicate quantum numbers between O'Mega and Whizard. This gives full flexibility to change the representation at any time <>= public :: color_t type color_t contains procedure :: write => color_write end type color_t public :: col_discrete type, extends(color_t) :: col_discrete integer :: i end type col_discrete public :: flavor_t type flavor_t contains procedure :: write => flavor_write end type flavor_t public :: flv_discrete type, extends(flavor_t) :: flv_discrete integer :: i end type flv_discrete public :: helicity_t type :: helicity_t contains procedure :: write => helicity_write end type helicity_t public :: hel_discrete type, extends(helicity_t) :: hel_discrete integer :: i end type hel_discrete public :: hel_trigonometric type, extends(helicity_t) :: hel_trigonometric real :: theta end type hel_trigonometric public :: hel_exponential type, extends(helicity_t) :: hel_exponential real :: phi end type hel_exponential public :: hel_spherical type, extends(helicity_t) :: hel_spherical real :: theta, phi end type hel_spherical <>= subroutine color_write (color, fh) class(color_t), intent(in) :: color integer, intent(in) :: fh select type(color) type is (col_discrete) write(fh, *) 'color_discrete%i = ', color%i end select end subroutine color_write subroutine helicity_write (helicity, fh) class(helicity_t), intent(in) :: helicity integer, intent(in) :: fh select type(helicity) type is (hel_discrete) write(fh, *) 'helicity_discrete%i = ', helicity%i type is (hel_trigonometric) write(fh, *) 'helicity_trigonometric%theta = ', helicity%theta type is (hel_exponential) write(fh, *) 'helicity_exponential%phi = ', helicity%phi type is (hel_spherical) write(fh, *) 'helicity_spherical%phi = ', helicity%phi write(fh, *) 'helicity_spherical%theta = ', helicity%theta end select end subroutine helicity_write subroutine flavor_write (flavor, fh) class(flavor_t), intent(in) :: flavor integer, intent(in) :: fh select type(flavor) type is (flv_discrete) write(fh, *) 'flavor_discrete%i = ', flavor%i end select end subroutine flavor_write @ \subsection{Memory Layout} Some internal parameters <>= integer, parameter :: len_instructions = 8 integer, parameter :: N_version_lines = 2 ! Comment lines including the first header description line integer, parameter :: N_comments = 6 ! Actual data lines plus intermediate description lines ! 'description \n 1 2 3 \n description \n 3 2 1' would count as 3 integer, parameter :: N_header_lines = 5 real(default), parameter, public :: N_ = three @ This is the basic type of a VM <>= type :: basic_vm_t private logical :: verbose type(string_t) :: bytecode_file integer :: bytecode_fh, out_fh integer :: N_instructions, N_levels integer :: N_table_lines integer, dimension(:, :), allocatable :: instructions integer, dimension(:), allocatable :: levels end type @ To allow for a lazy evaluation of amplitudes, we have to keep track whether a wave function has already been computed, to avoid multiple-computing that would arise when the bytecode has redundant fusions, which is necessary for flavor and color MC (and helicity MC when we use Weyl-van-der-Waerden-spinors) <>= type :: vm_scalar logical :: c complex(kind=default) :: v end type type :: vm_spinor logical :: c type(spinor) :: v end type type :: vm_conjspinor logical :: c type(conjspinor) :: v end type type :: vm_bispinor logical :: c type(bispinor) :: v end type type :: vm_vector logical :: c type(vector) :: v end type type :: vm_tensor_2 logical :: c type(tensor) :: v end type type :: vm_tensor_1 logical :: c type(tensor2odd) :: v end type type :: vm_vectorspinor logical :: c type(vectorspinor) :: v end type @ We need a memory pool for all the intermediate results <>= type, public, extends (basic_vm_t) :: vm_t private type(string_t) :: version type(string_t) :: model integer :: N_momenta, N_particles, N_prt_in, N_prt_out, N_amplitudes ! helicities = helicity combinations integer :: N_helicities, N_col_flows, N_col_indices, N_flavors, N_col_factors integer :: N_scalars, N_spinors, N_conjspinors, N_bispinors integer :: N_vectors, N_tensors_2, N_tensors_1, N_vectorspinors integer :: N_coupl_real, N_coupl_real2, N_coupl_cmplx, N_coupl_cmplx2 integer, dimension(:, :), allocatable :: table_flavor integer, dimension(:, :, :), allocatable :: table_color_flows integer, dimension(:, :), allocatable :: table_spin logical, dimension(:, :), allocatable :: table_ghost_flags type(OCF), dimension(:), allocatable :: table_color_factors logical, dimension(:, :), allocatable :: table_flv_col_is_allowed real(default), dimension(:), allocatable :: coupl_real real(default), dimension(:, :), allocatable :: coupl_real2 complex(default), dimension(:), allocatable :: coupl_cmplx complex(default), dimension(:, :), allocatable :: coupl_cmplx2 real(default), dimension(:), allocatable :: mass real(default), dimension(:), allocatable :: width type(momentum), dimension(:), allocatable :: momenta complex(default), dimension(:), allocatable :: amplitudes complex(default), dimension(:, :, :), allocatable :: table_amplitudes class(flavor_t), dimension(:), allocatable :: flavor class(color_t), dimension(:), allocatable :: color ! gfortran 4.7 !class(helicity_t), dimension(:), pointer :: helicity => null() integer, dimension(:), allocatable :: helicity type(vm_scalar), dimension(:), allocatable :: scalars type(vm_spinor), dimension(:), allocatable :: spinors type(vm_conjspinor), dimension(:), allocatable :: conjspinors type(vm_bispinor), dimension(:), allocatable :: bispinors type(vm_vector), dimension(:), allocatable :: vectors type(vm_tensor_2), dimension(:), allocatable :: tensors_2 type(vm_tensor_1), dimension(:), allocatable :: tensors_1 type(vm_vectorspinor), dimension(:), allocatable :: vectorspinors logical, dimension(:), allocatable :: hel_is_allowed real(default), dimension(:), allocatable :: hel_max_abs real(default) :: hel_sum_abs = 0, hel_threshold = 1E10 integer :: hel_count = 0, hel_cutoff = 100 integer, dimension(:), allocatable :: hel_map integer :: hel_finite logical :: cms logical :: openmp contains <> end type @ <>= subroutine alloc_arrays (vm) type(vm_t), intent(inout) :: vm integer :: i allocate (vm%table_flavor(vm%N_particles, vm%N_flavors)) allocate (vm%table_color_flows(vm%N_col_indices, vm%N_particles, & vm%N_col_flows)) allocate (vm%table_spin(vm%N_particles, vm%N_helicities)) allocate (vm%table_ghost_flags(vm%N_particles, vm%N_col_flows)) allocate (vm%table_color_factors(vm%N_col_factors)) allocate (vm%table_flv_col_is_allowed(vm%N_flavors, vm%N_col_flows)) allocate (vm%momenta(vm%N_momenta)) allocate (vm%amplitudes(vm%N_amplitudes)) allocate (vm%table_amplitudes(vm%N_flavors, vm%N_col_flows, & vm%N_helicities)) vm%table_amplitudes = zero allocate (vm%scalars(vm%N_scalars)) allocate (vm%spinors(vm%N_spinors)) allocate (vm%conjspinors(vm%N_conjspinors)) allocate (vm%bispinors(vm%N_bispinors)) allocate (vm%vectors(vm%N_vectors)) allocate (vm%tensors_2(vm%N_tensors_2)) allocate (vm%tensors_1(vm%N_tensors_1)) allocate (vm%vectorspinors(vm%N_vectorspinors)) allocate (vm%hel_is_allowed(vm%N_helicities)) vm%hel_is_allowed = .True. allocate (vm%hel_max_abs(vm%N_helicities)) vm%hel_max_abs = 0 allocate (vm%hel_map(vm%N_helicities)) vm%hel_map = (/(i, i = 1, vm%N_helicities)/) vm%hel_finite = vm%N_helicities end subroutine alloc_arrays @ \subsection{Controlling the VM} These type-bound procedures steer the VM <>= procedure :: init => vm_init procedure :: write => vm_write procedure :: reset => vm_reset procedure :: run => vm_run procedure :: final => vm_final @ The [[init]] completely sets the environment for the OVM. Parameters can be changed with [[reset]] without reloading the bytecode. <>= subroutine vm_init (vm, bytecode_file, version, model, & coupl_real, coupl_real2, coupl_cmplx, coupl_cmplx2, & mass, width, verbose, out_fh, openmp) class(vm_t), intent(out) :: vm type(string_t), intent(in) :: bytecode_file type(string_t), intent(in) :: version type(string_t), intent(in) :: model real(default), dimension(:), optional, intent(in) :: coupl_real real(default), dimension(:, :), optional, intent(in) :: coupl_real2 complex(default), dimension(:), optional, intent(in) :: coupl_cmplx complex(default), dimension(:, :), optional, intent(in) :: coupl_cmplx2 real(default), dimension(:), optional, intent(in) :: mass real(default), dimension(:), optional, intent(in) :: width logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh logical, optional, intent(in) :: openmp vm%bytecode_file = bytecode_file vm%version = version vm%model = model if (present (coupl_real)) then allocate (vm%coupl_real (size (coupl_real)), source=coupl_real) end if if (present (coupl_real2)) then allocate (vm%coupl_real2 (2, size (coupl_real2, 2)), source=coupl_real2) end if if (present (coupl_cmplx)) then allocate (vm%coupl_cmplx (size (coupl_cmplx)), source=coupl_cmplx) end if if (present (coupl_cmplx2)) then allocate (vm%coupl_cmplx2 (2, size (coupl_cmplx2, 2)), & source=coupl_cmplx2) end if if (present (mass)) then allocate (vm%mass(size(mass)), source=mass) end if if (present (width)) then allocate (vm%width(size (width)), source=width) end if if (present (openmp)) then vm%openmp = openmp else vm%openmp = .false. end if vm%cms = .false. call basic_init (vm, verbose, out_fh) end subroutine vm_init @ <>= subroutine vm_reset (vm, & coupl_real, coupl_real2, coupl_cmplx, coupl_cmplx2, & mass, width, verbose, out_fh) class(vm_t), intent(inout) :: vm real(default), dimension(:), optional, intent(in) :: coupl_real real(default), dimension(:, :), optional, intent(in) :: coupl_real2 complex(default), dimension(:), optional, intent(in) :: coupl_cmplx complex(default), dimension(:, :), optional, intent(in) :: coupl_cmplx2 real(default), dimension(:), optional, intent(in) :: mass real(default), dimension(:), optional, intent(in) :: width logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh if (present (coupl_real)) then vm%coupl_real = coupl_real end if if (present (coupl_real2)) then vm%coupl_real2 = coupl_real2 end if if (present (coupl_cmplx)) then vm%coupl_cmplx = coupl_cmplx end if if (present (coupl_cmplx2)) then vm%coupl_cmplx2 = coupl_cmplx2 end if if (present (mass)) then vm%mass = mass end if if (present (width)) then vm%width = width end if if (present (verbose)) then vm%verbose = verbose end if if (present (out_fh)) then vm%out_fh = out_fh end if end subroutine vm_reset @ Mainly for debugging <>= subroutine vm_write (vm) class(vm_t), intent(in) :: vm integer :: i, j, k call basic_write (vm) write(vm%out_fh, *) 'table_flavor = ', vm%table_flavor write(vm%out_fh, *) 'table_color_flows = ', vm%table_color_flows write(vm%out_fh, *) 'table_spin = ', vm%table_spin write(vm%out_fh, *) 'table_ghost_flags = ', vm%table_ghost_flags write(vm%out_fh, *) 'table_color_factors = ' do i = 1, size(vm%table_color_factors) write(vm%out_fh, *) vm%table_color_factors(i)%i1, & vm%table_color_factors(i)%i2, & vm%table_color_factors(i)%factor end do write(vm%out_fh, *) 'table_flv_col_is_allowed = ', & vm%table_flv_col_is_allowed do i = 1, vm%N_flavors do j = 1, vm%N_col_flows do k = 1, vm%N_helicities write(vm%out_fh, *) 'table_amplitudes(f,c,h), f, c, h = ', vm%table_amplitudes(i,j,k), i, j, k end do end do end do if (allocated(vm%coupl_real)) then write(vm%out_fh, *) 'coupl_real = ', vm%coupl_real end if if (allocated(vm%coupl_real2)) then write(vm%out_fh, *) 'coupl_real2 = ', vm%coupl_real2 end if if (allocated(vm%coupl_cmplx)) then write(vm%out_fh, *) 'coupl_cmplx = ', vm%coupl_cmplx end if if (allocated(vm%coupl_cmplx2)) then write(vm%out_fh, *) 'coupl_cmplx2 = ', vm%coupl_cmplx2 end if write(vm%out_fh, *) 'mass = ', vm%mass write(vm%out_fh, *) 'width = ', vm%width write(vm%out_fh, *) 'momenta = ', vm%momenta ! gfortran 4.7 !do i = 1, size(vm%flavor) !call vm%flavor(i)%write (vm%out_fh) !end do !do i = 1, size(vm%color) !call vm%color(i)%write (vm%out_fh) !end do !do i = 1, size(vm%helicity) !call vm%helicity(i)%write (vm%out_fh) !end do write(vm%out_fh, *) 'helicity = ', vm%helicity write(vm%out_fh, *) 'amplitudes = ', vm%amplitudes write(vm%out_fh, *) 'scalars = ', vm%scalars write(vm%out_fh, *) 'spinors = ', vm%spinors write(vm%out_fh, *) 'conjspinors = ', vm%conjspinors write(vm%out_fh, *) 'bispinors = ', vm%bispinors write(vm%out_fh, *) 'vectors = ', vm%vectors write(vm%out_fh, *) 'tensors_2 = ', vm%tensors_2 write(vm%out_fh, *) 'tensors_1 = ', vm%tensors_1 !!! !!! !!! Regression with ifort 16.0.0 !!! write(vm%out_fh, *) 'vectorspinors = ', vm%vectorspinors write(vm%out_fh, *) 'N_momenta = ', vm%N_momenta write(vm%out_fh, *) 'N_particles = ', vm%N_particles write(vm%out_fh, *) 'N_prt_in = ', vm%N_prt_in write(vm%out_fh, *) 'N_prt_out = ', vm%N_prt_out write(vm%out_fh, *) 'N_amplitudes = ', vm%N_amplitudes write(vm%out_fh, *) 'N_helicities = ', vm%N_helicities write(vm%out_fh, *) 'N_col_flows = ', vm%N_col_flows write(vm%out_fh, *) 'N_col_indices = ', vm%N_col_indices write(vm%out_fh, *) 'N_flavors = ', vm%N_flavors write(vm%out_fh, *) 'N_col_factors = ', vm%N_col_factors write(vm%out_fh, *) 'N_scalars = ', vm%N_scalars write(vm%out_fh, *) 'N_spinors = ', vm%N_spinors write(vm%out_fh, *) 'N_conjspinors = ', vm%N_conjspinors write(vm%out_fh, *) 'N_bispinors = ', vm%N_bispinors write(vm%out_fh, *) 'N_vectors = ', vm%N_vectors write(vm%out_fh, *) 'N_tensors_2 = ', vm%N_tensors_2 write(vm%out_fh, *) 'N_tensors_1 = ', vm%N_tensors_1 write(vm%out_fh, *) 'N_vectorspinors = ', vm%N_vectorspinors write(vm%out_fh, *) 'Overall size of VM: ' ! GNU extension ! write(vm%out_fh, *) 'sizeof(wavefunctions) = ', & ! sizeof(vm%scalars) + sizeof(vm%spinors) + sizeof(vm%conjspinors) + & ! sizeof(vm%bispinors) + sizeof(vm%vectors) + sizeof(vm%tensors_2) + & ! sizeof(vm%tensors_1) + sizeof(vm%vectorspinors) ! write(vm%out_fh, *) 'sizeof(mometa) = ', sizeof(vm%momenta) ! write(vm%out_fh, *) 'sizeof(amplitudes) = ', sizeof(vm%amplitudes) ! write(vm%out_fh, *) 'sizeof(tables) = ', & ! sizeof(vm%table_amplitudes) + sizeof(vm%table_spin) + & ! sizeof(vm%table_flavor) + sizeof(vm%table_flv_col_is_allowed) + & ! sizeof(vm%table_color_flows) + sizeof(vm%table_color_factors) + & ! sizeof(vm%table_ghost_flags) end subroutine vm_write @ Most of this is redundant (Fortran will deallocate when we leave the scope) but when we change from [[allocatable]]s to [[pointer]]s, it is necessary to avoid leaks <>= subroutine vm_final (vm) class(vm_t), intent(inout) :: vm deallocate (vm%table_flavor) deallocate (vm%table_color_flows) deallocate (vm%table_spin) deallocate (vm%table_ghost_flags) deallocate (vm%table_color_factors) deallocate (vm%table_flv_col_is_allowed) if (allocated (vm%coupl_real)) then deallocate (vm%coupl_real) end if if (allocated (vm%coupl_real2)) then deallocate (vm%coupl_real2) end if if (allocated (vm%coupl_cmplx)) then deallocate (vm%coupl_cmplx) end if if (allocated (vm%coupl_cmplx2)) then deallocate (vm%coupl_cmplx2) end if if (allocated (vm%mass)) then deallocate (vm%mass) end if if (allocated (vm%width)) then deallocate (vm%width) end if deallocate (vm%momenta) deallocate (vm%flavor) deallocate (vm%color) deallocate (vm%helicity) deallocate (vm%amplitudes) deallocate (vm%table_amplitudes) deallocate (vm%scalars) deallocate (vm%spinors) deallocate (vm%conjspinors) deallocate (vm%bispinors) deallocate (vm%vectors) deallocate (vm%tensors_2) deallocate (vm%tensors_1) deallocate (vm%vectorspinors) end subroutine vm_final @ Handing over the polymorph object helicity didn't work out as planned. A work-around is the use of [[pointer]]s. [[flavor]] and [[color]] are not yet used but would have to be changed to [[pointer]]s as well. At least this potentially avoids copying. Actually, neither the allocatable nor the pointer version works in [[gfortran 4.7]] due to the broken [[select type]]. Back to Stone Age, i.e. integers. <>= subroutine vm_run (vm, mom, flavor, color, helicity) class(vm_t), intent(inout) :: vm real(default), dimension(0:3, *), intent(in) :: mom class(flavor_t), dimension(:), optional, intent(in) :: flavor class(color_t), dimension(:), optional, intent(in) :: color ! gfortran 4.7 !class(helicity_t), dimension(:), optional, target, intent(in) :: helicity integer, dimension(:), optional, intent(in) :: helicity integer :: i, h, hi do i = 1, vm%N_particles if (i <= vm%N_prt_in) then vm%momenta(i) = - mom(:, i) ! incoming, crossing symmetry else vm%momenta(i) = mom(:, i) ! outgoing end if end do if (present (flavor)) then allocate(vm%flavor(size(flavor)), source=flavor) else if (.not. (allocated (vm%flavor))) then allocate(flv_discrete::vm%flavor(vm%N_particles)) end if end if if (present (color)) then allocate(vm%color(size(color)), source=color) else if (.not. (allocated (vm%color))) then allocate(col_discrete::vm%color(vm%N_col_flows)) end if end if ! gfortran 4.7 if (present (helicity)) then !vm%helicity => helicity vm%helicity = helicity call vm_run_one_helicity (vm, 1) else !if (.not. (associated (vm%helicity))) then !allocate(hel_discrete::vm%helicity(vm%N_particles)) !end if if (.not. (allocated (vm%helicity))) then allocate(vm%helicity(vm%N_particles)) end if if (vm%hel_finite == 0) return do hi = 1, vm%hel_finite h = vm%hel_map(hi) !> vm%helicity = vm%table_spin(:,h) call vm_run_one_helicity (vm, h) end do end if end subroutine vm_run @ This only removes the [[ICE]] but still leads to a segmentation fault in [[gfortran 4.7]]. I am running out of ideas how to make this compiler work with arrays of polymorph datatypes. <>= integer :: hj <>= do hj = 1, size(vm%helicity) select type (hel => vm%helicity(hj)) type is (hel_discrete) hel%i = vm%table_spin(hj,h) end select end do @ <>= select type (hel => vm%helicity) type is (hel_discrete) hel(:)%i = vm%table_spin(:,h) end select @ <>= subroutine vm_run_one_helicity (vm, h) class(vm_t), intent(inout) :: vm integer, intent(in) :: h integer :: f, c, i vm%amplitudes = zero if (vm%N_levels > 0) then call null_all_wfs (vm) call iterate_instructions (vm) end if i = 1 do c = 1, vm%N_col_flows do f = 1, vm%N_flavors if (vm%table_flv_col_is_allowed(f,c)) then vm%table_amplitudes(f,c,h) = vm%amplitudes(i) i = i + 1 end if end do end do end subroutine @ <>= subroutine null_all_wfs (vm) type(vm_t), intent(inout) :: vm integer :: i, j vm%scalars%c = .False. vm%scalars%v = zero vm%spinors%c = .False. vm%conjspinors%c = .False. vm%bispinors%c = .False. vm%vectorspinors%c = .False. do i = 1, 4 vm%spinors%v%a(i) = zero vm%conjspinors%v%a(i) = zero vm%bispinors%v%a(i) = zero do j = 1, 4 vm%vectorspinors%v%psi(i)%a(j) = zero end do end do vm%vectors%c = .False. vm%vectors%v%t = zero vm%tensors_1%c = .False. vm%tensors_2%c = .False. do i = 1, 3 vm%vectors%v%x(i) = zero vm%tensors_1%v%e(i) = zero vm%tensors_1%v%b(i) = zero do j = 1, 3 vm%tensors_2%v%t(i,j) = zero end do end do end subroutine @ \subsection{Reading the bytecode} <>= subroutine load_header (vm, IO) type(vm_t), intent(inout) :: vm integer, intent(inout) :: IO integer, dimension(len_instructions) :: line read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_momenta = line(1) vm%N_particles = line(2) vm%N_prt_in = line(3) vm%N_prt_out = line(4) vm%N_amplitudes = line(5) vm%N_helicities = line(6) vm%N_col_flows = line(7) if (vm%N_momenta == 0) then vm%N_col_indices = 2 else vm%N_col_indices = line(8) end if read(vm%bytecode_fh, fmt = *, iostat = IO) read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_flavors = line(1) vm%N_col_factors = line(2) vm%N_scalars = line(3) vm%N_spinors = line(4) vm%N_conjspinors = line(5) vm%N_bispinors = line(6) vm%N_vectors = line(7) vm%N_tensors_2 = line(8) read(vm%bytecode_fh, fmt = *, iostat = IO) read(vm%bytecode_fh, fmt = *, iostat = IO) line vm%N_tensors_1 = line(1) vm%N_vectorspinors = line(2) ! Add 1 for seperating label lines like 'Another table' vm%N_table_lines = vm%N_helicities + 1 + vm%N_flavors + 1 + vm%N_col_flows & + 1 + vm%N_col_flows + 1 + vm%N_col_factors + 1 + vm%N_col_flows end subroutine load_header @ <>= subroutine read_tables (vm, IO) type(vm_t), intent(inout) :: vm integer, intent(inout) :: IO integer :: i integer, dimension(2) :: tmpcf integer, dimension(3) :: tmpfactor integer, dimension(vm%N_flavors) :: tmpF integer, dimension(vm%N_particles) :: tmpP real(default) :: factor do i = 1, vm%N_helicities read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_spin(:, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_flavors read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_flavor(:, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) vm%table_color_flows(:, :, i) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) tmpP vm%table_ghost_flags(:, i) = int_to_log(tmpP) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_factors read(vm%bytecode_fh, fmt = '(2I9)', iostat = IO, advance='no') tmpcf factor = zero do read(vm%bytecode_fh, fmt = '(3I9)', iostat = IO, advance='no', EOR=10) tmpfactor factor = factor + color_factor(tmpfactor(1), tmpfactor(2), tmpfactor(3)) end do 10 vm%table_color_factors(i) = OCF(tmpcf(1), tmpcf(2), factor) end do read(vm%bytecode_fh, fmt = *, iostat = IO) do i = 1, vm%N_col_flows read(vm%bytecode_fh, fmt = *, iostat = IO) tmpF vm%table_flv_col_is_allowed(:, i) = int_to_log(tmpF) end do end subroutine read_tables @ This checking has proven useful more than once <>= subroutine extended_version_check (vm, IO) type(vm_t), intent(in) :: vm integer, intent(inout) :: IO character(256) :: buffer read(vm%bytecode_fh, fmt = "(A)", iostat = IO) buffer if (vm%version /= buffer) then print *, "Warning: Bytecode has been generated with an older O'Mega version." else if (vm%verbose) then write (vm%out_fh, fmt = *) "Bytecode version fits." end if end if end subroutine extended_version_check @ This chunk is copied verbatim from the [[basic_vm]] <>= subroutine basic_init (vm, verbose, out_fh) type(vm_t), intent(inout) :: vm logical, optional, intent(in) :: verbose integer, optional, intent(in) :: out_fh if (present (verbose)) then vm%verbose = verbose else vm%verbose = .true. end if if (present (out_fh)) then vm%out_fh = out_fh else vm%out_fh = stdout end if call set_stream (vm) call alloc_and_count (vm) if (vm%N_levels > 0) then call read_bytecode (vm) call sanity_check (vm) end if close (vm%bytecode_fh) end subroutine basic_init subroutine basic_write (vm) type(vm_t), intent(in) :: vm integer :: i write (vm%out_fh, *) '=====> VM ', char(vm%version), ' <=====' write (vm%out_fh, *) 'verbose = ', vm%verbose write (vm%out_fh, *) 'bytecode_file = ', char (vm%bytecode_file) write (vm%out_fh, *) 'N_instructions = ', vm%N_instructions write (vm%out_fh, *) 'N_levels = ', vm%N_levels write (vm%out_fh, *) 'instructions = ' do i = 1, vm%N_instructions write (vm%out_fh, *) vm%instructions(:, i) end do write (vm%out_fh, *) 'levels = ', vm%levels end subroutine basic_write subroutine alloc_and_count (vm) type(vm_t), intent(inout) :: vm integer, dimension(len_instructions) :: line character(256) :: buffer integer :: i, IO read(vm%bytecode_fh, fmt = "(A)", iostat = IO) buffer if (vm%model /= buffer) then print *, "Warning: Bytecode has been generated with an older O'Mega version." else if (vm%verbose) then write (vm%out_fh, fmt = *) "Using the model: " write (vm%out_fh, fmt = *) char(vm%model) end if end if call extended_version_check (vm, IO) if (vm%verbose) then write (vm%out_fh, fmt = *) "Trying to allocate." end if do i = 1, N_comments read(vm%bytecode_fh, fmt = *, iostat = IO) end do call load_header (vm, IO) call alloc_arrays (vm) if (vm%N_momenta /= 0) then do i = 1, vm%N_table_lines + 1 read(vm%bytecode_fh, fmt = *, iostat = IO) end do vm%N_instructions = 0 vm%N_levels = 0 do read(vm%bytecode_fh, fmt = *, end = 42) line if (line(1) /= 0) then vm%N_instructions = vm%N_instructions + 1 else vm%N_levels = vm%N_levels + 1 end if end do 42 rewind(vm%bytecode_fh, iostat = IO) allocate (vm%instructions(len_instructions, vm%N_instructions)) allocate (vm%levels(vm%N_levels)) if (IO /= 0) then print *, "Error: vm.alloc : Couldn't load bytecode!" stop 1 end if end if end subroutine alloc_and_count subroutine read_bytecode (vm) type(vm_t), intent(inout) :: vm integer, dimension(len_instructions) :: line integer :: i, j, IO ! Jump over version number, comments, header and first table description do i = 1, N_version_lines + N_comments + N_header_lines + 1 read (vm%bytecode_fh, fmt = *, iostat = IO) end do call read_tables (vm, IO) read (vm%bytecode_fh, fmt = *, iostat = IO) i = 0; j = 0 do read (vm%bytecode_fh, fmt = *, iostat = IO) line if (IO /= 0) exit if (line(1) == 0) then if (j <= vm%N_levels) then j = j + 1 vm%levels(j) = i ! last index of a level is saved else print *, 'Error: vm.read_bytecode: File has more levels than anticipated!' stop 1 end if else if (i <= vm%N_instructions) then i = i + 1 ! A valid instruction line vm%instructions(:, i) = line else print *, 'Error: vm.read_bytecode: File is larger than anticipated!' stop 1 end if end if end do end subroutine read_bytecode subroutine iterate_instructions (vm) type(vm_t), intent(inout) :: vm integer :: i, j if (vm%openmp) then !$omp parallel do j = 1, vm%N_levels - 1 !$omp do schedule (static) do i = vm%levels (j) + 1, vm%levels (j + 1) call decode (vm, i) end do !$omp end do end do !$omp end parallel else do j = 1, vm%N_levels - 1 do i = vm%levels (j) + 1, vm%levels (j + 1) call decode (vm, i) end do end do end if end subroutine iterate_instructions subroutine set_stream (vm) type(vm_t), intent(inout) :: vm integer :: IO call find_free_unit (vm%bytecode_fh, IO) open (vm%bytecode_fh, file = char (vm%bytecode_file), form = 'formatted', & access = 'sequential', status = 'old', position = 'rewind', iostat = IO, & action = 'read') if (IO /= 0) then print *, "Error: vm.set_stream: Bytecode file '", char(vm%bytecode_file), & "' not found!" stop 1 end if end subroutine set_stream subroutine sanity_check (vm) type(vm_t), intent(in) :: vm if (vm%levels(1) /= 0) then print *, "Error: vm.vm_init: levels(1) != 0" stop 1 end if if (vm%levels(vm%N_levels) /= vm%N_instructions) then print *, "Error: vm.vm_init: levels(N_levels) != N_instructions" stop 1 end if if (vm%verbose) then write(vm%out_fh, *) "vm passed sanity check. Starting calculation." end if end subroutine sanity_check @ \subsection{Main Decode Function} This is the heart of the OVM <>= ! pure & ! if no warnings subroutine decode (vm, instruction_index) type(vm_t), intent(inout) :: vm integer, intent(in) :: instruction_index integer, dimension(len_instructions) :: i, curr complex(default) :: braket integer :: tmp real(default) :: w i = vm%instructions (:, instruction_index) select case (i(1)) case ( : -1) ! Jump over subinstructions <<[[case]]s of [[decode]]>> case (0) print *, 'Error: Levelbreak put in decode! Line:', & instruction_index stop 1 case default print *, "Error: Decode has case not catched! Line: ", & instruction_index stop 1 end select end subroutine decode @ \subsubsection{Momenta} The most trivial instruction <>= integer, parameter :: ovm_ADD_MOMENTA = 1 @ <<[[case]]s of [[decode]]>>= case (ovm_ADD_MOMENTA) vm%momenta(i(4)) = vm%momenta(i(5)) + vm%momenta(i(6)) if (i(7) > 0) then vm%momenta(i(4)) = vm%momenta(i(4)) + vm%momenta(i(7)) end if @ \subsubsection{Loading External states} <>= integer, parameter :: ovm_LOAD_SCALAR = 10 integer, parameter :: ovm_LOAD_SPINOR_INC = 11 integer, parameter :: ovm_LOAD_SPINOR_OUT = 12 integer, parameter :: ovm_LOAD_CONJSPINOR_INC = 13 integer, parameter :: ovm_LOAD_CONJSPINOR_OUT = 14 integer, parameter :: ovm_LOAD_MAJORANA_INC = 15 integer, parameter :: ovm_LOAD_MAJORANA_OUT = 16 integer, parameter :: ovm_LOAD_VECTOR_INC = 17 integer, parameter :: ovm_LOAD_VECTOR_OUT = 18 integer, parameter :: ovm_LOAD_VECTORSPINOR_INC = 19 integer, parameter :: ovm_LOAD_VECTORSPINOR_OUT = 20 integer, parameter :: ovm_LOAD_TENSOR2_INC = 21 integer, parameter :: ovm_LOAD_TENSOR2_OUT = 22 integer, parameter :: ovm_LOAD_BRS_SCALAR = 30 integer, parameter :: ovm_LOAD_BRS_SPINOR_INC = 31 integer, parameter :: ovm_LOAD_BRS_SPINOR_OUT = 32 integer, parameter :: ovm_LOAD_BRS_CONJSPINOR_INC = 33 integer, parameter :: ovm_LOAD_BRS_CONJSPINOR_OUT = 34 integer, parameter :: ovm_LOAD_BRS_VECTOR_INC = 37 integer, parameter :: ovm_LOAD_BRS_VECTOR_OUT = 38 integer, parameter :: ovm_LOAD_MAJORANA_GHOST_INC = 23 integer, parameter :: ovm_LOAD_MAJORANA_GHOST_OUT = 24 integer, parameter :: ovm_LOAD_BRS_MAJORANA_INC = 35 integer, parameter :: ovm_LOAD_BRS_MAJORANA_OUT = 36 @ <<[[case]]s of [[decode]]>>= case (ovm_LOAD_SCALAR) vm%scalars(i(4))%v = one vm%scalars(i(4))%c = .True. case (ovm_LOAD_SPINOR_INC) call load_spinor(vm%spinors(i(4)), - <

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

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

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

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

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

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

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

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

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

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

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

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

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

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

> * <

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

>, <>, & w, vm%tensors_2(i(4))%v) vm%tensors_2(i(4))%c = .True. case (ovm_PROPAGATE_NONE) ! This will not work with color MC. Appropriate type%c has to be set to ! .True. @ \subsection{Helper functions} Factoring out these parts helps a lot to keep sane but might hurt the performance of the VM noticably. In that case, we have to copy \& paste to avoid the additional function calls. Note that with preprocessor macros, we could maintain this factorized form (and factor out even more since types don't have to match), in case we would decide to allow this <>= !select type (h) !type is (hel_trigonometric) !wf%v = (cos (h%theta) * load_wf (m, p, + 1) + & !sin (h%theta) * load_wf (m, p, - 1)) * sqrt2 !type is (hel_exponential) !wf%v = exp (+ imago * h%phi) * load_wf (m, p, + 1) + & !exp (- imago * h%phi) * load_wf (m, p, - 1) !type is (hel_spherical) !wf%v = (exp (+ imago * h%phi) * cos (h%theta) * load_wf (m, p, + 1) + & !exp (- imago * h%phi) * sin (h%theta) * load_wf (m, p, - 1)) * & !sqrt2 !type is(hel_discrete) !wf%v = load_wf (m, p, h%i) !end select wf%v = load_wf (m, p, h) wf%c = .True. @ Caveat: Helicity MC not tested with Majorana particles but should be fine <>= if ((mode%col_MC .eq. FULL_SUM) .or. (mode%col_MC .eq. DIAG_COL)) then go = .not. vm%spinors%c(i(4)) else go = (i(8) == o%cols(1)) .or. (i(8) == o%cols(2)) end if if (go) .. <>= subroutine load_bispinor(wf, p, m, h, opcode) type(vm_bispinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(bi_u), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_MAJORANA_INC) load_wf => bi_u case (ovm_LOAD_MAJORANA_OUT) load_wf => bi_v case default load_wf => null() end select <> end subroutine load_bispinor subroutine load_spinor(wf, p, m, h, opcode) type(vm_spinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(u), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_SPINOR_INC) load_wf => u case (ovm_LOAD_SPINOR_OUT) load_wf => v case default load_wf => null() end select <> end subroutine load_spinor subroutine load_conjspinor(wf, p, m, h, opcode) type(vm_conjspinor), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(ubar), pointer :: load_wf <> select case (opcode) case (ovm_LOAD_CONJSPINOR_INC) load_wf => vbar case (ovm_LOAD_CONJSPINOR_OUT) load_wf => ubar case default load_wf => null() end select <> end subroutine load_conjspinor subroutine load_vector(wf, p, m, h, opcode) type(vm_vector), intent(out) :: wf type(momentum), intent(in) :: p real(default), intent(in) :: m !class(helicity_t), intent(in) :: h integer, intent(in) :: h integer, intent(in) :: opcode procedure(eps), pointer :: load_wf <> load_wf => eps <> if (opcode == ovm_LOAD_VECTOR_OUT) then wf%v = conjg(wf%v) end if end subroutine load_vector @ <>= function ferm_vf(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_vf), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_VF) load_wf => f_vf case (ovm_FUSE_F_VLF) load_wf => f_vlf case (ovm_FUSE_F_VRF) load_wf => f_vrf case default load_wf => null() end select x = load_wf(<>, <>, vm%spinors(curr(6))%v) end function ferm_vf function ferm_vf2(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_vaf), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_VAF) load_wf => f_vaf case default load_wf => null() end select x = f_vaf(<>, <>, <>, vm%spinors(curr(6))%v) end function ferm_vf2 function ferm_sf(vm, curr) result (x) type(spinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_F_SF) x = f_sf(<>, <>, vm%spinors(curr(6))%v) case (ovm_FUSE_F_SPF) x = f_spf(<>, <>, <>, vm%spinors(curr(6))%v) case default end select end function ferm_sf function ferm_fv(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fv), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FV) load_wf => f_fv case (ovm_FUSE_F_FVL) load_wf => f_fvl case (ovm_FUSE_F_FVR) load_wf => f_fvr case default load_wf => null() end select x = load_wf(<>, vm%conjspinors(curr(5))%v, vm%vectors(curr(6))%v) end function ferm_fv function ferm_fv2(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fva), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FVA) load_wf => f_fva case default load_wf => null() end select x = f_fva(<>, <>, & vm%conjspinors(curr(5))%v, vm%vectors(curr(6))%v) end function ferm_fv2 function ferm_fs(vm, curr) result (x) type(conjspinor) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(f_fs), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_F_FS) x = f_fs(<>, vm%conjspinors(curr(5))%v, vm%scalars(curr(6))%v) case (ovm_FUSE_F_FSP) x = f_fsp(<>, <>, & vm%conjspinors(curr(5))%v, vm%scalars(curr(6))%v) case default x%a = zero end select end function ferm_fs function vec_ff(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(v_ff), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_V_FF) load_wf => v_ff case (ovm_FUSE_VL_FF) load_wf => vl_ff case (ovm_FUSE_VR_FF) load_wf => vr_ff case default load_wf => null() end select x = load_wf(<>, vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) end function vec_ff function vec_ff2(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr procedure(va_ff), pointer :: load_wf select case (curr(1)) case (ovm_FUSE_VA_FF) load_wf => va_ff case default load_wf => null() end select x = load_wf(<>, <>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) end function vec_ff2 function scal_ff(vm, curr) result (x) complex(default) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_S_FF) x = s_ff(<>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) case (ovm_FUSE_SP_FF) x = sp_ff(<>, <>, & vm%conjspinors(curr(5))%v, vm%spinors(curr(6))%v) case default x = zero end select end function scal_ff function scal_g2(vm, curr) result (x) complex(default) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_S_G2) x = <> * ((<> * <>) * & (<> * <>) - & (<> * <>) * & (<> * <>)) case (ovm_FUSE_S_G2_SKEW) x = - phi_vv(<>, <>, <>, & <>, <>) case default x = zero end select end function scal_g2 pure function gauge_sg(vm, curr) result (x) type(vector) :: x class(vm_t), intent(in) :: vm integer, dimension(:), intent(in) :: curr select case (curr(1)) case (ovm_FUSE_G_SG) x = <> * <> * ( & -((<> + <>) * & <>) * <> - & (-(<> + <>) * & <>) * <>) case (ovm_FUSE_G_GS) x = <> * <> * ( & -((<> + <>) * & <>) * <> - & (-(<> + <>) * & <>) * <>) case (ovm_FUSE_G_SG_SKEW) x = - v_phiv(<>, <>, <>, & <>, <>) case (ovm_FUSE_G_GS_SKEW) x = - v_phiv(<>, <>, <>, & <>, <>) case default x = [zero, zero, zero, zero] end select end function gauge_sg @ Some really tiny ones that hopefully get inlined by the compiler <>= elemental function sgn_coupl_cmplx(vm, j) result (s) class(vm_t), intent(in) :: vm integer, intent(in) :: j complex(default) :: s s = isign(1, j) * vm%coupl_cmplx(abs(j)) end function sgn_coupl_cmplx elemental function sgn_coupl_cmplx2(vm, j, i) result (s) class(vm_t), intent(in) :: vm integer, intent(in) :: j, i complex(default) :: s if (i == 1) then s = isign(1, j) * vm%coupl_cmplx2(i, abs(j)) else s = isign(1, j) * vm%coupl_cmplx2(i, abs(j)) end if end function sgn_coupl_cmplx2 elemental function int_to_log(i) result(yorn) integer, intent(in) :: i logical :: yorn if (i /= 0) then yorn = .true. else yorn = .false. end if end function elemental function color_factor(num, den, pwr) result (cf) integer, intent(in) :: num, den, pwr real(kind=default) :: cf if (pwr == 0) then cf = (one * num) / den else cf = (one * num) / den * (N_**pwr) end if end function color_factor @ \subsection{O'Mega Interface} We want to keep the interface close to the native Fortran code but of course one has to hand over the [[vm]] additionally <>= procedure :: number_particles_in => vm_number_particles_in procedure :: number_particles_out => vm_number_particles_out procedure :: number_color_indices => vm_number_color_indices procedure :: reset_helicity_selection => vm_reset_helicity_selection procedure :: new_event => vm_new_event procedure :: color_sum => vm_color_sum procedure :: spin_states => vm_spin_states procedure :: number_spin_states => vm_number_spin_states procedure :: number_color_flows => vm_number_color_flows procedure :: flavor_states => vm_flavor_states procedure :: number_flavor_states => vm_number_flavor_states procedure :: color_flows => vm_color_flows procedure :: color_factors => vm_color_factors procedure :: number_color_factors => vm_number_color_factors procedure :: is_allowed => vm_is_allowed procedure :: get_amplitude => vm_get_amplitude @ <>= elemental function vm_number_particles_in (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_prt_in end function vm_number_particles_in elemental function vm_number_particles_out (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_prt_out end function vm_number_particles_out elemental function vm_number_spin_states (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_helicities end function vm_number_spin_states pure subroutine vm_spin_states (vm, a) class(vm_t), intent(in) :: vm integer, dimension(:,:), intent(out) :: a a = vm%table_spin end subroutine vm_spin_states elemental function vm_number_flavor_states (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_flavors end function vm_number_flavor_states pure subroutine vm_flavor_states (vm, a) class(vm_t), intent(in) :: vm integer, dimension(:,:), intent(out) :: a a = vm%table_flavor end subroutine vm_flavor_states elemental function vm_number_color_indices (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_indices end function vm_number_color_indices elemental function vm_number_color_flows (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_flows end function vm_number_color_flows pure subroutine vm_color_flows (vm, a, g) class(vm_t), intent(in) :: vm integer, dimension(:,:,:), intent(out) :: a logical, dimension(:,:), intent(out) :: g a = vm%table_color_flows g = vm%table_ghost_flags end subroutine vm_color_flows elemental function vm_number_color_factors (vm) result (n) class(vm_t), intent(in) :: vm integer :: n n = vm%N_col_factors end function vm_number_color_factors pure subroutine vm_color_factors (vm, cf) class(vm_t), intent(in) :: vm type(OCF), dimension(:), intent(out) :: cf cf = vm%table_color_factors end subroutine vm_color_factors ! pure & ! pure unless OpenMp function vm_color_sum (vm, flv, hel) result (amp2) class(vm_t), intent(in) :: vm integer, intent(in) :: flv, hel real(default) :: amp2 amp2 = ovm_color_sum (flv, hel, vm%table_amplitudes, vm%table_color_factors) end function vm_color_sum subroutine vm_new_event (vm, p) class(vm_t), intent(inout) :: vm real(default), dimension(0:3,*), intent(in) :: p logical :: mask_dirty integer :: hel call vm%run (p) if ((vm%hel_threshold .gt. 0) .and. (vm%hel_count .le. vm%hel_cutoff)) then call omega_update_helicity_selection (vm%hel_count, vm%table_amplitudes, & vm%hel_max_abs, vm%hel_sum_abs, vm%hel_is_allowed, vm%hel_threshold, & vm%hel_cutoff, mask_dirty) if (mask_dirty) then vm%hel_finite = 0 do hel = 1, vm%N_helicities if (vm%hel_is_allowed(hel)) then vm%hel_finite = vm%hel_finite + 1 vm%hel_map(vm%hel_finite) = hel end if end do end if end if end subroutine vm_new_event pure subroutine vm_reset_helicity_selection (vm, threshold, cutoff) class(vm_t), intent(inout) :: vm real(kind=default), intent(in) :: threshold integer, intent(in) :: cutoff integer :: i vm%hel_is_allowed = .True. vm%hel_max_abs = 0 vm%hel_sum_abs = 0 vm%hel_count = 0 vm%hel_threshold = threshold vm%hel_cutoff = cutoff vm%hel_map = (/(i, i = 1, vm%N_helicities)/) vm%hel_finite = vm%N_helicities end subroutine vm_reset_helicity_selection pure function vm_is_allowed (vm, flv, hel, col) result (yorn) class(vm_t), intent(in) :: vm logical :: yorn integer, intent(in) :: flv, hel, col yorn = vm%table_flv_col_is_allowed(flv,col) .and. vm%hel_is_allowed(hel) end function vm_is_allowed pure function vm_get_amplitude (vm, flv, hel, col) result (amp_result) class(vm_t), intent(in) :: vm complex(kind=default) :: amp_result integer, intent(in) :: flv, hel, col amp_result = vm%table_amplitudes(flv, col, hel) end function vm_get_amplitude @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <>= ! omegalib.nw -- ! ! Copyright (C) 1999-2024 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter -! with contributions from -! Fabian Bach -! Bijan Chokoufe Nejad +! with contributions from +! Fabian Bach +! Bijan Chokoufe Nejad ! Christian Speckner ! ! WHIZARD is free software; you can redistribute it and/or modify it ! under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2, or (at your option) ! any later version. ! ! WHIZARD is distributed in the hope that it will be useful, but ! WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/omega/src/algebra.mli =================================================================== --- trunk/omega/src/algebra.mli (revision 8919) +++ trunk/omega/src/algebra.mli (revision 8920) @@ -1,347 +1,352 @@ (* algebra.mli -- Copyright (C) 1999-2024 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 suite : OUnit.test end (* \thocwmodulesection{Coefficients} *) (* For our algebra, we need coefficient rings with addition, subtraction, multiplication and the corresponding neutral elements. *) module type CRing = sig type t (* [add null x = x = add x null] *) val null : t val is_null : t -> bool val add : t -> t -> t (* [neg x = sub null x] and [sub x y = add x (neg y)] *) val neg : t -> t val sub : t -> t -> t (* [mul unit x = x = mul x unit] *) val unit : t val is_unit : t -> bool val mul : t -> t -> t (* Equality: *) val equal : t -> t -> bool end (* Rational numbers provide a particularly important example and they come with a partial inverse: *) module type Rational = sig include CRing val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int (* Convenience: $n \mapsto n/1$ and $n \mapsto 1/n$ *) val int : int -> t val fraction : int -> t (* Order *) val compare : t -> t -> int (* Tracing, debugging, toplevel and unit testing *) val to_string : t -> string val pp : Format.formatter -> t -> unit module Test : Test end (* \thocwmodulesection{Naive Rational Arithmetic} *) (* \begin{dubious} This \emph{is} dangerous and will overflow even for simple applications. The production code will have to be linked to a library for large integer arithmetic. \end{dubious} *) module Small_Rational : Rational module Q : Rational (* \thocwmodulesection{Rational Complex Numbers} *) module type QComplex = sig include CRing type q val make : q -> q -> t val re : t -> q val im : t -> q val conj : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val is_real : t -> bool (* Convenience: real rationals and integers, *) val rational : q -> t val int : int -> t (* $n \to 1/n$ *) val fraction : int -> t (* $n \to n\ii$ *) val imag : int -> t (* Order *) val compare : t -> t -> int (* Tracing, debugging, toplevel and unit testing *) val to_string : t -> string val pp : Format.formatter -> t -> unit module Test : Test end module QComplex : functor (Q' : Rational) -> QComplex with type q = Q'.t module QC : QComplex with type q = Q.t (* \thocwmodulesection{Laurent Polynomials} *) (* Polynomials, including negative powers, in one variable. In our applications, the variable~$x$ will often be~$N_C$, the number of colors \begin{equation} \sum_n c_n N_C^n \end{equation} *) module type Laurent = sig include CRing (* The type of coefficients. In the implementation below, it is [QComplex.t]: complex numbers with rational real and imaginary parts. *) type c (* [atom c n] constructs a term $c x^n$, where $x$ denotes the variable. *) val atom : c -> int -> t (* Shortcut: [const c = atom c 0] *) val const : c -> t (* Elementary arithmetic *) val scale : c -> t -> t val sum : t list -> t val product : t list -> t val pow : t -> int -> t (* [log]$(cN_C^n)$ returns [Some]$(c,n)$. For other terms, [log] returns [None]. *) val log : t -> (c * int) option (* return the corresponding list of coefficients and descending powers *) val to_list : t -> (c * int) list (* [eval c p] evaluates the polynomial [p] by substituting the constant [c] for the variable. *) val eval : c -> t -> c (* A total ordering. Does not correspond to any mathematical order. *) val compare : t -> t -> int (* Provide some convenience functions for constructing coefficients from integers and rationals. *) (* Rationals coefficients (without imaginary part!) $\left\{(q_i,n_i)\right\}_n \mapsto \sum_i q_i x^{n_i}$ *) val rationals : (Q.t * int) list -> t (* Integer coefficients $\left\{(k_i,n_i)\right\}_n \mapsto \sum_i k_i x^{n_i}$ *) val ints : (int * int) list -> t (* For convenience, some special cases. Starting with injections *) val rational : Q.t -> t val int : int -> t (* $k\mapsto 1/k = k^{-1}$ *) val fraction : int -> t (* $k\mapsto k \ii$ *) val imag : int -> t (* $k\mapsto k x$ *) val nc : int -> t (* $k\mapsto k / x = k x^{-1}$ *) val over_nc : int -> t + (* Extract a prefactor such that the remaining polynomial has no fractional + coefficients. The sign is chosen so that the coefficient of the leading + power is positive. *) + val prefactor : t list -> c + (* Tracing, debugging, toplevel and unit testing *) val to_string : string -> t -> string val pp : Format.formatter -> t -> unit module Test : Test end (* \begin{dubious} Could (should?) be functorialized over [QComplex]. We had to wait until we upgraded our O'Caml requirements to 4.02, but that has been done. \end{dubious} *) module Laurent : Laurent with type c = QC.t (* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *) (* The tensor algebra will be spanned by an abelian monoid: *) module type Term = sig type 'a t val unit : unit -> 'a t val is_unit : 'a t -> bool val atom : 'a -> 'a t val power : 'a t -> int -> 'a t val mul : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string (* The derivative of a term is \emph{not} a term, but a sum of terms instead: \begin{equation} D (f_1^{p_1}f_2^{p_2}\cdots f_n^{p_n}) = \sum_i (Df_i) p_i f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n} \end{equation} The function returns the sum as a list of triples $(Df_i,p_i, f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n})$. Summing the terms is left to the calling module and the $Df_i$ are \emph{not} guaranteed to be different. NB: The function implementating the inner derivative, is supposed to return~[Some]~$Df_i$ and [None], iff~$Df_i$ vanishes. *) val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list (* convenience function *) val product : 'a t list -> 'a t val atoms : 'a t -> 'a list end module type Ring = sig module C : Rational type 'a t val null : unit -> 'a t val unit : unit -> 'a t val is_null : 'a t -> bool val is_unit : 'a t -> bool val atom : 'a -> 'a t val scale : C.t -> 'a t -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val neg : 'a t -> 'a t (* Again \begin{equation} D (f_1^{p_1}f_2^{p_2}\cdots f_n^{p_n}) = \sum_i (Df_i) p_i f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n} \end{equation} but, iff~$Df_i$ can be identified with a~$f'$, we know how to perform the sum. *) val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *) val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *) (* Below, we will need partial derivatives that lead out of the ring: [derive_outer derive_atom term] returns a list of partial derivatives ['b] with non-zero coefficients ['a t]: *) val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list (* convenience functions *) val sum : 'a t list -> 'a t val product : 'a t list -> 'a t (* The list of all generators appearing in an expression: *) val atoms : 'a t -> 'a list val to_string : ('a -> string) -> 'a t -> string end module type Linear = sig module C : Ring type ('a, 'c) t val null : unit -> ('a, 'c) t val atom : 'a -> ('a, 'c) t val singleton : 'c C.t -> 'a -> ('a, 'c) t val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t (* A partial derivative w.\,r.\,t.~a vector maps from a coefficient ring to the dual vector space. *) val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t (* A linear combination of vectors \begin{equation} \text{[linear]} \lbrack (v_1, c_1); (v_2, c_2); \ldots; (v_n, c_n)\rbrack = \sum_{i=1}^{n} c_i\cdot v_i \end{equation} *) val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t (* Some convenience functions *) val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t val sum : ('a, 'c) t list -> ('a, 'c) t (* The list of all generators and the list of all generators of coefficients appearing in an expression: *) val atoms : ('a, 'c) t -> 'a list * 'c list val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string end module Term : Term module Make_Ring (C : Rational) (T : Term) : Ring module Make_Linear (C : Ring) : Linear with module C = C Index: trunk/omega/src/partial.ml =================================================================== --- trunk/omega/src/partial.ml (revision 8919) +++ trunk/omega/src/partial.ml (revision 8920) @@ -1,167 +1,164 @@ (* partial.ml -- Copyright (C) 1999-2024 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 domain type 'a t val of_list : (domain * 'a) list -> 'a t val of_lists : domain list -> 'a list -> 'a t exception Undefined of domain val apply : 'a t -> domain -> 'a val apply_opt : 'a t -> domain -> 'a option val apply_with_fallback : (domain -> 'a) -> 'a t -> domain -> 'a val auto : domain t -> domain -> domain end module Make (D : Map.OrderedType) : T with type domain = D.t = struct module M = Map.Make (D) type domain = D.t type 'a t = 'a M.t let of_list l = List.fold_left (fun m (d, v) -> M.add d v m) M.empty l let of_lists domain values = of_list (try List.map2 (fun d v -> (d, v)) domain values with | Invalid_argument _ (* ["List.map2"] *) -> invalid_arg "Partial.of_lists: length mismatch") let auto partial d = try M.find d partial with | Not_found -> d exception Undefined of domain let apply partial d = try M.find d partial with | Not_found -> raise (Undefined d) let apply_opt partial d = try Some (M.find d partial) with | Not_found -> None let apply_with_fallback fallback partial d = try M.find d partial with | Not_found -> fallback d end (* \thocwmodulesection{Unit Tests} *) module Test : sig val suite : OUnit.test end = struct open OUnit - module P = Make (struct type t = int let compare = compare end) + module P = Make (Int) let apply_ok = "apply/ok" >:: (fun () -> let p = P.of_list [ (0,"a"); (1,"b"); (2,"c") ] and l = [ 0; 1; 2 ] in assert_equal [ "a"; "b"; "c" ] (List.map (P.apply p) l)) let apply_ok2 = "apply/ok2" >:: (fun () -> let p = P.of_lists [0; 1; 2] ["a"; "b"; "c"] and l = [ 0; 1; 2 ] in assert_equal [ "a"; "b"; "c" ] (List.map (P.apply p) l)) let apply_shadowed = "apply/shadowed" >:: (fun () -> let p = P.of_list [ (0,"a"); (1,"b"); (2,"c"); (1,"d") ] and l = [ 0; 1; 2 ] in assert_equal [ "a"; "d"; "c" ] (List.map (P.apply p) l)) let apply_shadowed2 = "apply/shadowed2" >:: (fun () -> let p = P.of_lists [0; 1; 2; 1] ["a"; "b"; "c"; "d"] and l = [ 0; 1; 2 ] in assert_equal [ "a"; "d"; "c" ] (List.map (P.apply p) l)) let apply_mismatch = "apply/mismatch" >:: (fun () -> assert_raises (Invalid_argument "Partial.of_lists: length mismatch") (fun () -> P.of_lists [0; 1; 2] ["a"; "b"; "c"; "d"])) let suite_apply = "apply" >::: [apply_ok; apply_ok2; apply_shadowed; apply_shadowed2; apply_mismatch] let auto_ok = "auto/ok" >:: (fun () -> let p = P.of_list [ (0,10); (1,11)] and l = [ 0; 1; 2 ] in assert_equal [ 10; 11; 2 ] (List.map (P.auto p) l)) let suite_auto = "auto" >::: [auto_ok] let apply_with_fallback_ok = "apply_with_fallback/ok" >:: (fun () -> let p = P.of_list [ (0,10); (1,11)] and l = [ 0; 1; 2 ] in assert_equal [ 10; 11; -2 ] (List.map (P.apply_with_fallback (fun n -> - n) p) l)) let suite_apply_with_fallback = "apply_with_fallback" >::: [apply_with_fallback_ok] let suite = "Partial" >::: [suite_apply; suite_auto; suite_apply_with_fallback] - let time () = - () - end Index: trunk/omega/src/SU3.ml =================================================================== --- trunk/omega/src/SU3.ml (revision 8919) +++ trunk/omega/src/SU3.ml (revision 8920) @@ -1,1440 +1,1527 @@ (* SU3.ml -- Copyright (C) 2022-2024 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{Import Functions from [Birdtracks]} *) module A = Arrow open Arrow.Infix module L = Algebra.Laurent type t = Birdtracks.t open Birdtracks open Birdtracks.Infix (* \thocwmodulesection{Constructors specific to $\mathrm{SU}(N_C)$} *) (* \thocwmodulesubsection{Fundamental and Adjoint Representation} *) let delta3 i j = - [ Arrows { coeff = L.int 1; arrows = j ==> i } ] + [ Arrows { coeff = L.unit; arrows = j ==> i } ] let delta8 a b = - [ Arrows { coeff = L.int 1; arrows = a <=> b } ] + [ Arrows { coeff = L.unit; arrows = a <=> b } ] (* If the~$\delta_{ab}$ originates from a~$\tr(T_aT_b)$, like an effective~$gg\to H$ coupling, it makes a difference in the color flow basis and we must write the full expression~(6.2) from~\cite{Kilian:2012pz} including the ghosts instead. Note that the sign for the terms with one ghost has not been spelled out in that reference. *) let delta8_loop a b = - [ Arrows { coeff = L.int 1; arrows = a <=> b }; + [ Arrows { coeff = L.unit; arrows = a <=> b }; Arrows { coeff = L.int (-1); arrows = [a => a; ?? b] }; Arrows { coeff = L.int (-1); arrows = [?? a; b => b] }; Arrows { coeff = L.nc 1; arrows = [?? a; ?? b] } ] (* The following can be used for computing polarization sums (eventually, this could make the [Flow] module redundant). Note that we have $-N_C$ instead of $-1/N_C$ in the ghost contribution here, because [add_arrow_to_arrows_list'] from the module [Birdtracks] (cf.~page ~\pageref{pg:add_arrow}) will produce a factor of $-1/N_C$ when contracting each one of the two ghost indices. Indeed, with this definition we can maintain all projection properties \begin{itemize} \item[] [gluon 1 (-3) *** gluon (-3) 2 = gluon 1 2], \item[] [delta8 1 (-3) *** delta8 (-3) 2 = delta8 1 2], \item[] [ghost 1 (-3) *** ghost (-3) 2 = ghost 1 2] \end{itemize} and most importantly \begin{itemize} \item[] [t (-1) 1 2 *** gluon (-1) (-2) *** t (-2) 3 4 = t (-1) 1 2 *** t (-1) 3 4]. \end{itemize} *) let ghost a b = [ Arrows { coeff = L.nc (-1); arrows = [?? a; ?? b] } ] let gluon a b = delta8 a b @ ghost a b (* Note that the arrow is directed from the second to the first index, opposite to our color flow paper~\cite{Kilian:2012pz}. Fortunately, this is just a matter of conventions. \begin{subequations} \begin{align} \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph*}(20,20) \fmfleft{f1,f2} \fmfright{g} \fmfv{label=$i$}{f2} \fmfv{label=$j$}{f1} \fmfv{label=$a$}{g} \fmf{fermion}{f1,v} \fmf{fermion}{v,f2} \fmf{gluon}{v,g} \end{fmfgraph*}}} &\Longrightarrow \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph*}(20,20) \fmfleft{f1,f2} \fmfright{g} \fmfv{label=$i$}{f2} \fmfv{label=$j$}{f1} \fmfv{label=$a$}{g} \fmf{phantom}{f1,v} \fmf{phantom}{v,f2} \fmf{phantom}{v,g} \fmffreeze \fmfi{phantom_arrow}{vpath (__v, __g) sideways -thick} \fmfi{phantom_arrow}{(reverse vpath (__v, __g)) sideways -thick} \fmfi{phantom_arrow}{vpath (__f1, __v)} \fmfi{phantom_arrow}{vpath (__v, __f2)} \fmfi{plain}{% (vpath (__f1, __v) join (vpath (__v, __g)) sideways -thick)} \fmfi{plain}{% ((reverse vpath (__g, __v) sideways -thick) join vpath (__v, __f2))} \end{fmfgraph*}}} \parbox{28\unitlength}{% \fmfframe(4,4)(4,4){% \begin{fmfgraph*}(20,20) \fmfleft{f1,f2} \fmfright{g} \fmfv{label=$i$}{f1} \fmfv{label=$j$}{f2} \fmfv{label=$a$}{g} \fmf{fermion}{f1,v} \fmf{fermion}{v,f2} \fmf{dots}{v,g} \end{fmfgraph*}}}\\ T_a^{ij} \qquad\quad &\Longrightarrow \qquad\quad \delta^{ia}\delta^{aj} \qquad\qquad\qquad - \delta^{ij} \end{align} \end{subequations} *) let t a i j = - [ Arrows { coeff = L.int 1; arrows = [j => a; a => i] }; + [ Arrows { coeff = L.unit; arrows = [j => a; a => i] }; Arrows { coeff = L.int (-1); arrows = [j => i; ?? a] } ] (* Note that while we expect $\tr(T_a)=T_a^{ii}=0$, the evaluation of the expression [t 1 (-1) (-1)] will stop at [ [ -1 => 1; 1 => -1 ] --- [ -1 => -1; ?? 1 ] ], because the summation index appears in a single term. However, a naive further evaluation would get stuck at [ [ 1 => 1 ] --- nc *** [ ?? 1 ] ]. Fortunately, traces of single generators are never needed in our applications. We just have to resist the temptation to use them in unit tests. *) (* \begin{equation} \parbox{29\unitlength}{% \fmfframe(2,2)(2,2){% \begin{fmfgraph*}(25,25) \fmfleft{g1,g2} \fmfright{g3} \fmfv{label=$a$}{g1} \fmfv{label=$b$}{g2} \fmfv{label=$c$}{g3} \fmf{gluon}{g1,v} \fmf{gluon}{g2,v} \fmf{gluon}{g3,v} \end{fmfgraph*}}} \qquad\Longrightarrow \parbox{29\unitlength}{% \fmfframe(2,2)(2,2){% \begin{fmfgraph*}(25,25) \fmfleft{g1,g2} \fmfright{g3} \fmfv{label=$a$}{g1} \fmfv{label=$b$}{g2} \fmfv{label=$c$}{g3} \fmf{phantom}{g1,v} \fmf{phantom}{g2,v} \fmf{phantom}{g3,v} \fmffreeze \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g2,__v))) sideways thick} \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g3,__v))) sideways thick} \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g1,__v))) sideways thick} \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick} \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick} \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick} \end{fmfgraph*}}} \qquad \parbox{29\unitlength}{% \fmfframe(2,2)(2,2){% \begin{fmfgraph*}(25,25) \fmfleft{g1,g2} \fmfright{g3} \fmfv{label=$a$}{g1} \fmfv{label=$b$}{g2} \fmfv{label=$c$}{g3} \fmf{phantom}{g1,v} \fmf{phantom}{g2,v} \fmf{phantom}{g3,v} \fmffreeze \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g3,__v))) sideways thick} \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g1,__v))) sideways thick} \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g2,__v))) sideways thick} \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick} \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick} \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick} \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick} \end{fmfgraph*}}} \end{equation} *) let f a b c = [ Arrows { coeff = L.imag ( 1); arrows = A.cycle [a; b; c] }; Arrows { coeff = L.imag (-1); arrows = A.cycle [a; c; b] } ] (* The generator in the adjoint representation $T_a^{bc}=-\ii f_{abc}$: *) let t8 a b c = minus *** imag *** f a b c (* This $d_{abc}$ is now compatible with~(6.11) in our color flow paper~\cite{Kilian:2012pz}. The signs had been wrong in earlier versions of the code to match the missing sign in the ghost contribution to the generator~$T_a^{ij}$ above. *) let d a b c = - [ Arrows { coeff = L.int 1; arrows = A.cycle [a; b; c] }; - Arrows { coeff = L.int 1; arrows = A.cycle [a; c; b] }; + [ Arrows { coeff = L.unit; arrows = A.cycle [a; b; c] }; + Arrows { coeff = L.unit; arrows = A.cycle [a; c; b] }; Arrows { coeff = L.int (-2); arrows = (a <=> b) @ [?? c] }; Arrows { coeff = L.int (-2); arrows = (b <=> c) @ [?? a] }; Arrows { coeff = L.int (-2); arrows = (c <=> a) @ [?? b] }; Arrows { coeff = L.int 2; arrows = [a => a; ?? b; ?? c] }; Arrows { coeff = L.int 2; arrows = [?? a; b => b; ?? c] }; Arrows { coeff = L.int 2; arrows = [?? a; ?? b; c => c] }; Arrows { coeff = L.nc (-2); arrows = [?? a; ?? b; ?? c] } ] (* \thocwmodulesubsection{Decomposed Tensor Product Representations} *) let pass_through m n incoming outgoing = List.rev_map2 (fun i o -> (m, i) >=>> (n, o)) incoming outgoing let delta_of_permutations n permutations k l = let incoming = ThoList.range 0 (pred n) and normalization = List.length permutations in List.rev_map (fun (eps, outgoing) -> Arrows { coeff = L.fraction (eps * normalization); arrows = pass_through l k incoming outgoing } ) permutations let totally_symmetric n = List.map (fun p -> (1, p)) (Combinatorics.permute (ThoList.range 0 (pred n))) let totally_antisymmetric n = (Combinatorics.permute_signed (ThoList.range 0 (pred n))) let delta_S n k l = delta_of_permutations n (totally_symmetric n) k l let delta_A n k l = delta_of_permutations n (totally_antisymmetric n) k l let delta6 = delta_S 2 let delta10 = delta_S 3 let delta15 = delta_S 4 let delta3bar = delta_A 2 (* Mixed symmetries, as in section 9.4 of the birdtracks book. *) -module IM = Partial.Make (struct type t = int let compare = compare end) +module IM = Partial.Make (Int) module P = Permutation.Default (* Map the elements of [original] to [permuted] in [all], with [all] a list of $n$ integers from $0$ to $n-1$ in order, and use the resulting list to define a permutation. E.\,g.~[permute_partial [1;3] [3;1] [0;1;2;3;4]] will define a permutation that transposes the second and fourth element in a 5 element list. *) let permute_partial original permuted all = P.of_list (List.map (IM.auto (IM.of_lists original permuted)) all) let apply1 (sign, indices) (eps, p) = (eps * sign, P.list p indices) let apply signed_permutations signed_indices = List.rev_map (apply1 signed_indices) signed_permutations let apply_list signed_permutations signed_indices = ThoList.flatmap (apply signed_permutations) signed_indices let symmetrizer_of_permutations n original signed_permutations = let incoming = ThoList.range 0 (pred n) in List.rev_map (fun (eps, permuted) -> (eps, permute_partial original permuted incoming)) signed_permutations let symmetrizer n indices = symmetrizer_of_permutations n indices (List.rev_map (fun p -> (1, p)) (Combinatorics.permute indices)) let anti_symmetrizer n indices = symmetrizer_of_permutations n indices (Combinatorics.permute_signed indices) let symmetrize n elements indices = apply_list (symmetrizer n elements) indices let anti_symmetrize n elements indices = apply_list (anti_symmetrizer n elements) indices let id n = [(1, ThoList.range 0 (pred n))] (* \begin{dubious} We can avoid the recursion here, if we use [Combinatorics.permute_tensor_signed] in [symmetrizer] above. \end{dubious} *) let rec apply_tableau f n tableau indices = match tableau with | [] | [_] :: _ -> indices | cells :: rest -> apply_tableau f n rest (f n cells indices) (* \begin{dubious} Here we should at a sanity test for [tableau]: all integers should be consecutive starting from 0 with no duplicates. In additions the rows must not grow in length. \end{dubious} *) let young_tableau_valid_omega y = Young.standard_tableau ~offset:0 y let delta_of_tableau tableau i j = if young_tableau_valid_omega tableau then let n = Young.num_cells_tableau tableau and num, den = Young.normalization (Young.diagram_of_tableau tableau) and rows = tableau and cols = Young.conjugate_tableau tableau in let permutations = apply_tableau symmetrize n rows (apply_tableau anti_symmetrize n cols (id n)) in int num *** fraction den *** delta_of_permutations n permutations i j else let s = Young.tableau_to_string string_of_int tableau in invalid_arg ("SU3.delta_of_tableau: " ^ s ^ " is not standard!") -let incomplete tensor = +let _incomplete tensor = failwith ("SU3: " ^ tensor ^ " not supported yet!") -let experimental tensor = +let _experimental tensor = Printf.eprintf "SU3: %s support still experimental and untested!\n" tensor let distinct integers = let rec distinct' seen = function | [] -> true | i :: rest -> if Sets.Int.mem i seen then false else distinct' (Sets.Int.add i seen) rest in distinct' Sets.Int.empty integers (* All lines start here: they point towards the vertex. *) -let epsilon tips = +let epsilon0 tips = if distinct tips then - [ Epsilons ({ coeff = L.int 1; arrows = [] }, NEList.singleton (A.epsilon tips)) ] + [ Epsilons ({ coeff = L.unit; arrows = [] }, NEList.singleton (A.epsilon0 tips)) ] else [] (* All lines end here: they point away from the vertex. *) -let epsilon_bar tails = +let epsilon0_bar tails = if distinct tails then - [ Epsilon_Bars ({ coeff = L.int 1; arrows = [] },NEList.singleton (A.epsilon_bar tails)) ] + [ Epsilon_Bars ({ coeff = L.unit; arrows = [] },NEList.singleton (A.epsilon0_bar tails)) ] else [] (* In order to get the correct $N_C$ dependence of quadratic Casimir operators, the arrows in the vertex must have the same permutation symmetry as the propagator. This is demonstrated by the unit tests involving Casimir operators on page \pageref{pg:casimir-tests} below. These tests also provide a check of our normalization. The implementation takes a propagator and uses [Arrow.tee] to replace one arrow by the pair of arrows corresponding to the insertion of a gluon. This is repeated for each arrow. The normalization remains unchanged from the propagator. A minus sign is added for antiparallel arrows, since the conjugate representation is~$-T^*_a$. To this, we add the diagrams with a gluon connected to one arrow. Since these are identical, only one diagram multiplied by the difference of the number of parallel and antiparallel arrows is added. *) let insert_gluon a k l term = let rec insert_gluon' acc left = function | [] -> acc | arrow :: right -> insert_gluon' (Arrows { coeff = Algebra.Laurent.mul (L.int (A.dir k l arrow)) term.coeff; arrows = List.rev_append left ((A.tee a arrow) @ right) } :: acc) (arrow :: left) right in insert_gluon' [] [] term.arrows let t_of_delta delta a k l = match delta k l with | [] -> [] - | Arrows { arrows = arrows } :: _ as delta_kl -> + | Arrows { arrows = arrows; _ } :: _ as delta_kl -> let n = List.fold_left (fun acc arrow -> acc + A.dir k l arrow) 0 arrows in let ghosts = List.rev_map (fun term -> match term with | Arrows aterm -> Arrows { coeff = Algebra.Laurent.mul (L.int (-n)) aterm.coeff; arrows = ?? a :: aterm.arrows } | Epsilons _ -> failwith "t_of_delta: unexpected epsilon" | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar") delta_kl in List.fold_left (fun acc -> function | Arrows aterm -> insert_gluon a k l aterm @ acc | Epsilons _ -> failwith "t_of_delta: unexpected epsilon" | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar") ghosts delta_kl | Epsilons _ :: _ -> failwith "t_of_delta: unexpected epsilon" | Epsilon_Bars _ :: _ -> failwith "t_of_delta: unexpected epsilon_bar" let t_of_delta delta a k l = canonicalize (t_of_delta delta a k l) let t_S n a k l = t_of_delta (delta_S n) a k l let t_A n a k l = t_of_delta (delta_A n) a k l let t6 = t_S 2 let t10 = t_S 3 let t15 = t_S 4 let t3bar = t_A 2 (* Equivalent definition: *) -let t8' a b c = +let _t8' a b c = t_of_delta delta8 a b c let t_of_tableau tableau a k l = t_of_delta (delta_of_tableau tableau) a k l (* \begin{dubious} Check the following for a real live UFO file! \end{dubious} *) (* In the UFO paper, the Clebsh-Gordan is defined - as~$K^{(6),ij}_{\hphantom{(6),ij}m}$. Therefore, keeping + as~$(K_6)^{\bar\imath\bar\jmath}_{\hphantom{\bar\imath\bar\jmath}m}$. Therefore, keeping our convention for the generators~$T_{a\hphantom{(6),j}i}^{(6),j}$, - the must arrows \emph{end} at~$m$. *) + the must arrows \emph{end} at~$m$. + + Naively, one might have expected a normalization factor~$1/\sqrt{2}$, + but the~$1/2$ makes sure that + $(K_6)^{\bar\imath\bar\jmath}_{\hphantom{\bar\imath\bar\jmath}m} + (\overline K_6)^{\bar m}_{\hphantom{\bar m}i'j'}$ and + $(\overline K_6)^{\bar m}_{\hphantom{\bar m}ij} + (K_6)^{\bar\imath\bar\jmath}_{\hphantom{\bar\imath\bar\jmath}m'}$ + are projectors. *) let k6 m i j = - experimental "k6"; - [ Arrows { coeff = L.int 1; arrows = [i =>> (m, 0); j =>> (m, 1)] }; - Arrows { coeff = L.int 1; arrows = [i =>> (m, 1); j =>> (m, 0)] } ] + [ Arrows { coeff = L.fraction 2; arrows = [i =>> (m, 0); j =>> (m, 1)] }; + Arrows { coeff = L.fraction 2; arrows = [i =>> (m, 1); j =>> (m, 0)] } ] -(* The arrow are reversed for~$\bar K^{(6),m}_{\hphantom{(6),m}ij}$ +(* The arrow are reversed for~$(\overline K_6)^{\bar m}_{\hphantom{\bar m}ij}$ and \emph{start} at~$m$. *) let k6bar m i j = - experimental "k6bar"; - [ Arrows { coeff = L.int 1; arrows = [(m, 0) >=> i; (m, 1) >=> j] }; - Arrows { coeff = L.int 1; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ] + [ Arrows { coeff = L.fraction 2; arrows = [(m, 0) >=> i; (m, 1) >=> j] }; + Arrows { coeff = L.fraction 2; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ] (* \begin{dubious} - Playing arround with an example, it appears that we need the - opposite direction. Investigate! + Playing around with an example, it appeared that people expect the + opposite direction. But this makes no sense. Investigate! \end{dubious} *) -let k6 m i j = - experimental "k6"; - [ Arrows { coeff = L.int 1; arrows = [(m, 0) >=> i; (m, 1) >=> j] }; - Arrows { coeff = L.int 1; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ] - -let k6bar m i j = - experimental "k6bar"; - [ Arrows { coeff = L.int 1; arrows = [i =>> (m, 0); j =>> (m, 1)] }; - Arrows { coeff = L.int 1; arrows = [i =>> (m, 1); j =>> (m, 0)] } ] +let _k6 m i j = + [ Arrows { coeff = L.unit; arrows = [(m, 0) >=> i; (m, 1) >=> j] }; + Arrows { coeff = L.unit; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ] + +let _k6bar m i j = + [ Arrows { coeff = L.unit; arrows = [i =>> (m, 0); j =>> (m, 1)] }; + Arrows { coeff = L.unit; arrows = [i =>> (m, 1); j =>> (m, 0)] } ] + +(* \thocwmodulesection{Ghosts} *) + +let add_ghost_to_aterm a arrows aterm = + { coeff = L.neg aterm.coeff; arrows = ?? a :: arrows } + +let add_loop_to_aterm a arrows aterm = + { coeff = L.product [L.nc (-1); aterm.coeff]; arrows = ?? a :: arrows } + +let add_ghost_to_term a = function + | Arrows aterm -> + begin match A.adjoint_arrows_opt a aterm.arrows with + | None -> Arrows aterm + | Some (Tee, arrows) -> Arrows (add_ghost_to_aterm a arrows aterm) + | Some (Reflex, arrows) -> Arrows (add_loop_to_aterm a arrows aterm) + end + | Epsilons (aterm, eps) as eterm -> + begin match A.adjoint_eps_opt a aterm.arrows eps with + | None -> eterm + | Some (Tee, arrows, eps) -> Epsilons (add_ghost_to_aterm a arrows aterm, eps) + | Some (Reflex, arrows, eps) -> Epsilons (add_loop_to_aterm a arrows aterm, eps) + end + | Epsilon_Bars (aterm, eps_bar) as bterm -> + begin match A.adjoint_eps_bar_opt a aterm.arrows eps_bar with + | None -> bterm + | Some (Tee, arrows, eps_bar) -> Epsilon_Bars (add_ghost_to_aterm a arrows aterm, eps_bar) + | Some (Reflex, arrows, eps_bar) -> Epsilon_Bars (add_loop_to_aterm a arrows aterm, eps_bar) + end + +let add_ghost_to_terms a terms = + canonicalize (List.map (add_ghost_to_term a) terms) + +exception Haunted + +let evoke_some gluons terms = + if haunted terms then + raise Haunted + else + sum (Combinatorics.subfolds (Fun.flip add_ghost_to_terms) terms gluons) +let evoke terms = + evoke_some (adjoints terms) terms + (* \thocwmodulesection{Unit Tests} *) module Test = struct open OUnit module L = Algebra.Laurent - let exorcise vertex = - List.filter - (function - | Arrows aterm | Epsilons (aterm, _) | Epsilon_Bars (aterm, _) -> - not (List.exists A.is_ghost aterm.arrows)) - vertex - let exorcised_equal v1 v2 = equal (exorcise v1) (exorcise v2) (* \thocwmodulesubsection{Trivia} *) let suite_sum = "sum" >::: [ "atoms" >:: (fun () -> equal (int 2 *** delta3 1 2) (delta3 1 2 +++ delta3 1 2)) ] let suite_diff = "diff" >::: [ "atoms" >:: (fun () -> equal (delta3 3 4) (delta3 1 2 +++ delta3 3 4 --- delta3 1 2)) ] (* \begin{equation} \prod_{k=i}^j f(k) \end{equation} *) let rec product f i j = if i > j then null else if i = j then f i else f i *** product f (succ i) j (* In particular \begin{equation} \text{[nc_minus_n_plus] n k}\, \mapsto N_C-n+k \end{equation} and \begin{multline} \text{[product (nc_minus_n_plus n) i j]}\, \mapsto \\ \prod_{k=i}^j (N_C-n+k) = \frac{(N_C-n+j)!}{(N_C-n+i-1)!} = (N_C-n+j)(N_C-n+j-1)\cdots(N_C-n+i) \end{multline} *) let nc_minus_n_plus n k = const (L.ints [ (1, 1); (-n + k, 0) ]) let contractions rank k = product (nc_minus_n_plus rank) 1 k let suite_times = + let epsilon = epsilon0 + and epsilon_bar = epsilon0_bar in "times" >::: [ "reorder components t1*t2" >:: (* trivial $T_a^{ik}T_a^{kj}=T_a^{kj}T_a^{ik}$ *) (fun () -> let t1 = t (-1) 1 (-2) and t2 = t (-1) (-2) 2 in equal (t1 *** t2) (t2 *** t1)); "reorder components tr(t1*t2)" >:: (* trivial $T_a^{ij}T_a^{ji}=T_a^{ji}T_a^{ij}$ *) (fun () -> let t1 = t 1 (-1) (-2) and t2 = t 2 (-2) (-1) in equal (t1 *** t2) (t2 *** t1)); "reorderings" >:: (fun () -> let v1 = [Arrows { coeff = L.unit; arrows = [ 1 => -2; -2 => -1; -1 => 1] }] and v2 = [Arrows { coeff = L.unit; arrows = [-1 => 2; 2 => -2; -2 => -1] }] and v' = [Arrows { coeff = L.unit; arrows = [ 1 => 1; 2 => 2] }] in equal v' (v1 *** v2)); "eps*epsbar" >:: (fun () -> equal (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2) (epsilon [1; 3] *** epsilon_bar [2; 4])); "eps*epsbar -" >:: (fun () -> equal (delta3 1 4 *** delta3 3 2 --- delta3 1 2 *** delta3 3 4) (epsilon [1; 3] *** epsilon_bar [4; 2])); "eps*epsbar 1" >:: (fun () -> equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *) (contractions 3 1 *** (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2)) (epsilon [-1; 1; 3] *** epsilon_bar [-1; 2; 4])); "eps*epsbar cyclic 1" >:: (fun () -> equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *) (contractions 3 1 *** (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2)) (epsilon [3; -1; 1] *** epsilon_bar [-1; 2; 4])); "eps*epsbar cyclic 2" >:: (fun () -> equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *) (contractions 3 1 *** (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2)) (epsilon [-1; 1; 3] *** epsilon_bar [4; -1; 2])); "eps*epsbar 2" >:: (fun () -> equal (* $(N_C-3+2)(N_C-3+1)=(N_C-1)(N_C-2)$, for $NC=3$: $2$ *) (contractions 3 2 *** delta3 1 2) (epsilon [-1; -2; 1] *** epsilon_bar [-1; -2; 2])); "eps*epsbar 3" >:: (fun () -> equal (* $(N_C-3+3)(N_C-3+2)(N_C-3+1)=N_C(N_C-1)(N_C-2)$, for $NC=3$: $3!$ *) (contractions 3 3) (epsilon [-1; -2; -3] *** epsilon_bar [-1; -2; -3])); "eps*epsbar big" >:: (fun () -> equal (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *) (contractions 5 3 *** (epsilon [4; 5] *** epsilon_bar [6; 7])) (epsilon [-1; -2; -3; 4; 5] *** epsilon_bar [-1; -2; -3; 6; 7])); "eps*epsbar big -" >:: (fun () -> equal (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *) (contractions 5 3 *** (epsilon [5; 4] *** epsilon_bar [6; 7])) (epsilon [-1; 4; -3; -2; 5] *** epsilon_bar [-1; -2; -3; 6; 7])) ] (* \thocwmodulesubsection{Propagators} *) (* Verify the normalization of the propagators by making sure that $D^{ij}D^{jk}=D^{ik}$ *) let projection_id rep_d = equal (rep_d 1 2) (rep_d 1 (-1) *** rep_d (-1) 2) let orthogonality d d' = assert_zero_vertex (d 1 (-1) *** d' (-1) 2) (* Pass every arrow straight through, without (anti-)symmetrization. *) let delta_unsymmetrized n k l = delta_of_permutations n [(1, ThoList.range 0 (pred n))] k l let completeness n tableaux = equal (delta_unsymmetrized n 1 2) (sum (List.map (fun t -> delta_of_tableau t 1 2) tableaux)) (* The following names are of historical origin. From the time, when we didn't have full support for Young tableaux and implemented figure 9.1 from the birdtrack book. \ytableausetup{centertableaux,smalltableaux} \begin{equation} \ytableaushort{01,2} \end{equation} *) let delta_SAS i j = delta_of_tableau [[0;1];[2]] i j (* \begin{equation} \ytableaushort{02,1} \end{equation} *) let delta_ASA i j = delta_of_tableau [[0;2];[1]] i j let suite_propagators = "propagators" >::: [ "D*D=D" >:: (fun () -> projection_id delta3); "D8*D8=D8" >:: (fun () -> projection_id delta8); "G*G=G" >:: (fun () -> projection_id gluon); "D6*D6=D6" >:: (fun () -> projection_id delta6); "D10*D10=D10" >:: (fun () -> projection_id delta10); "D15*D15=D15" >:: (fun () -> projection_id delta15); "D3bar*D3bar=D3bar" >:: (fun () -> projection_id delta3bar); "D6*D3bar=0" >:: (fun () -> orthogonality delta6 delta3bar); "D_A3*D_A3=D_A3" >:: (fun () -> projection_id (delta_A 3)); "D10*D_A3=0" >:: (fun () -> orthogonality delta10 (delta_A 3)); "D_SAS*D_SAS=D_SAS" >:: (fun () -> projection_id delta_SAS); "D_ASA*D_ASA=D_ASA" >:: (fun () -> projection_id delta_ASA); "D_SAS*D_S3=0" >:: (fun () -> orthogonality delta_SAS (delta_S 3)); "D_SAS*D_A3=0" >:: (fun () -> orthogonality delta_SAS (delta_A 3)); "D_SAS*D_ASA=0" >:: (fun () -> orthogonality delta_SAS delta_ASA); "D_ASA*D_SAS=0" >:: (fun () -> orthogonality delta_ASA delta_SAS); "D_ASA*D_S3=0" >:: (fun () -> orthogonality delta_ASA (delta_S 3)); "D_ASA*D_A3=0" >:: (fun () -> orthogonality delta_ASA (delta_A 3)); "DU*DU=DU" >:: (fun () -> projection_id (delta_unsymmetrized 3)); "S3=[0123]" >:: (fun () -> equal (delta_S 4 1 2) (delta_of_tableau [[0;1;2;3]] 1 2)); "A3=[0,1,2,3]" >:: (fun () -> equal (delta_A 4 1 2) (delta_of_tableau [[0];[1];[2];[3]] 1 2)); "[0123]*[012,3]=0" >:: (fun () -> orthogonality (delta_of_tableau [[0;1;2;3]]) (delta_of_tableau [[0;1;2];[3]])); "[0123]*[01,23]=0" >:: (fun () -> orthogonality (delta_of_tableau [[0;1;2;3]]) (delta_of_tableau [[0;1];[2;3]])); "[012,3]*[012,3]=[012,3]" >:: (fun () -> projection_id (delta_of_tableau [[0;1;2];[3]])); (* \ytableausetup{centertableaux,smalltableaux} \begin{equation} \ytableaushort{01} + \ytableaushort{0,1} \end{equation} *) "completeness 2" >:: (fun () -> completeness 2 [ [[0;1]]; [[0];[1]] ]) ; "completeness 2'" >:: (fun () -> equal (delta_unsymmetrized 2 1 2) (delta_S 2 1 2 +++ delta_A 2 1 2)); (* The normalization factors are written for illustration. They are added by [delta_of_tableau] automatically. \ytableausetup{centertableaux,smalltableaux} \begin{equation} \ytableaushort{012} + \frac{4}{3}\cdot\ytableaushort{01,2} + \frac{4}{3}\cdot\ytableaushort{02,1} + \ytableaushort{0,1,2} \end{equation} *) "completeness 3" >:: (fun () -> completeness 3 [ [[0;1;2]]; [[0;1];[2]]; [[0;2];[1]]; [[0];[1];[2]] ]); "completeness 3'" >:: (fun () -> equal (delta_unsymmetrized 3 1 2) (delta_S 3 1 2 +++ delta_SAS 1 2 +++ delta_ASA 1 2 +++ delta_A 3 1 2)); (* \ytableausetup{centertableaux,smalltableaux} \begin{equation} \ytableaushort{0123} + \frac{3}{2}\cdot\ytableaushort{012,3} + \frac{3}{2}\cdot\ytableaushort{013,2} + \frac{3}{2}\cdot\ytableaushort{023,1} + \frac{4}{3}\cdot\ytableaushort{01,23} + \frac{4}{3}\cdot\ytableaushort{02,13} + \frac{3}{2}\cdot\ytableaushort{01,2,3} + \frac{3}{2}\cdot\ytableaushort{02,1,3} + \frac{3}{2}\cdot\ytableaushort{03,1,2} + \ytableaushort{0,1,2,3} \end{equation} *) "completeness 4" >:: (fun () -> completeness 4 [ [[0;1;2;3]]; [[0;1;2];[3]]; [[0;1;3];[2]]; [[0;2;3];[1]]; [[0;1];[2;3]]; [[0;2];[1;3]]; [[0;1];[2];[3]]; [[0;2];[1];[3]]; [[0;3];[1];[2]]; [[0];[1];[2];[3]] ]) ] (* \thocwmodulesubsection{Normalization} *) let suite_normalization = "normalization" >::: [ "tr(t*t)" >:: (* $\tr(T_aT_b)=\delta_{ab} + \text{ghosts}$ *) (fun () -> equal (delta8_loop 1 2) (t 1 (-1) (-2) *** t 2 (-2) (-1))); "tr(t*t) sans ghosts" >:: (* $\tr(T_aT_b)=\delta_{ab}$ *) (fun () -> exorcised_equal (delta8 1 2) (t 1 (-1) (-2) *** t 2 (-2) (-1))); (* The additional ghostly terms were unexpected, but arises like~(6.2) in our color flow paper~\cite{Kilian:2012pz}. *) "t*t*t" >:: (* $T_aT_bT_a=-T_b/N_C + \ldots$ *) (fun () -> equal (minus *** over_nc *** t 1 2 3 - +++ [Arrows { coeff = L.int 1; arrows = [1 => 1; 3 => 2] }; + +++ [Arrows { coeff = L.unit; arrows = [1 => 1; 3 => 2] }; Arrows { coeff = L.nc (-1); arrows = [3 => 2; ?? 1] }]) (t (-1) 2 (-2) *** t 1 (-2) (-3) *** t (-1) (-3) 3)); (* As expected, these ghostly terms cancel in the summed squares \begin{equation} \tr(T_aT_bT_aT_cT_bT_c) = \tr(T_bT_b)/N_C^2 = \delta_{bb}/N_C^2 = (N_C^2-1) / N_C^2 = 1 - 1 / N_C^2 \end{equation} *) "sum((t*t*t)^2)" >:: (fun () -> equal (ints [(1, 0); (-1, -2)]) (t (-1) (-11) (-12) *** t (-2) (-12) (-13) *** t (-1) (-13) (-14) *** t (-3) (-14) (-15) *** t (-2) (-15) (-16) *** t (-3) (-16) (-11))); "d*d" >:: (fun () -> exorcised_equal [ Arrows { coeff = L.ints [(2, 1); (-8,-1)]; arrows = 1 <=> 2 }; Arrows { coeff = L.ints [(2, 0); ( 4,-2)]; arrows = [1=>1; 2=>2] }] (d 1 (-1) (-2) *** d 2 (-2) (-1))) ] (* As proposed in our color flow paper~\cite{Kilian:2012pz}, we can get the correct (anti-)symmetrized generators by sandwiching the following unsymmetrized generators between the corresponding (anti-)symmetrized projectors. Therefore, the unsymmetrized generators work as long as they're used in Feynman diagrams, where they are connected by propagators that contain (anti-)symmetrized projectors. They even work in the Lie algebra relations and give the correct normalization there. They fail however for more general color algebra expressions that can appear in UFO files. In particular, the Casimir operators come out really wrong. *) let t_unsymmetrized n k l = t_of_delta (delta_unsymmetrized n) k l (* The following trivial vertices are \emph{not} used anymore, since they don't get the normalization of the Ward identities right. For the quadratic casimir operators, they always produce a result proportional to~$C_F=C_2(S_1)$. This can be understood because they correspond to a fundamental representation with spectators. (Anti-)symmetrizing by sandwiching with projectors almost works, but they must be multiplied by hand by the number of arrows to get the normalization right. They're here just for documenting what doesn't work. *) let t_trivial n a k l = let sterile = List.map (fun i -> (l, i) >=>> (k, i)) (ThoList.range 1 (pred n)) in [ Arrows { coeff = L.int ( 1); arrows = ((l, 0) >=> a) :: (a =>> (k, 0)) :: sterile }; Arrows { coeff = L.int (-1); arrows = (?? a) :: ((l, 0) >=>> (k, 0)) :: sterile }] let t6_trivial = t_trivial 2 let t10_trivial = t_trivial 3 let t15_trivial = t_trivial 4 let t_SAS = t_of_delta delta_SAS let t_ASA = t_of_delta delta_ASA let symmetrization ?rep_ts rep_tu rep_d = let rep_ts = match rep_ts with | None -> rep_tu | Some rep_t -> rep_t in equal (rep_ts 1 2 3) (gluon 1 (-1) *** rep_d 2 (-2) *** rep_tu (-1) (-2) (-3) *** rep_d (-3) 3) let suite_symmetrization = "symmetrization" >::: [ "t6" >:: (fun () -> symmetrization t6 delta6); "t10" >:: (fun () -> symmetrization t10 delta10); "t15" >:: (fun () -> symmetrization t15 delta15); "t3bar" >:: (fun () -> symmetrization t3bar delta3bar); "t_SAS" >:: (fun () -> symmetrization t_SAS delta_SAS); "t_ASA" >:: (fun () -> symmetrization t_ASA delta_ASA); "t6'" >:: (fun () -> symmetrization ~rep_ts:t6 (t_unsymmetrized 2) delta6); "t10'" >:: (fun () -> symmetrization ~rep_ts:t10 (t_unsymmetrized 3) delta10); "t15'" >:: (fun () -> symmetrization ~rep_ts:t15 (t_unsymmetrized 4) delta15); "t6''" >:: (fun () -> equal (t6 1 2 3) (int 2 *** delta6 2 (-1) *** t6_trivial 1 (-1) (-2) *** delta6 (-2) 3)); "t10''" >:: (fun () -> equal (t10 1 2 3) (int 3 *** delta10 2 (-1) *** t10_trivial 1 (-1) (-2) *** delta10 (-2) 3)); "t15''" >:: (fun () -> equal (t15 1 2 3) (int 4 *** delta15 2 (-1) *** t15_trivial 1 (-1) (-2) *** delta15 (-2) 3)) ] (* \thocwmodulesubsection{Traces} *) (* Compute (anti-)commutators of generators in the representation~$r$, i.\,e.~$[r(t_a)r(t_b)]_{ij}\mp[r(t_b)r(t_a)]_{ij}$, using [isum<0] as summation index in the matrix products. *) let commutator rep_t i_sum a b i j = multiply [rep_t a i i_sum; rep_t b i_sum j] --- multiply [rep_t b i i_sum; rep_t a i_sum j] let anti_commutator rep_t i_sum a b i j = multiply [rep_t a i i_sum; rep_t b i_sum j] +++ multiply [rep_t b i i_sum; rep_t a i_sum j] (* Trace of the product of three generators in the representation~$r$, i.\,e.~$\tr_r(r(t_a)r(t_b)r(t_c))$, using $-1,-2,-3$ as summation indices in the matrix products. *) let trace3 rep_t a b c = rep_t a (-1) (-2) *** rep_t b (-2) (-3) *** rep_t c (-3) (-1) let loop3 a b c = - [ Arrows { coeff = L.int 1; arrows = A.cycle (List.rev [a; b; c]) }; + [ Arrows { coeff = L.unit; arrows = A.cycle (List.rev [a; b; c]) }; Arrows { coeff = L.int (-1); arrows = (a <=> b) @ [?? c] }; Arrows { coeff = L.int (-1); arrows = (b <=> c) @ [?? a] }; Arrows { coeff = L.int (-1); arrows = (c <=> a) @ [?? b] }; - Arrows { coeff = L.int 1; arrows = [a => a; ?? b; ?? c] }; - Arrows { coeff = L.int 1; arrows = [?? a; b => b; ?? c] }; - Arrows { coeff = L.int 1; arrows = [?? a; ?? b; c => c] }; + Arrows { coeff = L.unit; arrows = [a => a; ?? b; ?? c] }; + Arrows { coeff = L.unit; arrows = [?? a; b => b; ?? c] }; + Arrows { coeff = L.unit; arrows = [?? a; ?? b; c => c] }; Arrows { coeff = L.nc (-1); arrows = [?? a; ?? b; ?? c] } ] let suite_trace = "trace" >::: [ "tr(ttt)" >:: (fun () -> equal (trace3 t 1 2 3) (loop3 1 2 3)); "tr(ttt) cyclic 1" >:: (* $\tr(T_aT_bT_c)=\tr(T_bT_cT_a)$ *) (fun () -> equal (trace3 t 1 2 3) (trace3 t 2 3 1)); "tr(ttt) cyclic 2" >:: (* $\tr(T_aT_bT_c)=\tr(T_cT_aT_b)$ *) (fun () -> equal (trace3 t 1 2 3) (trace3 t 3 1 2)); (* \begin{dubious} Do we expect this? \end{dubious} *) "tr(tttt)" >:: (* $\tr(T_aT_bT_cT_d)=\ldots$ *) (fun () -> exorcised_equal - [ Arrows { coeff = L.int 1; arrows = A.cycle [4; 3; 2; 1] }] + [ Arrows { coeff = L.unit; arrows = A.cycle [4; 3; 2; 1] }] (t 1 (-1) (-2) *** t 2 (-2) (-3) *** t 3 (-3) (-4) *** t 4 (-4) (-1))) ] let suite_ghosts = "ghosts" >::: [ "H->gg" >:: (fun () -> equal (delta8_loop 1 2) (t 1 (-1) (-2) *** t 2 (-2) (-1))); + "|H->gg|^2" >:: + (fun () -> + equal + (const (L.ints [ (1, 2); (-1, 0) ])) + (delta8_loop (-1) (-2) *** delta8_loop (-2) (-1))); + "H->ggg f" >:: (fun () -> equal (imag *** f 1 2 3) (trace3 t 1 2 3 --- trace3 t 1 3 2)); "H->ggg d" >:: (fun () -> equal (d 1 2 3) (trace3 t 1 2 3 +++ trace3 t 1 3 2)); "H->ggg f'" >:: (fun () -> equal (imag *** f 1 2 3) (t 1 (-3) (-2) *** commutator t (-1) 2 3 (-2) (-3))); "H->ggg d'" >:: (fun () -> equal (d 1 2 3) (t 1 (-3) (-2) *** anti_commutator t (-1) 2 3 (-2) (-3))); "H->ggg cyclic'" >:: (fun () -> let trace a b c = t a (-3) (-2) *** commutator t (-1) b c (-2) (-3) in equal (trace 1 2 3) (trace 2 3 1)) ] + let equal_evoke t = + equal t (evoke (exorcise t)) + + let suite_evoke = + "evoke" >::: + + [ "delta8" >:: (fun () -> equal (delta8_loop 1 2) (evoke (delta8 1 2))); + "delta8'" >:: (fun () -> equal_evoke (delta8_loop 1 2)); + "d" >:: (fun () -> equal_evoke (d 1 2 3)); + "f" >:: (fun () -> equal_evoke (f 1 2 3)); + "f'" >:: (fun () -> equal (f 1 2 3) (evoke (f 1 2 3))); + "f''" >:: (fun () -> equal (f 1 2 3) (exorcise (f 1 2 3))); + "tr(ttt)" >:: (fun () -> equal_evoke (trace3 t 1 2 3)); + "tr(t6t6t6)" >:: (fun () -> equal_evoke (trace3 t6 1 2 3)); + "eps8" >:: (fun () -> equal_evoke (epsilon0_bar [1;2;-1] *** t 4 (-1) 3)); + "eps88" >:: (fun () -> equal_evoke (epsilon0_bar [1;-1;-2] *** t 4 (-1) 2 *** t 5 (-2) 3)); + "eps888" >:: (fun () -> equal_evoke (epsilon0_bar [-1;-2;-3] *** t 4 (-1) 1 *** + t 5 (-2) 2 *** t 6 (-3) 3)); + "epsbar8" >:: (fun () -> equal_evoke (epsilon0 [1;2;-1] *** t 4 3 (-1))); + "epsbar88" >:: (fun () -> equal_evoke (epsilon0 [1;-1;-2] *** t 4 2 (-1) *** t 5 3 (-2))); + "epsbar888" >:: (fun () -> equal_evoke (epsilon0 [-1;-2;-3] *** t 4 1 (-1) *** + t 5 2 (-2) *** t 6 3 (-3))); + "epseps88" >:: (fun () -> equal_evoke (epsilon0_bar [1;2;-1] *** t 4 (-1) 3 *** + epsilon0_bar [5;6;-2] *** t 8 (-2) 9)); + "epsbarepsbar88" >:: (fun () -> equal_evoke (epsilon0 [1;2;-1] *** t 4 3 (-1) *** + epsilon0 [5;6;-2] *** t 8 9 (-2))) ] + + let ff a1 a2 a3 a4 = [ Arrows { coeff = L.int (-1); arrows = A.cycle [a1; a2; a3; a4] }; Arrows { coeff = L.int ( 1); arrows = A.cycle [a2; a1; a3; a4] }; Arrows { coeff = L.int ( 1); arrows = A.cycle [a1; a2; a4; a3] }; Arrows { coeff = L.int (-1); arrows = A.cycle [a2; a1; a4; a3] } ] let tf j i a b = [ Arrows { coeff = L.imag ( 1); arrows = A.chain [i; a; b; j] }; Arrows { coeff = L.imag (-1); arrows = A.chain [i; b; a; j] } ] let suite_ff = "f*f" >::: [ "1" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f (-1) 3 4)); "2" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f 3 4 (-1))); "3" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f 4 (-1) 3)) ] let suite_tf = "t*f" >::: [ "1" >:: (fun () -> equal (tf 1 2 3 4) (t (-1) 1 2 *** f (-1) 3 4)) ] (* \thocwmodulesubsection{Completeness Relation} *) (* Check the completeness relation corresponding to $q\bar q$-scattering: \begin{equation} \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFourAmp \fmflabel{$i$}{i2} \fmflabel{$j$}{i1} \fmflabel{$k$}{o1} \fmflabel{$l$}{o2} \fmf{fermion}{i1,v1,i2} \fmf{fermion}{o2,v2,o1} \fmf{gluon}{v1,v2} \end{fmfgraph*}}} = \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFourAmp \fmflabel{$i$}{i2} \fmflabel{$j$}{i1} \fmflabel{$k$}{o1} \fmflabel{$l$}{o2} \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v1, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{reverse vpath (__v1, __v2) sideways -thick} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join (vpath (__v1, __v2) sideways -thick) join vpath (__v2, __o1)} \fmfi{plain}{vpath (__o2, __v2) join (reverse vpath (__v1, __v2) sideways -thick) join vpath (__v1, __i2)} \end{fmfgraph*}}} + \parbox{38\unitlength}{% \fmfframe(4,2)(4,4){% \begin{fmfgraph*}(30,20) \setupFourAmp \fmflabel{$i$}{i2} \fmflabel{$j$}{i1} \fmflabel{$k$}{o1} \fmflabel{$l$}{o2} \fmfi{phantom_arrow}{vpath (__i1, __v1)} \fmfi{phantom_arrow}{vpath (__v2, __o1)} \fmfi{phantom_arrow}{vpath (__o2, __v2)} \fmfi{phantom_arrow}{vpath (__v1, __i2)} \fmfi{plain}{vpath (__i1, __v1) join vpath (__v1, __i2)} \fmfi{plain}{vpath (__o2, __v2) join vpath (__v2, __o1)} \fmfi{dots,label=$-1/N_C$}{vpath (__v1, __v2)} \end{fmfgraph*}}} \end{equation} *) (* $T_{a}^{ij} T_{a}^{kl}$ *) let tt i j k l = t (-1) i j *** t (-1) k l (* $ \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *) let tt_expected i j k l = - [ Arrows { coeff = L.int 1; arrows = [l => i; j => k] }; + [ Arrows { coeff = L.unit; arrows = [l => i; j => k] }; Arrows { coeff = L.over_nc (-1); arrows = [j => i; l => k] }] let suite_tt = "t*t" >::: [ "1" >:: (* $T_{a}^{ij} T_{a}^{kl} = \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *) (fun () -> equal (tt_expected 1 2 3 4) (tt 1 2 3 4)) ] (* \thocwmodulesubsection{Lie Algebra} *) (* Check the commutation relations $[T_a,T_b]=\ii f_{abc} T_c$ in various representations. *) - let lie_algebra_id rep_t = + let lie_algebra_id _rep_t = let lhs = imag *** f 1 2 (-1) *** t (-1) 3 4 and rhs = commutator t (-1) 1 2 3 4 in equal lhs rhs (* Check the normalization of the structure consistants $\mathcal{N} f_{abc} = - \ii \tr(T_a[T_b,T_c])$ *) let f_of_rep_id norm rep_t = let lhs = norm *** f 1 2 3 and rhs = f_of_rep rep_t 1 2 3 in equal lhs rhs (* \begin{dubious} Are the normalization factors for the traces of the higher dimensional representations correct? \end{dubious} *) (* \begin{dubious} The traces don't work for the symmetrized generators that we need elsewhere! \end{dubious} *) let suite_lie = "Lie algebra relations" >::: [ "[t,t]=ift" >:: (fun () -> lie_algebra_id t); "[t8,t8]=ift8" >:: (fun () -> lie_algebra_id t8); "[t6,t6]=ift6" >:: (fun () -> lie_algebra_id t6); "[t10,t10]=ift10" >:: (fun () -> lie_algebra_id t10); "[t15,t15]=ift15" >:: (fun () -> lie_algebra_id t15); "[t3bar,t3bar]=ift3bar" >:: (fun () -> lie_algebra_id t3bar); "[tSAS,tSAS]=iftSAS" >:: (fun () -> lie_algebra_id t_SAS); "[tASA,tASA]=iftASA" >:: (fun () -> lie_algebra_id t_ASA); "[t6,t6]=ift6'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 2)); "[t10,t10]=ift10'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 3)); "[t15,t15]=ift15'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 4)); "[t6,t6]=ift6''" >:: (fun () -> lie_algebra_id t6_trivial); "[t10,t10]=ift10''" >:: (fun () -> lie_algebra_id t10_trivial); "[t15,t15]=ift15''" >:: (fun () -> lie_algebra_id t15_trivial); "if = tr(t[t,t])" >:: (fun () -> f_of_rep_id one t); "2n*if = tr(t8[t8,t8])" >:: (fun () -> f_of_rep_id (two *** nc) t8); "n*if = tr(t6[t6,t6])" >:: (fun () -> f_of_rep_id nc t6_trivial); "n^2*if = tr(t10[t10,t10])" >:: (fun () -> f_of_rep_id (nc *** nc) t10_trivial); "n^3*if = tr(t15[t15,t15])" >:: (fun () -> f_of_rep_id (nc *** nc *** nc) t15_trivial) ] (* \thocwmodulesubsection{Ward Identities} *) (* Testing the color part of basic Ward identities is essentially the same as testing the Lie algebra equations above, but with generators sandwiched between propagators, as in Feynman diagrams, where the relative signs come from the kinematic part of the diagrams after applying the equations of motion.. *) (* First the diagram with the three gluon vertex $\ii f_{abc} D_{cd}^{\text{gluon}} D^{ik} T_d^{kl} D^{lj}$ *) let ward_ft rep_t rep_d a b i j = imag *** f a b (-11) *** gluon (-11) (-12) *** rep_d i (-1) *** rep_t (-12) (-1) (-2) *** rep_d (-2) j (* then one diagram with two gauge couplings $D^{ik} T_c^{kl} D^{lm} T_c^{mn} D^{nj}$ *) let ward_tt1 rep_t rep_d a b i j = rep_d i (-1) *** rep_t a (-1) (-2) *** rep_d (-2) (-3) *** rep_t b (-3) (-4) *** rep_d (-4) j (* finally the difference of exchanged orders: $D^{ik} T_a^{kl} D^{lm} T_b^{mn} D^{nj} -D^{ik} T_b^{kl} D^{lm} T_a^{mn} D^{nj}$ *) let ward_tt rep_t rep_d a b i j = ward_tt1 rep_t rep_d a b i j --- ward_tt1 rep_t rep_d b a i j (* \begin{dubious} The optional [~fudge] factor was used for debugging normalizations. \end{dubious} *) let ward_id ?(fudge=one) rep_t rep_d = let lhs = ward_ft rep_t rep_d 1 2 3 4 and rhs = ward_tt rep_t rep_d 1 2 3 4 in equal lhs (fudge *** rhs) let suite_ward = "Ward identities" >::: [ "fund." >:: (fun () -> ward_id t delta3); "adj." >:: (fun () -> ward_id t8 delta8); "S2" >:: (fun () -> ward_id t6 delta6); "S3" >:: (fun () -> ward_id t10 delta10); "A2" >:: (fun () -> ward_id t3bar delta3bar); "A3" >:: (fun () -> ward_id (t_A 3) (delta_A 3)); "SAS" >:: (fun () -> ward_id t_SAS delta_SAS); "ASA" >:: (fun () -> ward_id t_ASA delta_ASA); "S2'" >:: (fun () -> ward_id ~fudge:two t6_trivial delta6); "S3'" >:: (fun () -> ward_id ~fudge:(int 3) t10_trivial delta10) ] let suite_ward_long = "Ward identities" >::: [ "S4" >:: (fun () -> ward_id t15 delta15); "S4'" >:: (fun () -> ward_id ~fudge:(int 4) t15_trivial delta15) ] (* \thocwmodulesubsection{Jacobi Identities} *) (* $T_aT_bT_c$ *) let prod3 rep_t a b c i j = rep_t a i (-1) *** rep_t b (-1) (-2) *** rep_t c (-2) j (* $[T_a,[T_b,T_c]]$ *) let jacobi1 rep_t a b c i j = (prod3 rep_t a b c i j --- prod3 rep_t a c b i j) --- (prod3 rep_t b c a i j --- prod3 rep_t c b a i j) (* sum of cyclic permutations of $[T_a,[T_b,T_c]]$ *) let jacobi rep_t = sum [jacobi1 rep_t 1 2 3 4 5; jacobi1 rep_t 2 3 1 4 5; jacobi1 rep_t 3 1 2 4 5] let jacobi_id rep_t = assert_zero_vertex (jacobi rep_t) let suite_jacobi = "Jacobi identities" >::: [ "fund." >:: (fun () -> jacobi_id t); "adj." >:: (fun () -> jacobi_id f); "S2" >:: (fun () -> jacobi_id t6); "S3" >:: (fun () -> jacobi_id t10); "A2" >:: (fun () -> jacobi_id (t_A 2)); "A3" >:: (fun () -> jacobi_id (t_A 3)); "SAS" >:: (fun () -> jacobi_id t_SAS); "ASA" >:: (fun () -> jacobi_id t_ASA); "S2'" >:: (fun () -> jacobi_id t6_trivial); "S3'" >:: (fun () -> jacobi_id t10_trivial) ] let suite_jacobi_long = "Jacobi identities" >::: [ "S4" >:: (fun () -> jacobi_id t15); "S4'" >:: (fun () -> jacobi_id t15_trivial) ] (* \thocwmodulesubsection{Casimir Operators} \label{pg:casimir-tests} *) (* We can read of the eigenvalues of the Casimir operators for the adjoint, totally symmetric and totally antisymmetric representations of~$\mathrm{SU}(N)$ from table~II of \texttt{hep-ph/0611341} \begin{subequations} \begin{align} C_2(\text{adj}) &= 2N \\ C_2(S_n) &= \frac{n(N-1)(N+n)}{N} \\ \label{eq:C_2(A_n)} C_2(A_n) &= \frac{n(N-n)(N+1)}{N} \end{align} \end{subequations} adjusted for our normalization. Also from \texttt{arxiv:1912.13302} \begin{equation} C_3(S_1) =(N^2-1)(N^2-4)/N^2=\frac{N_C^4-5N_C^2+4}{N_C^2} \end{equation} *) (* Building blocks $n/N_C$ and $N_C+n$ *) let n_over_nc n = const (L.ints [ (n, -1) ]) let nc_plus n = const (L.ints [ (1, 1); (n,0) ]) (* $C_2(S_n) = n/N_C(N_C-1)(N_C+n)$ *) let c2_S n = n_over_nc n *** nc_plus (-1) *** nc_plus n (* $C_2(A_n) = n/N_C(N_C-n)(N_C+1)$ *) let c2_A n = n_over_nc n *** nc_plus (-n) *** nc_plus 1 let casimir_tt i j = c2_S 1 *** delta3 i j let casimir_t6t6 i j = c2_S 2 *** delta6 i j let casimir_t10t10 i j = c2_S 3 *** delta10 i j let casimir_t15t15 i j = c2_S 4 *** delta15 i j let casimir_t3bart3bar i j = c2_A 2 *** delta3bar i j let casimir_tA3tA3 i j = c2_A 3 *** delta_A 3 i j (* $C_2(\text{adj})=2N_C$ *) let ca = L.ints [(2, 1)] let casimir_ff a b = - [ Arrows { coeff = ca; arrows = 1 <=> 2 }; - Arrows { coeff = L.int (-2); arrows = [1=>1; 2=>2] }] + [ Arrows { coeff = ca; arrows = a <=> b }; + Arrows { coeff = L.int (-2); arrows = [a=>a; b=>b] }] (* $C_3(S_1)=N_C^2-5+4/N_C^2$ *) let c3f = L.ints [(1, 2); (-5, 0); (4, -2)] let casimir_ttt i j = const c3f *** delta3 i j let suite_casimir = "Casimir operators" >::: [ "t*t" >:: (fun () -> equal (casimir_tt 1 2) (t (-1) 1 (-2) *** t (-1) (-2) 2)); "t*t*t" >:: (fun () -> equal (casimir_ttt 1 2) (d (-1) (-2) (-3) *** t (-1) 1 (-4) *** t (-2) (-4) (-5) *** t (-3) (-5) 2)); "f*f" >:: (fun () -> equal (casimir_ff 1 2) (minus *** f (-1) 1 (-2) *** f (-1) (-2) 2)); "t6*t6" >:: (fun () -> equal (casimir_t6t6 1 2) (t6 (-1) 1 (-2) *** t6 (-1) (-2) 2)); "t3bar*t3bar" >:: (fun () -> equal (casimir_t3bart3bar 1 2) (t3bar (-1) 1 (-2) *** t3bar (-1) (-2) 2)); "tA3*tA3" >:: (fun () -> equal (casimir_tA3tA3 1 2) (t_A 3 (-1) 1 (-2) *** t_A 3 (-1) (-2) 2)); "t_SAS*t_SAS" >:: (fun () -> equal (const (L.ints [(3,1); (-9,-1)]) *** delta_SAS 1 2) (t_SAS (-1) 1 (-2) *** t_SAS (-1) (-2) 2)); "t_ASA*t_ASA" >:: (fun () -> equal (const (L.ints [(3,1); (-9,-1)]) *** delta_ASA 1 2) (t_ASA (-1) 1 (-2) *** t_ASA (-1) (-2) 2)); "t10*t10" >:: (fun () -> equal (casimir_t10t10 1 2) (t10 (-1) 1 (-2) *** t10 (-1) (-2) 2)) ] let suite_casimir_long = "Casimir operators" >::: [ "t15*t15" >:: (fun () -> equal (casimir_t15t15 1 2) (t15 (-1) 1 (-2) *** t15 (-1) (-2) 2)) ] (* \thocwmodulesubsection{Color Sums} *) let suite_colorsums = "(squared) color sums" >::: [ "gluon normalization" >:: (fun () -> equal (delta8 1 2) (delta8 1 (-1) *** gluon (-1) (-2) *** delta8 (-2) 2)); "f*f" >:: (fun () -> let sum_ff = multiply [ f (-11) (-12) (-13); f (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] and expected = ints [(2, 3); (-2, 1)] in equal expected sum_ff); "d*d" >:: (fun () -> let sum_dd = multiply [ d (-11) (-12) (-13); d (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] and expected = ints [(2, 3); (-10, 1); (8, -1)] in equal expected sum_dd); "f*d" >:: (fun () -> let sum_fd = multiply [ f (-11) (-12) (-13); d (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] in assert_zero_vertex sum_fd); "Hgg" >:: (fun () -> let sum_hgg = multiply [ delta8_loop (-11) (-12); delta8_loop (-21) (-22); gluon (-11) (-21); gluon (-12) (-22) ] and expected = ints [(1, 2); (-1, 0)] in equal expected sum_hgg) ] + (* \thocwmodulesubsection{Sextet Clebsh-Gordans} *) + + let suite_k6 = + "k6/k6bar" >::: + + [ "k6bar*k6" >:: (fun () -> equal (delta6 2 1) (k6bar 1 (-1) (-2) *** k6 2 (-1) (-2))); + "k6*k6bar" >:: (fun () -> equal + ((delta3 3 1 *** delta3 4 2 +++ delta3 4 1 *** delta3 3 2)) + (two *** k6 (-1) 1 2 *** k6bar (-1) 3 4)) ] + let suite = "SU3" >::: [suite_sum; suite_diff; suite_times; suite_normalization; suite_symmetrization; suite_ghosts; + suite_evoke; suite_propagators; suite_trace; suite_ff; suite_tf; suite_tt; suite_lie; suite_ward; suite_jacobi; suite_casimir; - suite_colorsums] + suite_colorsums; + suite_k6] let suite_long = "SU3 long" >::: [suite_ward_long; suite_jacobi_long; suite_casimir_long] end Index: trunk/omega/src/momentum.mli =================================================================== --- trunk/omega/src/momentum.mli (revision 8919) +++ trunk/omega/src/momentum.mli (revision 8920) @@ -1,235 +1,227 @@ (* momentum.mli -- Copyright (C) 1999-2024 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. *) (* Model the finite combinations \begin{equation} p = \sum_{n=1}^k c_k \bar p_n,\qquad \text{(with $c_k\in\{0,1\}$)} \end{equation} of~$n_{\text{in}}$ incoming and~$k-n_{\text{in}}$ outgoing momenta~$p_n$ \begin{equation} \bar p_n = \begin{cases} - p_n & \text{for $1\le n \le n_{\text{in}}$} \\ p_n & \text{for $n_{\text{in}}+1\le n\le k$} \end{cases} \end{equation} where momentum is conserved \begin{equation} \sum_{n=1}^k \bar p_n = 0 \end{equation} below, we need the notion of `rank' and `dimension': \begin{subequations} \begin{align} \text{\ocwlowerid{dim}} (p) &= k \\ \text{\ocwlowerid{rank}} (p) &= \sum_{n=1}^{k} c_k \end{align} \end{subequations} where `dimension' is \emph{not} the dimension of the underlying space-time, of course. *) module type T = sig type t (* Constructor: $(k,N)\to p = \sum_{n\in N} \bar p_n$ and $k=\text{\ocwlowerid{dim}}(p)$ is the \emph{overall} number of independent momenta, while $\text{\ocwlowerid{rank}}(p)=|N|$ is the number of momenta in~$p$. It would be possible to fix~[dim] as a functor argument instead. This might be slightly faster and allow a few more compile time checks, but would be much more tedious to use, since the number of particles will be chosen at runtime. *) val of_ints : int -> int list -> t (* No two indices may be the same. Implementions of [of_ints] can either raise the exception [Duplicate] or ignore the duplicate, but implementations of [add] are required to raise [Duplicate]. *) exception Duplicate of int (* Raise [Range] iff $n>k$: *) exception Range of int (* Binary oparations require that both momenta have the same dimension. [Mismatch] is raised if this condition is violated. *) exception Mismatch of string * t * t (* [Negative] is raised if the result of [sub] is undefined. *) exception Negative (* The inverses of the constructor (we have [rank p = List.length (to_ints p)], but [rank] might be more efficient): *) val to_ints : t -> int list val dim : t -> int val rank : t -> int (* Shortcuts: [singleton d p = of_ints d [p]] and [zero d = of_ints d []]: *) val singleton : int -> int -> t val zero : int -> t (* An arbitrary total order, with the condition $\text{\ocwlowerid{rank}}(p_1)<\text{\ocwlowerid{rank}}(p_2) \Rightarrow p_1 t -> int (* Use momentum conservation to construct the negative momentum with positive coefficients: *) val neg : t -> t (* Return the momentum or its negative, whichever has the lower rank. NB: the present implementation does \emph{not} guarantee that \begin{equation} \text{abs} p = \text{abs} q \Longleftrightarrow p = p \lor p = - q \end{equation} for momenta with $\text{rank} = \text{dim}/2$. *) val abs : t -> t (* Add and subtract momenta. This can fail, since the coefficients~$c_k$ must me either~$0$ or~$1$. *) val add : t -> t -> t val sub : t -> t -> t (* Once more, but not raising exceptions this time: *) val try_add : t -> t -> t option val try_sub : t -> t -> t option (* \emph{Not} the total order provided by [compare], but set inclusion of non-zero coefficients instead: *) val less : t -> t -> bool val lesseq : t -> t -> bool (* $p_1 + (\pm p_2) + (\pm p_3) = 0$ *) val try_fusion : t -> t -> t -> (bool * bool) option (* A textual representation for debugging: *) val to_string : t -> string (* [split i n p] splits~$\bar p_i$ into~$n$ momenta~$\bar p_i \to \bar p_i + \bar p_{i+1} + \ldots + \bar p_{i+n-1}$ and makes room via~$\bar p_{j>i} \to \bar p_{j+n-1}$. This is used for implementating cascade decays, like combining \begin{subequations} \begin{align} \mathrm{e}^+(p_1) \mathrm{e}^-(p_2) \to &\mathrm{W}^-(p_3) \nu_{\mathrm{e}}(p_4) \mathrm{e}^+(p_5)\\ &\mathrm{W}^-(p_3)\to \mathrm{d}(p_3') \bar{\mathrm{u}}(p_4') \end{align} \end{subequations} to \begin{equation} \mathrm{e}^+(p_1) \mathrm{e}^-(p_2) \to \mathrm{d}(p_3) \bar{\mathrm{u}}(p_4) \nu_{\mathrm{e}}(p_5) \mathrm{e}^+(p_6) \end{equation} in narrow width approximation for the~$\mathrm{W}^-$. *) val split : int -> int -> t -> t (* \thocwmodulesection{Scattering Kinematics} From here on, we assume scattering kinematics $\{1,2\}\to\{3,4,\ldots\}$, i.\,e.~$n_{\text{in}}=2$. \begin{dubious} Since functions like [timelike] can be used for decays as well (in which case they must \emph{always} return [true], the representation---and consequently the constructors---should be extended by a flag discriminating between the two cases! \end{dubious} *) module Scattering : sig (* Test if the momentum is an incoming one: $p=\bar p_1\lor p=\bar p_2$ *) val incoming : t -> bool (* $p=\bar p_3\lor p=\bar p_4\lor \ldots$ *) val outgoing : t -> bool (* $p^2 \ge 0$. NB: \textit{par abus de langange}, we report the incoming individual momenta as spacelike, instead as timelike. This will be useful for phasespace constructions below. *) val timelike : t -> bool (* $p^2 \le 0$. NB: the simple algebraic criterion can be violated for heavy initial state particles. *) val spacelike : t -> bool (* $p = \bar p_1 + \bar p_2$ *) val s_channel_in : t -> bool (* $p = \bar p_3 + \bar p_4 + \ldots + \bar p_n$ *) val s_channel_out : t -> bool (* $p = \bar p_1 + \bar p_2 \lor p = \bar p_3 + \bar p_4 + \ldots + \bar p_n$ *) val s_channel : t -> bool (* $ \bar p_1 + \bar p_2 \to \bar p_3 + \bar p_4 + \ldots + \bar p_n$ *) val flip_s_channel_in : t -> t end (* \thocwmodulesection{Decay Kinematics} *) module Decay : sig (* Test if the momentum is an incoming one: $p=\bar p_1$ *) val incoming : t -> bool (* $p=\bar p_2\lor p=\bar p_3\lor \ldots$ *) val outgoing : t -> bool (* $p^2 \ge 0$. NB: here, we report the incoming individual momenta as timelike. *) val timelike : t -> bool (* $p^2 \le 0$. *) val spacelike : t -> bool end end module Lists : T module Bits : T module Default : T (* Wolfgang's funny tree codes: \begin{equation} (2^n, 2^{n-1}) \to (1, 2, 4, \ldots, 2^{n-2}) \end{equation} *) module type Whizard = sig type t val of_momentum : t -> int val to_momentum : int -> int -> t end module ListsW : Whizard with type t = Lists.t module BitsW : Whizard with type t = Bits.t module DefaultW : Whizard with type t = Default.t - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/fusion.mli =================================================================== --- trunk/omega/src/fusion.mli (revision 8919) +++ trunk/omega/src/fusion.mli (revision 8920) @@ -1,427 +1,428 @@ (* fusion.mli -- Copyright (C) 1999-2024 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{Signature of [Fusion.T]} *) module type T = sig val options : Options.t (* JRR's implementation of Majoranas needs a special case. *) val vintage : bool (* Wavefunctions are an abstract data type, containing a momentum~[p] and additional quantum numbers, collected in~[flavor]. *) type wf (* Return the wave function with the the same momentum and a charge conjugated [flavor]. *) val conjugate : wf -> wf (* Obviously, [flavor] is not restricted to the physical notion of flavor, but can carry spin, color, etc. See the implementation of [Model.T] for the physics. *) type flavor val flavor : wf -> flavor (* If [flavor] contains powers of coupling orders, it is sometimes useful for organizing the output and for diagnostics to be able to strip it away. *) type flavor_all_orders val flavor_all_orders : wf -> flavor_all_orders (* If [flavor] contains $\textrm{SU}(3)$ color, it is sometimes useful for organizing the output and for diagnostics to be able to strip it away. *) type flavor_sans_color val flavor_sans_color : wf -> flavor_sans_color (* Momenta are represented by an abstract datatype (defined in~[Momentum]) that is optimized for performance. They can be accessed either abstractly or as lists of indices of the external momenta. These indices are assigned sequentially by [amplitude] below. *) type p val momentum : wf -> p val momentum_list : wf -> int list (* Coupling constants *) type constant (* and right hand sides of assignments. The latter are formed from a sign from Fermi statistics, a coupling (constand and Lorentz structure) and wave functions of the children. *) type coupling type rhs (* \begin{dubious} There is no deep reason for defining a polymorphic [type 'a children], since we will only ever use [wf children]. \end{dubious} *) type 'a children (* Keep track of statistics. *) val sign : rhs -> int (* Extract the coupling (constant and structure) fusing the children. *) val coupling : rhs -> constant Coupling.t (* In renormalized perturbation theory, couplings come in different orders of the loop expansion. Be prepared: [val order : rhs -> int] *) (* \begin{dubious} The concrete return type [wf list] is here only for the benefit of [Target] and could become [wf children] in a more refined interface \ldots \end{dubious} *) val children : rhs -> wf list (* Fusions come in two types: fusions of wave functions to off-shell wave functions: \begin{equation*} \phi'(p+q) = \phi_1(p)\phi_2(q) \end{equation*} *) type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list (* and products at the keystones: \begin{equation*} \braket{\phi'(-p-q)|\phi_1(p)\phi_2(q)} \end{equation*} *) type braket val bra : braket -> wf val ket : braket -> rhs list (* [amplitude goldstones incoming outgoing] calculates the amplitude for scattering of [incoming] to [outgoing]. If [goldstones] is true, also non-propagating off-shell Goldstone amplitudes are included to allow the checking of Slavnov-Taylor identities. [selectors] is an instance of [Cascade.T.selectors] and used to select certain parts of an amplitude, see section~\ref{sec:cascades}. *) type amplitude type amplitude_sans_color type selectors type slicings val amplitudes : bool -> selectors -> slicings option -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitudes_all_orders : bool -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color (* How a given wave function depends on other wave functions and couplings. This is used for finding subexpressions common among different color flow amplitudes. *) val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t (* We should be precise regarding the semantics of the following functions, since modules implementating [Target] must not make any mistakes interpreting the return values. Instead of calculating the amplitude \begin{subequations} \begin{equation} \label{eq:physical-amplitude} \Braket{f_3,p_3,f_4,p_4,\ldots|T|f_1,p_1,f_2,p_2} \end{equation} directly, O'Mega calculates the---equivalent, but more symmetrical---crossed amplitude \begin{equation} \Braket{\bar f_1,-p_1,\bar f_2,-p_2,f_3,p_3,f_4,p_4,\ldots|T|0} \end{equation} For the benefit of the people implementing [Model]s, however, all flavors are represented internally by the charge conjugates \begin{equation} \label{eq:internal-amplitude} A(f_1,-p_1,f_2,-p_2,\bar f_3,p_3,\bar f_4,p_4,\ldots) \end{equation} \end{subequations} Indeed, the vertex and corresponding term in the lagrangian \begin{equation} \parbox{26\unitlength}{% \fmfframe(5,3)(5,3){% \begin{fmfgraph*}(15,20) \fmfleft{v} \fmfright{p,A,e} \fmflabel{$\mathrm{e}^-$}{e} \fmflabel{$\mathrm{e}^+$}{p} \fmflabel{$\mathrm{A}$}{A} \fmf{fermion}{p,v,e} \fmf{photon}{A,v} \fmfdot{v} \end{fmfgraph*}}}: \bar\psi\fmslash{A}\psi \end{equation} suggests to denote the \emph{outgoing} particle by the flavor of the \emph{anti}particle and the \emph{outgoing} \emph{anti}particle by the flavor of the particle, since this choice allows to represent the vertex by a triple \begin{equation} \bar\psi\fmslash{A}\psi: (\mathrm{e}^+,A,\mathrm{e}^-) \end{equation} which is more intuitive than the alternative $(\mathrm{e}^-,A,\mathrm{e}^+)$. Also, when thinking in terms of building wavefunctions from the outside in, the outgoing \emph{antiparticle} is represented by a \emph{particle} propagator and vice versa\footnote{Even if this choice will appear slightly counter-intuitive on the [Target] side, one must keep in mind that much more people are expected to prepare [Model]s.}. Note that [incoming] and [outgoing] are the physical flavors as in~(\ref{eq:physical-amplitude}) or in the argument of [amplitudes], but with the color flow quantum numbers added. *) val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list (* In contrast, [externals] are flavors and momenta as in~(\ref{eq:internal-amplitude}) *) val externals : amplitude -> wf list (* Return all off-shell wave functions so that [Target] can allocate variables for them. *) val variables : amplitude -> wf list (* Return all [fusion]s in an order so that all right hand sides have been computed before they are used. *) val fusions : amplitude -> fusion list (* Return all [braket]s. *) type 'a slices val brakets : amplitude -> braket list slices (* Test if an off-shell wave function has been forced on-shell or is smeared as as gaussian. *) val on_shell : amplitude -> wf -> bool val is_gauss : amplitude -> wf -> bool (* Describe the constraints in the [selectors] argument to [amplitudes]. *) val constraints : amplitude -> string option (* Human readable description of the requested slicings of type [Orders.Conditions.t] *) val slicings : amplitude -> string list (* Compute the symmetry factor $\prod_i n_i!$ for identical outgoing particles. *) val symmetry : amplitude -> int (* Quickly test whether an amplitude vanishes. *) val allowed : amplitude -> bool (* \thocwmodulesubsection{Diagnostics} *) (* Compute a list of all charge conservation violating vertices in the [Model]. *) val check_charges : unit -> flavor_sans_color list list (* Count the fusions and propagators that are computed and compare to the number of Feynman diagrams appearing in the amplitude. *) val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int (* Expand the [DAG] beneath an off-shell wave function into the corresponding forest. \textit{Use with caution for complicated processes!} *) val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list (* A list of all combinations of off-shell wave functions in the Feynman diagrams described by the [DAG]. This could be used for phase space mappings, but lies dormant at the moment. \begin{dubious} At the moment, the result contains empty lists and many redundancies. This should be cleaned up! \end{dubious} *) val poles : amplitude -> wf list list (* A list of all $s$-channel poles in the [DAG]. Helpful for phase space mappings and for fudging widths. *) val s_channel : amplitude -> wf list (* Prepare \texttt{.dot} files as input fot \texttt{graphviz} to draw graphical representations of the tower of of-shell wavefunctions and the dag corresponding to the amplitude. *) val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit (* \thocwmodulesubsection{WHIZARD} *) (* Phase space descriptions for \texttt{WHIZARD}. Once as written and once with the incoming particles exchanged. This way we can write a tree starting from the first and one from the second incoming particle. *) val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end (* \thocwmodulesection{Various Functors generating [Fusion.T]} *) (* There is more than one way to make fusions, differing in the unterlying topology of diagrams. *) module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Orders.Slice(Colorize.It(M)).flavor and type flavor_all_orders = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list (*i If we want or need to expose [Make], here's how to do it: module type Stat = sig type flavor type stat exception Impossible val stat : flavor -> int -> stat val stat_fuse : stat -> stat -> flavor -> stat val stat_sign : stat -> int end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor module Make : functor (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) -> Maker i*) (* Straightforward Dirac fermions vs. slightly more complicated Majorana fermions: *) exception Majorana module Binary : Maker module Binary_Majorana : Maker module Mixed23 : Maker module Mixed23_Majorana : Maker module Nary : functor (B : Tuple.Bound) -> Maker module Nary_Majorana : functor (B : Tuple.Bound) -> Maker (* We can also proceed \'a la~\cite{HELAC:2000}. Empirically, this will use slightly~($O(10\%)$) fewer fusions than the symmetric factorization. Our implementation uses significantly~($O(50\%)$) fewer fusions than reported by~\cite{HELAC:2000}. Our pruning of the DAG might be responsible for this. *) module Helac_Binary : Maker module Helac_Binary_Majorana : Maker module Helac_Mixed23 : Maker module Helac_Mixed23_Majorana : Maker module Helac : functor (B : Tuple.Bound) -> Maker module Helac_Majorana : functor (B : Tuple.Bound) -> Maker (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type selectors type slicings type coupling_order type amplitudes (* Construct all possible color flow amplitudes for a given process. *) val amplitudes : bool -> int option -> selectors -> slicings option -> process list -> amplitudes val empty : amplitudes (* The list of all combinations of incoming and outgoing particles with a nonvanishing scattering amplitude. *) val flavors : amplitudes -> process list (* The list of all combinations of incoming and outgoing particles that don't lead to any color flow with non vanishing scattering amplitude. *) val vanishing_flavors : amplitudes -> process list (* The list of all color flows with a nonvanishing scattering amplitude. *) val color_flows : amplitudes -> Color.Flow.t list (* The coupling orders that are not summed over and their powers. *) val coupling_orders : amplitudes -> (coupling_order list * int list list) option (* The list of all valid helicity combinations. *) val helicities : amplitudes -> (int list * int list) list (* The list of all amplitudes. *) val processes : amplitudes -> amplitude list (* [(process_table a).(f).(c)] returns the amplitude for the [f]th allowed flavor combination and the [c]th allowed color flow as an [amplitude option]. *) val process_table : amplitudes -> amplitude option array array (* [(process_table a).(co).(f).(c)] returns the amplitude for - the [o]th set of coupling orders, the [f]th + the [co]th set of coupling orders, the [f]th allowed flavor combination and the [c]th allowed color flow as an [amplitude option]. *) - val process_table_new : amplitudes -> amplitude option array array array + val process_table_new : + amplitudes -> ((coupling_order * int) list * amplitude) option array array array (* The list of all non redundant fusions together with the amplitudes they came from. *) val fusions : amplitudes -> (fusion * amplitude) list (* If there's more than external flavor state, the wavefunctions are \emph{not} uniquely specified by [flavor] and [Momentum.t]. This function can be used to determine how many variables must be allocated. *) val multiplicity : amplitudes -> wf -> int (* This function can be used to disambiguate wavefunctions with the same combination of [flavor] and [Momentum.t]. *) val dictionary : amplitudes -> amplitude -> wf -> int (* [(color_factors a).(c1).(c2)] power of~$N_C$ for the given product of color flows. *) val color_factors : amplitudes -> Color.Flow.factor array array (* A description of optional diagram selectors. *) val constraints : amplitudes -> string option (* Human readable description of the requested slicings of type [Orders.Conditions.t]. *) val slicings : amplitudes -> string list end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t and type coupling_order = Orders.Slice(Colorize.It(M)).coupling_order module Multi : Multi_Maker Index: trunk/omega/src/UFOx.mli =================================================================== --- trunk/omega/src/UFOx.mli (revision 8919) +++ trunk/omega/src/UFOx.mli (revision 8920) @@ -1,255 +1,320 @@ (* vertex.mli -- Copyright (C) 1999-2024 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module Expr : sig type t val of_string : string -> t val of_strings : string list -> t val substitute : string -> t -> t -> t val rename : (string * string) list -> t -> t val map_names : (string -> string) -> t -> t val half : string -> t val variables : t -> Sets.String_Caseless.t val functions : t -> Sets.String_Caseless.t end module Value : sig type t val of_expr : Expr.t -> t val to_string : t -> string val to_coupling : (string -> 'b) -> t -> 'b Coupling.expr end (* \begin{dubious} UFO represents rank-2 indices $(i,j)$ as $1000\cdot j + i$. This should be replaced by a proper union type eventually. Unfortunately, this requires many changes in the [Atom]s in [UFOx]. Therefore, we try a quick'n'dirty proof of principle first. \end{dubious} *) module type Index = sig type t = int val position : t -> int val factor : t -> int val unpack : t -> int * int val pack : int -> int -> t val map_position : (int -> int) -> t -> t val to_string : t -> string val list_to_string : t list -> string (* Indices are represented by a pair [int * 'r], where ['r] denotes the representation the index belongs to. *) (* [free indices] returns all free indices in the list [indices], i.\,e.~all positive indices. *) val free : (t * 'r) list -> (t * 'r) list (* [summation indices] returns all summation indices in the list [indices], i.\,e.~all negative indices. *) val summation : (t * 'r) list -> (t * 'r) list val classes_to_string : ('r -> string) -> (t * 'r) list -> string (* Generate summation indices, starting from~$-1001$. TODO: check that there are no clashes with explicitely named indices. *) val fresh_summation : unit -> t val named_summation : string -> unit -> t end module Index : Index module type Tensor = sig type atom (* A tensor is a linear combination of products of [atom]s with rational coefficients. The following could be refined by introducing [scalar] atoms and restricting the denominators to [(scalar list * Algebra.QC.t) list]. At the moment, this restriction is implemented dynamically by [of_expr] and not statically in the type system. Polymorphic variants appear to be the right tool, either directly or as phantom types. However, this is certainly only \textit{nice-to-have} and is not essential. *) type 'a linear = ('a list * Algebra.QC.t) list type t = | Linear of atom linear | Ratios of (atom linear * atom linear) list (* We might need to replace atoms if the syntax is not context free. *) val map_atoms : (atom -> atom) -> t -> t (* We need to rename indices to implement permutations \ldots *) val map_indices : (int -> int) -> t -> t (* \ldots{} but in order to to clean up inconsistencies in the syntax of \texttt{lorentz.py} and \texttt{propagators.py} we also need to rename indices without touching the second argument of \texttt{P}, the argument of \texttt{Mass} etc. *) val rename_indices : (int -> int) -> t -> t (* We need scale coefficients. *) val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t (* Try to contract adjacent pairs of [atoms] as allowed but [Atom.contract_pair]. This is not exhaustive, but helps a lot with invariant squares of momenta in applications of [Lorentz]. *) val contract_pairs : t -> t (* The list of variable referenced in the tensor expression, that will need to be imported by the numerical code. *) val variables : t -> string list (* Parsing and unparsing. Lists of [string]s are interpreted as sums. *) val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string (* The supported representations. *) type r val classify_indices : t -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r val rep_conjugate : r -> r val rep_trivial : r -> bool (* There is not a 1-to-1 mapping between the representations in the model files and the representations used by O'Mega, e.\,g.~in [Coupling.lorentz]. We might need to use heuristics. *) type r_omega val omega : r -> r_omega end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val rename_indices : (int -> int) -> t -> t val contract_pair : t -> t -> t option val variable : t -> string option val scalar : t -> bool val is_unit : t -> bool val invertible : t -> bool val invert : t -> t val of_expr : string -> UFOx_syntax.expr list -> t list val to_string : t -> string type r val classify_indices : t list -> (int * r) list val disambiguate_indices : t list -> t list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end +(* Copied verbatim from~\cite{Darme:2023jdn}: + \begin{quote} + \textit{Elementary spin tensors that can be used to construct + the elements of the spin basis relevant to a given UFO vertex. + Spin and Lorentz indices are respectively denoted as $s$ and $\mu$.} + \end{quote} + \begin{center} + \begin{tabular}{rl} + \label{pg:UFO-Lorentz} + UFO spin tensor & Description\\ + \hline + \verb+Identity(1,2)+ & (Spinorial) Kronecker delta $\delta_{s_1s_2}$\\ + \verb+IdentityL(1,2)+ & (Lorentz) Kronecker delta $\delta^{\mu_1}_{\mu_2}$\\ + \verb+Gamma(1,2,3)+ & Dirac matrix $(\gamma^{\mu_1})_{s_2s_3}$\\ + \verb+Gamma5(1,2)+ & Fifth Dirac matrix $(\gamma^5)_{s_1s_2}$\\ + \verb+ProjM(1,2)+ & Left chirality projector $(\frac{1-\gamma_5}{2})_{s_1s_2}$\\ + \verb+ProjP(1,2)+ & Right chirality projector $(\frac{1+\gamma_5}{2})_{s_1s_2}$\\ + \verb+Sigma(1,2,3,4)+ & Sigma matrix $(\sigma^{\mu_1\mu_2})_{s_1s_2}$\\ + \verb+C(1,2)+ & Charge conjugation matrix $C_{s_1s_2}$\\ + \verb+Metric(1,2)+ & Minkowski metric $\eta^{\mu_1\mu_2}$\\ + \verb+P(1,i)+ & Incoming momentum of the $i^{\rm th}$ particle $p_i^{\mu_1}$\\ + \verb+Epsilon(1,2,3,4)+ & Levi-Civita tensor $\epsilon^{\mu_1\mu_2\mu_3\mu_4}$ (with $\epsilon_{0123}=-\epsilon^{0123}=1$) + \end{tabular} + \end{center} *) + module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type scalar = (* private *) | Mass of int | Width of int | P2 of int | P12 of int * int | Variable of string | Coeff of Value.t type t = (* private *) | Dirac of dirac | Vector of vector | Scalar of scalar | Inverse of scalar val map_indices_scalar : (int -> int) -> scalar -> scalar val map_indices_vector : (int -> int) -> vector -> vector val rename_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom : Lorentz_Atom module Lorentz : Tensor with type atom = Lorentz_Atom.t and type r_omega = Coupling.lorentz +(* Copied verbatim from~\cite{Darme:2023jdn} to explain the notation + \begin{quote} + \textit{Elementary colour tensors that can be used to construct the elements of the + colour basis relevant for a given UFO vertex. Fundamental, sextet, antifundamental + and antisextet colour indices are denoted as $i$, $\alpha$, $\bar \imath$ and + $\bar\alpha$, whilst $a$ denotes an adjoint colour index.} + \end{quote} + Note that~\cite{Ohl:2024fpq} has a different mnemonic for~$\epsilon$: there~$\epsilon_{ijk}$ + is written~$\overline{\epsilon}_{ijk}$, while~$\epsilon^{{\bar i}{\bar j}{\bar k}}$ + is written~$\epsilon^{ijk}$. In other words, in~\cite{Ohl:2024fpq} all barred objects + have the triplet indices on the bottom. Here, as described in sections~\ref{sec:arrow}, + \ref{sec:birdtracks} and~\ref{sec:su3}, the mnemonic is as in~\cite{Darme:2023jdn}. + \begin{dubious} + But cross-check with [classify_indices] on page~\pageref{pg:classify-indices} + again! + \end{dubious} + \begin{center} + \begin{tabular}{rl} + \label{pg:UFO-Color} + UFO colour tensor & Description\\ + \hline + \verb+1+ & Trivial tensor (for non-coloured particles)\\ + \verb+Identity(2,1)+ & Kronecker delta $\delta^{\bar \imath_2}{}_{i_1}$, $\delta^{a_2a_1}$, or $\delta^{\bar \alpha_2}{}_{\alpha_1}$\\ + \verb+T(1,2,3)+ & Fundamental representation matrix + $(T^{a_1})^{\bar \imath_3}{}_{i_2}$\\ + \verb+f(1,2,3)+ & Antisymmetric structure constant $f^{a_1a_2a_3}$\\ + \verb+d(1,2,3)+ & Symmetric structure constant $d^{a_1a_2a_3}$\\ + \verb+Epsilon(1,2,3)+ & Fundamental Levi-Civita tensor + $\epsilon_{i_1i_2i_3}$\\ + \verb+EpsilonBar(1,2,3)+ & Antifundamental Levi-Civita tensor + $\epsilon^{{\bar \imath_1}{\bar \imath_2}{\bar \imath_3}}$\\ + \verb+T6(1,2,3)+ & Sextet representation matrix + $(T_6^{a_1})^{\bar \alpha_3}{}_{\alpha_2}$\\ + \verb+K6(1,2,3)+ & Sextet Clebsch-Gordan coefficient + $(K_6)^{{\bar \imath_2}{\bar \imath_3}}{}_{\alpha_1}$\\ + \verb+K6Bar(1,2,3)+ & Antisextet Clebsch-Gordan coefficient + $(\overline K_6)^{\bar \alpha_1}{}_{i_2i_3}$ + \end{tabular} + \end{center} *) + module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | Delta of int Young.tableau * int * int | T of int * int * int | TY of int Young.tableau * int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom : Color_Atom module Color : Tensor with type atom = Color_Atom.t and type r_omega = Color.t module type Test = sig val suite : OUnit.test end module Test : Test Index: trunk/omega/src/DAG.ml =================================================================== --- trunk/omega/src/DAG.ml (revision 8919) +++ trunk/omega/src/DAG.ml (revision 8920) @@ -1,641 +1,642 @@ (* DAG.ml -- Copyright (C) 1999-2024 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 Ord = sig type t val compare : t -> t -> int end module type Forest = sig module Nodes : Ord type node = Nodes.t type edge type children type t = edge * children val compare : t -> t -> int val for_all : (node -> bool) -> t -> bool val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a end module type T = sig type node type edge type children type t val empty : t val add_node : node -> t -> t val add_offspring : node -> edge * children -> t -> t exception Cycle val add_offspring_unsafe : node -> edge * children -> t -> t val is_node : node -> t -> bool val is_sterile : node -> t -> bool val is_offspring : node -> edge * children -> t -> bool val iter_nodes : (node -> unit) -> t -> unit val map_nodes : (node -> node) -> t -> t val fold_nodes : (node -> 'a -> 'a) -> t -> 'a -> 'a val iter : (node -> edge * children -> unit) -> t -> unit val map : (node -> node) -> (node -> edge * children -> edge * children) -> t -> t val fold : (node -> edge * children -> 'a -> 'a) -> t -> 'a -> 'a val lists : t -> (node * (edge * children) list) list val dependencies : t -> node -> (node, edge) Tree2.t val harvest : t -> node -> t -> t val harvest_list : t -> node list -> t val size : t -> int val eval : (node -> 'a) -> (node -> edge -> 'c -> 'd) -> ('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a val eval_memoized : (node -> 'a) -> (node -> edge -> 'c -> 'd) -> ('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a val forest : node -> t -> (node * edge option, node) Tree.t list val forest_memoized : node -> t -> (node * edge option, node) Tree.t list val count_trees : node -> t -> int end module type Graded_Ord = sig include Ord module G : Ord val rank : t -> G.t end module type Grader = functor (O : Ord) -> Graded_Ord with type t = O.t module type Graded_Forest = sig module Nodes : Graded_Ord type node = Nodes.t type edge type children type t = edge * children val compare : t -> t -> int val for_all : (node -> bool) -> t -> bool val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a end module type Forest_Grader = functor (G : Grader) -> functor (F : Forest) -> Graded_Forest with type Nodes.t = F.node and type node = F.node and type edge = F.edge and type children = F.children and type t = F.t (* \thocwmodulesection{The [Forest] Functor} *) module Forest (PT : Tuple.Poly) (N : Ord) (E : Ord) : Forest with module Nodes = N and type edge = E.t and type node = N.t and type children = N.t PT.t = struct module Nodes = N type edge = E.t type node = N.t type children = node PT.t type t = edge * children let compare (edge1, children1) (edge2, children2) = let c = PT.compare N.compare children1 children2 in if c <> 0 then c else E.compare edge1 edge2 let for_all f (_, nodes) = PT.for_all f nodes let fold f (_, nodes) acc = PT.fold_right f nodes acc end (* \thocwmodulesection{Gradings} *) module Chaotic (O : Ord) = struct include O module G = struct type t = unit let compare _ _ = 0 end let rank _ = () end module Discrete (O : Ord) = struct include O module G = O let rank x = x end module Fake_Grading (O : Ord) = struct include O exception Impossible of string module G = struct type t = unit let compare _ _ = raise (Impossible "G.compare") end let rank _ = raise (Impossible "G.compare") end module Grade_Forest (G : Grader) (F : Forest) = struct module Nodes = G(F.Nodes) type node = Nodes.t type edge = F.edge type children = F.children type t = F.t let compare = F.compare let for_all = F.for_all let fold = F.fold end (* A subset of [Map.S], with graded keys. The map is implemented as a two level map with the outer map from the rank of the key to a map from all key of this rank to the values. Thus we can find query the minimal and maximal ranks and find all keys with a given rank without having to scan the entire map.*) module type Graded_Map = sig (* We implement the subset of [Map.S] from the standard library that we need in our applications. The semantics is identical to [Map.S] so we don't need to duplicate the documentation. It would be trivial to implement the rest, if we ever need it. *) type key type 'a t val empty : 'a t val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (* Here come the additional functions dealing with the [rank]. All could be implemented by inspecting all keys in a map, but the keeping track of the grading makes them much more efficient.*) type rank (* Return a list of all ranks in a map. The application should not rely on the fact that the list is sorted. *) val ranks : 'a t -> rank list (* Return the minimal and maximal rank in the map, according to the order of [rank]. *) val min_max_rank : 'a t -> rank * rank (* Return all keys with the given [rank]. *) val ranked : rank -> 'a t -> key list end module type Graded_Map_Maker = functor (O : Graded_Ord) -> Graded_Map with type key = O.t and type rank = O.G.t (* \begin{dubious} Nested ['a -> 'b opt] functions cry out for the monadic binding operators introduced by O'Caml 4.08. \end{dubious} *) module Graded_Map (O : Graded_Ord) : Graded_Map with type key = O.t and type rank = O.G.t = struct module M1 = Map.Make(O.G) module M2 = Map.Make(O) type key = O.t type rank = O.G.t type (+'a) t = 'a M2.t M1.t let empty = M1.empty let map2_of_rank rank map1 = match M1.find_opt rank map1 with | None -> M2.empty | Some map2 -> map2 let add key data map1 = let rank = O.rank key in M1.add rank (M2.add key data (map2_of_rank rank map1)) map1 let find key map1 = M2.find key (M1.find (O.rank key) map1) let mem key map1 = M2.mem key (map2_of_rank (O.rank key) map1) let iter f map1 = - M1.iter (fun rank -> M2.iter f) map1 + M1.iter (fun _rank -> M2.iter f) map1 let fold f map1 acc1 = - M1.fold (fun rank -> M2.fold f) map1 acc1 + M1.fold (fun _rank -> M2.fold f) map1 acc1 (* \begin{dubious} The set of ranks and its minimum and maximum should be maintained explicitely! \end{dubious} *) module S1 = Set.Make(O.G) let ranks map = - M1.fold (fun key data acc -> key :: acc) map [] + M1.fold (fun key _data acc -> key :: acc) map [] let rank_set map = - M1.fold (fun key data -> S1.add key) map S1.empty + M1.fold (fun key _data -> S1.add key) map S1.empty let min_max_rank map = let s = rank_set map in (S1.min_elt s, S1.max_elt s) module S2 = Set.Make(O) let keys map = - M2.fold (fun key data acc -> key :: acc) map [] + M2.fold (fun key _data acc -> key :: acc) map [] - let sorted_keys map = - S2.elements (M2.fold (fun key data -> S2.add key) map S2.empty) + let _sorted_keys map = + S2.elements (M2.fold (fun key _data -> S2.add key) map S2.empty) let ranked rank map1 = keys (map2_of_rank rank map1) end (* \thocwmodulesection{The DAG Functor} *) (* Currently, we are \emph{not} using the grading in O'Mega. It seemed to be an interesting idea for structuring DAGs, but we have not yet come up with a real use case \ldots *) module Maybe_Graded (GMM : Graded_Map_Maker) (F : Graded_Forest) = struct module G = F.Nodes.G type node = F.node type rank = G.t type edge = F.edge type children = F.children (* If we get tired of graded DAGs, we just have to replace [Graded_Map] by [Map] here and remove [ranked] below and gain a tiny amount of simplicity and efficiency. *) module Parents = GMM(F.Nodes) module Offspring = Set.Make(F) type t = Offspring.t Parents.t let rank = F.Nodes.rank let ranks = Parents.ranks let min_max_rank = Parents.min_max_rank let ranked = Parents.ranked let empty = Parents.empty let add_node node dag = if Parents.mem node dag then dag else Parents.add node Offspring.empty dag let add_offspring_unsafe node offspring dag = let offsprings = try Parents.find node dag with Not_found -> Offspring.empty in Parents.add node (Offspring.add offspring offsprings) (F.fold add_node offspring dag) (*i let c = ref 0 let offspring_add offspring offsprings = if Offspring.mem offspring offsprings then (Printf.eprintf "<<<%d>>>\n" !c; incr c); Offspring.add offspring offsprings let add_offspring_unsafe node offspring dag = let offsprings = try Parents.find node dag with Not_found -> Offspring.empty in Parents.add node (offspring_add offspring offsprings) (F.fold add_node offspring dag) i*) exception Cycle let add_offspring node offspring dag = if F.for_all (fun n -> F.Nodes.compare n node < 0) offspring then add_offspring_unsafe node offspring dag else raise Cycle let is_node node dag = Parents.mem node dag let is_sterile node dag = try Offspring.is_empty (Parents.find node dag) with | Not_found -> false let is_offspring node offspring dag = try Offspring.mem offspring (Parents.find node dag) with | Not_found -> false let iter_nodes f dag = Parents.iter (fun n _ -> f n) dag let iter f dag = Parents.iter (fun node -> Offspring.iter (f node)) dag let map_nodes f dag = Parents.fold (fun n -> Parents.add (f n)) dag Parents.empty let map fn fo dag = Parents.fold (fun node offspring -> Parents.add (fn node) (Offspring.fold (fun o -> Offspring.add (fo node o)) offspring Offspring.empty)) dag Parents.empty let fold_nodes f dag acc = Parents.fold (fun n _ -> f n) dag acc let fold f dag acc = Parents.fold (fun node -> Offspring.fold (f node)) dag acc (* \begin{dubious} Note that in it's current incarnation, [fold add_offspring dag empty] copies \emph{only} the fertile nodes, while [fold add_offspring dag (fold_nodes add_node dag empty)] includes sterile ones, as does [map (fun n -> n) (fun n ec -> ec) dag]. \end{dubious} *) let dependencies dag node = let rec dependencies' node' = let offspring = Parents.find node' dag in if Offspring.is_empty offspring then Tree2.leaf node' else Tree2.cons (Offspring.fold (fun o acc -> (fst o, node', F.fold (fun wf acc' -> dependencies' wf :: acc') o []) :: acc) offspring []) in dependencies' node let lists dag = List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2) (Parents.fold (fun node offspring l -> (node, Offspring.elements offspring) :: l) dag []) let size dag = Parents.fold (fun _ _ n -> succ n) dag 0 let rec harvest dag node roots = Offspring.fold (fun offspring roots' -> if is_offspring node offspring roots' then roots' else F.fold (harvest dag) offspring (add_offspring_unsafe node offspring roots')) (Parents.find node dag) (add_node node roots) let harvest_list dag nodes = List.fold_left (fun roots node -> harvest dag node roots) empty nodes (* Build a closure once, so that we can recurse faster: *) let eval f mule muln add null unit node dag = let rec eval' n = if is_sterile n dag then f n else Offspring.fold (fun (e, _ as offspring) v0 -> add (mule n e (F.fold muln' offspring unit)) v0) (Parents.find n dag) null and muln' n = muln (eval' n) in eval' node let count_trees node dag = eval (fun _ -> 1) (fun _ _ p -> p) ( * ) (+) 0 1 node dag let build_forest evaluator node dag = evaluator (fun n -> [Tree.leaf (n, None) n]) (fun n e p -> List.map (fun p' -> Tree.cons (n, Some e) p') p) (fun p1 p2 -> Product.fold2 (fun n nl pl -> (n :: nl) :: pl) p1 p2 []) (@) [] [[]] node dag let forest = build_forest eval (* At least for [count_trees], the memoizing variant [eval_memoized] is considerably slower than direct recursive evaluation with [eval]. *) let eval_offspring f mule muln add null unit dag values (node, offspring) = let muln' n = muln (Parents.find n values) in let v = if is_sterile node dag then f node else Offspring.fold (fun (e, _ as offspring) v0 -> add (mule node e (F.fold muln' offspring unit)) v0) offspring null in (v, Parents.add node v values) let eval_memoized' f mule muln add null unit dag = let result, _ = List.fold_left - (fun (v, values) -> eval_offspring f mule muln add null unit dag values) + (fun (_v, values) -> eval_offspring f mule muln add null unit dag values) (null, Parents.empty) (List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2) (Parents.fold (fun node offspring l -> (node, offspring) :: l) dag [])) in result let eval_memoized f mule muln add null unit node dag = eval_memoized' f mule muln add null unit (harvest dag node empty) let forest_memoized = build_forest eval_memoized end module type Graded = sig include T type rank val rank : node -> rank val ranks : t -> rank list val min_max_rank : t -> rank * rank val ranked : rank -> t -> node list end module Graded (F : Graded_Forest) = Maybe_Graded(Graded_Map)(F) (* The following is not a graded map, obviously. But it can pass as one by the typechecker for constructing non-graded DAGs. *) module Fake_Graded_Map (O : Graded_Ord) : Graded_Map with type key = O.t and type rank = O.G.t = struct module M = Map.Make(O) type key = O.t type (+'a) t = 'a M.t let empty = M.empty let add = M.add let find = M.find let mem = M.mem let iter = M.iter let fold = M.fold (* We make sure that the remaining three are never called inside [DAG] and are not visible outside. *) type rank = O.G.t exception Impossible of string let ranks _ = raise (Impossible "ranks") let min_max_rank _ = raise (Impossible "min_max_rank") let ranked _ _ = raise (Impossible "ranked") end (* We could also have used signature projection with a chaotic or discrete grading, but the [Graded_Map] can cost some efficiency. This is probably not the case for the current simple implementation, but future embellishment can change this. Therefore, the ungraded DAG uses [Map] directly, without overhead. *) module Make (F : Forest) = Maybe_Graded(Fake_Graded_Map)(Grade_Forest(Fake_Grading)(F)) (* \begin{dubious} If O'Caml had \textit{polymorphic recursion}, we could think of even more elegant implementations unifying nodes and offspring (cf.~the generalized tries in~\cite{Okasaki:1998:book}). \end{dubious} *) (* \begin{dubious} GADTs to the rescue? \end{dubious} *) (* \thocwmodulesection{Unit Tests} *) module Test = struct let random_int_list imax n = let imax_plus = succ imax in Array.to_list (Array.init n (fun _ -> Random.int imax_plus)) - module OInts = +(*i module OInts = struct type t = int let compare = compare end +i*) module GOInts = struct type t = int let compare = compare module G = struct type t = int let compare = compare end let rank i = i mod 100 end module GM = Graded_Map(GOInts) let int_list_to_string l = ThoList.to_string string_of_int l - let int_list2_to_string l = + let _int_list2_to_string l = ThoList.to_string int_list_to_string l let int_pair_to_string (i1, i2) = int_list_to_string [i1; i2] let uniq l = ThoList.uniq (List.sort compare l) open OUnit let assert_equal_int_pair p1 p2 = assert_equal ~printer:int_pair_to_string p1 p2 let assert_equal_unsorted_int_list l1 l2 = assert_equal ~printer:int_list_to_string (List.sort compare l1) (List.sort compare l2) - let assert_equal_unsorted_int_list_ignore_duplicates l1 l2 = + let _assert_equal_unsorted_int_list_ignore_duplicates l1 l2 = assert_equal ~printer:int_list_to_string (uniq l1) (uniq l2) let squares n = let data = List.map (fun i -> (i, i * i)) (random_int_list 10000 n) in let map = List.fold_left (fun acc (i, s) -> GM.add i s acc) GM.empty data in (data, map) let suite_graded_map = "Graded_Map" >::: [ "ranks" >:: (fun () -> let data, graded_map = squares 100 in assert_equal_unsorted_int_list (uniq (List.map (fun (i, _) -> GOInts.rank i) data)) (GM.ranks graded_map)); "min_max_rank" >:: (fun () -> match squares 100 with | [], _ -> failwith "empty test data" | (r0, _) :: data, graded_map -> assert_equal_int_pair (List.fold_left (fun (r_min, r_max) (i, _) -> let r = GOInts.rank i in (min r r_min, max r r_max)) (GOInts.rank r0, GOInts.rank r0) data) (GM.min_max_rank graded_map)) ] (* \begin{dubious} We should add more unit tests, time permitting. \end{dubious} *) let suite = "DAG" >::: [suite_graded_map] end Index: trunk/omega/src/Makefile.ocaml =================================================================== --- trunk/omega/src/Makefile.ocaml (revision 8919) +++ trunk/omega/src/Makefile.ocaml (revision 8920) @@ -1,77 +1,77 @@ # Makefile.ocaml -- O'Caml rules for O'Mega Makefiles ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2024 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. # ######################################################################## OCAMLC += $(DBG) -safe-string OCAMLCI = $(OCAMLC) OCAMLDEBUGFLAGS = -g OCAMLOPTFLAGS = -inline 64 $(GPROF) -safe-string OCAML_NATIVE_EXT = .opt OCAML_BYTECODE_EXT = .bin ######################################################################## SUFFIXES = .mll .mly .ml .mli .cmi .cmo .cmx .bin .opt .cmx$(OCAML_NATIVE_EXT): @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ \ - unix.cmxa $(OMEGA_CMXA) $< + -I +unix unix.cmxa $(OMEGA_CMXA) $< .cmo$(OCAML_BYTECODE_EXT): @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ \ - unix.cma $(OMEGA_CMA) $< + -I +unix unix.cma $(OMEGA_CMA) $< .ml.cmx: @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ -c $< .mli.cmi: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLCI) $(OCAMLFLAGS) -o $@ -c $< .ml.cmo: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ -c $< .mll.ml: @if $(AM_V_P); then :; else echo " OCAMLLEX " $@; fi $(AM_V_at)$(OCAMLLEX) -o $@ $< .mly.mli: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< .mly.ml: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< ######################################################################## ## The End. ######################################################################## Index: trunk/omega/src/topology.ml =================================================================== --- trunk/omega/src/topology.ml (revision 8919) +++ trunk/omega/src/topology.ml (revision 8920) @@ -1,860 +1,860 @@ (* topology.ml -- Copyright (C) 1999-2024 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 partition val partitions : int -> partition list type 'a children val keystones : 'a list -> ('a list * 'a list children list) list val max_subtree : int -> int val inspect_partition : partition -> int list end (* \thocwmodulesection{Factorizing Diagrams for $\phi^3$} *) module Binary = struct type partition = int * int * int let inspect_partition (n1, n2, n3) = [n1; n2; n3] (* One way~\cite{ALPHA:1997} to lift the degeneracy is to select the vertex that is closest to the center (see table~\ref{tab:partition}): \begin{equation} \label{eq:partition} \text{\ocwlowerid{partitions}}: n \to \bigl\{ (n_1,n_2,n_3) \,\vert\, n_1 + n_2 + n_3 = n \land n_1 \le n_2 \le n_3 \le \lfloor n/2 \rfloor \bigr\} \end{equation} Other, less symmetric, approaches are possible. The simplest of these is: choose the vertex adjacent to a fixed external line~\cite{HELAC:2000}. They will be made available for comparison in the future. \begin{table} \begin{center} \begin{tabular}{ r | l } [n]& [partitions n] \\\hline 4 & (1,1,2) \\ 5 & (1,2,2) \\ 6 & (1,2,3), (2,2,2) \\ 7 & (1,3,3), (2,2,3) \\ 8 & (1,3,4), (2,2,4), (2,3,3) \\ 9 & (1,4,4), (2,3,4), (3,3,3) \\ 10 & (1,4,5), (2,3,5), (2,4,4), (3,3,4) \\ 11 & (1,5,5), (2,4,5), (3,3,5), (3,4,4) \\ 12 & (1,5,6), (2,4,6), (2,5,5), (3,3,6), (3,4,5), (4,4,4) \\ 13 & (1,6,6), (2,5,6), (3,4,6), (3,5,5), (4,4,5) \\ 14 & (1,6,7), (2,5,7), (2,6,6), (3,4,7), (3,5,6), (4,4,6), (4,5,5) \\ 15 & (1,7,7), (2,6,7), (3,5,7), (3,6,6), (4,4,7), (4,5,6), (5,5,5) \\ 16 & (1,7,8), (2,6,8), (2,7,7), (3,5,8), (3,6,7), (4,4,8), (4,5,7), (4,6,6), (5,5,6) \end{tabular} \end{center} \caption{\label{tab:partition} [partitions n] for moderate values of [n].} \end{table} *) (* An obvious consequence of~$n_1 + n_2 + n_3 = n$ and~$n_1 \le n_2 \le n_3$ is $n_1\le\lfloor n/3 \rfloor$: *) let rec partitions' n n1 = if n1 > n / 3 then [] else List.map (fun (n2, n3) -> (n1, n2, n3)) (Partition.pairs (n - n1) n1 (n / 2)) @ partitions' n (succ n1) let partitions n = partitions' n 1 (* \begin{figure} \begin{center} \hfil\\ \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{2} \fmftopn{t}{1} \fmf{plain}{t1,v} \fmf{plain}{b1,v} \fmf{plain}{b2,v} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{b1} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{b2} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{t1} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v} \end{fmfgraph*} \qquad\qquad\qquad\qquad \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{3} \fmftopn{t}{1} \fmf{plain}{b1,t1} \fmf{plain}{b2,t1} \fmf{plain}{b3,t1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b2} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b3} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1} \end{fmfgraph*} \end{center} \caption{\label{fig:nnn} Topologies with a blatant three-fold permutation symmetry, if the number of external lines is a multiple of three} \end{figure} \begin{figure} \begin{center} \begin{fmfgraph*}(15,20) \fmfstraight \fmfbottomn{b}{2} \fmftopn{t}{1} \fmf{plain}{b1,v} \fmf{plain}{b2,v} \fmf{plain,tension=2}{t1,v} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{t1} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n'$,l.d=0}{b1} \fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n'$,l.d=0}{b2} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v} \end{fmfgraph*} \qquad\qquad\qquad\qquad \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{3} \fmftopn{t}{1} \fmf{plain}{b1,t1} \fmf{plain}{b2,t1} \fmf{plain}{b3,t1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1} \fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n'$,l.d=0}{b2} \fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n'$,l.d=0}{b3} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1} \fmfshift{(0,.2h)}{b1} \end{fmfgraph*} \qquad\qquad \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{3} \fmftopn{t}{1} \fmf{plain}{b1,t1} \fmf{plain}{b2,t1} \fmf{plain}{b3,t1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n'$,l.d=0}{b1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n'$,l.d=0}{b2} \fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n$,l.d=0}{b3} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1} \fmfshift{(0,.2h)}{b1,b2} \end{fmfgraph*} \end{center} \caption{\label{fig:n1n2n2} Topologies with a blatant two-fold symmetry.} \end{figure} \begin{figure} \begin{center} \hfil\\ \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{3} \fmftopn{t}{1} \fmf{plain}{b1,t1} \fmf{plain}{b2,t1} \fmf{plain}{b3,t1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n_1$,l.d=0}{b1} \fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n_2$,l.d=0}{b2} \fmfv{d.sh=triangle,d.f=empty,d.si=35pt,l=$n_3$,l.d=0}{b3} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1} \fmfshift{(0,.30h)}{b1} \fmfshift{(0,.15h)}{b2} \end{fmfgraph*} \qquad\qquad \begin{fmfgraph*}(25,20) \fmfstraight \fmfbottomn{b}{3} \fmftopn{t}{1} \fmf{plain}{b1,t1} \fmf{plain}{b2,t1} \fmf{plain}{b3,t1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1} \fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b2} \fmfv{d.sh=triangle,d.f=empty,d.si=35pt,l=$2n$,l.d=0}{b3} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1} \fmfshift{(0,.20h)}{b1} \fmfshift{(0,.20h)}{b2} \end{fmfgraph*} \end{center} \caption{\label{fig:n1n2n3} If~$n_3=n_1+n_2$, the apparently asymmetric topologies on the left hand side have a non obvious two-fold symmetry, that exchanges the two halves. Therefore, the topologies on the right hand side have a four fold symmetry.} \end{figure} *) type 'a children = 'a Tuple.Binary.t (* There remains one peculiar case, when the number of external lines is even and~$n_3=n_1+n_2$ (cf.~figure~\ref{fig:n1n2n3}). Unfortunately, this reflection symmetry is not respected by the equivalence classes. E.\,g. \begin{equation} \{1\}\{2,3\}\{4,5,6\}\mapsto\bigl\{ \{4\}\{5,6\}\{1,2,3\}; \{5\}\{4,6\}\{1,2,3\}; \{6\}\{4,5\}\{1,2,3\} \bigr\} \end{equation} However, these reflections will always exchange the two halves and a representative can be chosen by requiring that one fixed momentum remains in one half. We choose to filter out the half of the partitions where the element~[p] appears in the second half, i.\,e.~the list of length~[n3]. Finally, a closed expression for the number of Feynman diagrams in the equivalence class $(n_1,n_2,n_3)$ is \begin{equation} N(n_1,n_2,n_3) = \frac{(n_1+n_2+n_3)!}{S(n_1,n_2,n_3)} \prod_{i=1}^{3} \frac{(2n_i-3)!!}{n_i!} \end{equation} where the symmetry factor from the above arguments is \begin{equation} \label{eq:S(1,2,3)} S(n_1,n_2,n_3) = \begin{cases} 3! & \text{for $n_1 = n_2 = n_3$} \\ 2\cdot2 & \text{for $n_3 = 2n_1 = 2n_2$} \\ 2 & \text{for $n_1 = n_2 \lor n_2 = n_3$} \\ 2 & \text{for $n_1 + n_2 = n_3$} \end{cases} \end{equation} Indeed, the sum of all Feynman diagrams \begin{equation} \label{eq:keystone-check} \sum_{\substack{n_1 + n_2 + n_3 = n\\ 1 \le n_1 \le n_2 \le n_3 \le \lfloor n/2 \rfloor}} N(n_1,n_2,n_3) = (2n-5)!! \end{equation} can be checked numerically for large values of $n=n_1+n_2+n_3$, verifying the symmetry factor (see table~\ref{tab:keystone-check}). \begin{dubious} P.\,M.~claims to have seen similar formulae in the context of Young tableaux. That's a good occasion to read the new edition of Howard's book \ldots \end{dubious} \begin{table} \begin{center} \begin{tabular}{ r | r | l } $n$ & $(2n-5)!!$ & $\sum N(n_1,n_2,n_3)$ \\\hline 4 & 3 & $3\cdot(1,1,2)$ \\ 5 & 15 & $15\cdot(1,2,2)$ \\ 6 & 105 & $90\cdot(1,2,3) + 15\cdot(2,2,2)$ \\ 7 & 945 & $630\cdot(1,3,3) + 315\cdot(2,2,3)$ \\ 8 & 10395 & $6300\cdot(1,3,4) + 1575\cdot(2,2,4) + 2520\cdot(2,3,3)$ \\ 9 & 135135 & $70875\cdot(1,4,4) + 56700\cdot(2,3,4) + 7560\cdot(3,3,3)$ \\ 10 & 2027025 & $992250\cdot(1,4,5) + 396900\cdot(2,3,5)$ \\ & & \quad$\mbox{}+ 354375\cdot(2,4,4) + 283500\cdot(3,3,4)$ \\ 11 & 34459425 & $15280650\cdot(1,5,5) + 10914750\cdot(2,4,5)$ \\ & & \quad$\mbox{}+ 4365900\cdot(3,3,5) + 3898125\cdot(3,4,4)$ \\ 12 & 654729075 & $275051700\cdot(1,5,6) + 98232750\cdot(2,4,6)$ \\ & & \quad$\mbox{}+ 91683900\cdot(2,5,5)+ 39293100\cdot(3,3,6)$ \\ & & \quad$\mbox{}+ 130977000\cdot(3,4,5) + 19490625\cdot(4,4,4)$ \end{tabular} \end{center} \caption{\label{tab:keystone-check} Equation~(\ref{eq:keystone-check}) for small values of $n$.} \end{table} *) (* Return a list of all inequivalent partitions of the list~[l] in three lists of length [n1], [n2] and [n3], respectively. Common first lists are factored. This is nothing more than a typedafe wrapper around [Combinatorics.factorized_keystones]. *) exception Impossible of string let tuple_of_list2 = function | [x1; x2] -> Tuple.Binary.of2 x1 x2 | _ -> raise (Impossible "Topology.tuple_of_list") let keystone (n1, n2, n3) l = List.map (fun (p1, p23) -> (p1, List.rev_map tuple_of_list2 p23)) (Combinatorics.factorized_keystones [n1; n2; n3] l) let keystones l = ThoList.flatmap (fun n123 -> keystone n123 l) (partitions (List.length l)) let max_subtree n = n / 2 end (* \thocwmodulesection{Factorizing Diagrams for $\sum_n\lambda_n\phi^n$} *) (* \begin{figure} \begin{center} \begin{fmfgraph}(25,20) \fmfleftn{l}{3} \fmfrightn{r}{3} \fmf{plain}{l1,v4} \fmf{plain}{l2,v4} \fmf{plain}{l3,v4} \fmf{plain}{r1,v1} \fmf{plain}{r2,v1} \fmf{plain}{v1,v2} \fmf{plain}{r3,v2} \fmf{plain}{v2,v4} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v4} \fmfdot{v1,v2} \end{fmfgraph} \qquad\qquad \begin{fmfgraph}(25,20) \fmfleftn{l}{3} \fmfrightn{r}{3} \fmf{plain}{l1,v4} \fmf{plain}{l2,v4} \fmf{plain}{l3,v4} \fmf{plain}{r1,v1} \fmf{plain}{r2,v1} \fmf{plain}{v1,v2} \fmf{plain}{r3,v2} \fmf{plain}{v2,v4} \fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v2} \fmfdot{v1,v4} \end{fmfgraph} \end{center} \caption{\label{fig:n1n2n3n4} Degenerate $(1,1,1,3)$ and $(1,2,3)$.} \end{figure} *) (* Mixed $\phi^n$ adds new degeneracies, as in figure~\ref{fig:n1n2n3n4}. They appear if and only if one part takes exactly half of the external lines and can relate central vertices of different arity. *) module Nary (B : Tuple.Bound) = struct type partition = int list let inspect_partition p = p let partition d sum = Partition.tuples d sum 1 (sum / 2) let rec partitions' d sum = if d < 3 then [] else partition d sum @ partitions' (pred d) sum let partitions sum = partitions' (succ (B.max_arity ())) sum (* \begin{table} \begin{center} \begin{tabular}{ r | r | l } $n$ & $\sum$ & $\sum$ \\\hline 4 & 4 & $1\cdot(1,1,1,1) + 3\cdot(1,1,2)$ \\ 5 & 25 & $10\cdot(1,1,1,2) + 15\cdot(1,2,2)$ \\ 6 & 220 & $40\cdot(1,1,1,3) + 45\cdot(1,1,2,2) + 120\cdot(1,2,3) + 15\cdot(2,2,2)$ \\ 7 & 2485 & $840\cdot(1,1,2,3) + 105\cdot(1,2,2,2) + 1120\cdot(1,3,3) + 420\cdot(2,2,3)$ \\ 8 & 34300 & $5250\cdot(1,1,2,4) + 4480\cdot(1,1,3,3) + 3360\cdot(1,2,2,3)$\\ & & \quad$\mbox{}+ 105\cdot(2,2,2,2) + 14000\cdot(1,3,4)$\\ & & \quad$\mbox{}+ 2625\cdot(2,2,4) + 4480\cdot(2,3,3)$ \\ 9 & 559405 & $126000\cdot(1,1,3,4) + 47250\cdot(1,2,2,4) + 40320\cdot(1,2,3,3)$\\ & & \quad$\mbox{}+ 5040\cdot(2,2,2,3) + 196875\cdot(1,4,4)$\\ & & \quad$\mbox{}+ 126000\cdot(2,3,4) + 17920\cdot(3,3,3)$ \\ 10 & 10525900 & $1108800\cdot(1,1,3,5) + 984375\cdot(1,1,4,4) + 415800\cdot(1,2,2,5)$\\ & & \quad$\mbox{}+ 1260000\cdot(1,2,3,4) + 179200\cdot(1,3,3,3) + 78750\cdot(2,2,2,4)$\\ & & \quad$\mbox{}+ 100800\cdot(2,2,3,3) + 3465000\cdot(1,4,5) + 1108800\cdot(2,3,5)$\\ & & \quad$\mbox{}+ 984375\cdot(2,4,4) + 840000\cdot(3,3,4)$ \end{tabular} \end{center} \caption{\label{tab:keystone-check4}% $\mathcal{L}=\lambda_3\phi^3+\lambda_4\phi^4$} \end{table} \begin{table} \begin{center} \begin{tabular}{ r | r | l } $n$ & $\sum$ & $\sum$ \\\hline 4 & 4 & $1\cdot(1,1,1,1) + 3\cdot(1,1,2)$ \\ 5 & 26 & $1\cdot(1,1,1,1,1) + 10\cdot(1,1,1,2) + 15\cdot(1,2,2)$ \\ 6 & 236 & $1\cdot(1,1,1,1,1,1) + 15\cdot(1,1,1,1,2) + 40\cdot(1,1,1,3)$\\ & & \quad$\mbox{}+ 45\cdot(1,1,2,2) + 120\cdot(1,2,3) + 15\cdot(2,2,2)$ \\ 7 & 2751 & $21\cdot(1,1,1,1,1,2) + 140\cdot(1,1,1,1,3) + 105\cdot(1,1,1,2,2)$\\ & & \quad$\mbox{}+ 840\cdot(1,1,2,3) + 105\cdot(1,2,2,2) + 1120\cdot(1,3,3) + 420\cdot(2,2,3)$ \\ 8 & 39179 & $224\cdot(1,1,1,1,1,3) + 210\cdot(1,1,1,1,2,2) + 910\cdot(1,1,1,1,4)$\\ & & \quad$\mbox{}+ 2240\cdot(1,1,1,2,3) + 420\cdot(1,1,2,2,2) + 5460\cdot(1,1,2,4)$\\ & & \quad$\mbox{}+ 4480\cdot(1,1,3,3) + 3360\cdot(1,2,2,3) + 105\cdot(2,2,2,2)$\\ & & \quad$\mbox{}+ 14560\cdot(1,3,4) + 2730\cdot(2,2,4) + 4480\cdot(2,3,3)$ \end{tabular} \end{center} \caption{\label{tab:keystone-check6}% $\mathcal{L}=\lambda_3\phi^3+\lambda_4\phi^4+\lambda_5\phi^5+\lambda_6\phi^6$} \end{table} *) module Tuple = Tuple.Nary(B) type 'a children = 'a Tuple.t let keystones' l = let n = List.length l in ThoList.flatmap (fun p -> Combinatorics.factorized_keystones p l) (partitions n) let keystones l = List.map (fun (bra, kets) -> (bra, List.map Tuple.of_list kets)) (keystones' l) let max_subtree n = n / 2 end module Nary4 = Nary (struct let max_arity () = 3 end) (* \thocwmodulesection{Factorizing Diagrams for $\phi^4$} *) module Ternary = struct type partition = int * int * int * int let inspect_partition (n1, n2, n3, n4) = [n1; n2; n3; n4] type 'a children = 'a Tuple.Ternary.t let collect4 acc = function | [x; y; z; u] -> (x, y, z, u) :: acc | _ -> acc let partitions n = List.fold_left collect4 [] (Nary4.partitions n) let collect3 acc = function | [x; y; z] -> Tuple.Ternary.of3 x y z :: acc | _ -> acc let keystones l = List.map (fun (bra, kets) -> (bra, List.fold_left collect3 [] kets)) (Nary4.keystones' l) let max_subtree = Nary4.max_subtree end (* \thocwmodulesection{Factorizing Diagrams for $\phi^3+\phi^4$} *) module Mixed23 = struct type partition = | P3 of int * int * int | P4 of int * int * int * int let inspect_partition = function | P3 (n1, n2, n3) -> [n1; n2; n3] | P4 (n1, n2, n3, n4) -> [n1; n2; n3; n4] type 'a children = 'a Tuple.Mixed23.t let collect34 acc = function | [x; y; z] -> P3 (x, y, z) :: acc | [x; y; z; u] -> P4 (x, y, z, u) :: acc | _ -> acc let partitions n = List.fold_left collect34 [] (Nary4.partitions n) let collect23 acc = function | [x; y] -> Tuple.Mixed23.of2 x y :: acc | [x; y; z] -> Tuple.Mixed23.of3 x y z :: acc | _ -> acc let keystones l = List.map (fun (bra, kets) -> (bra, List.fold_left collect23 [] kets)) (Nary4.keystones' l) let max_subtree = Nary4.max_subtree end (* \thocwmodulesection{% Diagnostics: Counting Diagrams and Factorizations for $\sum_n\lambda_n\phi^n$} *) module type Integer = sig type t val zero : t val one : t val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val pred : t -> t val succ : t -> t val ( = ) : t -> t -> bool val ( <> ) : t -> t -> bool val ( < ) : t -> t -> bool val ( <= ) : t -> t -> bool val ( > ) : t -> t -> bool val ( >= ) : t -> t -> bool val of_int : int -> t val to_int : t -> int val to_string : t -> string val compare : t -> t -> int val factorial : t -> t end (* O'Caml's native integers suffice for all applications, but in appendix~\ref{sec:count}, we want to use big integers for numeric checks in high orders: *) module Int : Integer = struct type t = int let zero = 0 let one = 1 let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let pred = pred let succ = succ let ( = ) = ( = ) let ( <> ) = ( <> ) let ( < ) = ( < ) let ( <= ) = ( <= ) let ( > ) = ( > ) let ( >= ) = ( >= ) let of_int n = n let to_int n = n let to_string = string_of_int let compare = compare let factorial = Combinatorics.factorial end module type Count = sig type integer val diagrams : ?f:(integer -> bool) -> integer -> integer -> integer val diagrams_via_keystones : integer -> integer -> integer val keystones : integer list -> integer val diagrams_per_keystone : integer -> integer list -> integer end module Count (I : Integer) = struct - let description = ["(still inoperational) phi^n topology"] + let _description = ["(still inoperational) phi^n topology"] type integer = I.t open I let two = of_int 2 let three = of_int 3 (* If [I.t] is an abstract datatype, the polymorphic [Stdlib.min] can fail. Provide our own version using the specific comparison ``[(<=)]''. *) - let min x y = + let _min x y = if x <= y then x else y (* \thocwmodulesubsection{Counting Diagrams for $\sum_n\lambda_n\phi^n$} *) (* Classes of diagrams are defined by the number of vertices and their degrees. We could use fixed size arrays, but we will use a map instead. For efficiency, we also maintain the number of external lines and the total number of propagators. *) module IMap = Map.Make (struct type t = integer let compare = I.compare end) type diagram_class = { ext : integer; prop : integer; v : integer IMap.t } (*i let to_string cl = IMap.fold (fun d n s -> s ^ Printf.sprintf ", #%s=%s" (to_string d) (to_string n)) cl.v (Printf.sprintf "#ext=%s, #prop=%s" (to_string cl.ext) (to_string cl.prop)) i*) (* The numbers of external lines, propagators and vertices are determined by the degrees and multiplicities of vertices: \begin{subequations} \begin{align} E(\{n_3,n_4,\ldots\}) &= 2 + \sum_{d=3}^{\infty} (d-2)n_d \\ P(\{n_3,n_4,\ldots\}) &= \sum_{d=3}^{\infty} n_d - 1 = V(\{n_3,n_4,\ldots\}) - 1 \\ V(\{n_3,n_4,\ldots\}) &= \sum_{d=3}^{\infty} n_d \end{align} \end{subequations} *) let num_ext v = List.fold_left (fun sum (d, n) -> sum + (d - two) * n) two v let num_prop v = List.fold_left (fun sum (_, n) -> sum + n) (zero - one) v (* The sum of all vertex degrees must be equal to the number of propagator end points. This can be verified easily: \begin{equation} 2 P(\{n_3,n_4,\ldots\}) + E(\{n_3,n_4,\ldots\}) = \sum_{d=3}^{\infty} dn_d \end{equation} *) let add_degree map (d, n) = if d < three then invalid_arg "add_degree: d < 3" else if n < zero then invalid_arg "add_degree: n <= 0" else if n = zero then map else IMap.add d n map let create_class v = { ext = num_ext v; prop = num_prop v; v = List.fold_left add_degree IMap.empty v } let multiplicity cl d = if d >= three then try IMap.find d cl.v with | Not_found -> zero else invalid_arg "multiplicity: d < 3" (* Remove one vertex of degree [d], maintaining the invariants. Raises [Zero] if all vertices of degree [d] are exhausted. *) exception Zero let remove cl d = let n = pred (multiplicity cl d) in if n < zero then raise Zero else { ext = cl.ext - (d - two); prop = pred cl.prop; v = if n = zero then IMap.remove d cl.v else IMap.add d n cl.v } (* Add one vertex of degree [d], maintaining the invariants. *) let add cl d = { ext = cl.ext + (d - two); prop = succ cl.prop; v = IMap.add d (succ (multiplicity cl d)) cl.v } (* Count the number of diagrams. Any diagram can be obtained recursively either from a diagram with one ternary vertex less by insertion if a ternary vertex in an internal or external propagator or from a diagram with a higher order vertex that has its degree reduced by one: \begin{multline} D(\{n_3,n_4,\ldots\}) = \\ \left(P(\{n_3-1,n_4,\ldots\})+E(\{n_3-1,n_4,\ldots\})\right) D(\{n_3-1,n_4,\ldots\}) \\ {} + \sum_{d=4}^{\infty} (n_{d-1} + 1) D(\{n_3,n_4,\ldots,n_{d-1}+1,n_d-1,\ldots\}) \end{multline} *) let rec class_size cl = if cl.ext = two || cl.prop = zero then one else IMap.fold (fun d _ s -> class_size_n cl d + s) cl.v (class_size_3 cl) (* Purely ternary vertices recurse among themselves: *) and class_size_3 cl = try let d' = remove cl three in (d'.ext + d'.prop) * class_size d' with | Zero -> zero (* Vertices of higher degree recurse one step towards lower degrees: *) and class_size_n cl d = if d > three then begin try let d' = pred d in let cl' = add (remove cl d) d' in multiplicity cl' d' * class_size cl' with | Zero -> zero end else zero (* Find all $\{n_3,n_4,\ldots,n_d\}$ with \begin{equation} E(\{n_3,n_4,\ldots,n_d\}) - 2 = \sum_{i=3}^cl (i-2)n_i = \ocwlowerid{sum} \end{equation} The implementation is a variant of [tuples] above. *) let rec distribute_degrees' d sum = if d < three then invalid_arg "distribute_degrees" else if d = three then [[(d, sum)]] else distribute_degrees'' d sum (sum / (d - two)) and distribute_degrees'' d sum n = if n < zero then [] else List.fold_left (fun ll l -> ((d, n) :: l) :: ll) (distribute_degrees'' d sum (pred n)) (distribute_degrees' (pred d) (sum - (d - two) * n)) (* Actually, we need to find all $\{n_3,n_4,\ldots,n_d\}$ with \begin{equation} E(\{n_3,n_4,\ldots,n_d\}) = \ocwlowerid{sum} \end{equation} *) let distribute_degrees d sum = distribute_degrees' d (sum - two) (* Finally we can count all diagrams by adding all possible ways of splitting the degrees of vertices. We can also count diagrams where \emph{all} degrees satisfy a predicate [f]: *) let diagrams ?(f = fun _ -> true) deg n = List.fold_left (fun s d -> if List.for_all (fun (d', n') -> f d' || n' = zero) d then s + class_size (create_class d) else s) zero (distribute_degrees deg n) (* The next two are duplicated from [ThoList] and [Combinatorics], in order to use the specific comparison functions. *) let classify l = let rec add_to_class a = function | [] -> [of_int 1, a] | (n, a') :: rest -> if a = a' then (succ n, a) :: rest else (n, a') :: add_to_class a rest in let rec classify' cl = function | [] -> cl | a :: rest -> classify' (add_to_class a cl) rest in classify' [] l let permutation_symmetry l = List.fold_left (fun s (n, _) -> factorial n * s) one (classify l) let symmetry l = let sum = List.fold_left (+) zero l in if List.exists (fun x -> two * x = sum) l then two * permutation_symmetry l else permutation_symmetry l (* The number of Feynman diagrams built of vertices with maximum degree~$d_{\max}$ in a partition $N_{d,n}=\{n_1,n_2,\ldots,n_d\}$ with $n = n_1 + n_2 + \cdots + n_d$ and \begin{equation} \tilde F(d_{\max},N_{d,n}) = \frac{n!}{ |\mathcal{S}(N_{d,n})| \sigma(n_d,n)} \prod_{i=1}^{d} \frac{F(d_{\max},n_i+1)}{n_i!} \end{equation} with~$|\mathcal{S}(N)|$ the size of the symmetric group of~$N$, $\sigma(n,2n) = 2$ and $\sigma(n,m) = 1$ otherwise. *) let keystones p = let sum = List.fold_left (+) zero p in List.fold_left (fun acc n -> acc / (factorial n)) (factorial sum) p / symmetry p let diagrams_per_keystone deg p = List.fold_left (fun acc n -> acc * diagrams deg (succ n)) one p (* We must find \begin{equation} F(d_{\max},n) = \sum_{d=3}^{d_{\max}} \sum_{\substack{N = \{n_1,n_2,\ldots,n_d\}\\ n_1 + n_2 + \cdots + n_d = n\\ 1 \le n_1 \le n_2 \le \cdots \le n_d \le \lfloor n/2 \rfloor}} \tilde F(d_{\max},N) \end{equation} *) let diagrams_via_keystones deg n = let module N = Nary (struct let max_arity () = to_int (pred deg) end) in List.fold_left (fun acc p -> acc + diagrams_per_keystone deg p * keystones p) zero (List.map (List.map of_int) (N.partitions (to_int n))) end (* \thocwmodulesection{Emulating HELAC} *) (* In~\cite{HELAC:2000}, one leg is singled out: *) module Helac (B : Tuple.Bound) = struct module Tuple = Tuple.Nary(B) type partition = int list let inspect_partition p = p let partition d sum = Partition.tuples d sum 1 (sum - d + 1) let rec partitions' d sum = let d' = pred d in if d' < 2 then [] else List.map (fun p -> 1::p) (partition d' (pred sum)) @ partitions' d' sum let partitions sum = partitions' (succ (B.max_arity ())) sum type 'a children = 'a Tuple.t let keystones' l = match l with | [] -> [] | head :: tail -> [([head], ThoList.flatmap (fun p -> Combinatorics.partitions (List.tl p) tail) (partitions (List.length l)))] let keystones l = List.map (fun (bra, kets) -> (bra, List.map Tuple.of_list kets)) (keystones' l) let max_subtree n = pred n end (* \begin{dubious} The following is not tested, but it is no rocket science either \ldots \end{dubious} *) module Helac_Binary = struct type partition = int * int * int let inspect_partition (n1, n2, n3) = [n1; n2; n3] let partitions sum = List.map (fun (n2, n3) -> (1, n2, n3)) (Partition.pairs (sum - 1) 1 (sum - 2)) type 'a children = 'a Tuple.Binary.t let keystones' l = match l with | [] -> [] | head :: tail -> [([head], ThoList.flatmap (fun (_, p2, _) -> Combinatorics.split p2 tail) (partitions (List.length l)))] let keystones l = List.map (fun (bra, kets) -> (bra, List.map (fun (x, y) -> Tuple.Binary.of2 x y) kets)) (keystones' l) let max_subtree n = pred n end Index: trunk/omega/src/omega.tex =================================================================== --- trunk/omega/src/omega.tex (revision 8919) +++ trunk/omega/src/omega.tex (revision 8920) @@ -1,1369 +1,1378 @@ % omega.tex -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \RequirePackage{ifpdf} \ifpdf \documentclass[a4paper,notitlepage,chapters]{flex} \usepackage[T1]{fontenc} \usepackage{type1cm} \usepackage[pdftex,colorlinks]{hyperref} \usepackage[pdftex]{graphicx,feynmp,emp} \DeclareGraphicsRule{*}{mps}{*}{} \else \documentclass[a4paper,notitlepage,chapters]{flex} \usepackage[T1]{fontenc} % \usepackage[hypertex]{hyperref} \usepackage{graphicx,feynmp,emp} \fi \usepackage{verbatim,array,amsmath,amssymb} \usepackage{url,thophys,thohacks} \usepackage{alphalph} %%% too many appendices ... \usepackage{pgf} \usepackage{ytableau} \setlength{\unitlength}{1mm} \empaddtoTeX{\usepackage{amsmath,amssymb}} \empaddtoTeX{\usepackage{thophys,thohacks}} \empaddtoprelude{input graph;} \empaddtoprelude{input boxes;} \IfFileExists{geometry.sty}% {\usepackage{geometry}% \geometry{a4paper,margin=2cm}}% {\relax} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% This should be part of flex.cls and/or thopp.sty \makeatletter \@ifundefined{frontmatter}% {\def\frontmatter{\pagenumbering{roman}}% \def\mainmatter{\cleardoublepage\pagenumbering{arabic}}} {} \makeatother %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \makeatletter %%% %%% Italic figure captions to separate them visually from the text %%% %%% (this should be supported by flex.cls): %%% \makeatletter %%% \@secpenalty=-1000 %%% \def\fps@figure{t} %%% \def\fps@table{b} %%% \long\def\@makecaption#1#2{% %%% \vskip\abovecaptionskip %%% \sbox\@tempboxa{#1: \textit{#2}}% %%% \ifdim\wd\@tempboxa>\hsize %%% #1: \textit{#2}\par %%% \else %%% \global\@minipagefalse %%% \hb@xt@\hsize{\hfil\box\@tempboxa\hfil}% %%% \fi %%% \vskip\belowcaptionskip} %%% \makeatother \widowpenalty=4000 \clubpenalty=4000 \displaywidowpenalty=4000 %%% \pagestyle{headings} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \allowdisplaybreaks \renewcommand{\topfraction}{0.8} \renewcommand{\bottomfraction}{0.8} \renewcommand{\textfraction}{0.2} \setlength{\abovecaptionskip}{.5\baselineskip} \setlength{\belowcaptionskip}{\baselineskip} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% allow VERY overfull hboxes \setlength{\hfuzz}{5cm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{noweb} %%% \usepackage{nocondmac} \setlength{\nwmarginglue}{1em} \noweboptions{smallcode,noidentxref}%%%{webnumbering} %%% Saving paper: \def\nwendcode{\endtrivlist\endgroup} \nwcodepenalty=0 \let\nwdocspar\relax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newcommand{\ttfilename}[1]{\texttt{\detokenize{#1}}} \usepackage[noweb,bypages]{ocamlweb} \empaddtoTeX{\usepackage[noweb,bypages]{ocamlweb}} \renewcommand{\ocwinterface}[1]{\section{Interface of \ocwupperid{#1}}} \renewcommand{\ocwmodule}[1]{\section{Implementation of \ocwupperid{#1}}} \renewcommand{\ocwinterfacepart}{\relax} \renewcommand{\ocwcodepart}{\relax} \renewcommand{\ocwbeginindex}{\begin{theindex}} \newcommand{\thocwmodulesection}[1]{\subsection{#1}} \newcommand{\thocwmodulesubsection}[1]{\subsubsection{#1}} \newcommand{\thocwmoduleparagraph}[1]{\paragraph{#1}} \renewcommand{\ocwindent}[1]{\noindent\ignorespaces} \renewcommand{\ocwbegincode}{\renewcommand{\ocwindent}[1]{\noindent\kern##1}} \renewcommand{\ocwendcode}{\renewcommand{\ocwindent}[1]{\noindent\ignorespaces}} \renewcommand{\ocweol}{\setlength\parskip{0pt}\par} \makeatletter \renewcommand{\@oddfoot}{\reset@font\hfil\thepage\hfil} \let\@evenfoot\@oddfoot \def\@evenhead{\leftmark{} \hrulefill}% \def\@oddhead{\hrulefill{} \rightmark}% \let\@mkboth\markboth \renewcommand{\chaptermark}[1]{\markboth{\hfil}{\hfil}}% \renewcommand{\sectionmark}[1]{\markboth{#1}{#1}} \renewcommand{\chapter}{% \clearpage\global\@topnum\z@\@afterindentfalse \secdef\@chapter\@schapter} \makeatother -\newcommand{\signature}[1]{% - \InputIfFileExists{#1.interface}{}% - {\begin{dubious}\textit{Interface \ttfilename{#1.mli} unavailable!}\end{dubious}}} \newcommand{\interface}[1]{% \label{mod:#1}% \InputIfFileExists{#1.implementation}{}% {\begin{dubious}\textit{Interface \ttfilename{#1.ml} unavailable!}\end{dubious}}} \newcommand{\application}[1]{% \InputIfFileExists{#1.implementation}{}% {\begin{dubious}\textit{Application \ttfilename{#1.ml} unavailable!}\end{dubious}}} \newcommand{\module}[1]{% \label{mod:#1}% \InputIfFileExists{#1.interface}{}% {\begin{dubious}\textit{Interface \ttfilename{#1.mli} unavailable!}\end{dubious}}% \InputIfFileExists{#1.implementation}{}% {\begin{dubious}\textit{Implementation \ttfilename{#1.ml} unavailable!}\end{dubious}}} \newcommand{\lexer}[1]{\application{#1_lexer}} \renewcommand{\ocwlexmodule}[1]{\relax} \newcommand{\parser}[1]{\application{#1_parser}} \renewcommand{\ocwyaccmodule}[1]{\relax} \newcommand{\thocwincludegraphics}[2]{\includegraphics[#1]{#2}} \ifpdf \newcommand{\thocwdefref}[1]{\textbf{\pageref{#1}}}% \newcommand{\thocwuseref}[1]{\textrm{\pageref{#1}}}% \renewcommand{\ocwrefindexentry}[5]% {\item #1,\quad\let\ref\thocwdefref{#4}, used: \let\ref\thocwuseref{#5}} \fi \newcommand{\thocwmakebox}[4]{\makebox(#1,#2)[#3]{#4}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newenvironment{modules}[1]% {\begin{list}{}% {\setlength{\leftmargin}{3em}% \setlength{\rightmargin}{2em}% \setlength{\itemindent}{-1em}% \setlength{\listparindent}{0pt}% %%%\setlength{\itemsep}{0pt}% \settowidth{\labelwidth}{\textbf{\ocwupperid{#1}:}}% \renewcommand{\makelabel}[1]{\ocwupperid{##1:}}}}% {\end{list}} \newenvironment{JR}% {\begin{dubious}\textit{JR sez' (regarding the Majorana Feynman rules):}} {\textit{(JR's probably right, but I need to check myself \ldots)} \end{dubious}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \DeclareMathOperator{\tr}{tr} \newcommand{\dd}{\mathrm{d}} \newcommand{\ii}{\mathrm{i}} \newcommand{\ee}{\mathrm{e}} \renewcommand{\Re}{\text{Re}} \renewcommand{\Im}{\text{Im}} \newcommand{\ketbra}[2]{\ket{#1}\!\bra{#2}} \newcommand{\Ketbra}[2]{\Ket{#1}\!\Bra{#2}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \makeindex \begin{document} \begin{fmffile}{\jobname pics} \fmfset{arrow_ang}{10} \fmfset{curly_len}{2mm} \fmfset{wiggly_len}{3mm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \fmfcmd{% numeric joindiameter; joindiameter := 7thick;} \fmfcmd{% vardef sideways_at (expr d, p, frac) = save len; len = length p; (point frac*len of p) shifted ((d,0) rotated (90 + angle direction frac*len of p)) enddef; secondarydef p sideways d = for frac = 0 step 0.01 until 0.99: sideways_at (d, p, frac) .. endfor sideways_at (d, p, 1) enddef; secondarydef p choptail d = subpath (ypart (fullcircle scaled d shifted (point 0 of p) intersectiontimes p), infinity) of p enddef; secondarydef p choptip d = reverse ((reverse p) choptail d) enddef; secondarydef p pointtail d = fullcircle scaled d shifted (point 0 of p) intersectionpoint p enddef; secondarydef p pointtip d = (reverse p) pointtail d enddef; secondarydef pa join pb = pa choptip joindiameter .. pb choptail joindiameter enddef; vardef cyclejoin (expr p) = subpath (0.5*length p, infinity) of p join subpath (0, 0.5*length p) of p .. cycle enddef;} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \fmfcmd{% style_def double_line_arrow expr p = save pi, po; path pi, po; pi = reverse (p sideways thick); po = p sideways -thick; cdraw pi; cdraw po; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_line_arrow_beg expr p = save pi, po, pc; path pi, po, pc; pc = p choptail 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw pi .. p pointtail 5thick .. po; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_line_arrow_end expr p = save pi, po, pc; path pi, po, pc; pc = p choptip 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw po .. p pointtip 5thick .. pi; cfill (arrow pi); cfill (arrow po); enddef;} \fmfcmd{% style_def double_line_arrow_both expr p = save pi, po, pc; path pi, po, pc; pc = p choptip 7thick choptail 7thick; pi = reverse (pc sideways thick); po = pc sideways -thick; cdraw po .. p pointtip 5thick .. pi .. p pointtail 5thick .. cycle; cfill (arrow pi); cfill (arrow po); enddef;} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \fmfcmd{vardef middir (expr p, ang) = dir (angle direction length(p)/2 of p + ang) enddef;} \fmfcmd{style_def arrow_left expr p = shrink (.7); cfill (arrow p shifted (4thick * middir (p, 90))); endshrink enddef;} \fmfcmd{style_def arrow_right expr p = shrink (.7); cfill (arrow p shifted (4thick * middir (p, -90))); endshrink enddef;} \fmfcmd{style_def warrow_left expr p = shrink (.7); cfill (arrow p shifted (8thick * middir (p, 90))); endshrink enddef;} \fmfcmd{style_def warrow_right expr p = shrink (.7); cfill (arrow p shifted (8thick * middir (p, -90))); endshrink enddef;} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newcommand{\threeexternal}[3]{% \fmfsurround{d1,e1,d2,e2,d3,e3}% \fmfv{label=$#1$,label.ang=0}{e1}% \fmfv{label=$#2$,label.ang=180}{e2}% \fmfv{label=$#3$,label.ang=0}{e3}} \newcommand{\Threeexternal}[3]{% \fmfsurround{d1,e1,d3,e3,d2,e2}% \fmfv{label=$#1$,label.ang=0}{e1}% \fmfv{label=$#2$,label.ang=0}{e2}% \fmfv{label=$#3$,label.ang=180}{e3}} \newcommand{\Fourexternal}[4]{% \fmfsurround{d2,e2,d1,e1,d4,e4,d3,e3}% \fmfv{label=$#1$,label.ang=180}{e1}% \fmfv{label=$#2$,label.ang=0}{e2}% \fmfv{label=$#3$,label.ang=0}{e3}% \fmfv{label=$#4$,label.ang=180}{e4}} \newcommand{\Fiveexternal}[5]{% \fmfsurround{d2,e2,d1,e1,d5,e5,d4,e4,d3,e3}% \fmfv{label=$#1$,label.ang=180}{e1}% \fmfv{label=$#2$,label.ang=0}{e2}% \fmfv{label=$#3$,label.ang=0}{e3}% \fmfv{label=$#4$,label.ang=0}{e4}% \fmfv{label=$#5$,label.ang=180}{e5}} \newcommand{\twoincoming}{% \fmfdot{v}% \fmffreeze% \fmf{warrow_right}{e1,v}% \fmf{warrow_right}{e2,v}% \fmf{warrow_right}{v,e3}} \newcommand{\threeincoming}{% \fmfdot{v}% \fmffreeze% \fmf{warrow_right}{e1,v}% \fmf{warrow_right}{e2,v}% \fmf{warrow_right}{e3,v}} \newcommand{\threeoutgoing}{% \fmfdot{v}% \fmffreeze% \fmf{warrow_right}{v,e1}% \fmf{warrow_right}{v,e2}% \fmf{warrow_right}{v,e3}} \newcommand{\fouroutgoing}{% \threeoutgoing% \fmf{warrow_right}{v,e4}} \newcommand{\fiveoutgoing}{% \fouroutgoing% \fmf{warrow_right}{v,e5}} \newcommand{\setupthreegluons}{% \fmftop{g3} \fmfbottom{g1,g2} \fmf{phantom}{v,g1} \fmf{phantom}{v,g2} \fmf{phantom}{v,g3} \fmffreeze \fmfipair{v,g[],a[],b[]} \fmfiset{g1}{vloc (__g1)} \fmfiset{g2}{vloc (__g2)} \fmfiset{g3}{vloc (__g3)} \fmfiset{v}{vloc (__v)} \fmfiset{a1}{g1 shifted (-3thin,0)} \fmfiset{b1}{g1 shifted (+1thin,-2thin)} \fmfiset{a2}{g2 shifted (0,-3thin)} \fmfiset{b2}{g2 shifted (0,+3thin)} \fmfiset{a3}{g3 shifted (+1thin,+2thin)} \fmfiset{b3}{g3 shifted (-3thin,0)}} \begin{empfile} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \frontmatter \title{ O'Mega:\\ Optimal~Monte-Carlo\\ Event~Generation~Amplitudes} \author{% Thorsten Ohl\thanks{% \texttt{ohl@physik.uni-wuerzburg.de}, \texttt{http://physik.uni-wuerzburg.de/ohl}}\\ \hfil\\ Institut f\"ur Theoretische~Physik und Astrophysik\\ Julius-Maximilians-Universit\"at~W\"urzburg\\ Emil-Hilb-Weg 22, 97074~W\"urzburg, Germany\\ \hfil\\ J\"urgen Reuter\thanks{\texttt{juergen.reuter@desy.de}}\\ \hfil\\ DESY Theory Group, Notkestr. 85, 22603 Hamburg, Germany\\ \hfil\\ Wolfgang Kilian${}^{c,}$\thanks{\texttt{kilian@physik.uni-siegen.de}}\\ \hfil\\ Theoretische Physik 1\\ Universit\"at Siegen\\ Walter-Flex-Str.~3, 57068 Siegen, Germany\\ \hfil\\ with contributions from Christian Speckner${}^{d,}$\thanks{\texttt{cnspeckn@googlemail.com}}\\ as well as Christian Schwinn et al.} \date{\textbf{unpublished draft, printed \timestamp}} \maketitle \begin{abstract} \ldots \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newpage \begin{quote} Copyright \textcopyright~1999-2023 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[Target_Fortran] Fortran95 language implementation, calling subroutines \end{modules} Other targets could come in the future: \texttt{C}, \texttt{C++}, O'Caml itself, symbolic manipulation languages, etc. \subsection{Applications} (section~\ref{sec:omega}, p.~\pageref{sec:omega}) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Big To Do Lists} \label{sec:TODO} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Required} All features required for leading order physics applications are in place. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Useful} \begin{enumerate} \item select allowed helicity combinations for massless fermions \item Weyl-Van der Waerden spinors \item speed up helicity sums by using discrete symmetries \item general triple and quartic vector couplings \item diagnostics: count corresponding Feynman diagrams more efficiently for more than ten external lines \item recognize potential cascade decays ($\tau$, $b$, etc.) \begin{itemize} \item warn the user to add additional \item kill fusions (at runtime), that contribute to a cascade \end{itemize} \item complete standard model in $R_\xi$-gauge \item groves (the simple method of cloned generations works) \end{enumerate} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Future Features} \begin{enumerate} \item investigate if unpolarized squared matrix elements can be calculated faster as traces of densitiy matrices. Unfortunately, the answer apears to be \emph{no} for fermions and \emph{up to a constant factor} for massive vectors. Since the number of fusions in the amplitude grows like~$10^{n/2}$, the number of fusions in the squared matrix element grows like~$10^n$. On the other hand, there are $2^{\#\text{fermions}+\#\text{massless vectors}} \cdot3^{\#\text{massive vectors}}$ terms in the helicity sum, which grows \emph{slower} than~$10^{n/2}$. The constant factor is probably also not favorable. However, there will certainly be asymptotic gains for sums over gauge (and other) multiplets, like color sums. \item compile Feynman rules from Lagrangians \item evaluate amplitues in O'Caml by compiling it to three address code for a virtual machine \begin{flushleft} \ocwkw{type}~$\ocwlowerid{mem}~=~\ocwlowerid{scalar}~$\ocwbt{array}~$% \times{}~\ocwlowerid{spinor}~$\ocwbt{array}~$% \times{}~\ocwlowerid{spinor}~$\ocwbt{array}~$% \times{}~\ocwlowerid{vector}~$\ocwbt{array}\\ \ocwkw{type}~$\ocwlowerid{instr}~=$\\ \qquad|~$\ocwupperid{VSS}~$\ocwkw{of}~\ocwbt{int}~$% \times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\ \qquad|~$\ocwupperid{SVS}~$\ocwkw{of}~\ocwbt{int}~$% \times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\ \qquad|~$\ocwupperid{AVA}~$\ocwkw{of}~\ocwbt{int}~$% \times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\ \qquad\ldots \end{flushleft} this could be as fast as~\cite{ALPHA:1997} or~\cite{HELAC:2000}. \item a virtual machine will be useful for for other target as well, because native code appears to become to large for most compilers for more than ten external particles. Bytecode might even be faster due to improved cache locality. \item use the virtual machine in O'Giga \end{enumerate} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Science Fiction} \begin{enumerate} \item numerical and symbolical loop calculations with \textsc{O'Tera: O'Mega Tool for Evaluating Renormalized Amplitudes} \end{enumerate} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Tuples and Polytuples} \label{sec:tuple} \module{tuple} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Topologies} \label{sec:topology} \module{topology} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Directed Acyclical Graphs} \label{sec:DAG} \module{DAG} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Momenta} \label{sec:momentum} \module{momentum} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Cascades} \label{sec:cascades} \module{cascade_syntax} \section{Lexer} \lexer{cascade} \section{Parser} \parser{cascade} \module{cascade} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Arrows and Epsilon Tensors} \label{sec:arrow} \module{arrow} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Birdtracks} \label{sec:birdtracks} \module{birdtracks} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{$\mathrm{SU}(3)$} \label{sec:su3} Using the normalization~$\tr(T_{a}T_{b}) = \delta_{ab}$, we can check the selfconsistency of the completeness relation \begin{equation} T_{a}^{i_1j_1} T_{a}^{i_2j_2} = \left( \delta^{i_1j_2} \delta^{i_2j_1} - \frac{1}{N_C} \delta^{i_1j_1} \delta^{j_1j_2}\right) \end{equation} as \begin{multline} T_{a}^{i_1j_1} T_{a}^{i_2j_2} = \tr\left(T_{a_1}T_{a_2}\right) T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_1} T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} \\ = \left( \delta^{l_1j_1} \delta^{i_1l_2} - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right) \left( \delta^{l_2j_2} \delta^{i_2l_1} - \frac{1}{N_C} \delta^{l_2l_1} \delta^{i_2j_2}\right) = \left( \delta^{i_1j_2} \delta^{i_2j_1} - \frac{1}{N_C} \delta^{i_1i_2} \delta^{j_2j_1}\right) \end{multline} With \begin{equation} \label{eq:f=tr(TTT)'} \ii f_{a_1a_2a_3} = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right) = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \end{equation} and \begin{multline} \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_3} T_{a_3}^{l_3l_1} T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = \\ \left( \delta^{l_1j_1} \delta^{i_1l_2} - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right) \left( \delta^{l_2j_2} \delta^{i_2l_3} - \frac{1}{N_C} \delta^{l_2l_3} \delta^{i_2j_2}\right) \left( \delta^{l_3j_3} \delta^{i_3l_1} - \frac{1}{N_C} \delta^{l_3l_1} \delta^{i_3j_3}\right) \end{multline} we find the decomposition \begin{equation} \label{eq:fTTT'} \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3} = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,. \end{equation} Indeed, \begin{verbatim} symbol nc; Dimension nc; vector i1, i2, i3, j1, j2, j3; index l1, l2, l3; local [TT] = ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j2(l2) * i2(l1) - d_(l2,l1) * i2.j2 / nc ); #procedure TTT(sign) local [TTT`sign'] = ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j2(l2) * i2(l3) - d_(l2,l3) * i2.j2 / nc ) * ( j3(l3) * i3(l1) - d_(l3,l1) * i3.j3 / nc ) `sign' ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j3(l2) * i3(l3) - d_(l2,l3) * i3.j3 / nc ) * ( j2(l3) * i2(l1) - d_(l3,l1) * i2.j2 / nc ); #endprocedure #call TTT(-) #call TTT(+) bracket nc; print; .sort .end \end{verbatim} gives \begin{verbatim} [TT] = + nc^-1 * ( - i1.j1*i2.j2 ) + i1.j2*i2.j1; [TTT-] = + i1.j2*i2.j3*i3.j1 - i1.j3*i2.j1*i3.j2; [TTT+] = + nc^-2 * ( 4*i1.j1*i2.j2*i3.j3 ) + nc^-1 * ( - 2*i1.j1*i2.j3*i3.j2 - 2*i1.j2*i2.j1*i3.j3 - 2*i1.j3*i2.j2*i3.j1 ) + i1.j2*i2.j3*i3.j1 + i1.j3*i2.j1*i3.j2; \end{verbatim} \module{SU3} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Color Propagators} \label{sec:color_propagator} \module{color_Propagator} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Color Fusions} \label{sec:color_fusion} \module{color_fusion} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Color} \label{sec:color} \module{color} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Colorization} \label{sec:colorize} \module{colorize} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Count Coupling Constants} \label{sec:orders} \module{orders} \module{orders_syntax} \section{Lexer} \lexer{orders} \section{Parser} \parser{orders} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Fusions} \label{sec:fusion} \module{fusion} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Lorentz Representations, Couplings, Models and Targets} \label{sec:coupling} -\signature{coupling} -\signature{model} +\interface{coupling} +\interface{model} \module{dirac} %%% \module{vertex} -\signature{target} +\interface{target} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Conserved Quantum Numbers} \label{sec:charges} \module{charges} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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} \module{UFOx_syntax} \section{Expression Lexer} \lexer{UFOx} \section{Expression Parser} \parser{UFOx} \module{UFOx} \module{UFO_syntax} \section{Lexer} \lexer{UFO} \section{Parser} \parser{UFO} \module{UFO_Lorentz} \module{UFO} \section{Targets} \module{UFO_targets} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Hardcoded Targets} \label{sec:targets} The following modules used to be submodules of [Targets], but this as become unwieldy over time. \module{format_Fortran} \module{target_Fortran_Names} \module{target_Fortran} \module{targets_vintage} \module{targets_Kmatrix} \module{targets_Kmatrix_2} \module{target_VM} %module{targets} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Phase Space} \label{sec:phasespace} \module{phasespace} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Whizard} \label{sec:whizard} Talk to~\cite{Kilian:WHIZARD}. \module{whizard} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{FeynMP, n\'ee FeynMF} \label{sec:feynmp} Talk to~\cite{Ohl:1995kr}. \module{feynmp} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Applications} \label{sec:omega} \module{omega} \module{omega_cli} \application{omega3} %application{omega_Phi3} %application{omega_Phi3h} %application{omega_Phi4} %application{omega_Phi4h} \application{omega_QED} %application{omega_QCD} %application{omega_SM3} %application{omega_SM3_ac} \application{omega_SM} \application{omega_SYM} %application{omega_SM_ac} %application{f90Maj_SM} %application{f90Maj_SM4} %application{omega_MSSM} %application{omega_MSSM_g} %application{omega_SM_Rxi} %application{omega_SM_clones} %application{omega_THDM} %application{omega_SMh} %application{omega_SM4h} %application{helas_QED} %application{helas_QCD} %application{helas_SM} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter*{Acknowledgements} We thank Mauro Moretti for fruitful discussions of the ALPHA algorithm~\cite{ALPHA:1997}, that inspired our solution of the double counting problem. We thank Wolfgang Kilian for providing the WHIZARD environment that turns our numbers into real events with unit weight. Thanks to the ECFA/DESY workshops and their participants for providing a showcase. Thanks to Edward Boos for discussions in Kaluza-Klein gravitons. This research is supported by Bundesministerium f\"ur Bildung und Forschung, Germany, (05\,HT9RDA) and Deutsche Forschungsgemeinschaft (MA\,676/6-1). Thanks to the Caml and Objective Caml teams from INRIA for the development and the lean and mean implementation of a programming language that does not insult the programmer's intelligence. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{thebibliography}{10} \bibitem{ALPHA:1997} F. Caravaglios, M. Moretti, Z.{} Phys.{} \textbf{C74} (1997) 291. \bibitem{HELAC:2000} A. Kanaki, C. Papadopoulos, DEMO-HEP-2000/01, hep-ph/0002082, February 2000. \bibitem{Ler97} Xavier Leroy, \textit{The Objective Caml system, documentation and user's guide}, Technical Report, INRIA, 1997. \bibitem{Okasaki:1998:book} Chris Okasaki, \textit{Purely Functional Data Structures}, Cambridge University Press, 1998. \bibitem{HELAS} H. Murayama, I. Watanabe, K. Hagiwara, KEK Report 91-11, January 1992. \bibitem{MADGRAPH:1994} T. Stelzer, W.F. Long, Comput.{} Phys.{} Commun.{} \textbf{81} (1994) 357. \bibitem{Denner:Majorana} A. Denner, H. Eck, O. Hahn and J. K\"ublbeck, Phys.{} Lett.{} \textbf{B291} (1992) 278; Nucl.{} Phys.{} \textbf{B387} (1992) 467. \bibitem{Barger/etal:1992:color} V.~Barger, A.~L.~Stange, R.~J.~N.~Phillips, Phys.~Rev.~\textbf{D45}, (1992) 1751. \bibitem{Ohl:LOTR} T. Ohl, \textit{Lord of the Rings}, (Computer algebra library for O'Caml, unpublished). \bibitem{Ohl:bocages} T. Ohl, \textit{Bocages}, (Feynman diagram library for O'Caml, unpublished). \bibitem{Kilian:WHIZARD} W. Kilian, \textit{\texttt{WHIZARD}}, University of Karlsruhe, 2000. %\cite{Ohl:1995kr} \bibitem{Ohl:1995kr} T.~Ohl, %``Drawing Feynman diagrams with Latex and Metafont,'' Comput. Phys. Commun. \textbf{90} (1995), 340-354 doi:10.1016/0010-4655(95)90137-S [arXiv:hep-ph/9505351 [hep-ph]]. %51 citations counted in INSPIRE as of 13 Jun 2023 \bibitem{Boos/Ohl:groves} E.\,E. Boos, T. Ohl, Phys.\ Rev.\ Lett.\ \textbf{83} (1999) 480. \bibitem{Han/Lykken/Zhang:1999:Kaluza-Klein} T.~Han, J.~D.~Lykken and R.~Zhang, %``On Kaluza-Klein states from large extra dimensions,'' Phys.{} Rev.{} \textbf{D59} (1999) 105006 [hep-ph/9811350]. %%CITATION = HEP-PH 9811350;%% \bibitem{PTVF92} William H. Press, Saul A. Teukolsky, William T. Vetterling, Brian P. Flannery, \textit{Numerical Recipes: The Art of Scientific Computing}, Second Edition, Cambridge University Press, 1992. \bibitem{Cvi76} P.~Cvitanovi\'c, % author={Predrag Cvitanovi\'c}, % title={Group Theory for {Feynman} Diagrams in Non-{Abelian} % Gauge Theories}, Phys.{} Rev.{} \textbf{D14} (1976) 1536. %%%\bibitem{Kleiss/etal:Color-Monte-Carlo} %%% \begin{dubious} %%% ``\texttt{Kleiss/etal:Color-Monte-Carlo}'' %%% \end{dubious} %\cite{Kilian:2012pz} \bibitem{Kilian:2012pz} W.~Kilian, T.~Ohl, J.~Reuter and C.~Speckner, %``QCD in the Color-Flow Representation,'' JHEP \textbf{1210} (2012) 022 [arXiv:1206.3700 [hep-ph]]. %%CITATION = doi:10.1007/JHEP10(2012)022;%% %37 citations counted in INSPIRE as of 23 Apr 2019 + %\cite{Ohl:2024fpq} +\bibitem{Ohl:2024fpq} +T.~Ohl, +%``Birdtracks of Exotic SU(N) Color Structures,'' +[arXiv:2403.04685 [hep-ph]]. %\cite{Degrande:2011ua} \bibitem{Degrande:2011ua} C.~Degrande, C.~Duhr, B.~Fuks, D.~Grellscheid, O.~Mattelaer and T.~Reiter, %``UFO - The Universal FeynRules Output,'' Comput.{} Phys.{} Commun.{} \textbf{183} (2012), 1201-1214 doi:10.1016/j.cpc.2012.01.022 [arXiv:1108.2040 [hep-ph]]. +%\cite{Darme:2023jdn} +\bibitem{Darme:2023jdn} +L.~Darm\'e, C.~Degrande, C.~Duhr, B.~Fuks, M.~Goodsell, G.~Heinrich, V.~Hirschi, S.~H\"oche, M.~H\"ofer and J.~Isaacson, \textit{et al.} +%``UFO 2.0: the \textquoteleft{}Universal Feynman Output\textquoteright{} format,'' +Eur.{} Phys.{} J.{} C \textbf{83} (2023) no.7, 631 +[arXiv:2304.09883 [hep-ph]]. +%32 citations counted in INSPIRE as of 21 Mar 2024 \bibitem{TAOCP2} Donald E.~Knuth, \textit{The Art of Computer Programming. 2: Seminumerical algorithms} \end{thebibliography} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \appendix %%% we've started to have too many appendices \ldots \renewcommand{\thechapter}{\AlphAlph{\value{chapter}}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Autotools} \label{sec:autotools} \module{config} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Textual Options} \label{sec:options} \module{options} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Progress Reports} \label{sec:progress} \module{progress} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More on Filenames} \label{sec:thoFilename} \module{thoFilename} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Cache Files} \label{sec:cache} \module{cache} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More On Lists} \label{sec:tholist} \module{thoList} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Non-Empty Lists} \label{sec:nelist} \module{NEList} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Lists with Typed Length} \label{sec:nlist} \module{NList} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More On Arrays} \label{sec:thoarray} \module{thoArray} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Persistent Arrays} \label{sec:parray} \module{PArray} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More On Strings} \label{sec:thostring} \module{thoString} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Structured Maps} \label{sec:thomap} \module{thoMap} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Polymorphic Maps} \label{sec:pmap} From~\cite{Ohl:LOTR}. \module{pmap} \module{partial} %%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \chapter{Tries} %%% \label{sec:trie} %%% From~\cite{Okasaki:1998:book}, extended for~\cite{Ohl:LOTR}. %%% \module{trie} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Tensor Products} \label{sec:product} From~\cite{Ohl:LOTR}. \module{product} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{(Fiber) Bundles} \label{sec:bundle} \module{bundle} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Power Sets} \label{sec:powSet} \module{powSet} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Combinatorics} \label{sec:combinatorics} \module{combinatorics} \module{permutation} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Partitions} \label{sec:partition} \module{partition} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Young Diagrams and Tableaux} \label{sec:young} \module{young} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Trees} \label{sec:tree} From~\cite{Ohl:bocages}: Trees with one root admit a straightforward recursive definition \begin{equation} \label{eq:trees} T(N,L) = L \cup N\times T(N,L)\times T(N,L) \end{equation} that is very well adapted to mathematical reasoning. Such recursive definitions are useful because they allow us to prove properties of elements by induction \begin{multline} \label{eq:tree-induction} \forall l\in L: p(l) \land (\forall n\in N: \forall t_1,t_2\in T(N,L): p(t_1) \land p(t_2) \Rightarrow p(n\times t_1\times t_2)) \\ \Longrightarrow \forall t\in T(N,L): p(t) \end{multline} i.\,e.~establishing a property for all leaves and showing that a node automatically satisfies the property if it is true for all children proves the property for \emph{all} trees. This induction is of course modelled after standard mathematical induction \begin{equation} p(1) \land (\forall n\in \mathbf{N}: p(n) \Rightarrow p(n+1)) \Longrightarrow \forall n\in \mathbf{N}: p(n) \end{equation} The recursive definition~(\ref{eq:trees}) is mirrored by the two tree construction functions\footnote{To make the introduction more accessible to non-experts, I avoid the `curried' notation for functions with multiple arguments and use tuples instead. The actual implementation takes advantage of curried functions, however. Experts can read $\alpha\to\beta\to\gamma$ for $\alpha\times\beta\to\gamma$.} \begin{subequations} \begin{align} \ocwlowerid{leaf}:\;& \nu\times\lambda \to(\nu,\lambda) T \\ \ocwlowerid{node}:\;& \nu\times(\nu,\lambda)T \times(\nu,\lambda)T \to(\nu,\lambda)T \end{align} \end{subequations} Renaming leaves and nodes leaves the structure of the tree invariant. Therefore, morphisms~$L\to L'$ and~$N\to N'$ of the sets of leaves and nodes induce natural homomorphisms~$T(N,L)\to T(N',L')$ of trees \begin{equation} \ocwlowerid{map}:\; (\nu\to\nu')\times(\lambda\to\lambda') \times(\nu,\lambda)T \to(\nu',\lambda') T \end{equation} The homomorphisms constructed by \ocwlowerid{map} are trivial, but ubiquitous. More interesting are the morphisms \begin{equation} \begin{aligned} \ocwlowerid{fold}:\;& (\nu\times\lambda\to\alpha) \times(\nu\times\alpha\times\alpha\to\alpha) \times(\nu,\lambda)T \to\alpha \\ & (f_1,f_2,l\in L) \mapsto f_1(l) \\ & (f_1,f_2,(n,t_1,t_2)) \mapsto f_2(n,\ocwlowerid{fold}(f_1,f_2,t_1), \ocwlowerid{fold}(f_1,f_2,t_2)) \end{aligned} \end{equation} and \begin{equation} \begin{aligned} \ocwlowerid{fan}:\;& (\nu\times\lambda\to\{\alpha\}) \times(\nu\times\alpha\times\alpha\to\{\alpha\}) \times(\nu,\lambda)T \to\{\alpha\} \\ & (f_1,f_2,l\in L) \mapsto f_1(l) \\ & (f_1,f_2,(n,t_1,t_2)) \mapsto f_2(n, \ocwlowerid{fold}(f_1,f_2,t_1) \otimes\ocwlowerid{fold}(f_1,f_2,t_2)) \end{aligned} \end{equation} where the tensor product notation means that~$f_2$ is applied to all combinations of list members in the argument: \begin{equation} \phi(\{x\}\otimes \{y\}) = \left\{ \phi(x,y) | x\in\{x\} \land y\in\{y\} \right\} \end{equation} But note that due to the recursive nature of trees, \ocwlowerid{fan} is \emph{not} a morphism from $T(N,L)$ to $T(N\otimes N,L)$.\par If we identify singleton sets with their members, \ocwlowerid{fold} could be viewed as a special case of \ocwlowerid{fan}, but that is probably more confusing than helpful. Also, using the special case~$\alpha=(\nu',\lambda')T$, the homomorphism \ocwlowerid{map} can be expressed in terms of \ocwlowerid{fold} and the constructors \begin{equation} \begin{aligned} \ocwlowerid{map}:\;& (\nu\to\nu')\times(\lambda\to\lambda') \times(\nu,\lambda)T \to(\nu',\lambda')T \\ &(f,g,t) \mapsto \ocwlowerid{fold} (\ocwlowerid{leaf}\circ (f\times g), \ocwlowerid{node}\circ (f\times\ocwlowerid{id} \times\ocwlowerid{id}), t) \end{aligned} \end{equation} \ocwlowerid{fold} is much more versatile than \ocwlowerid{map}, because it can be used with constructors for other tree representations to translate among different representations. The target type can also be a mathematical expression. This is used extensively below for evaluating Feynman diagrams.\par Using \ocwlowerid{fan} with~$\alpha=(\nu',\lambda')T$ can be used to construct a multitude of homomorphic trees. In fact, below it will be used extensively to construct all Feynman diagrams~$\{(\nu,\{p_1,\ldots,p_n\})T\}$ of a given topology~$t\in (\emptyset,\{1,\ldots,n\})T$. \begin{dubious} The physicist in me guesses that there is another morphism of trees that is related to \ocwlowerid{fan} like a Lie-algebra is related to the it's Lie-group. I have not been able to pin it down, but I guess that it is a generalization of \ocwlowerid{grow} below. \end{dubious} \module{tree} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Dependency Trees} \label{sec:tree2} \module{tree2} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Consistency Checks} \label{sec:count} \application{count} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Complex Numbers} \label{sec:complex} \module{complex} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Algebra} \label{sec:algebra} \module{algebra} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Simple Linear Algebra} \label{sec:linalg} \module{linalg} %application{test_linalg} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Partial Maps} \label{sec:partial} \module{partial} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Talk To The WHiZard \ldots} \label{sec:whizard_tool} Talk to~\cite{Kilian:WHIZARD}. \begin{dubious} Temporarily disabled, until, we implement some conditional weaving\ldots \end{dubious} %application{whizard_tool} %%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \chapter{Widget Library and Class Hierarchy for O'Giga} %%% \label{sec:thogtk} %%% {\itshape NB: The code in this chapter \emph{must} be compiled with %%% \verb+-labels+, since \verb+lablgtk+ doesn't appear to work in classic mode.} %%% \begin{dubious} %%% Keep in mind that \texttt{ocamlweb} doesn't work properly with %%% O'Caml~3 yet. The colons in label declarations are typeset with %%% erroneous white space. %%% \end{dubious} %%% %%% \section{Architecture} %%% In \texttt{lablgtk}, O'Caml objects are typically constructed in %%% parallel to constructors for \texttt{GTK+} widgets. The objects %%% provide inheritance and all that, while the constructors implement the %%% semantics. %%% %%% \subsection{Inheritance vs.~Aggregation} %%% We have two mechanisms for creating new widgets: inheritance and %%% aggregation. Inheritance makes it easy to extend a given widget with %%% new methods or to combine orthogonal widgets (\emph{multiple %%% inheritance}). Aggregation is more suitable for combining %%% non-orthogonal widgets (e.\,g.~multiple instances of the same widget). %%% %%% The problem with inheritance in \texttt{lablgtk} is, that it is a %%% \emph{bad} idea to implement the semantics in the objects. In a %%% multi-level inheritance hierarchy, O'Caml can evaluate class functions %%% more than once. Since functions accessing \texttt{GTK+} change the %%% state of \texttt{GTK+}, we could accidentally violate invariants. %%% Therefore inheritance forces us to use the two-tiered approach of %%% \texttt{lablgtk} ourselves. It is not really complicated, but tedious %%% and it appears to be a good idea to use aggregation whenever in doubt. %%% %%% Nevertheless, there are examples (like %%% \ocwupperid{ThoGButton.mutable\_button} below, where just one new %%% method is added), that cry out for inheritance for the benefit of the %%% application developer. %%% %%% \module{thoGWindow} %%% \module{thoGButton} %%% \module{thoGMenu} %%% \module{thoGDraw} %%% %%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% \chapter{O'Mega Virtual Machine} %%% \label{sec:ovm} %%% \module{OVM} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{\texttt{Fortran} Libraries} \label{sec:fortran} \input{omegalib} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{raggedright} \ifpdf \chapter{Index} \let\origtwocolumn\twocolumn \def\twocolumn[#1]{\origtwocolumn}% This index has been generated automatically and might not be 100\%ly accurate. In particular, hyperlinks have been observed to be off by one page. \fi \input{index.tex} \end{raggedright} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \end{empfile} \end{fmffile} \end{document} \endinput Local Variables: mode:latex indent-tabs-mode:nil page-delimiter:"^%%%%%.*\n" End: Index: trunk/omega/src/modeltools.ml =================================================================== --- trunk/omega/src/modeltools.ml (revision 8919) +++ trunk/omega/src/modeltools.ml (revision 8920) @@ -1,673 +1,696 @@ (* modeltools.ml -- Copyright (C) 1999-2024 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Compilation} *) (* Flavors and coupling constants: flavors can be tested for equality and charge conjugation is defined. *) module type Flavor = sig type f type c val compare : f -> f -> int val conjugate : f -> f end (* Compiling fusions from a list of vertices: *) module type Fusions = sig type t type f type c val fuse2 : t -> f -> f -> (f * c Coupling.t) list val fuse3 : t -> f -> f -> f -> (f * c Coupling.t) list val fuse : t -> f list -> (f * c Coupling.t) list val of_vertices : (((f * f * f) * c Coupling.vertex3 * c) list * ((f * f * f * f) * c Coupling.vertex4 * c) list * (f list * c Coupling.vertexn * c) list) -> t end module Fusions (F : Flavor) : Fusions with type f = F.f and type c = F.c = struct type f = F.f type c = F.c module F2 = struct type t = f * f let hash = Hashtbl.hash let compare (f1, f2) (f1', f2') = let c1 = F.compare f1 f1' in if c1 <> 0 then c1 else F.compare f2 f2' let equal f f' = compare f f' = 0 end module F3 = struct type t = f * f * f let hash = Hashtbl.hash let compare (f1, f2, f3) (f1', f2', f3') = let c1 = F.compare f1 f1' in if c1 <> 0 then c1 else let c2 = F.compare f2 f2' in if c2 <> 0 then c2 else F.compare f3 f3' let equal f f' = compare f f' = 0 end module Fn = struct type t = f list let hash = Hashtbl.hash let compare f f' = ThoList.compare ~cmp:F.compare f f' let equal f f' = compare f f' = 0 end module H2 = Hashtbl.Make (F2) module H3 = Hashtbl.Make (F3) module Hn = Hashtbl.Make (Fn) type t = { v3 : (f * c Coupling.t) list H2.t; v4 : (f * c Coupling.t) list H3.t; vn : (f * c Coupling.t) list Hn.t } let lookup_fuse2 table f1 f2 = try H2.find table.v3 (f1, f2) with Not_found -> [] let lookup_fuse3 table f1 f2 f3 = try H3.find table.v4 (f1, f2, f3) with Not_found -> [] let lookup_fusen table f = try Hn.find table.vn f with Not_found -> [] let fuse2 table f1 f2 = List.rev_append (lookup_fusen table [f1; f2]) (lookup_fuse2 table f1 f2) let fuse3 table f1 f2 f3 = List.rev_append (lookup_fusen table [f1; f2; f3]) (lookup_fuse3 table f1 f2 f3) let fusen table f = lookup_fusen table f let fuse table = function | [] | [_] -> invalid_arg "Fusions().fuse" | [f1; f2] -> fuse2 table f1 f2 | [f1; f2; f3] -> fuse3 table f1 f2 f3 | f -> fusen table f (* Note that a pair or a triplet can appear more than once (e.\,g.~$e^+e^-\to \gamma$ and~$e^+e^-\to Z$). Therefore don't replace the entry, but augment it instead. *) let add_fusion2 table f1 f2 fusions = H2.add table.v3 (f1, f2) (fusions :: lookup_fuse2 table f1 f2) let add_fusion3 table f1 f2 f3 fusions = H3.add table.v4 (f1, f2, f3) (fusions :: lookup_fuse3 table f1 f2 f3) let add_fusionn table f fusions = Hn.add table.vn f (fusions :: lookup_fusen table f) (* \begin{dubious} Do we need to take into account the charge conjugation of the coupling constants here? \end{dubious} *) (* If some flavors are identical, we must not introduce the same vertex more than once: *) open Coupling let permute3 (f1, f2, f3) = [ (f1, f2), F.conjugate f3, F12; (f2, f1), F.conjugate f3, F21; (f2, f3), F.conjugate f1, F23; (f3, f2), F.conjugate f1, F32; (f3, f1), F.conjugate f2, F31; (f1, f3), F.conjugate f2, F13 ] (* Here we add identical permutations of pairs only once: *) module F2' = Set.Make (F2) let add_permute3 table v c set ((f1, f2 as f12), f, p) = if F2'.mem f12 set then set else begin add_fusion2 table f1 f2 (f, V3 (v, p, c)); F2'.add f12 set end let add_vertex3 table (f123, v, c) = ignore (List.fold_left (fun set f -> add_permute3 table v c set f) F2'.empty (permute3 f123)) (* \begin{dubious} Handling all the cases explicitely is OK for cubic vertices, but starts to become questionable already for quartic couplings. The advantage remains that we can check completeness in [Targets]. \end{dubious} *) let permute4 (f1, f2, f3, f4) = [ (f1, f2, f3), F.conjugate f4, F123; (f2, f3, f1), F.conjugate f4, F231; (f3, f1, f2), F.conjugate f4, F312; (f2, f1, f3), F.conjugate f4, F213; (f3, f2, f1), F.conjugate f4, F321; (f1, f3, f2), F.conjugate f4, F132; (f1, f2, f4), F.conjugate f3, F124; (f2, f4, f1), F.conjugate f3, F241; (f4, f1, f2), F.conjugate f3, F412; (f2, f1, f4), F.conjugate f3, F214; (f4, f2, f1), F.conjugate f3, F421; (f1, f4, f2), F.conjugate f3, F142; (f1, f3, f4), F.conjugate f2, F134; (f3, f4, f1), F.conjugate f2, F341; (f4, f1, f3), F.conjugate f2, F413; (f3, f1, f4), F.conjugate f2, F314; (f4, f3, f1), F.conjugate f2, F431; (f1, f4, f3), F.conjugate f2, F143; (f2, f3, f4), F.conjugate f1, F234; (f3, f4, f2), F.conjugate f1, F342; (f4, f2, f3), F.conjugate f1, F423; (f3, f2, f4), F.conjugate f1, F324; (f4, f3, f2), F.conjugate f1, F432; (f2, f4, f3), F.conjugate f1, F243 ] (* Add identical permutations of triplets only once: *) module F3' = Set.Make (F3) let add_permute4 table v c set ((f1, f2, f3 as f123), f, p) = if F3'.mem f123 set then set else begin add_fusion3 table f1 f2 f3 (f, V4 (v, p, c)); F3'.add f123 set end let add_vertex4 table (f1234, v, c) = ignore (List.fold_left (fun set f -> add_permute4 table v c set f) F3'.empty (permute4 f1234)) module Fn' = Set.Make (Fn) - let permuten = function + let _permuten = function | [] -> invalid_arg "Modeltools.permuten" | f -> List.map (fun f' -> match List.split f' with | i :: i_list, f :: f_list -> (f_list, F.conjugate f, i_list @ [i]) | _ -> failwith "Modeltools.permuten: impossible") (Combinatorics.permute (ThoList.enumerate 1 f)) (* This is for debugging: it provides the same permutations than the legacy version. *) - let permutations = function + let _permutations = function | [f1; f2; f3] -> [ [f1; f2; f3]; [f2; f1; f3]; [f2; f3; f1]; [f3; f2; f1]; [f3; f1; f2]; [f1; f3; f2] ] | [f1; f2; f3; f4] -> [ [f1; f2; f3; f4]; [f1; f2; f4; f3]; [f1; f3; f2; f4]; [f1; f3; f4; f2]; [f1; f4; f2; f3]; [f1; f4; f3; f2]; [f2; f1; f3; f4]; [f2; f1; f4; f3]; [f2; f3; f1; f4]; [f2; f3; f4; f1]; [f2; f4; f1; f3]; [f2; f4; f3; f1]; [f3; f1; f2; f4]; [f3; f1; f4; f2]; [f3; f2; f1; f4]; [f3; f2; f4; f1]; [f3; f4; f1; f2]; [f3; f4; f2; f1]; [f4; f1; f2; f3]; [f4; f1; f3; f2]; [f4; f2; f1; f3]; [f4; f2; f3; f1]; [f4; f3; f1; f2]; [f4; f3; f2; f1] ] | flist -> Combinatorics.permute flist let permutations = Combinatorics.permute let permuten = function | [] -> invalid_arg "Modeltools.permuten" | f -> List.map (fun f' -> match List.split (List.rev f') with | i_list, f :: f_list -> (* [Printf.eprintf "permuten: %s\n" (ThoList.to_string string_of_int (List.rev i_list));] *) (List.rev f_list, F.conjugate f, List.rev i_list) | _ -> failwith "Modeltools.permuten: impossible") (permutations (ThoList.enumerate 1 f)) let add_permuten table v c set (f12__n, f, p) = if Fn'.mem f12__n set then set else begin add_fusionn table f12__n (f, Vn (v, p, c)); Fn'.add f12__n set end (* \begin{dubious} We could apply any necessary permutations to objects that are hidden inside of the vertex [v] here instead of in [Fusion.stat_fuse] and [Colorize.fuse]. \end{dubious} *) let add_vertexn table (f12__n, v, c) = ignore (List.fold_left (fun set f -> add_permuten table v c set f) Fn'.empty (permuten f12__n)) let of_vertices (vlist3, vlist4, vlistn) = let table = { v3 = H2.create 37; v4 = H3.create 37; vn = Hn.create 37 } in List.iter (add_vertex3 table) vlist3; List.iter (add_vertex4 table) vlist4; List.iter (add_vertexn table) vlistn; table end module type Constant = sig type t val of_string : string -> t end module Constant (M : Model.T) : Constant with type t = M.constant = struct type t = M.constant module String_Key = struct type t = string let hash = Hashtbl.hash let equal = (=) end module String_Hash = Hashtbl.Make (String_Key) let table = String_Hash.create 37 let fill_table table vs = List.iter (fun (_, _, c) -> String_Hash.add table (M.constant_symbol c) c) vs (* Delay loading of the tables until the first use, so that [M.vertices] can be initialized from a file. *) let tables_filled = ref false let fill_tables () = if not !tables_filled then begin let (v3, v4, vn) = M.vertices () in fill_table table v3; fill_table table v4; fill_table table vn; tables_filled := true end let of_string name = try fill_tables (); String_Hash.find table name with | Not_found -> invalid_arg ("Constant(Model).of_string: unknown coupling constant: " ^ name) end (* \thocwmodulesection{Mutable Models} *) exception Uninitialized of string module Mutable (FGC : sig type f and g and c and co end) : Model.Mutable with type flavor = FGC.f and type gauge = FGC.g and type constant = FGC.c and type coupling_order = FGC.co = struct type flavor = FGC.f type gauge = FGC.g type constant = FGC.c type coupling_order = FGC.co type init = string let init _ = () let write_whizard _ = () let options = Options.empty let caveats () = [] module Ch = Charges.Null let charges _ = () let uninitialized name = raise (Uninitialized name) (* Note that [lookup] works, by the magic of currying, for any arity. But we need to supply one argument to delay evaluation. *) (* Also note that the references are \emph{not} shared among results of functor applications. Simple module renaming causes sharing. *) let declare initial = let reference = ref initial in let update fct = reference := fct and lookup arg = !reference arg in (update, lookup) let declare1 name = declare (fun _ -> uninitialized name) let declare2 name = declare (fun _ _ -> uninitialized name) let declare3 name = declare (fun _ _ _ -> uninitialized name) let set_all_coupling_orders, all_coupling_orders = declare1 "all_coupling_orders" let set_coupling_orders, coupling_orders = declare1 "coupling_orders" let set_coupling_order_to_string, coupling_order_to_string = declare1 "coupling_order_to_string" let set_color, color = declare1 "color" let set_nc, nc = declare1 "nc" let set_pdg, pdg = declare1 "pdg" let set_lorentz, lorentz = declare1 "lorentz" let set_propagator, propagator = declare1 "propagator" let set_width, width = declare1 "width" let set_goldstone, goldstone = declare1 "goldstone" let set_conjugate, conjugate = declare1 "conjugate" let set_fermion, fermion = declare1 "fermion" let set_max_degree, max_degree = declare1 "max_degree" let set_vertices, vertices = declare1 "vertices" let set_fuse2, fuse2 = declare2 "fuse2" let set_fuse3, fuse3 = declare3 "fuse3" let set_fuse, fuse = declare1 "fuse" let set_flavors, flavors = declare1 "flavors" let set_external_flavors, external_flavors = declare (fun () -> [("uninitialized", [])]) let set_parameters, parameters = declare1 "parameters" let set_flavor_of_string, flavor_of_string = declare1 "flavor_of_string" let set_flavor_to_string, flavor_to_string = declare1 "flavor_to_string" let set_flavor_to_TeX, flavor_to_TeX = declare1 "flavor_to_TeX" let set_flavor_symbol, flavor_symbol = declare1 "flavor_symbol" let set_gauge_symbol, gauge_symbol = declare1 "gauge_symbol" let set_mass_symbol, mass_symbol = declare1 "mass_symbol" let set_width_symbol, width_symbol = declare1 "width_symbol" let set_constant_symbol, constant_symbol = declare1 "constant_symbol" module F = Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) let max_degree_of_vertices (v3, v4, vn) = List.fold_left (fun acc (p, _, _) -> max acc (List.length p)) (max (match v3 with [] -> 0 | _ -> 3) (match v4 with [] -> 0 | _ -> 4)) vn let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone ~conjugate ~fermion ~vertices ~flavors ~parameters ~flavor_of_string ~flavor_to_string ~flavor_to_TeX ~flavor_symbol ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol ~all_coupling_orders ~coupling_order_to_string ~coupling_orders = set_color color; set_nc nc; set_pdg pdg; set_lorentz lorentz; set_propagator propagator; set_width width; set_goldstone goldstone; set_conjugate conjugate; set_fermion fermion; let v = vertices () in let max_degree = max_degree_of_vertices v in set_max_degree (fun () -> max_degree); set_vertices (fun () -> v); let table = F.of_vertices v in set_fuse2 (F.fuse2 table); set_fuse3 (F.fuse3 table); set_fuse (F.fuse table); set_external_flavors (fun () -> flavors); let flavors = ThoList.flatmap snd flavors in set_flavors (fun () -> flavors); set_parameters parameters; set_flavor_of_string flavor_of_string; set_flavor_to_string flavor_to_string; set_flavor_to_TeX flavor_to_TeX; set_flavor_symbol flavor_symbol; set_gauge_symbol gauge_symbol; set_mass_symbol mass_symbol; set_width_symbol width_symbol; set_constant_symbol constant_symbol; set_all_coupling_orders all_coupling_orders; set_coupling_orders coupling_orders; set_coupling_order_to_string coupling_order_to_string end module Static (M : Model.T) = struct type flavor = M.flavor type gauge = M.gauge type constant = M.constant type coupling_order = M.coupling_order type init = string module Ch = M.Ch let all_coupling_orders = M.all_coupling_orders let coupling_orders = M.coupling_orders let coupling_order_to_string = M.coupling_order_to_string let color = M.color let nc = M.nc let charges = M.charges let pdg = M.pdg let lorentz = M.lorentz let propagator = M.propagator let width = M.width let conjugate = M.conjugate let fermion = M.fermion let max_degree = M.max_degree let vertices = M.vertices let fuse2 = M.fuse2 let fuse3 = M.fuse3 let fuse = M.fuse let flavors = M.flavors let external_flavors = M.external_flavors let goldstone = M.goldstone let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol let options = M.options let caveats = M.caveats let init _ = () let write_whizard _ = () let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone ~conjugate ~fermion ~vertices ~flavors ~parameters ~flavor_of_string ~flavor_to_string ~flavor_to_TeX ~flavor_symbol ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol ~all_coupling_orders ~coupling_order_to_string ~coupling_orders = + ignore color; + ignore nc; + ignore pdg; + ignore lorentz; + ignore propagator; + ignore width; + ignore goldstone; + ignore conjugate; + ignore fermion; + ignore vertices; + ignore flavors; + ignore parameters; + ignore flavor_of_string; + ignore flavor_to_string; + ignore flavor_to_TeX; + ignore flavor_symbol; + ignore gauge_symbol; + ignore mass_symbol; + ignore width_symbol; + ignore constant_symbol; + ignore all_coupling_orders; + ignore coupling_order_to_string; + ignore coupling_orders; () end (* \thocwmodulesection{Topology Only} *) (* UFO models can have more than one Lorentz structure for a given flavor combination. This messes up the phase space generation. There we need to be able to ignore the redundant flavor combinations. *) (* Filter vertices with more than one Lorentz structure for a combination of flavors. Only the first Lorentz structure is kept. *) let filter_couplings flavor_coupling_list = List.map (fun (f, c_list) -> (f, List.hd c_list)) (ThoList.factorize flavor_coupling_list) let triple_to_nested (a, b, c) = (a, (b, c)) let nested_to_triple (a, (b, c)) = (a, b, c) let filter_couplings_triples fc = List.map nested_to_triple (filter_couplings (List.map triple_to_nested fc)) (* \begin{dubious} It would be clearer to replace [constant Coupling.t] by [unit] in the resultig model, but that would require much more code duplication. \end{dubious} *) module Topology (M : Model.T) = struct type flavor = M.flavor type gauge = M.gauge type constant = M.constant type coupling_order = M.coupling_order module Ch = M.Ch let all_coupling_orders = M.all_coupling_orders let coupling_orders = M.coupling_orders let coupling_order_to_string = M.coupling_order_to_string let color = M.color let nc = M.nc let charges = M.charges let pdg = M.pdg let lorentz = M.lorentz let propagator = M.propagator let width = M.width let conjugate = M.conjugate let fermion = M.fermion let max_degree = M.max_degree let vertices () = let (v3, v4, vn) = M.vertices () in (filter_couplings_triples v3, filter_couplings_triples v4, filter_couplings_triples vn) let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2) let fuse3 f1 f2 f3 = filter_couplings (M.fuse3 f1 f2 f3) let fuse f_list = filter_couplings (M.fuse f_list) let flavors = M.flavors let external_flavors = M.external_flavors let goldstone = M.goldstone let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol let options = M.options let caveats = M.caveats end module Topology3 (M : Model.T) = struct type flavor = M.flavor type gauge = M.gauge type constant = M.constant type coupling_order = M.coupling_order module Ch = M.Ch let all_coupling_orders = M.all_coupling_orders let coupling_orders = M.coupling_orders let coupling_order_to_string = M.coupling_order_to_string let color = M.color let nc = M.nc let charges = M.charges let pdg = M.pdg let lorentz = M.lorentz let propagator = M.propagator let width = M.width let conjugate = M.conjugate let fermion = M.fermion let max_degree = M.max_degree let vertices () = let (v3, _, vn) = M.vertices () in (filter_couplings_triples v3, [], filter_couplings_triples (List.filter (fun (f, _, _) -> List.length f < 3) vn)) let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2) - let fuse3 f1 f2 f3 = [] + let fuse3 _f1 _f2 _f3 = [] let fuse = function | [_; _] as f_list -> filter_couplings (M.fuse f_list) | _ -> [] let flavors = M.flavors let external_flavors = M.external_flavors let goldstone = M.goldstone let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol let options = M.options let caveats = M.caveats end Index: trunk/omega/src/dune =================================================================== --- trunk/omega/src/dune (revision 0) +++ trunk/omega/src/dune (revision 8920) @@ -0,0 +1,50 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This is NOT an offical dune file for O'Mega +;;; It is for internal development only! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(library + (name omega) + (public_name omega) + (modules ;;; Interfaces + Coupling Model Target + ;;; O'Mega main physiscs modules + Color Color_Propagator Color_Fusion Colorize + DAG Topology Fusion Modeltools Charges Momentum Phasespace Process + ;;; diagram selection + Orders Orders_syntax Orders_lexer Orders_parser + Cascade Cascade_syntax cascade_lexer Cascade_parser + ;;; UFO + UFO Config ;;; UFO depends on Config, which needs preprocessing ... + UFO_syntax UFO_lexer UFO_parser + UFOx UFOx_syntax UFOx_lexer UFOx_parser + UFO_targets UFO_Lorentz UFO_tools Dirac + ;;; more libraries + Bundle Tuple Partition PowSet Tree Tree2 Linalg + PArray Options Sets Trie + Format_Fortran + ThoMap ThoFilename Progress + ;;; beneath this line is enough for tangara: + Arrow Birdtracks SU3 + Algebra Combinatorics Permutation Young + NEList Partial Product + ThoArray ThoList ThoString Pmap Sets + OUnit) + (private_modules) + (wrapped false) + (flags (:standard -I +unix)) + (ocamlc_flags (:standard)) + (ocamlopt_flags (:standard -inline 32)) + (libraries)) + +(rule + (target config.ml) + (deps config.ml.in) + (action + (run cp %{deps} %{target}))) + +(ocamllex UFOx_lexer UFO_lexer orders_lexer cascade_lexer) +(ocamlyacc UFOx_parser UFO_parser orders_parser cascade_parser) + +; (documentation +; (mld_files index)) Index: trunk/omega/src/target.ml =================================================================== --- trunk/omega/src/target.ml (revision 0) +++ trunk/omega/src/target.ml (revision 8920) @@ -0,0 +1,43 @@ +(* target.mli -- + + Copyright (C) 1999-2024 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 amplitudes + + val options : Options.t + type diagnostic = All | Arguments | Momenta | Gauge + +(* Format the amplitudes as a sequence of strings. *) + val amplitudes_to_channel : string -> out_channel -> + (diagnostic * bool) list -> amplitudes -> unit + + val parameters_to_channel : out_channel -> unit + + end + +module type Maker = + functor (F : Fusion.Maker) -> + functor (P : Momentum.T) -> functor (M : Model.T) -> + T with type amplitudes = Fusion.Multi(F)(P)(M).amplitudes Index: trunk/omega/src/thoMap.ml =================================================================== --- trunk/omega/src/thoMap.ml (revision 8919) +++ trunk/omega/src/thoMap.ml (revision 8920) @@ -1,162 +1,161 @@ (* thoMap.ml -- Copyright (C) 2023-2024 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. *) (* \thocwmodulesection{Maps to Sets} *) module type Buckets = sig type t type key type element val empty : t val add : key -> element -> t -> t val to_lists : t -> (key * element list) list val factorize : (key * element) list -> (key * element list) list val factorize_batches : (key * element) list list -> (key * element list) list end module Buckets (Key : Map.OrderedType) (Element : Set.OrderedType) : Buckets with type key = Key.t and type element = Element.t = struct module Keys = Map.Make(Key) module Elements = Set.Make(Element) type t = Elements.t Keys.t type key = Key.t type element = Element.t let empty = Keys.empty let lookup key map = match Keys.find_opt key map with | None -> Elements.empty | Some set -> set let add key element map = Keys.add key (Elements.add element (lookup key map)) map let to_lists map = List.map (fun (key, set) -> (key, Elements.elements set)) (Keys.bindings map) let add_pairs initial pairs = List.fold_left (fun acc (key, elt) -> add key elt acc) initial pairs let of_pairs = add_pairs empty let factorize pairs = to_lists (of_pairs pairs) let factorize_batches pairs_list = to_lists (List.fold_left add_pairs empty pairs_list) end -let random_int_list imax n = +let _random_int_list imax n = let imax = succ imax in let rec random_int_list' acc i = if i = 0 then List.rev acc else random_int_list' (Random.int imax :: acc) (pred i) in random_int_list' [] n let shuffle l = let a = Array.of_list l in ThoArray.shuffle a; Array.to_list a module Test = struct open OUnit - module Integers = struct type t = int let compare = compare end - module II = Buckets(Integers)(Integers) + module II = Buckets(Int)(Int) let compare_pair (a1, b1) (a2, b2) = let c = compare a1 a2 in if c <> 0 then c else compare b1 b2 let ilist = ThoList.range 1 42 let mod7 i = (i mod 7, i) let mod7_ilist = List.map mod7 ilist let mod7_ilist_batched = ThoList.chopn 10 mod7_ilist let mod7_factorized = List.sort compare_pair (ThoList.factorize mod7_ilist) let factorized_to_string l = ThoList.to_string (fun (i, ilist) -> "(" ^ string_of_int i ^ ", " ^ ThoList.to_string string_of_int ilist ^ ")" ) l let suite_factorize = "factorize" >::: [ "int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize mod7_ilist)); "reversed int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize (List.rev mod7_ilist))); "shuffled int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize (shuffle mod7_ilist))) ] let suite_factorize_batches = "factorize_batches" >::: [ "int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize_batches mod7_ilist_batched)); "reversed int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize_batches (List.rev mod7_ilist_batched))); "shuffled int list" >:: (fun () -> assert_equal ~printer:factorized_to_string mod7_factorized (II.factorize_batches (shuffle mod7_ilist_batched))) ] let suite_buckets = "Buckets" >::: - [ suite_factorize; + [ suite_factorize_batches; suite_factorize ] let suite = "ThoMap" >::: [ suite_buckets ] end Index: trunk/omega/src/cascade_syntax.ml =================================================================== --- trunk/omega/src/cascade_syntax.ml (revision 8919) +++ trunk/omega/src/cascade_syntax.ml (revision 8920) @@ -1,112 +1,103 @@ (* cascade_syntax.ml -- Copyright (C) 1999-2024 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. *) (* Concerning the Gaussian propagators, we admit the following: In principle, they would allow for flavor sums like the off-shell lines, but for all practical purposes they are used only for determining the significance of a specified intermediate state. So we select them in the same manner as on-shell states. *) (* [False] is probably redundant. *) type ('flavor, 'p, 'constant) t = | True | False | On_shell of 'flavor list * 'p | On_shell_not of 'flavor list * 'p | Off_shell of 'flavor list * 'p | Off_shell_not of 'flavor list * 'p | Gauss of 'flavor list * 'p | Gauss_not of 'flavor list * 'p | Any_flavor of 'p | And of ('flavor, 'p, 'constant) t list | X_Flavor of 'flavor list | X_Vertex of 'constant list * 'flavor list list let mk_true () = True let mk_false () = False let mk_on_shell f p = On_shell (f, p) let mk_on_shell_not f p = On_shell_not (f, p) let mk_off_shell f p = Off_shell (f, p) let mk_off_shell_not f p = Off_shell_not (f, p) let mk_gauss f p = Gauss (f, p) let mk_gauss_not f p = Gauss_not (f, p) let mk_any_flavor p = Any_flavor p let mk_and c1 c2 = match c1, c2 with | c, True | True, c -> c - | c, False | False, c -> False + | _, False | False, _ -> False | And cs, And cs' -> And (cs @ cs') | And cs, c | c, And cs -> And (c::cs) | c, c' -> And [c; c'] let mk_x_flavor f = X_Flavor f let mk_x_vertex c fs = X_Vertex (c, fs) let to_string flavor_to_string momentum_to_string coupling_to_string cascades = let flavors_to_string fs = String.concat ":" (List.map flavor_to_string fs) and couplings_to_string cs = String.concat ":" (List.map coupling_to_string cs) in let rec 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 -> "(" ^ to_string' c ^ ")") cs) | X_Flavor fs -> "!" ^ String.concat ":" (List.map flavor_to_string fs) | X_Vertex (cs, fss) -> "^" ^ couplings_to_string cs ^ "[" ^ (String.concat "," (List.map flavors_to_string fss)) ^ "]" in to_string' cascades -let int_list_to_string p = +let _int_list_to_string p = String.concat "+" (List.map string_of_int (List.sort compare p)) exception Syntax_Error of string * int * int - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) - Index: trunk/omega/src/dirac.ml =================================================================== --- trunk/omega/src/dirac.ml (revision 8919) +++ trunk/omega/src/dirac.ml (revision 8920) @@ -1,493 +1,493 @@ (* dirac.ml -- Copyright (C) 1999-2024 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Dirac $\gamma$-matrices} *) module type T = sig type qc = Algebra.QC.t type t = qc array array val zero : qc val one : qc val minus_one : qc val i : qc val minus_i : qc val unit : t val null : t val gamma0 : t val gamma1 : t val gamma2 : t val gamma3 : t val gamma5 : t val gamma : t array val cc : t val neg : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val times : qc -> t -> t val transpose : t -> t val adjoint : t -> t val conj : t -> t val product : t list -> t val pp : Format.formatter -> t -> unit val test_suite : OUnit.test end (* \thocwmodulesubsection{Matrices with complex rational entries} *) module Q = Algebra.Q module QC = Algebra.QC type complex_rational = QC.t let zero = QC.null let one = QC.unit let minus_one = QC.neg one let i = QC.make Q.null Q.unit let minus_i = QC.conj i type matrix = complex_rational array array (* \thocwmodulesubsection{Dirac $\gamma$-matrices} *) module type R = sig type qc = complex_rational type t = matrix val gamma0 : t val gamma1 : t val gamma2 : t val gamma3 : t val gamma5 : t val cc : t val cc_is_i_gamma2_gamma_0 : bool end module Make (R : R) : T = struct type qc = complex_rational type t = matrix let zero = zero let one = one let minus_one = minus_one let i = i let minus_i = minus_i let null = [| [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |]; [| zero; zero; zero; zero |] |] let unit = [| [| one; zero; zero; zero |]; [| zero; one; zero; zero |]; [| zero; zero; one; zero |]; [| zero; zero; zero; one |] |] let gamma0 = R.gamma0 let gamma1 = R.gamma1 let gamma2 = R.gamma2 let gamma3 = R.gamma3 let gamma5 = R.gamma5 let gamma = [| gamma0; gamma1; gamma2; gamma3 |] let cc = R.cc let neg g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.neg g.(i).(j) done done; g' let add g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g12.(i).(j) <- QC.add g1.(i).(j) g2.(i).(j) done done; g12 let sub g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g12.(i).(j) <- QC.sub g1.(i).(j) g2.(i).(j) done done; g12 let mul g1 g2 = let g12 = Array.make_matrix 4 4 zero in for i = 0 to 3 do for k = 0 to 3 do for j = 0 to 3 do g12.(i).(k) <- QC.add g12.(i).(k) (QC.mul g1.(i).(j) g2.(j).(k)) done done done; g12 let times q g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.mul q g.(i).(j) done done; g' let transpose g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- g.(j).(i) done done; g' let adjoint g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.conj g.(j).(i) done done; g' let conj g = let g' = Array.make_matrix 4 4 zero in for i = 0 to 3 do for j = 0 to 3 do g'.(i).(j) <- QC.conj g.(i).(j) done done; g' let product glist = List.fold_right mul glist unit let pp fmt g = let pp_row i = for j = 0 to 3 do Format.fprintf fmt " %8s" (QC.to_string g.(i).(j)) done in Format.fprintf fmt "\n /"; pp_row 0; Format.fprintf fmt " \\\n"; for i = 1 to 2 do Format.fprintf fmt " |"; pp_row i; Format.fprintf fmt " |\n" done; Format.fprintf fmt " \\"; pp_row 3; Format.fprintf fmt " /\n" open OUnit let two = QC.make (Q.make 2 1) Q.null - let half = QC.make (Q.make 1 2) Q.null + let _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 = + 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.re lhs.(i).(j))) (Q.to_string (QC.im lhs.(i).(j))) (Q.to_string (QC.re rhs.(i).(j))) (Q.to_string (QC.im rhs.(i).(j))) done done let dump2_all lhs rhs = for mu = 0 to 3 do for nu = 0 to 3 do Printf.printf "mu = %d, nu =%d: \n" mu nu; dump2 lhs.(mu).(nu) rhs.(mu).(nu) done done let anticommute = "anticommutation relations" >:: (fun () -> assert_bool "" (if ac_lhs_all = ac_rhs_all then true else begin dump2_all ac_lhs_all ac_rhs_all; false end)) let equal_or_dump2 lhs rhs = if lhs = rhs then true else begin dump2 lhs rhs; false end let gamma5_def = "gamma5" >:: (fun () -> assert_bool "definition" (equal_or_dump2 gamma5 (times i (product [gamma0; gamma1; gamma2; gamma3])))) let self_adjoint = "(anti)selfadjointness" >::: [ "gamma0" >:: (fun () -> assert_bool "self" (equal_or_dump2 gamma0 (adjoint gamma0))); "gamma1" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma1 (neg (adjoint gamma1)))); "gamma2" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma2 (neg (adjoint gamma2)))); "gamma3" >:: (fun () -> assert_bool "anti" (equal_or_dump2 gamma3 (neg (adjoint gamma3)))); "gamma5" >:: (fun () -> assert_bool "self" (equal_or_dump2 gamma5 (adjoint gamma5))) ] (* $C^2=-\mathbf{1}$ is \emph{not} true in all realizations, but we assume it at several points in [UFO_Lorentz]. Therefore we must test it here for all realizations that are implemented. *) let cc_inv = neg cc (* Verify that $\Gamma^T= - C\Gamma C^{-1}$ using the actual matrix transpose: *) let cc_gamma g = equal_or_dump2 (neg (transpose g)) (product [cc; g; cc_inv]) (* Of course, $C=\ii\gamma^2\gamma^0$ is also not true in \emph{all} realizations. But it is true in the chiral representation used here and we can test it. *) let charge_conjugation = "charge conjugation" >::: [ "inverse" >:: (fun () -> assert_bool "" (equal_or_dump2 (mul cc cc_inv) unit)); "gamma0" >:: (fun () -> assert_bool "" (cc_gamma gamma0)); "gamma1" >:: (fun () -> assert_bool "" (cc_gamma gamma1)); "gamma2" >:: (fun () -> assert_bool "" (cc_gamma gamma2)); "gamma3" >:: (fun () -> assert_bool "" (cc_gamma gamma3)); "gamma5" >:: (fun () -> assert_bool "" (equal_or_dump2 (transpose gamma5) (product [cc; gamma5; cc_inv]))); "=i*g2*g0" >:: (fun () -> skip_if (not R.cc_is_i_gamma2_gamma_0) "representation dependence"; assert_bool "" (equal_or_dump2 cc (times i (mul gamma2 gamma0)))) ] let test_suite = "Dirac Matrices" >::: [anticommute; gamma5_def; self_adjoint; charge_conjugation] end module Chiral_R : R = struct type qc = complex_rational type t = matrix let gamma0 = [| [| zero; zero; one; zero |]; [| zero; zero; zero; one |]; [| one; zero; zero; zero |]; [| zero; one; zero; zero |] |] let gamma1 = [| [| zero; zero; zero; one |]; [| zero; zero; one; zero |]; [| zero; minus_one; zero; zero |]; [| minus_one; zero; zero; zero |] |] let gamma2 = [| [| zero; zero; zero; minus_i |]; [| zero; zero; i; zero |]; [| zero; i; zero; zero |]; [| minus_i; zero; zero; zero |] |] let gamma3 = [| [| zero; zero; one; zero |]; [| zero; zero; zero; minus_one |]; [| minus_one; zero; zero; zero |]; [| zero; one; zero; zero |] |] let gamma5 = [| [| minus_one; zero; zero; zero |]; [| zero; minus_one; zero; zero |]; [| zero; zero; one; zero |]; [| zero; zero; zero; one |] |] let cc = [| [| zero; one; zero; zero |]; [| minus_one; zero; zero; zero |]; [| zero; zero; zero; minus_one |]; [| zero; zero; one; zero |] |] let cc_is_i_gamma2_gamma_0 = true end module Dirac_R : R = struct type qc = complex_rational type t = matrix let gamma0 = [| [| one; zero; zero; zero |]; [| zero; one; zero; zero |]; [| zero; zero; minus_one; zero |]; [| zero; zero; zero; minus_one |] |] let gamma1 = Chiral_R.gamma1 let gamma2 = Chiral_R.gamma2 let gamma3 = Chiral_R.gamma3 let gamma5 = [| [| zero; zero; one; zero |]; [| zero; zero; zero; one |]; [| one; zero; zero; zero |]; [| zero; one; zero; zero |] |] let cc = [| [| zero; zero; zero; minus_one |]; [| zero; zero; one; zero |]; [| zero; minus_one; zero; zero |]; [| one; zero; zero; zero |] |] let cc_is_i_gamma2_gamma_0 = true end module Majorana_R : R = struct type qc = complex_rational type t = matrix let gamma0 = [| [| zero; zero; zero; minus_i |]; [| zero; zero; i; zero |]; [| zero; minus_i; zero; zero |]; [| i; zero; zero; zero |] |] let gamma1 = [| [| i; zero; zero; zero |]; [| zero; minus_i; zero; zero |]; [| zero; zero; i; zero |]; [| zero; zero; zero; minus_i |] |] let gamma2 = [| [| zero; zero; zero; i |]; [| zero; zero; minus_i; zero |]; [| zero; minus_i; zero; zero |]; [| i; zero; zero; zero |] |] let gamma3 = [| [| zero; minus_i; zero; zero |]; [| minus_i; zero; zero; zero |]; [| zero; zero; zero; minus_i |]; [| zero; zero; minus_i; zero |] |] let gamma5 = [| [| zero; minus_i; zero; zero |]; [| i; zero; zero; zero |]; [| zero; zero; zero; i |]; [| zero; zero; minus_i; zero |] |] let cc = [| [| zero; zero; zero; minus_one |]; [| zero; zero; one; zero |]; [| zero; minus_one; zero; zero |]; [| one; zero; zero; zero |] |] let cc_is_i_gamma2_gamma_0 = false end module Chiral = Make (Chiral_R) module Dirac = Make (Dirac_R) module Majorana = Make (Majorana_R) Index: trunk/omega/src/UFO.ml =================================================================== --- trunk/omega/src/UFO.ml (revision 8919) +++ trunk/omega/src/UFO.ml (revision 8920) @@ -1,3032 +1,3032 @@ (* UFO.ml -- Copyright (C) 1999-2024 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Unfortunately, \texttt{ocamlweb} will not typeset all multi character operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *) let (<*>) f g x = f (g x) let (<**>) f g x y = f (g x y) module SMap = Map.Make(String) module SSet = Sets.String module CMap = Map.Make (struct type t = string let compare = ThoString.compare_caseless end) module CSet = Sets.String_Caseless let error_in_string text start_pos end_pos = let i = start_pos.Lexing.pos_cnum and j = end_pos.Lexing.pos_cnum in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) let parse_string text = try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string text)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) exception File_missing of string let parse_file name = let ic = try open_in name with | Sys_error msg as exc -> if msg = name ^ ": No such file or directory" then raise (File_missing name) else raise exc in let result = begin try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position name (Lexing.from_channel ic)) with | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: lexical error (%s)" (error_in_file name start_pos end_pos) msg) end | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s (or immediately afterwards): syntax error (%s)" (error_in_file name start_pos end_pos) msg) end | Parsing.Parse_error -> begin close_in ic; invalid_arg ("parse error: " ^ name) end end in close_in ic; result (* These are the contents of the Python files after lexical analysis as context-free variable declarations, before any semantic interpretation. *) module type Files = sig type t = private { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } val parse_directory : string -> t end module Files : Files = struct type t = { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } let parse_directory dir = let filename stem = Filename.concat dir (stem ^ ".py") in let parse stem = parse_file (filename stem) in let parse_optional stem = try parse stem with File_missing _ -> [] in { particles = parse "particles"; couplings = parse "couplings"; coupling_orders = parse_optional "coupling_orders"; vertices = parse "vertices"; lorentz = parse "lorentz"; parameters = parse "parameters"; propagators = parse_optional "propagators"; decays = parse_optional "decays" } end -let dump_file pfx f = +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 = +let _find_attrib name attribs = try (List.find (fun a -> name = a.S.a_name) attribs).S.a_value with | Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found") let find_attrib name attribs = (List.find (fun a -> name = a.S.a_name) attribs).S.a_value let name_to_string ?strip name = let stripped = begin match strip, List.rev name with | Some pfx, head :: tail -> if pfx = head then tail else failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^ "', got '" ^ head ^ "'") | _, name -> name end in String.concat "." stripped let name_attrib ?strip name attribs = match find_attrib name attribs with | S.Name n -> name_to_string ?strip n | _ -> invalid_arg ("UFO.name_attrib: " ^ name) let integer_attrib name attribs = match find_attrib name attribs with | S.Integer i -> i | _ -> invalid_arg ("UFO.integer_attrib: " ^ name) let charge_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Q_Integer i | S.Fraction (n, d) -> Q_Fraction (n, d) | _ -> invalid_arg ("UFO.charge_attrib: " ^ name) let string_attrib name attribs = match find_attrib name attribs with | S.String s -> s | _ -> invalid_arg ("UFO.string_attrib: " ^ name) let string_expr_attrib name attribs = match find_attrib name attribs with | S.Name n -> [S.Macro n] | S.String s -> [S.Literal s] | S.String_Expr e -> e | _ -> invalid_arg ("UFO.string_expr_attrib: " ^ name) let young_tableau_attrib name attribs = match find_attrib name attribs with | S.Young_Tableau y -> y | _ -> invalid_arg ("UFO.young_tableau_attrib: " ^ name) let boolean_attrib name attribs = try match ThoString.lowercase (name_attrib name attribs) with | "true" -> true | "false" -> false | _ -> invalid_arg ("UFO.boolean_attrib: " ^ name) with | Not_found -> false type value = | Integer of int | Fraction of int * int | Float of float | Expr of UFOx.Expr.t | Name of string list let map_expr f default = function | Integer _ | Fraction (_, _) | Float _ | Name _ -> default | Expr e -> f e let variables = map_expr UFOx.Expr.variables CSet.empty -let functions = map_expr UFOx.Expr.functions CSet.empty +let _functions = map_expr UFOx.Expr.functions CSet.empty let add_to_set_in_map key element map = let set = try CMap.find key map with Not_found -> CSet.empty in CMap.add key (CSet.add element set) map (* Add all variables in [value] to the [map] from variables to the names in which they appear, indicating that [name] depends on these variables. *) let dependency name value map = CSet.fold (fun variable acc -> add_to_set_in_map variable name acc) (variables value) map let dependencies name_value_list = List.fold_left (fun acc (name, value) -> dependency name value acc) CMap.empty name_value_list let dependency_to_string (variable, appearences) = Printf.sprintf "%s -> {%s}" variable (String.concat ", " (CSet.elements appearences)) -let dependencies_to_strings map = +let _dependencies_to_strings map = List.map dependency_to_string (CMap.bindings map) let expr_to_string = UFOx.Value.to_string <*> UFOx.Value.of_expr let value_to_string = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x | Expr e -> "'" ^ expr_to_string e ^ "'" | Name n -> name_to_string n let value_to_expr substitutions = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x | Expr e -> expr_to_string (substitutions e) | Name n -> name_to_string n let value_to_coupling substitutions atom = function | Integer i -> Coupling.Integer i | Fraction (n, d) -> Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Float x -> Coupling.Float x | Expr e -> UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions e)) - | Name n -> failwith "UFO.value_to_coupling: Name not supported yet!" + | Name _ -> failwith "UFO.value_to_coupling: Name not supported yet!" let value_to_numeric = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%g" (float n /. float d) | Float x -> Printf.sprintf "%g" x | Expr e -> invalid_arg ("UFO.value_to_numeric: expr = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_numeric: name = " ^ name_to_string n) let value_to_float = function | Integer i -> float i | Fraction (n, d) -> float n /. float d | Float x -> x | Expr e -> invalid_arg ("UFO.value_to_float: string = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_float: name = " ^ name_to_string n) let value_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Integer i | S.Fraction (n, d) -> Fraction (n, d) | S.Float x -> Float x | S.String s -> Expr (UFOx.Expr.of_string s) | S.Name n -> Name n | _ -> invalid_arg ("UFO.value_attrib: " ^ name) let string_list_attrib name attribs = match find_attrib name attribs with | S.String_List l -> l | _ -> invalid_arg ("UFO.string_list_attrib: " ^ name) let name_list_attrib ~strip name attribs = match find_attrib name attribs with | S.Name_List l -> List.map (name_to_string ~strip) l | _ -> invalid_arg ("UFO.name_list_attrib: " ^ name) let integer_list_attrib name attribs = match find_attrib name attribs with | S.Integer_List l -> l | _ -> invalid_arg ("UFO.integer_list_attrib: " ^ name) let order_dictionary_attrib name attribs = match find_attrib name attribs with | S.Order_Dictionary d -> d | _ -> invalid_arg ("UFO.order_dictionary_attrib: " ^ name) let coupling_dictionary_attrib ~strip name attribs = match find_attrib name attribs with | S.Coupling_Dictionary d -> List.map (fun (i, j, c) -> (i, j, name_to_string ~strip c)) d | _ -> invalid_arg ("UFO.coupling_dictionary_attrib: " ^ name) let decay_dictionary_attrib name attribs = match find_attrib name attribs with | S.Decay_Dictionary d -> List.map (fun (p, w) -> (List.map List.hd p, w)) d | _ -> invalid_arg ("UFO.decay_dictionary_attrib: " ^ name) (*i The following doesn't typecheck in applications, even with type annotations ... let attrib_handlers : type attribs value. string -> string -> attribs -> ((string -> attribs -> value) -> string -> value) * ((string -> attribs -> value) -> string -> value -> value) = fun kind symbol attribs -> let required query name = try query name attribs with | Not_found -> invalid_arg (Printf.sprintf "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!" name kind symbol) and optional query name default = try query name attribs with | Not_found -> default in (required, optional) i*) let required_handler kind symbol attribs query name = try query name attribs with | Not_found -> invalid_arg (Printf.sprintf "fatal UFO error: mandatory attribute `%s' missing for %s `%s'!" name kind symbol) let optional_handler attribs query name default = try query name attribs with | Not_found -> default (* The UFO paper~\cite{Degrande:2011ua} is not clear on the question whether the \texttt{name} attribute of an instance must match its Python name. While the examples appear to imply this, there are examples of UFO files in the wild that violate this constraint. *) let warn_symbol_name file symbol name = if name <> symbol then Printf.eprintf "UFO: warning: symbol '%s' <> name '%s' in %s.py: \ while legal in UFO, it is unusual and can cause problems!\n" symbol name file let valid_fortran_id kind name = if not (ThoString.valid_fortran_id name) then invalid_arg (Printf.sprintf "fatal UFO error: the %s `%s' is not a valid fortran id!" kind name) -let map_to_alist map = +let _map_to_alist map = SMap.fold (fun key value acc -> (key, value) :: acc) map [] let keys map = SMap.fold (fun key _ acc -> key :: acc) map [] let keys_caseless map = CMap.fold (fun key _ acc -> key :: acc) map [] let values map = SMap.fold (fun _ value acc -> value :: acc) map [] module SKey = struct type t = string let hash = Hashtbl.hash let equal = (=) end module SHash = Hashtbl.Make (SKey) module type Particle = sig type t = private { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; propagator : string option; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : charge; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } val of_file : S.t -> t SMap.t val to_string : string -> t -> string val conjugate : t -> t val map_mass_and_width : (string -> string) -> t -> t val force_spinor : t -> t val force_conjspinor : t -> t val force_majorana : t -> t val is_majorana : t -> bool - val is_ghost : t -> bool - val is_goldstone : t -> bool +(*[ val is_ghost : t -> bool ]*) +(*[ val is_goldstone : t -> bool ]*) val is_physical : t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Particle : Particle = struct type t = { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; propagator : string option; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : charge; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } let to_string symbol p = Printf.sprintf "particle: %s => [pdg = %d, name = '%s'/'%s', \ spin = %s, color = %s, \ mass = %s, width = %s,%s \ Q = %s, G = %d, L = %d, Y = %s, \ TeX = '%s'/'%s'%s]" symbol p.pdg_code p.name p.antiname (UFOx.Lorentz.rep_to_string p.spin) (UFOx.Color.rep_to_string p.color) p.mass p.width (match p.propagator with | None -> "" | Some p -> " propagator = " ^ p ^ ",") (charge_to_string p.charge) p.ghost_number p.lepton_number (charge_to_string p.y) p.texname p.antitexname (if p.goldstone then ", GB" else "") let conjugate_charge = function | Q_Integer i -> Q_Integer (-i) | Q_Fraction (n, d) -> Q_Fraction (-n, d) let is_neutral p = (p.name = p.antiname) (* We \emph{must not} mess with [pdg_code] and [color] if the particle is neutral! *) let conjugate p = if is_neutral p then p else { pdg_code = - p.pdg_code; name = p.antiname; antiname = p.name; spin = UFOx.Lorentz.rep_conjugate p.spin; color = UFOx.Color.rep_conjugate p.color; mass = p.mass; width = p.width; propagator = p.propagator; texname = p.antitexname; antitexname = p.texname; charge = conjugate_charge p.charge; ghost_number = - p.ghost_number; lepton_number = - p.lepton_number; y = conjugate_charge p.y; goldstone = p.goldstone; propagating = p.propagating; line = p.line; is_anti = not p.is_anti } let map_mass_and_width f p = { p with mass = f p.mass; width = f p.width } let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Particle" ], attribs -> let required query name = required_handler "particle" symbol attribs query name and optional query name default = optional_handler attribs query name default in let name = required string_attrib "name" and antiname = required string_attrib "antiname" in let neutral = (name = antiname) in let pdg_code = required integer_attrib "pdg_code" in SMap.add symbol { (* The required attributes per UFO docs. *) pdg_code; name; antiname; spin = UFOx.Lorentz.rep_of_int neutral (required integer_attrib "spin"); color = UFOx.Color.rep_of_int_or_young_tableau neutral (try Some (integer_attrib "color" attribs) with _ -> None) (try Some (young_tableau_attrib "color_young" attribs) with _ -> None); mass = required (name_attrib ~strip:"Param") "mass"; width = required (name_attrib ~strip:"Param") "width"; texname = required string_attrib "texname"; antitexname = required string_attrib "antitexname"; charge = required charge_attrib "charge"; (* The optional attributes per UFO docs. *) ghost_number = optional integer_attrib "GhostNumber" 0; lepton_number = optional integer_attrib "LeptonNumber" 0; y = optional charge_attrib "Y" (Q_Integer 0); goldstone = optional boolean_attrib "goldstone" false; propagating = optional boolean_attrib "propagating" true; line = (try Some (name_attrib "line" attribs) with _ -> None); (* Undocumented extensions. *) propagator = (try Some (name_attrib ~strip:"Prop" "propagator" attribs) with _ -> None); (* O'Mega extensions. *) (* Instead of ``first come is particle'' rely on a negative PDG code to identify antiparticles. *) is_anti = pdg_code < 0 } map | [ "anti"; p ], [] -> begin try SMap.add symbol (conjugate (SMap.find p map)) map with | Not_found -> invalid_arg ("Particle.of_file: " ^ p ^ ".anti() not yet defined!") end | _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind) let of_file particles = List.fold_left of_file1 SMap.empty particles let is_spinor p = match UFOx.Lorentz.omega p.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> true | _ -> false (* \begin{dubious} TODO: this is a bit of a hack: try to expose the type [UFOx.Lorentz_Atom'.r] instead. \end{dubious} *) let force_spinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false 2 } else p let force_conjspinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false (-2) } else p let force_majorana p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int true 2 } else p let is_majorana p = match UFOx.Lorentz.omega p.spin with | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let is_ghost p = p.ghost_number <> 0 let is_goldstone p = p.goldstone let is_physical p = not (is_ghost p || is_goldstone p) let filter predicate map = - SMap.filter (fun symbol p -> predicate p) map + SMap.filter (fun _symbol p -> predicate p) map end module type UFO_Coupling = sig type t = private { name : string; value : UFOx.Expr.t; order : (string * int) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module UFO_Coupling : UFO_Coupling = struct type t = { name : string; value : UFOx.Expr.t; order : (string * int) list } let order_to_string orders = String.concat ", " (List.map (fun (s, i) -> Printf.sprintf "'%s':%d" s i) orders) let to_string symbol c = Printf.sprintf "coupling: %s => [name = '%s', value = '%s', order = [%s]]" symbol c.name (expr_to_string c.value) (order_to_string c.order) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Coupling" ], attribs -> let required query name = required_handler "coupling" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "couplings" symbol name; valid_fortran_id "coupling" name; SMap.add symbol { name; value = UFOx.Expr.of_string (required string_attrib "value"); order = required order_dictionary_attrib "order" } map | _ -> invalid_arg ("UFO_Coupling.of_file: " ^ name_to_string d.S.kind) let of_file couplings = List.fold_left of_file1 SMap.empty couplings end module type Coupling_Order = sig type t = private { name : string; expansion_order : int; hierarchy : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Coupling_Order : Coupling_Order = struct type t = { name : string; expansion_order : int; hierarchy : int } let to_string symbol c = Printf.sprintf "coupling_order: %s => [name = '%s', \ expansion_order = '%d', \ hierarchy = %d]" symbol c.name c.expansion_order c.hierarchy let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "CouplingOrder" ], attribs -> let required query name = required_handler "coupling order" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "coupling_orders" symbol name; SMap.add symbol { name; expansion_order = required integer_attrib "expansion_order"; hierarchy = required integer_attrib "hierarchy" } map | _ -> invalid_arg ("Coupling_order.of_file: " ^ name_to_string d.S.kind) let of_file coupling_orders = List.fold_left of_file1 SMap.empty coupling_orders end module type Lorentz_UFO = sig (* If the \texttt{name} attribute of a \texttt{Lorentz} object does \emph{not} match the the name of the object, we need the latter for weeding out unused Lorentz structures (see [Vertex.contains] below). Therefore, we keep it around. *) type t = private { name : string; symbol : string; spins : int list; structure : UFOx.Lorentz.t } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Lorentz_UFO : Lorentz_UFO = struct type t = { name : string; symbol : string; spins : int list; structure : UFOx.Lorentz.t } let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = [%s], \ structure = %s]" symbol l.name (String.concat ", " (List.map string_of_int l.spins)) (UFOx.Lorentz.to_string l.structure) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Lorentz" ], attribs -> let required query name = required_handler "lorentz" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "lorentz" symbol name; valid_fortran_id "lorentz" symbol; SMap.add symbol { name; symbol; spins = required integer_list_attrib "spins"; structure = UFOx.Lorentz.of_string (required string_attrib "structure") } map | _ -> invalid_arg ("Lorentz.of_file: " ^ name_to_string d.S.kind) let of_file lorentz = List.fold_left of_file1 SMap.empty lorentz end module type Vertex = sig type lcc = private (* Lorentz-color-coupling *) { lorentz : string; color : UFOx.Color.t; coupling : string } type t = private { name : string; particles : string array; lcc : lcc list } val of_file : Particle.t SMap.t -> S.t -> t SMap.t val to_string : string -> t -> string val to_string_expanded : Lorentz_UFO.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string val contains : Particle.t SMap.t -> (Particle.t -> bool) -> t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Vertex : Vertex = struct type lcc = { lorentz : string; color : UFOx.Color.t; coupling : string } type t = { name : string; particles : string array; lcc : lcc list } let to_string symbol c = Printf.sprintf "vertex: %s => [name = '%s', particles = [%s], \ lorentz-color-couplings = [%s]" symbol c.name (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling lcc.lorentz (UFOx.Color.to_string lcc.color)) c.lcc)) - let to_string_expanded lorentz couplings c = + let to_string_expanded lorentz _couplings c = let expand_lorentz s = try UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure with | Not_found -> "?" in Printf.sprintf "expanded: [%s] -> { lorentz-color-couplings = [%s] }" (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling (expand_lorentz lcc.lorentz) (UFOx.Color.to_string lcc.color)) c.lcc)) let contains particles predicate v = let p = v.particles in let rec contains' i = if i < 0 then false else if predicate (SMap.find p.(i) particles) then true else contains' (pred i) in contains' (Array.length p - 1) let force_adj_identity1 adj_indices = function | UFOx.Color_Atom.Identity (a, b) as atom -> begin match List.mem a adj_indices, List.mem b adj_indices with | true, true -> UFOx.Color_Atom.Identity8 (a, b) | false, false -> atom | true, false | false, true -> invalid_arg "force_adj_identity: mixed representations!" end | atom -> atom - let force_adj_identity adj_indices tensor = + let _force_adj_identity adj_indices tensor = UFOx.Color.map_atoms (force_adj_identity1 adj_indices) tensor - let find_adj_indices map particles = + 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!" + invalid_arg "force_identity1: 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!" + invalid_arg "force_identity1: 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!" + invalid_arg "force_identity1: mixed representations!" end else atom | atom -> atom let force_identity indices tensor = UFOx.Color.map_atoms (force_identity1 indices) tensor (* Here we don't have the Lorentz structures available yet. Thus we set [fermion_lines = []] for now and correct this later. *) let of_file1 particle_map map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Vertex" ], attribs -> let required query name = required_handler "vertex" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "vertices" symbol name; let particles = Array.of_list (required (name_list_attrib ~strip:"P") "particles") in let color = let indices = classify_color_indices particle_map particles in Array.of_list (List.map (force_identity indices <*> UFOx.Color.of_string) (required string_list_attrib "color")) and lorentz = Array.of_list (required (name_list_attrib ~strip:"L") "lorentz") and couplings_alist = required (coupling_dictionary_attrib ~strip:"C") "couplings" in let lcc = List.map (fun (i, j, c) -> { lorentz = lorentz.(j); color = color.(i); coupling = c }) couplings_alist in SMap.add symbol { name; particles; lcc } map | _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind) let of_file particles vertices = List.fold_left (of_file1 particles) SMap.empty vertices let filter predicate map = - SMap.filter (fun symbol p -> predicate p) map + SMap.filter (fun _symbol p -> predicate p) map end module type Parameter = sig type nature = private Internal | External type ptype = private Real | Complex type t = private { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string val missing : string -> t val map_names : (string -> string) -> t -> t end module Parameter : Parameter = struct type nature = Internal | External let nature_to_string = function | Internal -> "internal" | External -> "external" let nature_of_string = function | "internal" -> Internal | "external" -> External | s -> invalid_arg ("Parameter.nature_of_string: " ^ s) type ptype = Real | Complex let ptype_to_string = function | Real -> "real" | Complex -> "complex" let ptype_of_string = function | "real" -> Real | "complex" -> Complex | s -> invalid_arg ("Parameter.ptype_of_string: " ^ s) type t = { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } let to_string symbol p = Printf.sprintf "parameter: %s => [#%d, name = '%s', nature = %s, type = %s, \ value = %s, texname = '%s', \ lhablock = %s, lhacode = [%s]]" symbol p.sequence p.name (nature_to_string p.nature) (ptype_to_string p.ptype) (value_to_string p.value) p.texname (match p.lhablock with None -> "???" | Some s -> s) (match p.lhacode with | None -> "" | Some c -> String.concat ", " (List.map string_of_int c)) let of_file1 (map, n) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Parameter" ], attribs -> let required query name = required_handler "particle" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "parameters" symbol name; valid_fortran_id "parameter" name; (SMap.add symbol { name; nature = nature_of_string (required string_attrib "nature"); ptype = ptype_of_string (required string_attrib "type"); value = required value_attrib "value"; texname = required string_attrib "texname"; lhablock = (try Some (string_attrib "lhablock" attribs) with Not_found -> None); lhacode = (try Some (integer_list_attrib "lhacode" attribs) with Not_found -> None); sequence = n } map, succ n) | _ -> invalid_arg ("Parameter.of_file: " ^ name_to_string d.S.kind) let of_file parameters = let map, _ = List.fold_left of_file1 (SMap.empty, 0) parameters in map let missing name = { name; nature = External; ptype = Real; value = Integer 0; texname = Printf.sprintf "\\texttt{%s}" name; lhablock = None; lhacode = None; sequence = 0 } (* If the [Name] has a prefix, apply [f] only to the last component. *) let map_value f = function | (Integer _ | Fraction (_, _) | Float _ as v) -> v | Name n -> begin match List.rev n with | [] -> Name [] | stem :: prefix -> Name (List.rev (f stem :: prefix)) end | Expr e -> Expr (UFOx.Expr.map_names f e) let map_names f p = { p with name = f p.name; value = map_value f p.value } end (* Macros are encoded as a special [S.declaration] with [S.kind = "$"]. This is slightly hackish, but general enough and the overhead of a special union type is probably not worth the effort. *) module type Macro = sig type t val empty : t (* The domains and codomains are still a bit too much ad hoc, but it does the job. *) val define : t -> string -> S.value -> t val expand_string : t -> string -> S.value val expand_expr : t -> S.string_atom list -> string (* Only for documentation: *) - val expand_atom : t -> S.string_atom -> string + val _expand_atom : t -> S.string_atom -> string end module Macro : Macro = struct type t = S.value SMap.t let empty = SMap.empty let define macros name expansion = SMap.add name expansion macros let expand_string macros name = SMap.find name macros - let rec expand_atom macros = function + let rec _expand_atom macros = function | S.Literal s -> s | S.Macro [name] -> begin try begin match SMap.find name macros with | S.String s -> s | S.String_Expr expr -> expand_expr macros expr | _ -> invalid_arg ("expand_atom: not a string: " ^ name) end with | Not_found -> invalid_arg ("expand_atom: not found: " ^ name) end | S.Macro [] -> invalid_arg "expand_atom: empty" | S.Macro name -> invalid_arg ("expand_atom: compound name: " ^ String.concat "." name) and expand_expr macros expr = - String.concat "" (List.map (expand_atom macros) expr) + String.concat "" (List.map (_expand_atom macros) expr) end module type Propagator_UFO = sig type t = (* private *) { name : string; numerator : UFOx.Lorentz.t; denominator : UFOx.Lorentz.t } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Propagator_UFO : Propagator_UFO = struct type t = { name : string; numerator : UFOx.Lorentz.t; denominator : UFOx.Lorentz.t } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', numerator = '%s', \ denominator = '%s']" symbol p.name (UFOx.Lorentz.to_string p.numerator) (UFOx.Lorentz.to_string p.denominator) (* The \texttt{denominator} attribute is optional and there is a default (cf.~\texttt{arXiv:1308.1668}) *) let default_denominator = "P('mu', id) * P('mu', id) \ - Mass(id) * Mass(id) \ + complex(0,1) * Mass(id) * Width(id)" let of_string_with_error_correction symbol num_or_den s = try UFOx.Lorentz.of_string s with | Invalid_argument msg -> begin let fixed = s ^ ")" in try let tensor = UFOx.Lorentz.of_string fixed in Printf.eprintf "UFO.Propagator.of_string: added missing closing parenthesis \ in %s of %s: \"%s\"\n" num_or_den symbol s; tensor with | Invalid_argument _ -> invalid_arg (Printf.sprintf "UFO.Propagator.of_string: %s of %s: %s in \"%s\"\n" num_or_den symbol msg fixed) end let of_file1 (macros, map) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Propagator" ], attribs -> let required query name = required_handler "particle" symbol attribs query name and optional query name default = optional_handler attribs query name default in let name = required string_attrib "name" in warn_symbol_name "propagators" symbol name; let num_string_expr = required string_expr_attrib "numerator" and den_string = begin match optional find_attrib "denominator" (S.String default_denominator) with | S.String s -> s | S.Name [n] -> begin match Macro.expand_string macros n with | S.String s -> s | _ -> invalid_arg "Propagator.denominator" end | _ -> invalid_arg "Propagator.denominator: " end in let num_string = Macro.expand_expr macros num_string_expr in let numerator = of_string_with_error_correction symbol "numerator" num_string and denominator = of_string_with_error_correction symbol "denominator" den_string in (macros, SMap.add symbol { name; numerator; denominator } map) | [ "$" ], [ macro ] -> begin match macro.S.a_value with | S.String _ as s -> (Macro.define macros symbol s, map); | S.String_Expr expr -> let expanded = S.String (Macro.expand_expr macros expr) in (Macro.define macros symbol expanded, map) | _ -> invalid_arg ("Propagator:of_file: not a string " ^ symbol) end | [ "$" ], [] -> invalid_arg ("Propagator:of_file: empty declaration " ^ symbol) | [ "$" ], _ -> invalid_arg ("Propagator:of_file: multiple declaration " ^ symbol) | _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind) let of_file propagators = let _, propagators' = List.fold_left of_file1 (Macro.empty, SMap.empty) propagators in propagators' end module type Decay = sig type t = private { name : string; particle : string; widths : (string list * string) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Decay : Decay = struct type t = { name : string; particle : string; widths : (string list * string) list } let width_to_string ws = String.concat ", " (List.map (fun (ps, w) -> "(" ^ String.concat ", " ps ^ ") -> '" ^ w ^ "'") ws) let to_string symbol d = Printf.sprintf "decay: %s => [name = '%s', particle = '%s', widths = [%s]]" symbol d.name d.particle (width_to_string d.widths) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Decay" ], attribs -> let required query name = required_handler "particle" symbol attribs query name in let name = required string_attrib "name" in warn_symbol_name "decays" symbol name; SMap.add symbol { name; particle = required (name_attrib ~strip:"P") "particle"; widths = required decay_dictionary_attrib "partial_widths" } map | _ -> invalid_arg ("Decay.of_file: " ^ name_to_string d.S.kind) let of_file decays = List.fold_left of_file1 SMap.empty decays end (* We can read the spinor representations off the vertices to check for consistency. *) (* \begin{dubious} Note that we have to conjugate the representations! \end{dubious} *) -let collect_spinor_reps_of_vertex particles lorentz v sets = +let collect_spinor_reps_of_vertex _particles lorentz v sets = List.fold_left (fun sets' lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in List.fold_left (fun (spinors, conj_spinors as sets'') (i, rep) -> let p = v.Vertex.particles.(pred i) in match UFOx.Lorentz.omega rep with | Coupling.ConjSpinor -> (SSet.add p spinors, conj_spinors) | Coupling.Spinor -> (spinors, SSet.add p conj_spinors) | _ -> sets'') sets' (UFOx.Lorentz.classify_indices l)) sets v.Vertex.lcc let collect_spinor_reps_of_vertices particles lorentz vertices = SMap.fold (fun _ v -> collect_spinor_reps_of_vertex particles lorentz v) vertices (SSet.empty, SSet.empty) let lorentz_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not <*> UFOx.Lorentz.rep_trivial) ~offset:1 (List.map (fun p -> (* Why do we need to conjugate??? *) UFOx.Lorentz.rep_conjugate (SMap.find p particles).Particle.spin) (Array.to_list v.Vertex.particles)) let rep_compatible rep_vertex rep_particle = let open UFOx.Lorentz in let open Coupling in match omega rep_vertex, omega rep_particle with | (Spinor | ConjSpinor), Majorana -> true | r1, r2 -> r1 = r2 let reps_compatible reps_vertex reps_particles = List.for_all2 (fun (iv, rv) (ip, rp) -> iv = ip && rep_compatible rv rp) reps_vertex reps_particles let check_lorentz_reps_of_vertex particles lorentz v = let reps_particles = List.sort compare (lorentz_reps_of_vertex particles v) in List.iter (fun lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in let reps_vertex = List.sort compare (UFOx.Lorentz.classify_indices l) in if not (reps_compatible reps_vertex reps_particles) then begin Printf.eprintf "%s <> %s [%s]\n" (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_vertex) v.Vertex.name (* [(Vertex.to_string v.Vertex.name v)] *); (* [invalid_arg "check_lorentz_reps_of_vertex"] *) () end) v.Vertex.lcc let color_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not <*> UFOx.Color.rep_trivial) ~offset:1 (List.map (fun p -> (SMap.find p particles).Particle.color) (Array.to_list v.Vertex.particles)) let check_color_reps_of_vertex particles v = let reps_particles = List.sort compare (color_reps_of_vertex particles v) in List.iter (fun lcc -> let reps_vertex = List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in if reps_vertex <> reps_particles then begin Printf.eprintf "particles: %s\n<> vertex: %s\n" (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex); invalid_arg "check_color_reps_of_vertex" end) v.Vertex.lcc module P = Permutation.Default module type Lorentz = sig type spins = private | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t type t = private { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines; variables : string list } val required_charge_conjugates : t -> t list val permute : P.t -> t -> t val of_lorentz_UFO : Particle.t SMap.t -> Vertex.t SMap.t -> Lorentz_UFO.t SMap.t -> t SMap.t val lorentz_to_string : Coupling.lorentz -> string val to_string : string -> t -> string end module Lorentz : Lorentz = struct let rec lorentz_to_string = function | Coupling.Scalar -> "Scalar" | Coupling.Spinor -> "Spinor" | Coupling.ConjSpinor -> "ConjSpinor" | Coupling.Majorana -> "Majorana" | Coupling.Maj_Ghost -> "Maj_Ghost" | Coupling.Vector -> "Vector" | Coupling.Massive_Vector -> "Massive_Vector" | Coupling.Vectorspinor -> "Vectorspinor" | Coupling.Tensor_1 -> "Tensor_1" | Coupling.Tensor_2 -> "Tensor_2" | Coupling.BRS l -> "BRS(" ^ lorentz_to_string l ^ ")" (* Unlike UFO, O'Mega distinguishes bewteen spinors and conjugate spinors. However, we can inspect the particles in the vertices in which a Lorentz structure is used to determine the correct quantum numbers. Most model files in the real world contain unused Lorentz structures. This is not a problem, we can just ignore them. *) type spins = | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t (* \begin{dubious} Use [UFO_targets.Fortran.fusion_name] below in order to avoid communication problems. Or even move away from strings alltogether. \end{dubious} *) type t = { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines; variables : string list } (* Add one charge conjugated fermion lines. *) let charge_conjugate1 l (ket, bra as fermion_line) = { name = l.name ^ Printf.sprintf "_c%x%x" ket bra; n = l.n; spins = l.spins; structure = UFO_Lorentz.charge_conjugate fermion_line l.structure; fermion_lines = l.fermion_lines; variables = l.variables } (* Add several charge conjugated fermion lines. *) let charge_conjugate l fermion_lines = List.fold_left charge_conjugate1 l fermion_lines (*i let all_charge_conjugates l = List.map (charge_conjugate l) (ThoList.power l.fermion_lines) i*) (* Add all combinations of charge conjugated fermion lines that don't leave the fusion. *) let required_charge_conjugates l = let saturated_fermion_lines = List.filter (fun (ket, bra) -> ket != 1 && bra != 1) l.fermion_lines in List.map (charge_conjugate l) (ThoList.power saturated_fermion_lines) let permute_spins p = function | Unused -> Unused | Unique s -> Unique (P.array p s) | Ambiguous map -> Ambiguous (SMap.map (P.array p) map) (* Note that we apply the \emph{inverse} permutation to the indices in order to match the permutation of the particles/spins. *) let permute_structure n p (l, f) = let permuted = P.array (P.inverse p) (Array.init n succ) in let permute_index i = if i > 0 then UFOx.Index.map_position (fun pos -> permuted.(pred pos)) i else i in (UFO_Lorentz.map_indices permute_index l, UFO_Lorentz.map_fermion_lines permute_index f) let permute p l = let structure, fermion_lines = permute_structure l.n p (l.structure, l.fermion_lines) in { name = l.name ^ "_p" ^ P.to_string (P.inverse p); n = l.n; spins = permute_spins p l.spins; structure; fermion_lines; variables = l.variables } let omega_lorentz_reps n alist = let reps = Array.make n Coupling.Scalar in List.iter (fun (i, rep) -> reps.(pred i) <- UFOx.Lorentz.omega rep) alist; reps let contained lorentz vertex = List.exists (fun lcc1 -> lcc1.Vertex.lorentz = lorentz.Lorentz_UFO.symbol) vertex.Vertex.lcc (* Find all vertices in with the Lorentz structure [lorentz] is used and build a map from those vertices to the O'Mega Lorentz representations inferred from UFO's Lorentz structure and the [particles] involved. Then scan the bindings and check that we have inferred the same Lorentz representation from all vertices. *) let lorentz_reps_of_structure particles vertices lorentz = let uses = SMap.fold (fun name v acc -> if contained lorentz v then SMap.add name (omega_lorentz_reps (Array.length v.Vertex.particles) (lorentz_reps_of_vertex particles v)) acc else acc) vertices SMap.empty in let variants = ThoList.uniq (List.sort compare (List.map snd (SMap.bindings uses))) in match variants with | [] -> Unused | [s] -> Unique s | _ -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: AMBIGUOUS!\n"; List.iter (fun variant -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: %s\n" (ThoList.to_string lorentz_to_string (Array.to_list variant))) variants; Ambiguous uses let of_lorentz_tensor spins lorentz = match spins with | Unique s -> begin try Some (UFO_Lorentz.parse (Array.to_list s) lorentz) with | Failure msg -> begin prerr_endline msg; Some (UFO_Lorentz.dummy) end end | Unused -> Printf.eprintf "UFO.Lorentz: stripping unused structure %s\n" (UFOx.Lorentz.to_string lorentz); None | Ambiguous _ -> invalid_arg "UFO.Lorentz.of_lorentz_tensor: Ambiguous" (* NB: if the \texttt{name} attribute of a \texttt{Lorentz} object does \emph{not} match the the name of the object, the former has a better chance to correspond to a valid Fortran name. Therefore we use it. *) let of_lorentz_UFO particles vertices lorentz_UFO = SMap.fold (fun name l acc -> let spins = lorentz_reps_of_structure particles vertices l in match of_lorentz_tensor spins l.Lorentz_UFO.structure with | None -> acc | Some structure -> SMap.add name { name = l.Lorentz_UFO.symbol; n = List.length l.Lorentz_UFO.spins; spins; structure; fermion_lines = UFO_Lorentz.fermion_lines structure; variables = UFOx.Lorentz.variables l.Lorentz_UFO.structure } acc) lorentz_UFO SMap.empty let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = %s, \ structure = %s, fermion_lines = %s]" symbol l.name (match l.spins with | Unique s -> "[" ^ String.concat ", " (List.map lorentz_to_string (Array.to_list s)) ^ "]" | Ambiguous _ -> "AMBIGUOUS!" | Unused -> "UNUSED!") (UFO_Lorentz.to_string l.structure) (UFO_Lorentz.fermion_lines_to_string l.fermion_lines) end (* According to arxiv:1308:1668, there should not be a factor of~$i$ in the numerators of propagators, but the (unused) \texttt{propagators.py} in most models violate this rule! *) let divide_propagators_by_i = ref false module type Propagator = sig type t = (* private *) { name : string; spins : Coupling.lorentz * Coupling.lorentz; numerator : UFO_Lorentz.t; denominator : UFO_Lorentz.t; variables : string list } val of_propagator_UFO : ?majorana:bool -> Propagator_UFO.t -> t val of_propagators_UFO : ?majorana:bool -> Propagator_UFO.t SMap.t -> t SMap.t val transpose : t -> t val to_string : string -> t -> string end module Propagator : Propagator = struct type t = (* private *) { name : string; spins : Coupling.lorentz * Coupling.lorentz; numerator : UFO_Lorentz.t; denominator : UFO_Lorentz.t; variables : string list } let lorentz_rep_at rep_classes i = try UFOx.Lorentz.omega (List.assoc i rep_classes) with | Not_found -> Coupling.Scalar let imaginary = Algebra.QC.make Algebra.Q.null Algebra.Q.unit let scalars = [Coupling.Scalar; Coupling.Scalar] (* If~$51$ and~$52$ show up as indices, we must map $(1,51)\to(1001,2001)$ and $(2,52)\to(1002,2002)$, as per the UFO conventions for Lorentz structures. *) (* \begin{dubious} This does not work yet, because [UFOx.Lorentz.map_indices] affects also the position argument of [P], [Mass] and [Width]. \end{dubious} *) let contains_51_52 tensor = List.exists (fun (i, _) -> i = 51 || i = 52) (UFOx.Lorentz.classify_indices tensor) let remap_51_52 = function | 1 -> 1001 | 51 -> 2001 | 2 -> 1002 | 52 -> 2002 | i -> i let canonicalize_51_52 tensor = if contains_51_52 tensor then UFOx.Lorentz.rename_indices remap_51_52 tensor else tensor let force_majorana = function | Coupling.Spinor | Coupling.ConjSpinor -> Coupling.Majorana | s -> s let string_list_union l1 l2 = Sets.String.elements (Sets.String.union (Sets.String.of_list l1) (Sets.String.of_list l2)) (* In the current conventions, the factor of~$i$ is not included: *) let of_propagator_UFO ?(majorana=false) p = let numerator = canonicalize_51_52 p.Propagator_UFO.numerator in let lorentz_reps = UFOx.Lorentz.classify_indices numerator in let spin1 = lorentz_rep_at lorentz_reps 1 and spin2 = lorentz_rep_at lorentz_reps 2 in let numerator_sans_i = if !divide_propagators_by_i then UFOx.Lorentz.map_coeff (fun q -> Algebra.QC.div q imaginary) numerator else numerator in { name = p.Propagator_UFO.name; spins = if majorana then (force_majorana spin1, force_majorana spin2) else (spin1, spin2); numerator = UFO_Lorentz.parse ~allow_denominator:true [spin1; spin2] numerator_sans_i; denominator = UFO_Lorentz.parse scalars p.Propagator_UFO.denominator; variables = string_list_union (UFOx.Lorentz.variables p.Propagator_UFO.denominator) (UFOx.Lorentz.variables numerator_sans_i) } let of_propagators_UFO ?majorana propagators_UFO = SMap.fold (fun name p acc -> SMap.add name (of_propagator_UFO ?majorana p) acc) propagators_UFO SMap.empty let permute12 = function | 1 -> 2 | 2 -> 1 | n -> n let transpose_positions t = UFOx.Index.map_position permute12 t let transpose p = { name = p.name; spins = (snd p.spins, fst p.spins); numerator = UFO_Lorentz.map_indices transpose_positions p.numerator; denominator = p.denominator; variables = p.variables } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', spin = '(%s, %s)', numerator/I = '%s', \ denominator = '%s']" symbol p.name (Lorentz.lorentz_to_string (fst p.spins)) (Lorentz.lorentz_to_string (snd p.spins)) (UFO_Lorentz.to_string p.numerator) (UFO_Lorentz.to_string p.denominator) end type t = { particles : Particle.t SMap.t; particle_array : Particle.t array; (* for diagnostics *) couplings : UFO_Coupling.t SMap.t; coupling_orders : Coupling_Order.t SMap.t; vertices : Vertex.t SMap.t; lorentz_UFO : Lorentz_UFO.t SMap.t; lorentz : Lorentz.t SMap.t; parameters : Parameter.t SMap.t; propagators_UFO : Propagator_UFO.t SMap.t; propagators : Propagator.t SMap.t; decays : Decay.t SMap.t; nc : int } let use_majorana_spinors = ref false let fallback_to_majorana_if_necessary particles vertices lorentz_UFO = let majoranas = SMap.fold (fun p particle acc -> if Particle.is_majorana particle then SSet.add p acc else acc) particles SSet.empty in let spinors, conj_spinors = collect_spinor_reps_of_vertices particles lorentz_UFO vertices in let ambiguous = SSet.diff (SSet.inter spinors conj_spinors) majoranas in let no_majoranas = SSet.is_empty majoranas and no_ambiguities = SSet.is_empty ambiguous in if no_majoranas && no_ambiguities && not !use_majorana_spinors then (SMap.mapi (fun p particle -> if SSet.mem p spinors then Particle.force_spinor particle else if SSet.mem p conj_spinors then Particle.force_conjspinor particle else particle) particles, false) else begin if !use_majorana_spinors then Printf.eprintf "O'Mega: Majorana fermions requested.\n"; if not no_majoranas then Printf.eprintf "O'Mega: found Majorana fermions!\n"; if not no_ambiguities then Printf.eprintf "O'Mega: found ambiguous spinor representations for %s!\n" (String.concat ", " (SSet.elements ambiguous)); Printf.eprintf "O'Mega: falling back to the Majorana representation for all fermions.\n"; (SMap.map Particle.force_majorana particles, true) end let nc_of_particles particles = let nc_set = List.fold_left (fun nc_set (_, p) -> match UFOx.Color.omega p.Particle.color with | Color.Singlet | Color.YT _ | Color.YTC _ -> nc_set | Color.SUN nc -> Sets.Int.add (abs nc) nc_set | Color.AdjSUN nc -> Sets.Int.add (abs nc) nc_set) Sets.Int.empty (SMap.bindings particles) in match Sets.Int.elements nc_set with | [] -> 0 | [n] -> n | nc_list -> invalid_arg ("UFO.Model: more than one value of N_C: " ^ String.concat ", " (List.map string_of_int nc_list)) let of_file u = let particles = Particle.of_file u.Files.particles in let vertices = Vertex.of_file particles u.Files.vertices and lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz and propagators_UFO = Propagator_UFO.of_file u.Files.propagators in let particles, majorana = fallback_to_majorana_if_necessary particles vertices lorentz_UFO in let particle_array = Array.of_list (values particles) and lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO and propagators = Propagator.of_propagators_UFO ~majorana propagators_UFO in let model = { particles; particle_array; couplings = UFO_Coupling.of_file u.Files.couplings; coupling_orders = Coupling_Order.of_file u.Files.coupling_orders; vertices; lorentz_UFO; lorentz; parameters = Parameter.of_file u.Files.parameters; propagators_UFO; propagators; decays = Decay.of_file u.Files.decays; nc = nc_of_particles particles } in SMap.iter (fun _ v -> check_color_reps_of_vertex model.particles v; check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v) model.vertices; model let map_parameter_names f m = { m with particles = SMap.map (Particle.map_mass_and_width f) m.particles; particle_array = Array.map (Particle.map_mass_and_width f) m.particle_array; parameters = SMap.map (Parameter.map_names f) m.parameters } let parse_directory dir = of_file (Files.parse_directory dir) let dump model = Printf.printf "NC = %d\n" model.nc; SMap.iter (print_endline <**> Particle.to_string) model.particles; SMap.iter (print_endline <**> UFO_Coupling.to_string) model.couplings; SMap.iter (print_endline <**> Coupling_Order.to_string) model.coupling_orders; (* [SMap.iter (print_endline <**> Vertex.to_string) model.vertices;] *) SMap.iter (fun symbol v -> (print_endline <**> Vertex.to_string) symbol v; print_endline (Vertex.to_string_expanded model.lorentz_UFO model.couplings v)) model.vertices; SMap.iter (print_endline <**> Lorentz_UFO.to_string) model.lorentz_UFO; SMap.iter (print_endline <**> Lorentz.to_string) model.lorentz; SMap.iter (print_endline <**> Parameter.to_string) model.parameters; SMap.iter (print_endline <**> Propagator_UFO.to_string) model.propagators_UFO; SMap.iter (print_endline <**> Propagator.to_string) model.propagators; SMap.iter (print_endline <**> Decay.to_string) model.decays; SMap.iter - (fun symbol d -> + (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) +let _unhandled s = raise (Unhandled s) module Model = struct (* NB: we could use [type flavor = Particle.t], but that would be very inefficient, because we will use [flavor] as a key for maps below. *) type flavor = int type constant = string type coupling_order = string type gauge = unit module M = Modeltools.Mutable (struct type f = flavor type g = gauge type c = constant type co = string end) let setup = M.setup let flavors = M.flavors let external_flavors = M.external_flavors let lorentz = M.lorentz let all_coupling_orders = M.all_coupling_orders let coupling_orders = M.coupling_orders let coupling_order_to_string co = co let color = M.color let nc = M.nc let propagator = M.propagator let width = M.width let goldstone = M.goldstone let conjugate = M.conjugate let fermion = M.fermion let vertices = M.vertices let fuse2 = M.fuse2 let fuse3 = M.fuse3 let fuse = M.fuse let max_degree = M.max_degree let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let pdg = M.pdg let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol module Ch = M.Ch let charges = M.charges let rec fermion_of_lorentz = function | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> -1 | Coupling.Majorana -> 2 | Coupling.Maj_Ghost -> 2 | Coupling.Vectorspinor -> 1 | Coupling.Vector | Coupling.Massive_Vector -> 0 | Coupling.Scalar | Coupling.Tensor_1 | Coupling.Tensor_2 -> 0 | Coupling.BRS f -> fermion_of_lorentz f module Q = Algebra.Q module QC = Algebra.QC - let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1 - let dummy_tensor4 = Coupling.Scalar4 1 + let _dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1 + let _dummy_tensor4 = Coupling.Scalar4 1 - let triplet p = (p.(0), p.(1), p.(2)) - let quartet p = (p.(0), p.(1), p.(2), p.(3)) + let _triplet p = (p.(0), p.(1), p.(2)) + let _quartet p = (p.(0), p.(1), p.(2), p.(3)) - let half_times q1 q2 = + let _half_times q1 q2 = Q.mul (Q.make 1 2) (Q.mul q1 q2) let name g = g.UFO_Coupling.name - let fractional_coupling g r = + let _fractional_coupling g r = let g = name g in match Q.to_ratio r with | 0, _ -> "0.0_default" | 1, 1 -> g | -1, 1 -> Printf.sprintf "(-%s)" g | n, 1 -> Printf.sprintf "(%d*%s)" n g | 1, d -> Printf.sprintf "(%s/%d)" g d | -1, d -> Printf.sprintf "(-%s/%d)" g d | n, d -> Printf.sprintf "(%d*%s/%d)" n g d let lorentz_of_symbol model symbol = try SMap.find symbol model.lorentz with | Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol) - let lorentz_UFO_of_symbol model symbol = + 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 = + 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 = + let _spin_quartet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique [|s0; s1; s2; s3|] -> (s0, s1, s2, s3) | Lorentz.Unique _ -> invalid_arg "spin_quartet: wrong number of spins" | Lorentz.Unused -> invalid_arg "spin_quartet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_quartet: Ambiguous" let spin_multiplet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique sarray -> sarray | Lorentz.Unused -> invalid_arg "spin_multiplet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_multiplet: Ambiguous" (* If we have reason to belive that a $\delta_{ab}$-vertex is an effective $\tr(T_aT_b)$-vertex generated at loop level, like~$gg\to H\ldots$ in the SM, we should interpret it as such and use the expression~(6.2) from~\cite{Kilian:2012pz}. *) (* AFAIK, there is no way to distinguish these cases directly in a UFO file. Instead we rely in a heuristic, in which each massless color octet vector particle or ghost is a gluon and colorless scalars are potential Higgses. *) let is_massless p = match ThoString.uppercase p.Particle.mass with | "ZERO" -> true | _ -> false let is_gluon model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color, UFOx.Lorentz.omega p.Particle.spin with | Color.AdjSUN _, Coupling.Vector -> is_massless p | Color.AdjSUN _, Coupling.Scalar -> if p.Particle.ghost_number <> 0 then is_massless p else false | _ -> false let is_color_singlet model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color with | Color.Singlet -> true | _ -> false let is_higgs_gluon_vertex model p adjoints = if Array.length p > List.length adjoints then List.for_all (fun (i, p) -> if List.mem i adjoints then is_gluon model p else is_color_singlet model p) (ThoList.enumerate 1 (Array.to_list p)) else false let delta8_heuristics model p a b = if is_higgs_gluon_vertex model p [a; b] then Color.Vertex.delta8_loop a b else Color.Vertex.delta8 a b let verbatim_higgs_glue = ref false let yt_to_omega y = Young.map pred y let translate_color_atom model p = function | UFOx.Color_Atom.Identity (i, j) -> Color.Vertex.delta3 j i | UFOx.Color_Atom.Identity8 (a, b) -> if !verbatim_higgs_glue then Color.Vertex.delta8 a b else delta8_heuristics model p a b | UFOx.Color_Atom.Delta (y, a, b) -> Color.Vertex.delta_of_tableau (yt_to_omega y) a b | UFOx.Color_Atom.T (a, i, j) -> Color.Vertex.t a i j | UFOx.Color_Atom.TY (y, a, i, j) -> Color.Vertex.t_of_tableau (yt_to_omega y) a i j | UFOx.Color_Atom.F (a, b, c) -> Color.Vertex.f a b c | UFOx.Color_Atom.D (a, b, c) -> Color.Vertex.d a b c - | UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon [i; j; k] - | UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilon_bar [i; j; k] + | UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon0 [i; j; k] + | UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilon0_bar [i; j; k] | UFOx.Color_Atom.T6 (a, i, j) -> Color.Vertex.t6 a i j | UFOx.Color_Atom.K6 (i, j, k) -> Color.Vertex.k6 i j k | UFOx.Color_Atom.K6Bar (i, j, k) -> Color.Vertex.k6bar i j k let translate_color_term model p = function | [], q -> Birdtracks.scale q Birdtracks.one | [atom], q -> Birdtracks.scale q (translate_color_atom model p atom) | atoms, q -> let atoms = List.map (translate_color_atom model p) atoms in Birdtracks.scale q (Birdtracks.multiply atoms) let translate_color model p terms = match terms with | [] -> invalid_arg "translate_color: empty" | [ term ] -> translate_color_term model p term | terms -> Birdtracks.sum (List.map (translate_color_term model p) terms) let translate_coupling_1 model p lcc = let l = lcc.Vertex.lorentz in let s = Array.to_list (spin_multiplet model l) and fl = (SMap.find l model.lorentz).Lorentz.fermion_lines and c = name (coupling_of_symbol model lcc.Vertex.coupling) in match lcc.Vertex.color with | UFOx.Color.Linear color -> let col = translate_color model p color in (Array.to_list p, Coupling.UFO (QC.unit, l, s, fl, col), c) | UFOx.Color.Ratios _ as color -> invalid_arg ("UFO.Model.translate_coupling: invalid color structure" ^ UFOx.Color.to_string color) let translate_coupling model p lcc = List.map (translate_coupling_1 model p) lcc - let long_flavors = ref false + let _long_flavors = ref false module type Lookup = sig type f = private { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal val flavor_format : flavor_format ref val of_model : t -> f end module Lookup : Lookup = struct type f = { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal let flavor_format = ref Hexadecimal (*i let match_pdf_code p1 p2 = p1.Particle.pdg_code = p2.Particle.pdg_code i*) let conjugate_of_particle_array particles = Array.init (Array.length particles) (fun i -> let f' = Particle.conjugate particles.(i) in match ThoArray.match_all f' particles with | [i'] -> i' | [] -> invalid_arg ("no charge conjugate: " ^ f'.Particle.name) | _ -> invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name)) let invert_flavor_array a = let table = SHash.create 37 in Array.iteri (fun i s -> SHash.add table s i) a; (fun name -> try SHash.find table name with | Not_found -> invalid_arg ("not found: " ^ name)) let digits base n = let rec digits' acc n = if n < 1 then acc else digits' (succ acc) (n / base) in if n < 0 then digits' 1 (-n) else if n = 0 then 1 else digits' 0 n let of_model model = let particle_array = Array.of_list (values model.particles) in let conjugate_array = conjugate_of_particle_array particle_array and name_array = Array.map (fun f -> f.Particle.name) particle_array and symbol_array = Array.of_list (keys model.particles) in let flavor_symbol f = begin match !flavor_format with | Long -> symbol_array.(f) | Decimal -> let w = digits 10 (Array.length particle_array - 1) in Printf.sprintf "%0*d" w f | Hexadecimal -> let w = digits 16 (Array.length particle_array - 1) in Printf.sprintf "%0*X" w f end in { flavors = ThoList.range 0 (Array.length particle_array - 1); flavor_of_string = invert_flavor_array name_array; flavor_of_symbol = invert_flavor_array symbol_array; particle = Array.get particle_array; flavor_symbol = flavor_symbol; conjugate = Array.get conjugate_array } end (* \begin{dubious} We appear to need to conjugate all flavors. Why??? \end{dubious} *) let translate_vertices model tables = let vn = List.fold_left (fun acc v -> let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles and lcc = v.Vertex.lcc in let p = Array.map conjugate p in (* FIXME: why? *) translate_coupling model p lcc @ acc) [] (values model.vertices) in ([], [], vn) let propagator_of_lorentz = function | Coupling.Scalar -> Coupling.Prop_Scalar | Coupling.Spinor -> Coupling.Prop_Spinor | Coupling.ConjSpinor -> Coupling.Prop_ConjSpinor | Coupling.Majorana -> Coupling.Prop_Majorana | Coupling.Maj_Ghost -> invalid_arg "UFO.Model.propagator_of_lorentz: SUSY ghosts do not propagate" | Coupling.Vector -> Coupling.Prop_Feynman | Coupling.Massive_Vector -> Coupling.Prop_Unitarity | Coupling.Tensor_2 -> Coupling.Prop_Tensor_2 | Coupling.Vectorspinor -> invalid_arg "UFO.Model.propagator_of_lorentz: Vectorspinor" | Coupling.Tensor_1 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_1" | Coupling.BRS _ -> invalid_arg "UFO.Model.propagator_of_lorentz: no BRST" let filter_unphysical model = let physical_particles = Particle.filter Particle.is_physical model.particles in let physical_particle_array = Array.of_list (values physical_particles) in let physical_vertices = Vertex.filter (not <*> (Vertex.contains model.particles (not <*> Particle.is_physical))) model.vertices in { model with particles = physical_particles; particle_array = physical_particle_array; vertices = physical_vertices } let whizard_constants = SSet.of_list [ "ZERO" ] let filter_constants parameters = List.filter (fun p -> not (SSet.mem (ThoString.uppercase p.Parameter.name) whizard_constants)) parameters let add_name set parameter = CSet.add parameter.Parameter.name set let hardcoded_parameters = CSet.of_list ["cmath.pi"] let missing_parameters input derived couplings = let input_parameters = List.fold_left add_name hardcoded_parameters input in let all_parameters = List.fold_left add_name input_parameters derived in let derived_dependencies = dependencies (List.map (fun p -> (p.Parameter.name, p.Parameter.value)) derived) in let coupling_dependencies = dependencies (List.map (fun p -> (p.UFO_Coupling.name, Expr p.UFO_Coupling.value)) (values couplings)) in let missing_input = CMap.filter - (fun parameter derived_parameters -> + (fun parameter _derived_parameters -> not (CSet.mem parameter all_parameters)) derived_dependencies and missing = CMap.filter - (fun parameter couplings -> + (fun parameter _couplings -> not (CSet.mem parameter all_parameters)) coupling_dependencies in CMap.iter (fun parameter derived_parameters -> Printf.eprintf "UFO warning: undefined input parameter %s appears in derived \ parameters {%s}: will be added to the list of input parameters!\n" parameter (String.concat "; " (CSet.elements derived_parameters))) missing_input; CMap.iter (fun parameter couplings -> Printf.eprintf "UFO warning: undefined parameter %s appears in couplings {%s}: \ will be added to the list of input parameters!\n" parameter (String.concat "; " (CSet.elements couplings))) missing; keys_caseless missing_input @ keys_caseless missing let classify_parameters model = let compare_parameters p1 p2 = compare p1.Parameter.sequence p2.Parameter.sequence in let input, derived = List.fold_left (fun (input, derived) p -> match p.Parameter.nature with | Parameter.Internal -> (input, p :: derived) | Parameter.External -> begin match p.Parameter.ptype with | Parameter.Real -> () | Parameter.Complex -> Printf.eprintf "UFO warning: invalid complex declaration of input \ parameter `%s' ignored!\n" p.Parameter.name end; (p :: input, derived)) ([], []) (filter_constants (values model.parameters)) in let additional = missing_parameters input derived model.couplings in (List.sort compare_parameters input @ List.map Parameter.missing additional, List.sort compare_parameters derived) (*i List.iter (fun line -> Printf.eprintf "par: %s\n" line) (dependencies_to_strings derived_dependencies); List.iter (fun line -> Printf.eprintf "coupling: %s\n" line) (dependencies_to_strings coupling_dependencies); i*) let translate_input p = (p.Parameter.name, value_to_float p.Parameter.value) let alpha_s_half e = UFOx.Expr.substitute "aS" (UFOx.Expr.half "aS") e let translate_derived p = let make_atom s = s in let c = make_atom p.Parameter.name and v = value_to_coupling alpha_s_half make_atom p.Parameter.value in match p.Parameter.ptype with | Parameter.Real -> (Coupling.Real c, v) | Parameter.Complex -> (Coupling.Complex c, v) let translate_coupling_constant c = let make_atom s = s in (Coupling.Complex c.UFO_Coupling.name, Coupling.Quot (value_to_coupling alpha_s_half make_atom (Expr c.UFO_Coupling.value), Coupling.I)) module Lowercase_Parameters = struct type elt = string type base = string let compare_elt = compare let compare_base = compare let pi = ThoString.lowercase end module Lowercase_Bundle = Bundle.Make (Lowercase_Parameters) let coupling_names model = SMap.fold (fun _ c acc -> c.UFO_Coupling.name :: acc) model.couplings [] let parameter_names model = SMap.fold (fun _ c acc -> c.Parameter.name :: acc) model.parameters [] let ambiguous_parameters model = let all_names = List.rev_append (coupling_names model) (parameter_names model) in let lc_bundle = Lowercase_Bundle.of_list all_names in let lc_set = List.fold_left (fun acc s -> SSet.add s acc) SSet.empty (Lowercase_Bundle.base lc_bundle) and ambiguities = List.filter (fun (_, names) -> List.length names > 1) (Lowercase_Bundle.fibers lc_bundle) in (lc_set, ambiguities) let disambiguate1 lc_set name = let rec disambiguate1' i = let name' = Printf.sprintf "%s_%d" name i in let lc_name' = ThoString.lowercase name' in if SSet.mem lc_name' lc_set then disambiguate1' (succ i) else (SSet.add lc_name' lc_set, name') in disambiguate1' 1 let disambiguate lc_set names = let _, replacements = List.fold_left (fun (lc_set', acc) name -> let lc_set'', name' = disambiguate1 lc_set' name in (lc_set'', SMap.add name name' acc)) (lc_set, SMap.empty) names in replacements let omegalib_names = ["u"; "ubar"; "v"; "vbar"; "eps"] let replacement_map model = let lc_set, ambiguities = ambiguous_parameters model in let replacement_list = disambiguate lc_set (ThoList.flatmap snd ambiguities) in SMap.iter (Printf.eprintf "UFO warning: case sensitive parameter names: renaming '%s' -> '%s'\n") replacement_list; List.fold_left (fun acc name -> SMap.add name ("UFO_" ^ name) acc) replacement_list omegalib_names let translated_parameters model = let input_parameters, derived_parameters = classify_parameters model and couplings = values model.couplings in { Coupling.input = List.map translate_input input_parameters; Coupling.derived = List.map translate_derived derived_parameters @ List.map translate_coupling_constant couplings; Coupling.derived_arrays = [] } (* UFO requires us to look up the mass parameter to distinguish between massless and massive vectors. TODO: this is a candidate for another lookup table. *) let lorentz_of_particle p = match UFOx.Lorentz.omega p.Particle.spin with | Coupling.Vector -> begin match ThoString.uppercase p.Particle.mass with | "ZERO" -> Coupling.Vector | _ -> Coupling.Massive_Vector end | s -> s type state = { directory : string; model : t } let initialized = ref None let is_initialized_from dir = match !initialized with | None -> false | Some state -> dir = state.directory let dump_raw = ref false (* Using [translated_parameters] only to extract the parameters, without affecting the corresponding changes in the model tables couldn't work! (Cf.~\url{https://answers.launchpad.net/whizard/+question/706815} and~\url{https://gitlab.tp.nt.uni-siegen.de/whizard/development/-/issues/450}) *) let map_names map name = match SMap.find_opt name map with | None -> name | Some name -> name type init = string * string list let init (dir, flags) = if List.mem "dump" flags then dump_raw := true; let model = filter_unphysical (parse_directory dir) in if !dump_raw then dump model; let replacements = replacement_map model in let model = map_parameter_names (map_names replacements) model in let parameters = translated_parameters model in let tables = Lookup.of_model model in let vertices () = translate_vertices model tables in let particle f = tables.Lookup.particle f in let lorentz f = lorentz_of_particle (particle f) in let propagator f = let p = particle f in match p.Particle.propagator with | None -> propagator_of_lorentz (lorentz_of_particle p) | Some s -> Coupling.Prop_UFO s in let gauge_symbol () = "?GAUGE?" in let constant_symbol s = s in let all_coupling_orders () = List.map fst (SMap.bindings model.coupling_orders) and coupling_orders c = (coupling_of_symbol model c).UFO_Coupling.order and coupling_order_to_string co = co in M.setup ~color:(fun f -> UFOx.Color.omega (particle f).Particle.color) ~nc:(fun () -> model.nc) ~pdg:(fun f -> (particle f).Particle.pdg_code) ~lorentz ~propagator - ~width:(fun f -> Coupling.Constant) - ~goldstone:(fun f -> None) + ~width:(fun _ -> Coupling.Constant) + ~goldstone:(fun _ -> 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 ~all_coupling_orders ~coupling_orders ~coupling_order_to_string; initialized := Some { directory = dir; model = model } let ufo_directory = ref Config.default_UFO_dir let load () = if is_initialized_from !ufo_directory then () else init (!ufo_directory, []) let include_all_fusions = ref false (* In case of Majorana spinors, also generate all combinations of charge conjugated fermion lines. The naming convention is to append \texttt{\_c}$nm$ if the $\gamma$-matrices of the fermion line $n\to m$ has been charge conjugated (this could become impractical for too many fermions at a vertex, but shouldn't matter in real life). *) (* Here we alway generate \emph{all} charge conjugations, because we treat \emph{all} fermions as Majorana fermion, if there is at least one Majorana fermion in the model! *) let is_majorana = function | Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true | _ -> false let name_spins_structure spins l = (l.Lorentz.name, spins, l.Lorentz.structure) let fusions_of_model ?only model = let include_fusion = match !include_all_fusions, only with | true, _ - | false, None -> (fun name -> true) + | false, None -> (fun _ -> true) | false, Some names -> (fun name -> SSet.mem name names) in SMap.fold (fun name l acc -> if include_fusion name then List.fold_left (fun acc p -> let l' = Lorentz.permute p l in match l'.Lorentz.spins with | Lorentz.Unused -> acc | Lorentz.Unique spins -> if Array.exists is_majorana spins then List.map (name_spins_structure spins) (Lorentz.required_charge_conjugates l') @ acc else name_spins_structure spins l' :: acc | Lorentz.Ambiguous _ -> failwith "fusions: Lorentz.Ambiguous") [] (Permutation.Default.cyclic l.Lorentz.n) @ acc else acc) model.lorentz [] let fusions ?only () = match !initialized with | None -> [] - | Some { model = model } -> fusions_of_model ?only model + | Some { model = model; _ } -> fusions_of_model ?only model let propagators_of_model ?only model = let include_propagator = match !include_all_fusions, only with | true, _ - | false, None -> (fun name -> true) + | false, None -> (fun _ -> true) | false, Some names -> (fun name -> SSet.mem name names) in SMap.fold (fun name p acc -> if include_propagator name then (name, p) :: acc else acc) model.propagators [] let propagators ?only () = match !initialized with | None -> [] - | Some { model = model } -> propagators_of_model ?only model + | Some { model = model; _ } -> propagators_of_model ?only model let include_hadrons = ref true (*i let ufo_majorana_warnings = [ "***************************************************"; "* *"; "* CAVEAT: *"; "* *"; "* These amplitudes have been computed for a *"; "* UFO model containing Majorana fermions. *"; "* This version of O'Mega contains some known *"; "* bugs for this case. It was released early at *"; "* the request of the Linear Collider community. *"; "* *"; "* These amplitudes MUST NOT be used for *"; "* publications without prior consulation *"; "* with the WHIZARD authors !!! *"; "* *"; "***************************************************" ] let caveats () = if !use_majorana_spinors then ufo_majorana_warnings else [] i*) let caveats () = [] module Whizard : sig val write : out_channel -> unit end = struct let write_header oc dir = let open Printf in fprintf oc "# WHIZARD Model file derived from UFO directory\n"; fprintf oc "# '%s'\n\n" dir; List.iter (fun s -> fprintf oc "# %s\n" s) (M.caveats ()); fprintf oc "model \"%s\"\n\n" (Filename.basename dir) let write_input_parameters oc parameters = let open Printf in let open Parameter in fprintf oc "# Independent (input) Parameters\n"; List.iter (fun p -> fprintf oc "parameter %s = %s" p.name (value_to_numeric p.value); begin match p.lhablock, p.lhacode with | None, None -> () | Some name, Some (index :: indices) -> fprintf oc " slha_entry %s %d" name index; List.iter (fun i -> fprintf oc " %d" i) indices | Some name, None -> eprintf "UFO: parameter %s: slhablock %s without slhacode\n" p.name name | Some name, Some [] -> eprintf "UFO: parameter %s: slhablock %s with empty slhacode\n" p.name name | None, Some _ -> eprintf "UFO: parameter %s: slhacode without slhablock\n" p.name end; fprintf oc "\n") parameters; fprintf oc "\n" let write_derived_parameters oc parameters = let open Printf in let open Parameter in fprintf oc "# Dependent (derived) Parameters\n"; List.iter (fun p -> fprintf oc "derived %s = %s\n" p.name (value_to_expr alpha_s_half p.value)) parameters let write_particles oc particles = let open Printf in let open Particle in fprintf oc "# Particles\n"; fprintf oc "# NB: hypercharge assignments appear to be unreliable\n"; fprintf oc "# therefore we can't infer the isospin\n"; fprintf oc "# NB: parton-, gauge- & handedness are unavailable\n"; List.iter (fun p -> if not p.is_anti then begin fprintf oc "particle \"%s\" %d ### parton? gauge? left?\n" p.name p.pdg_code; fprintf oc " spin %s charge %s color %s ### isospin?\n" (UFOx.Lorentz.rep_to_string_whizard p.spin) (charge_to_string p.charge) (UFOx.Color.rep_to_string_whizard p.color); fprintf oc " name \"%s\"\n" p.name; if p.antiname <> p.name then fprintf oc " anti \"%s\"\n" p.antiname; fprintf oc " tex_name \"%s\"\n" p.texname; if p.antiname <> p.name then fprintf oc " tex_anti \"%s\"\n" p.antitexname; fprintf oc " mass %s width %s\n\n" p.mass p.width end) (values particles); fprintf oc "\n" let write_hadrons oc = let open Printf in fprintf oc "# Hadrons (protons and beam remnants)\n"; fprintf oc "# NB: these are NOT part of the UFO model\n"; fprintf oc "# but added for WHIZARD's convenience!\n"; fprintf oc "particle PROTON 2212\n"; fprintf oc " spin 1/2 charge 1\n"; fprintf oc " name p \"p+\"\n"; fprintf oc " anti pbar \"p-\"\n"; fprintf oc "particle HADRON_REMNANT 90\n"; fprintf oc " name hr\n"; fprintf oc " tex_name \"had_r\"\n"; fprintf oc "particle HADRON_REMNANT_SINGLET 91\n"; fprintf oc " name hr1\n"; fprintf oc " tex_name \"had_r^{(1)}\"\n"; fprintf oc "particle HADRON_REMNANT_TRIPLET 92\n"; fprintf oc " color 3\n"; fprintf oc " name hr3\n"; fprintf oc " tex_name \"had_r^{(3)}\"\n"; fprintf oc " anti hr3bar\n"; fprintf oc " tex_anti \"had_r^{(\\bar 3)}\"\n"; fprintf oc "particle HADRON_REMNANT_OCTET 93\n"; fprintf oc " color 8\n"; fprintf oc " name hr8\n"; fprintf oc " tex_name \"had_r^{(8)}\"\n"; fprintf oc "\n" let vertex_to_string model v = String.concat " " (List.map (fun s -> "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"") (Array.to_list v.Vertex.particles)) let write_vertices3 oc model vertices = let open Printf in fprintf oc "# Vertices (for phasespace generation only)\n"; fprintf oc "# NB: particles should be sorted increasing in mass.\n"; fprintf oc "# This is NOT implemented yet!\n"; List.iter (fun v -> if Array.length v.Vertex.particles = 3 then fprintf oc "vertex %s\n" (vertex_to_string model v)) (values vertices); fprintf oc "\n" let write_vertices_higher oc model vertices = let open Printf in fprintf oc "# Higher Order Vertices (ignored by phasespace generation)\n"; List.iter (fun v -> if Array.length v.Vertex.particles <> 3 then fprintf oc "# vertex %s\n" (vertex_to_string model v)) (values vertices); fprintf oc "\n" let write_vertices oc model vertices = write_vertices3 oc model vertices; write_vertices_higher oc model vertices let write oc = match !initialized with | None -> failwith "UFO.Whizard.write: UFO model not initialized" | Some { directory = dir; model = model } -> let input_parameters, derived_parameters = classify_parameters model in write_header oc dir; write_input_parameters oc input_parameters; write_derived_parameters oc derived_parameters; write_particles oc model.particles; if !include_hadrons then write_hadrons oc; write_vertices oc model model.vertices; exit 0 end let write_whizard = Whizard.write let coupling_order_option co = let s = M.coupling_order_to_string co in ("-order:" ^ s, Arg.Int (fun n -> Printf.eprintf "coupling_order(%s) = %d\n" s n; flush stderr (*; [M.set_coupling_order co n] *) ), Printf.sprintf "n set %s coupling order n [>=0] (still ignored)" s) - let coupling_order_options () = + let _coupling_order_options () = Arg.align (List.map coupling_order_option (all_coupling_orders ())) - let flavor_list_to_string f_list = + let _flavor_list_to_string f_list = String.concat "|" (List.map flavor_to_string f_list) - let all_flavors () = + let _all_flavors () = try ThoList.flatmap snd (external_flavors ()) with | Modeltools.Uninitialized _ -> [] let load_and_update_cmdline () = load () (* [; Options.global := !Options.global @ (coupling_order_options ()); Options.usage := "usage: " ^ Sys.argv.(0) ^ " [options] [-scatter|-decay] process {flavors: " ^ flavor_list_to_string (all_flavors ()) ^ "}"] *) let options = Options.create [ ("UFO_dir", Arg.String (fun name -> ufo_directory := name), "dir UFO model directory (default: " ^ !ufo_directory ^ ")"); ("Majorana", Arg.Set use_majorana_spinors, " use Majorana spinors (must come _before_ exec!)"); ("divide_propagators_by_i", Arg.Set divide_propagators_by_i, " divide propagators by I (pre 2013 FeynRules convention)"); ("verbatim_Hg", Arg.Set verbatim_higgs_glue, " don't correct the color flows for effective Higgs Gluon couplings"); ("write_WHIZARD", Arg.Unit (fun () -> Whizard.write stdout), " write the WHIZARD model file (required once per model)"); ("long_flavors", Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long), " write use the UFO flavor names instead of integers"); ("dump", Arg.Set dump_raw, " dump UFO model for debugging the parser (must come _before_ exec!)"); ("all_fusions", Arg.Set include_all_fusions, " include all fusions in the fortran module"); ("no_hadrons", Arg.Clear include_hadrons, " don't add any particle not in the UFO file"); ("add_hadrons", Arg.Set include_hadrons, " add protons and beam remants for WHIZARD"); ("exec", Arg.Unit load_and_update_cmdline, " load the UFO model files (required _before_ using particles names)"); ("help", Arg.Unit (fun () -> prerr_endline "..."), " print information on the model")] end module type Fortran_Target = sig val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> Coupling.fermion_lines -> string -> string list -> string list -> Coupling.fusen -> unit val lorentz_module : ?only:SSet.t -> ?name:string -> ?fortran_module:string -> ?parameter_module:string -> Format_Fortran.formatter -> unit -> unit end module Targets = struct module Fortran : Fortran_Target = struct open Format_Fortran let fuse = UFO_targets.Fortran.fuse let lorentz_functions ff fusions () = List.iter (fun (name, s, l) -> UFO_targets.Fortran.lorentz ff name s l) fusions let propagator_functions ff parameter_module propagators () = List.iter (fun (name, p) -> UFO_targets.Fortran.propagator ff name parameter_module p.Propagator.variables p.Propagator.spins p.Propagator.numerator p.Propagator.denominator) propagators let lorentz_module ?only ?(name="omega_amplitude_ufo") ?(fortran_module="omega95") ?(parameter_module="parameter_module") ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf "module %s" name; nl (); printf " use kinds"; nl (); printf " use %s" fortran_module; nl (); printf " implicit none"; nl (); printf " private"; nl (); let fusions = Model.fusions ?only () and propagators = Model.propagators () in List.iter (fun (name, _, _) -> printf " public :: %s" name; nl ()) fusions; List.iter (fun (name, _) -> printf " public :: pr_U_%s" name; nl ()) propagators; UFO_targets.Fortran.eps4_g4_g44_decl ff (); UFO_targets.Fortran.eps4_g4_g44_init ff (); printf "contains"; nl (); UFO_targets.Fortran.inner_product_functions ff (); lorentz_functions ff fusions (); propagator_functions ff parameter_module propagators (); printf "end module %s" name; nl (); pp_flush ff () end end module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let lexer s = UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string s)) let suite_lexer_escapes = "escapes" >::: [ "single-quote" >:: (fun () -> assert_equal (UFO_parser.STRING "a'b'c") (lexer "'a\\'b\\'c'")); "unterminated" >:: (fun () -> assert_raises End_of_file (fun () -> lexer "'a\\'b\\'c")) ] let suite_lexer = "lexer" >::: [suite_lexer_escapes] let suite = "UFO" >::: [suite_lexer] end Index: trunk/omega/src/SU3.mli =================================================================== --- trunk/omega/src/SU3.mli (revision 8919) +++ trunk/omega/src/SU3.mli (revision 8920) @@ -1,73 +1,96 @@ (* SU3.mli -- Copyright (C) 2022-2024 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. *) (* We're computing with a general $N_C$, but [epsilon] and [epsilonbar] make only sense for $N_C=3$. Also some of the terminology alludes to $N_C=3$: triplet, sextet, octet. *) (* We can use all functions from [Birdtracks] that operate on [Birdtracks.t] transparently. *) type t = Birdtracks.t (* \thocwmodulesection{Constructors specific to $\mathrm{SU}(N_C)$} *) (* Fundamental representation $N=3$ *) val delta3 : int -> int -> t (* ``Adjoint'' representation, but \emph{without} subtracting ghosts, i.\,e.~$N\otimes\bar N=9$. Therefore, the ``8'' is a misnomer! *) val delta8 : int -> int -> t (* The trace $\tr(T_aT_b)$ contains additional ghosts *) val delta8_loop : int -> int -> t (* Gauge boson in the adjoint representation $N\otimes\bar N - N\cdot\text{ghost}$ *) val gluon : int -> int -> t (* Symmetric $N\otimes_{\mathrm{S}}N=6$ and $N\otimes_{\mathrm{S}}N\otimes_{\mathrm{S}}N=10$. *) val delta6 : int -> int -> t val delta10 : int -> int -> t val t : int -> int -> int -> t val f : int -> int -> int -> t val d : int -> int -> int -> t -val epsilon : int list -> t -val epsilon_bar : int list -> t +(* These used to be called [epsilon] and [epsilon_bar], but they are + not general enough! *) +val epsilon0 : int list -> t +val epsilon0_bar : int list -> t val t8 : int -> int -> int -> t val t6 : int -> int -> int -> t val t10 : int -> int -> int -> t val k6 : int -> int -> int -> t val k6bar : int -> int -> int -> t +(* Note that [delta_of_tableau [[0]] i j] produces [(i, 0) >==>> (j, 0)] + and not [i => j] (analogously for [t_of_tableau [[0]]], of course). + \begin{dubious} + This is consistent, but maybe unexpected and can trip up applications. + I might decide to change this behaviour in the future. + \end{dubious} *) + val delta_of_tableau : int Young.tableau -> int -> int -> t val t_of_tableau : int Young.tableau -> int -> int -> int -> t +(* Construct a preimage of [Birdtracks.exorcise]. + [evoke_some gluons term] adds all terms corresponding to the + addition of $\mathrm{U}(1)$ ghosts for the gluons at the + positions [gluons]. [evoke term] adds the ghosts for all + gluons. This is group specific + and can therefore not go into [Birdtracks]. *) + +val evoke_some : int list -> t -> t +val evoke : t -> t + +(* This exception is raised by [evoke] and [evoke_some] if the expression + already contains ghosts. *) +exception Haunted + (* The Unit tests are in fact the largest part of this module. *) module Test : sig val suite : OUnit.test val suite_long : OUnit.test end Index: trunk/omega/src/tuple.ml =================================================================== --- trunk/omega/src/tuple.ml (revision 8919) +++ trunk/omega/src/tuple.ml (revision 8920) @@ -1,538 +1,529 @@ (* tuple.ml -- Copyright (C) 1999-2024 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 Mono = sig type 'a t val arity : 'a t -> int val max_arity : unit -> int val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val for_all : ('a -> bool) -> 'a t -> bool val map : ('a -> 'b) -> 'a t -> 'b t val iter : ('a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_left_internal : ('a -> 'a -> 'a) -> 'a t -> 'a val fold_right_internal : ('a -> 'a -> 'a) -> 'a t -> 'a val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val split : ('a * 'b) t -> 'a t * 'b t val product : 'a list t -> 'a t list val product_fold : ('a t -> 'b -> 'b) -> 'a list t -> 'b -> 'b val power : ?truncate:int -> 'a list -> 'a t list val power_fold : ?truncate:int -> ('a t -> 'b -> 'b) -> 'a list -> 'b -> 'b type 'a graded = 'a list array val graded_sym_power : int -> 'a graded -> 'a t list val graded_sym_power_fold : int -> ('a t -> 'b -> 'b) -> 'a graded -> 'b -> 'b val to_list : 'a t -> 'a list val of2_kludge : 'a -> 'a -> 'a t end module type Poly = sig include Mono exception Mismatched_arity exception No_termination end (* \thocwmodulesection{Typesafe Combinatorics} *) (* Wrap the combinatorical functions with varying arities into typesafe functions with fixed arities. We could provide specialized implementations, but since we \emph{know} that [Impossible] is \emph{never} raised, the present approach is just as good (except for a tiny inefficiency). *) exception Impossible of string let impossible name = raise (Impossible name) let choose2 set = List.map (function [x; y] -> (x, y) | _ -> impossible "choose2") (Combinatorics.choose 2 set) let choose3 set = List.map (function [x; y; z] -> (x, y, z) | _ -> impossible "choose3") (Combinatorics.choose 3 set) (* \thocwmodulesection{Pairs} *) module type Binary = sig include Poly (* should become [Mono]! *) val of2 : 'a -> 'a -> 'a t end module Binary = struct type 'a t = 'a * 'a let arity _ = 2 let max_arity () = 2 let of2 x y = (x, y) let compare cmp (x1, y1) (x2, y2) = let cx = cmp x1 x2 in if cx <> 0 then cx else cmp y1 y2 let for_all p (x, y) = p x && p y let map f (x, y) = (f x, f y) let iter f (x, y) = f x; f y let fold_left f init (x, y) = f (f init x) y let fold_right f (x, y) init = f x (f y init) let fold_left_internal f (x, y) = f x y let fold_right_internal f (x, y) = f x y exception Mismatched_arity let map2 f (x1, y1) (x2, y2) = (f x1 x2, f y1 y2) let split ((x1, x2), (y1, y2)) = ((x1, y1), (x2, y2)) let product (lx, ly) = Product.list2 (fun x y -> (x, y)) lx ly let product_fold f (lx, ly) init = Product.fold2 (fun x y -> f (x, y)) lx ly init let power ?truncate l = match truncate with | None -> product (l, l) | Some n -> if n >= 2 then product (l, l) else invalid_arg "Tuple.Binary.power: truncate < 2" let power_fold ?truncate f l = match truncate with | None -> product_fold f (l, l) | Some n -> if n >= 2 then product_fold f (l, l) else invalid_arg "Tuple.Binary.power_fold: truncate < 2" (* In the special case of binary fusions, the implementation is very concise. *) type 'a graded = 'a list array let fuse2 f set (i, j) acc = if i = j then List.fold_right (fun (x, y) -> f x y) (choose2 set.(pred i)) acc else Product.fold2 f set.(pred i) set.(pred j) acc let graded_sym_power_fold rank f set acc = let max_rank = Array.length set in List.fold_right (fuse2 (fun x y -> f (of2 x y)) set) (Partition.pairs rank 1 max_rank) acc let graded_sym_power rank set = graded_sym_power_fold rank (fun pair acc -> pair :: acc) set [] let to_list (x, y) = [x; y] let of2_kludge = of2 exception No_termination end (* \thocwmodulesection{Triples} *) module type Ternary = sig include Mono val of3 : 'a -> 'a -> 'a -> 'a t end module Ternary = struct type 'a t = 'a * 'a * 'a let arity _ = 3 let max_arity () = 3 let of3 x y z = (x, y, z) let compare cmp (x1, y1, z1) (x2, y2, z2) = let cx = cmp x1 x2 in if cx <> 0 then cx else let cy = cmp y1 y2 in if cy <> 0 then cy else cmp z1 z2 let for_all p (x, y, z) = p x && p y && p z let map f (x, y, z) = (f x, f y, f z) let iter f (x, y, z) = f x; f y; f z let fold_left f init (x, y, z) = f (f (f init x) y) z let fold_right f (x, y, z) init = f x (f y (f z init)) let fold_left_internal f (x, y, z) = f (f x y) z let fold_right_internal f (x, y, z) = f x (f y z) - exception Mismatched_arity let map2 f (x1, y1, z1) (x2, y2, z2) = (f x1 x2, f y1 y2, f z1 z2) let split ((x1, x2), (y1, y2), (z1, z2)) = ((x1, y1, z1), (x2, y2, z2)) let product (lx,ly,lz) = Product.list3 (fun x y z -> (x, y, z)) lx ly lz let product_fold f (lx, ly, lz) init = Product.fold3 (fun x y z -> f (x, y, z)) lx ly lz init let power ?truncate l = match truncate with | None -> product (l, l, l) | Some n -> if n >= 3 then product (l, l, l) else invalid_arg "Tuple.Ternary.power: truncate < 3" let power_fold ?truncate f l = match truncate with | None -> product_fold f (l, l, l) | Some n -> if n >= 3 then product_fold f (l, l, l) else invalid_arg "Tuple.Ternary.power_fold: truncate < 3" type 'a graded = 'a list array let fuse3 f set (i, j, k) acc = if i = j then begin if j = k then List.fold_right (fun (x, y, z) -> f x y z) (choose3 set.(pred i)) acc else Product.fold2 (fun (x, y) z -> f x y z) (choose2 set.(pred i)) set.(pred k) acc end else begin if j = k then Product.fold2 (fun x (y, z) -> f x y z) set.(pred i) (choose2 set.(pred j)) acc else Product.fold3 (fun x y z -> f x y z) set.(pred i) set.(pred j) set.(pred k) acc end let graded_sym_power_fold rank f set acc = let max_rank = Array.length set in List.fold_right (fuse3 (fun x y z -> f (of3 x y z)) set) (Partition.triples rank 1 max_rank) acc let graded_sym_power rank set = graded_sym_power_fold rank (fun pair acc -> pair :: acc) set [] let to_list (x, y, z) = [x; y; z] let of2_kludge _ = failwith "Tuple.Ternary.of2_kludge" end (* \thocwmodulesection{Pairs and Triples} *) type 'a pair_or_triple = T2 of 'a * 'a | T3 of 'a * 'a *'a module type Mixed23 = sig include Poly val of2 : 'a -> 'a -> 'a t val of3 : 'a -> 'a -> 'a -> 'a t end module Mixed23 = struct type 'a t = 'a pair_or_triple let arity = function | T2 _ -> 2 | T3 _ -> 3 let max_arity () = 3 let of2 x y = T2 (x, y) let of3 x y z = T3 (x, y, z) let compare cmp m1 m2 = match m1, m2 with | T2 _, T3 _ -> -1 | T3 _, T2 _ -> 1 | T2 (x1, y1), T2 (x2, y2) -> let cx = cmp x1 x2 in if cx <> 0 then cx else cmp y1 y2 | T3 (x1, y1, z1), T3 (x2, y2, z2) -> let cx = cmp x1 x2 in if cx <> 0 then cx else let cy = cmp y1 y2 in if cy <> 0 then cy else cmp z1 z2 let for_all p = function | T2 (x, y) -> p x && p y | T3 (x, y, z) -> p x && p y && p z let map f = function | T2 (x, y) -> T2 (f x, f y) | T3 (x, y, z) -> T3 (f x, f y, f z) let iter f = function | T2 (x, y) -> f x; f y | T3 (x, y, z) -> f x; f y; f z let fold_left f init = function | T2 (x, y) -> f (f init x) y | T3 (x, y, z) -> f (f (f init x) y) z let fold_right f m init = match m with | T2 (x, y) -> f x (f y init) | T3 (x, y, z) -> f x (f y (f z init)) let fold_left_internal f m = match m with | T2 (x, y) -> f x y | T3 (x, y, z) -> f (f x y) z let fold_right_internal f m = match m with | T2 (x, y) -> f x y | T3 (x, y, z) -> f x (f y z) exception Mismatched_arity let map2 f m1 m2 = match m1, m2 with | T2 (x1, y1), T2 (x2, y2) -> T2 (f x1 x2, f y1 y2) | T3 (x1, y1, z1), T3 (x2, y2, z2) -> T3 (f x1 x2, f y1 y2, f z1 z2) | T2 _, T3 _ | T3 _, T2 _ -> raise Mismatched_arity let split = function | T2 ((x1, x2), (y1, y2)) -> (T2 (x1, y1), T2 (x2, y2)) | T3 ((x1, x2), (y1, y2), (z1, z2)) -> (T3 (x1, y1, z1), T3 (x2, y2, z2)) let product = function | T2 (lx, ly) -> Product.list2 (fun x y -> T2 (x, y)) lx ly | T3 (lx, ly, lz) -> Product.list3 (fun x y z -> T3 (x, y, z)) lx ly lz let product_fold f m init = match m with | T2 (lx, ly) -> Product.fold2 (fun x y -> f (T2 (x, y))) lx ly init | T3 (lx, ly, lz) -> Product.fold3 (fun x y z -> f (T3 (x, y, z))) lx ly lz init exception No_termination let power_fold23 f l init = product_fold f (T2 (l, l)) (product_fold f (T3 (l, l, l)) init) let power_fold2 f l init = product_fold f (T2 (l, l)) init let power_fold ?truncate f l init = match truncate with | None -> power_fold23 f l init | Some n -> if n >= 3 then power_fold23 f l init else if n = 2 then power_fold2 f l init else invalid_arg "Tuple.Mixed23.power_fold: truncate < 2" let power ?truncate l = power_fold ?truncate (fun m acc -> m :: acc) l [] type 'a graded = 'a list array let graded_sym_power_fold rank f set acc = let max_rank = Array.length set in List.fold_right (Binary.fuse2 (fun x y -> f (of2 x y)) set) (Partition.pairs rank 1 max_rank) (List.fold_right (Ternary.fuse3 (fun x y z -> f (of3 x y z)) set) (Partition.triples rank 1 max_rank) acc) let graded_sym_power rank set = graded_sym_power_fold rank (fun pair acc -> pair :: acc) set [] let to_list = function | T2 (x, y) -> [x; y] | T3 (x, y, z) -> [x; y; z] let of2_kludge = of2 end (* \thocwmodulesection{\ldots{} and All The Rest} *) module type Nary = sig include Poly val of2 : 'a -> 'a -> 'a t val of3 : 'a -> 'a -> 'a -> 'a t val of_list : 'a list -> 'a t end module Nary (A : sig val max_arity : unit -> int end) = struct type 'a t = 'a * 'a list let arity (_, y) = succ (List.length y) let max_arity () = try A.max_arity () with _ -> -1 let of2 x y = (x, [y]) let of3 x y z = (x, [y; z]) let of_list = function | x :: y -> (x, y) | [] -> invalid_arg "Tuple.Nary.of_list: empty" let compare cmp (x1, y1) (x2, y2) = let c = cmp x1 x2 in if c <> 0 then c else ThoList.compare ~cmp y1 y2 let for_all p (x, y) = p x && List.for_all p y let map f (x, y) = (f x, List.map f y) let iter f (x, y) = f x; List.iter f y let fold_left f init (x, y) = List.fold_left f (f init x) y let fold_right f (x, y) init = f x (List.fold_right f y init) let fold_left_internal f (x, y) = List.fold_left f x y let fold_right_internal f (x, y) = match List.rev y with | [] -> x | y0 :: y_sans_y0 -> f x (List.fold_right f (List.rev y_sans_y0) y0) exception Mismatched_arity let map2 f (x1, y1) (x2, y2) = try (f x1 x2, List.map2 f y1 y2) with | Invalid_argument _ -> raise Mismatched_arity let split ((x1, x2), y12) = let y1, y2 = List.split y12 in ((x1, y1), (x2, y2)) let product (xl, yl) = Product.list (function | x :: y -> (x, y) | [] -> failwith "Tuple.Nary.product") (xl :: yl) let product_fold f (xl, yl) init = Product.fold (function | x :: y -> f (x, y) | [] -> failwith "Tuple.Nary.product_fold") (xl :: yl) init exception No_termination let truncated_arity ?truncate () = let ma = max_arity () in match truncate with | None -> ma | Some n -> if n < 2 then invalid_arg "Tuple.Nary.power: truncate < 2" else if ma >= 2 then min n ma else n let power_fold ?truncate f l init = let ma = truncated_arity ?truncate () in if ma > 0 then List.fold_right (fun n -> product_fold f (l, ThoList.clone l (pred n))) (ThoList.range 2 ma) init else raise No_termination let power ?truncate l = power_fold ?truncate (fun t acc -> t :: acc) l [] type 'a graded = 'a list array - let fuse_n f set partition acc = + let _fuse_n f set partition acc = let choose (n, r) = Printf.printf "chose: n=%d r=%d len=%d\n" n r (List.length set.(pred r)); Combinatorics.choose n set.(pred r) in Product.fold (fun wfs -> f (List.concat wfs)) (List.map choose (ThoList.classify partition)) acc let fuse_n f set partition acc = let choose (n, r) = Combinatorics.choose n set.(pred r) in Product.fold (fun wfs -> f (List.concat wfs)) (List.map choose (ThoList.classify partition)) acc (* \begin{dubious} [graded_sym_power_fold] is well defined for unbounded arities as well: derive a reasonable replacement from [set]. The length of the flattened [set] is an upper limit, of course, but too pessimistic in most cases. \end{dubious} *) let graded_sym_power_fold rank f set acc = let max_rank = Array.length set in let degrees = ThoList.range 2 (max_arity ()) in let partitions = ThoList.flatmap (fun deg -> Partition.tuples deg rank 1 max_rank) degrees in List.fold_right (fuse_n (fun wfs -> f (of_list wfs)) set) partitions acc let graded_sym_power rank set = graded_sym_power_fold rank (fun pair acc -> pair :: acc) set [] let to_list (x, y) = x :: y let of2_kludge = of2 end module type Bound = sig val max_arity : unit -> int end module Unbounded_Nary = Nary (struct let max_arity () = -1 end) - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) Index: trunk/omega/src/combinatorics.ml =================================================================== --- trunk/omega/src/combinatorics.ml (revision 8919) +++ trunk/omega/src/combinatorics.ml (revision 8920) @@ -1,590 +1,635 @@ (* combinatorics.ml -- Copyright (C) 1999-2024 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 = +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) + _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) (* \begin{dubious} We have a slight inconsistency here: [permute [] = [[]]], while [permute_cyclic [] = []]. I don't know if it is worth fixing. \end{dubious} *) let permute_cyclic l = let rec permute_cyclic' acc before = function | [] -> List.rev acc | x :: rest as after -> permute_cyclic' ((after @ List.rev before) :: acc) (x :: before) rest in permute_cyclic' [] [] l (* Algorithm: toggle the signs and at the end map all signs to $+1$, iff the last sign is positive, i.\,e.~there's an odd number of elements. *) let permute_cyclic_signed l = let rec permute_cyclic_signed' eps acc before = function | [] -> if eps > 0 then List.rev_map (fun (_, p) -> (1, p)) acc else List.rev acc | x :: rest as after -> let eps' = - eps in permute_cyclic_signed' eps' ((eps', after @ List.rev before) :: acc) (x :: before) rest in permute_cyclic_signed' (-1) [] [] l (* \thocwmodulesubsection{Tensor Products of Permutations} *) let permute_tensor ll = Product.list (fun l -> l) (List.map permute ll) let join_signs l = let el, pl = List.split l in (List.fold_left (fun acc x -> x * acc) 1 el, pl) let permute_tensor_signed ll = Product.list join_signs (List.map permute_signed ll) let permute_tensor_even l = filter_sign 1 (permute_tensor_signed l) let permute_tensor_odd l = filter_sign (-1) (permute_tensor_signed l) (* \thocwmodulesubsection{Sorting} *) let insert_inorder_signed order x (eps, l) = let rec insert eps' accu = function | [] -> (eps * eps', List.rev_append accu [x]) | h :: t -> if order x h = 0 then invalid_arg "Combinatorics.insert_inorder_signed: identical elements" else if order x h < 0 then (eps * eps', List.rev_append accu (x :: h :: t)) else insert (-eps') (h::accu) t in insert 1 [] l let sort_signed ?(cmp=Stdlib.compare) l = List.fold_right (insert_inorder_signed cmp) l (1, []) let sign ?(cmp=Stdlib.compare) l = let eps, _ = sort_signed ~cmp l in eps let sign2 ?(cmp=Stdlib.compare) l = let a = Array.of_list l in let eps = ref 1 in for j = 0 to Array.length a - 1 do for i = 0 to j - 1 do if cmp a.(i) a.(j) > 0 then eps := - !eps done done; !eps +(* \thocwmodulesubsection{Subsets} *) + +(*i +let rec subsets = function + | [] -> [[]] + | head :: tail -> + let subsets_of_tail = subsets tail in + List.fold_left (fun subset_list subset -> (head :: subset) :: subset_list) subsets_of_tail subsets_of_tail +i*) + +let rec subfolds f acc = function + | [] -> [acc] + | head :: tail -> + let subfolds_of_tail = subfolds f acc tail in + List.fold_left (fun subfold_list subfold -> f subfold head :: subfold_list) subfolds_of_tail subfolds_of_tail + +let subsets list = + subfolds (Fun.flip List.cons) [] list + +(* \thocwmodulesubsection{Unit Tests} *) + module Test = struct open OUnit let to_string = ThoList.to_string (ThoList.to_string string_of_int) let assert_equal_perms = assert_equal ~printer:to_string let count_permutations n = let factorial_n = factorial n and range = ThoList.range 1 n in let sorted = List.sort compare (permute range) in (* Verify the count \ldots *) assert_equal factorial_n (List.length sorted); (* \ldots{} check that they're all different \ldots *) assert_equal factorial_n (List.length (ThoList.uniq sorted)); (* \ldots{} make sure that they a all permutations. *) assert_equal_perms [range] (ThoList.uniq (List.map (List.sort compare) sorted)) let suite_permute = "permute" >::: [ "permute []" >:: (fun () -> assert_equal_perms [[]] (permute [])); "permute [1]" >:: (fun () -> assert_equal_perms [[1]] (permute [1])); "permute [1;2;3]" >:: (fun () -> assert_equal_perms [ [2; 3; 1]; [2; 1; 3]; [3; 2; 1]; [1; 3; 2]; [1; 2; 3]; [3; 1; 2] ] (permute [1; 2; 3])); "permute [1;2;3;4]" >:: (fun () -> assert_equal_perms [ [3; 4; 1; 2]; [3; 1; 2; 4]; [3; 1; 4; 2]; [4; 3; 1; 2]; [1; 4; 2; 3]; [1; 2; 3; 4]; [1; 2; 4; 3]; [4; 1; 2; 3]; [1; 4; 3; 2]; [1; 3; 2; 4]; [1; 3; 4; 2]; [4; 1; 3; 2]; [3; 4; 2; 1]; [3; 2; 1; 4]; [3; 2; 4; 1]; [4; 3; 2; 1]; [2; 4; 1; 3]; [2; 1; 3; 4]; [2; 1; 4; 3]; [4; 2; 1; 3]; [2; 4; 3; 1]; [2; 3; 1; 4]; [2; 3; 4; 1]; [4; 2; 3; 1] ] (permute [1; 2; 3; 4])); "count permute 5" >:: (fun () -> count_permutations 5); "count permute 6" >:: (fun () -> count_permutations 6); "count permute 7" >:: (fun () -> count_permutations 7); "count permute 8" >:: (fun () -> count_permutations 8); "cyclic []" >:: (fun () -> assert_equal_perms [] (permute_cyclic [])); "cyclic [1]" >:: (fun () -> assert_equal_perms [[1]] (permute_cyclic [1])); "cyclic [1;2;3]" >:: (fun () -> assert_equal_perms [[1;2;3]; [2;3;1]; [3;1;2]] (permute_cyclic [1;2;3])); "cyclic [1;2;3;4]" >:: (fun () -> assert_equal_perms [[1;2;3;4]; [2;3;4;1]; [3;4;1;2]; [4;1;2;3]] (permute_cyclic [1;2;3;4])); "cyclic [1;2;3] signed" >:: (fun () -> assert_equal [(1,[1;2;3]); (1,[2;3;1]); (1,[3;1;2])] (permute_cyclic_signed [1;2;3])); "cyclic [1;2;3;4] signed" >:: (fun () -> assert_equal [(1,[1;2;3;4]); (-1,[2;3;4;1]); (1,[3;4;1;2]); (-1,[4;1;2;3])] (permute_cyclic_signed [1;2;3;4]))] let sort_signed_not_unique = "not unique" >:: (fun () -> assert_raises (Invalid_argument "Combinatorics.insert_inorder_signed: identical elements") (fun () -> sort_signed [1;2;3;4;2])) let sort_signed_even = "even" >:: (fun () -> assert_equal (1, [1;2;3;4;5;6]) (sort_signed [1;2;4;3;6;5])) let sort_signed_odd = "odd" >:: (fun () -> assert_equal (-1, [1;2;3;4;5;6]) (sort_signed [2;3;1;5;4;6])) let sort_signed_all = "all" >:: (fun () -> let l = ThoList.range 1 8 in assert_bool "all signed permutations" (List.for_all (fun (eps, p) -> let eps', p' = sort_signed p in eps' = eps && p' = l) (permute_signed l))) let sign_sign2 = "sign/sign2" >:: (fun () -> let l = ThoList.range 1 8 in assert_bool "all permutations" (List.for_all (fun p -> sign p = sign2 p) (permute l))) let suite_sort_signed = "sort_signed" >::: [sort_signed_not_unique; sort_signed_even; sort_signed_odd; sort_signed_all; sign_sign2] + let canonicalize_subsets l = + List.sort (ThoList.compare ~cmp:Stdlib.compare) (List.map (List.sort Stdlib.compare) l) + + let assert_equal_subsets l1 l2 = + assert_equal (canonicalize_subsets l1) (canonicalize_subsets l2) + + let suite_subsets = + "subsets" >::: + [ "[]" >:: + (fun () -> assert_equal_subsets [[]] (subsets [])); + + "[1]" >:: + (fun () -> assert_equal_subsets [[]; [1]] (subsets [1])); + + "[1;2]" >:: + (fun () -> assert_equal_subsets [[]; [1]; [2]; [1;2]] (subsets [1;2])); + + "[1;2;3]" >:: + (fun () -> + assert_equal_subsets + [[]; [1]; [2]; [3]; [1;2]; [1;3]; [2;3]; [1;2;3]] + (subsets [1;2;3])) ] + let suite = "Combinatorics" >::: [suite_permute; - suite_sort_signed] + suite_sort_signed; + suite_subsets] end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/orders.ml =================================================================== --- trunk/omega/src/orders.ml (revision 8919) +++ trunk/omega/src/orders.ml (revision 8920) @@ -1,980 +1,982 @@ (* orders.ml -- Copyright (C) 2023-2024 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. *) (* \thocwmodulesection{Conditions} *) module type Conditions = sig type coupling_order type orders = (coupling_order * int) list type t val trivial : t val of_strings : string list -> t val to_strings : t -> string list val constant : t -> orders -> bool val fusion : t -> orders -> bool val braket : t -> orders -> orders option val exclusive_fusion : t -> coupling_order list val exclusive_braket : t -> coupling_order list val square_root : t -> t val to_string : t -> string val pp : Format.formatter -> t -> unit end (* A projection of [Model.T] containing only coupling constants and coupling orders. This is useful for testing without having to link real models. *) module type Model_CO = sig type constant type coupling_order val all_coupling_orders : unit -> coupling_order list val coupling_order_to_string : coupling_order -> string val coupling_orders : constant -> (coupling_order * int) list end module Conditions (M : Model_CO (* $\subset$ [Model.T] *)) : Conditions with type coupling_order = M.coupling_order = struct type coupling_order = M.coupling_order type orders = (coupling_order * int) list module CO = struct type t = coupling_order let compare = Stdlib.compare end module COSet = Set.Make(CO) module COMap = Map.Make(CO) module COSMap = Partial.Make(String) (* Add a [unit] argument to support [Model.Mutable]: *) let co_set () = COSet.of_list (M.all_coupling_orders ()) let co_map () = COSMap.of_list (List.map (fun co -> (M.coupling_order_to_string co, co)) (M.all_coupling_orders ())) let co_set_of_strings pmap co_list = List.fold_left (fun acc s -> match COSMap.apply_opt pmap s with | None -> Printf.eprintf "omega: ignoring unknown coupling_order `%s'!\n" s; acc | Some co -> COSet.add co acc) COSet.empty co_list let complement = COSet.diff (* All the integers are non negative. We don't need a [LE] constructor, because $i \le n$ is equivalent to $0\le i \le n$ in this case. This saves us redundant match cases below. *) type range = | GE of int | IN of int * int | EQ of int type mode = Slice | Sum (* The lists of type [orders] must be very short to allow encoding of the counted coupling orders in Fortran variable names! That's why we keep the potentially much larger set of couplings that are set to zero separate. One could think of supporting a union of non overlapping ranges, but this adds a lot of complexity for little practical value. *) (* \begin{dubious} The correct semantics for \textit{OR}-ing conditions on \emph{different} coupling orders can not be implemented with the following data type. One would need a set or list of [(range * mode) COMap.t] for [orders]. It is not clear if this is worth the effort. \end{dubious} *) (* [fusion] is the union of [braket] and [only_fusion]. One of the three is therefore redundant, but we maintain all three for convenience. Similarly, [exclusive_braket] and [exclusive_fusion] are simply the result of applying [List.map fst] to [braket] and [fusion]. They are here just for convenience. *) type t = { braket : (coupling_order * range) list; fusion : (coupling_order * range) list; only_fusion : (coupling_order * range) list; exclusive_braket : coupling_order list; exclusive_fusion : coupling_order list; is_null : COSet.t } let trivial = { braket = []; fusion = []; only_fusion = []; exclusive_braket = []; exclusive_fusion = []; is_null = COSet.empty } type t_intermediate = { orders_map : (range * mode) COMap.t; null_set : COSet.t } let range_to_string l r = function | IN (i, j) -> Printf.sprintf "%c%d..%d%c" l i j r | GE i -> Printf.sprintf "%c%d..%c" l i r | EQ i -> Printf.sprintf "%d" i let interval_to_string = range_to_string '[' ']' let slice_to_string = range_to_string '{' '}' let co_and_interval_to_string (co, r) = M.coupling_order_to_string co ^ " = " ^ interval_to_string r let co_and_slice_to_string (co, r) = M.coupling_order_to_string co ^ " = " ^ slice_to_string r let to_string c = let is_null = match COSet.elements c.is_null with | [] -> [] | [co] -> [M.coupling_order_to_string co ^ " = 0"] | is_null -> ["{" ^ String.concat ", " (List.map M.coupling_order_to_string is_null) ^ "} = 0"] and intervals = List.map co_and_interval_to_string c.only_fusion and slices = List.map co_and_slice_to_string c.braket in String.concat "; " (is_null @ intervals @ slices) let to_string_raw c = let is_null = String.concat ", " (List.map M.coupling_order_to_string (COSet.elements c.is_null)) and braket = List.map co_and_slice_to_string c.braket and fusion = List.map co_and_interval_to_string c.fusion and only_fusion = List.map co_and_interval_to_string c.only_fusion in Printf.sprintf "is_null = {%s}; braket = (%s); fusion = (%s); only_fusion = (%s)" is_null (String.concat ", " braket) (String.concat ", " fusion) (String.concat ", " only_fusion) let to_strings c = let intervals = List.map co_and_interval_to_string c.only_fusion and slices = List.map co_and_slice_to_string c.braket in match COSet.elements c.is_null with | [] -> List.concat [intervals; slices] | is_null -> List.concat [intervals; slices; List.map (fun co_list -> "disabled: " ^ String.concat ", " (List.map M.coupling_order_to_string co_list)) (ThoList.chopn 5 is_null)] let accept_all = { orders_map = COMap.empty; null_set = COSet.empty } module S = Orders_syntax let rec compile_set all_co pmap = function | S.Set co_list -> co_set_of_strings pmap co_list | S.Diff (set, set') -> COSet.diff (compile_set all_co pmap set) (compile_set all_co pmap set') | S.Complement (S.Complement set) -> compile_set all_co pmap set | S.Complement set -> complement all_co (compile_set all_co pmap set) let compile_range = function | S.Range (i, j) -> if i = j then EQ i else if i < j then IN (i, j) else EQ 0 | S.Min i -> GE (max i 0) | S.Max j -> if j > 0 then IN (0, j) else EQ 0 let make_interval_or_slice mode all_co pmap co_set range = let co_set = compile_set all_co pmap co_set in let orders_map = COSet.fold (fun co map -> COMap.add co (compile_range range, mode) map) co_set COMap.empty in { accept_all with orders_map } let compile_atom all_co pmap = function | S.Null co_set | S.Exact (co_set, 0) | S.Interval (co_set, (S.Max 0 | S.Range (_, 0))) | S.Slices (co_set, (S.Max 0 | S.Range (_, 0))) -> { accept_all with null_set = compile_set all_co pmap co_set } | S.Exact (co_set, n) -> let co_set = compile_set all_co pmap co_set in let orders_map = COSet.fold (fun co map -> COMap.add co (EQ n, Slice) map) co_set COMap.empty in { accept_all with orders_map } | S.Interval (co_set, range) -> make_interval_or_slice Sum all_co pmap co_set range | S.Slices (co_set, range) -> make_interval_or_slice Slice all_co pmap co_set range let in_or_eq i j = if i = j then Some (EQ i) else if i <= j then Some (IN (i, j)) else None let and_range_opt r1 r2 = match r1, r2 with | GE i1, GE i2 -> Some (GE (max i1 i2)) | EQ i1, EQ i2 -> if i1 = i2 then Some (EQ i1) else None | IN (i1, j1), IN (i2, j2) -> in_or_eq (max i1 i2) (min j1 j2) | IN (i, j), GE k | GE k, IN (i, j) -> in_or_eq (max i k) j | GE i, EQ j | EQ j, GE i -> if i <= j then Some (EQ i) else None | IN (i, j), EQ k | EQ k, IN (i, j) -> if i <= k && k <= j then Some (EQ k) else None let prefer_slice m1 m2 = match m1, m2 with | Sum, Sum -> Sum | Slice, Sum | Sum, Slice | Slice, Slice -> Slice - let and_range co (r1, m1) (r2, m2) = + let and_range _co (r1, m1) (r2, m2) = match and_range_opt r1 r2 with | None -> None | Some r -> Some (r, prefer_slice m1 m2) let and_pair c1 c2 = { null_set = COSet.union c1.null_set c2.null_set; orders_map = COMap.union and_range c1.orders_map c2.orders_map } let gap co = let co = M.coupling_order_to_string co in invalid_arg (Printf.sprintf "or_range: %s: ranges with gaps not supported!" co) let or_range_opt co r1 r2 = match r1, r2 with | GE i1, GE i2 -> Some (GE (max 0 (min i1 i2))) | EQ i1, EQ i2 -> if i1 = i2 then Some (EQ i1) else if i1 = pred i2 then Some (IN (i1, i2)) else if i1 = succ i2 then Some (IN (i2, i1)) else gap co | IN (i1, j1), IN (i2, j2) -> if i2 <= succ j1 then Some (IN (i1, j2)) else if i1 <= succ j2 then Some (IN (i2, j1)) else gap co | IN (i, j), GE k | GE k, IN (i, j) -> if k <= succ j then Some (GE i) else gap co - | GE i, EQ j | EQ j, GE i -> + | GE _, EQ j | EQ j, GE _ -> if j >= pred j then Some (GE j) else gap co | IN (i, j), EQ k | EQ k, IN (i, j) -> if i <= k && k <= j then Some (IN (i, j)) else if k = pred i then Some (IN (k, j)) else if k = succ j then Some (IN (i, k)) else gap co let or_range co (r1, m1) (r2, m2) = match or_range_opt co r1 r2 with | None -> None | Some r -> Some (r, prefer_slice m1 m2) (* This will be used with [COMap.merge] and fails if the coupling order [co] appears as key in only one of the maps. *) let merge_or_range co r1 r2 = match r1, r2 with | None, None -> None | Some r1, Some r2 -> or_range co r1 r2 | None, Some _ | Some _, None -> let co = M.coupling_order_to_string co in invalid_arg (Printf.sprintf "or_range: %s: OR of different coupling_orders not supported!" co) let or_pair c1 c2 = { null_set = COSet.inter c1.null_set c2.null_set; orders_map = COMap.merge merge_or_range c1.orders_map c2.orders_map } let cleanup_condition c = let null_set = COMap.fold (fun co (r, _) set -> match r with | EQ 0 | IN (_, 0) -> COSet.add co set | _ -> COSet.remove co set) c.orders_map c.null_set in let orders_map = COMap.filter (fun co _ -> not (COSet.mem co null_set)) c.orders_map in { null_set; orders_map } let combine_conditions combine_pairs = function | [] -> accept_all | c0 :: clist -> cleanup_condition (List.fold_left combine_pairs c0 clist) let compile expr = let all_co = co_set () and pmap = co_map () in let rec compile' = function | S.Atom atom -> compile_atom all_co pmap atom | S.And clist -> combine_conditions and_pair (List.map compile' clist) | S.Or clist -> combine_conditions or_pair (List.map compile' clist) in let c = cleanup_condition (compile' expr) in let braket_rev, fusion_rev, only_fusion_rev = COMap.fold (fun co (range, mode) (braket, fusion, only_fusion) -> let co_range = (co, range) in match mode with | Slice -> (co_range :: braket, co_range :: fusion, only_fusion) | Sum -> (braket, co_range :: fusion, co_range :: only_fusion)) c.orders_map ([], [], []) in { braket = List.rev braket_rev; fusion = List.rev fusion_rev; only_fusion = List.rev only_fusion_rev; exclusive_braket = List.rev_map fst braket_rev; exclusive_fusion = List.rev_map fst fusion_rev; is_null = c.null_set} (* An empty list of ranges is interpreted as no constraint. This is used for brakets. *) let in_range n = function | GE i -> n >= i | IN (i, j) -> n >= i && n <= j | EQ i -> n = i (* In fusions, the coupling orders may still be below the final range. *) let beneath_range n = function | IN (_, i) | EQ i -> n <= i | GE _ -> true (* Test whether to include a vertex at all. *) let test_condition range_tester is_null condition co_list = let rec test_condition' acc = function | [], [] -> (* we're done *) Some (List.rev acc) | (co, r) :: rest, [] -> (* conditions on some orders remain, add them with power 0 *) if range_tester 0 r then test_condition' ((co, 0) :: acc) (rest, []) else None | [], (co', n') :: rest' -> (* no further conditions, check that the remaining couplings are allowed *) if n' > 0 && COSet.mem co' is_null then None else test_condition' acc ([], rest') | ((co, r) :: rest as orders), ((co', n') :: rest' as orders') -> if n' > 0 && COSet.mem co' is_null then (* bail if the coupling is forbidden *) None else if co = co' then (* condition and coupling line up *) begin if range_tester n' r then test_condition' ((co', n') :: acc) (rest, rest') else None end else if co < co' then (* condition missing from the couplings *) begin if range_tester 0 r then test_condition' ((co, 0) :: acc) (rest, orders') else None end else (* coupling not in the conditions, skip it *) test_condition' acc (orders, rest') in test_condition' [] (condition, co_list) (* Check that a the sum of coupling orders in a fusion does not exceed the limits. *) let fusion condition co_list = match test_condition beneath_range condition.is_null condition.fusion co_list with | None -> false | Some _ -> true (* Check both the intervals in [only_fusion] and the slices in [braket], but return only the matches of the latter: *) let braket condition co_list = match test_condition in_range condition.is_null condition.only_fusion co_list with | None -> None | Some _ -> test_condition in_range condition.is_null condition.braket co_list let constant condition co_list = not (List.exists (fun (co, n) -> n > 0 && COSet.mem co condition.is_null) co_list) let exclusive_fusion c = c.exclusive_fusion let exclusive_braket c = c.exclusive_braket (* Turn all intervals into slices, since we need to sum products. Include \emph{all} lower orders. *) let square_root_range = function | GE _ -> GE 0 | IN (_, j) | EQ j -> IN (0, j) let square_root_ranges ranges = List.map (fun (co, range) -> (co, square_root_range range)) ranges let square_root c = let fusion = square_root_ranges (List.sort (fun (co1, _) (co2, _) -> Stdlib.compare co1 co2) (List.rev_append c.only_fusion c.braket)) and exclusive_fusion = List.sort Stdlib.compare (List.rev_append c.exclusive_fusion c.exclusive_braket) in { fusion; braket = fusion; only_fusion = []; exclusive_fusion; exclusive_braket = exclusive_fusion; is_null = c.is_null } let parse_string s = Orders_parser.main Orders_lexer.token (Lexing.from_string s) let parse_strings slist = parse_string (String.concat "; " slist) let of_strings slist = compile (parse_strings slist) let pp fmt c = Format.fprintf fmt "%s" (to_string_raw c) end (* \thocwmodulesection{Decorate Flavors with Coupling Constant Orders} *) module type Coupling_Orders = sig type coupling_order (* The list is ordered wrt.~[order] and there must be no duplicate entry. Note that we're using lists instead of [Map.S.t], because we want to be able to use the polymorphic [compare] as long as possible. The lists are assumed to be short and we don't care about tail recursion. *) (* \begin{dubious} Eventually, we want to make this type abstract! \end{dubious} *) type orders = (coupling_order * int) list (* Simple constructors. *) val null : orders (* Sort the list and test it for duplicates. *) val of_list : (coupling_order * int) list -> orders val to_list : orders -> (coupling_order * int) list (* Add the matching powers of the coupling orders. The coupling orders in both operands \emph{must} be identical and the \emph{must} appear in the same order. If the coupling orders would be known at compile time, we could implement this in a type safe way as tuples, but the coupling orders can be selected on the command line and in UFO models not even the set of possible coupling orders is known at compile time. *) val add : orders -> orders -> orders (* Increment the powers of the coupling orders in the second operand by the powers of matching coupling orders in the first operand. Ignore the other coupling orders in the first operand. The coupling orders in the operands \emph{must} be ordered according to the same ordering relation. *) val incr : orders -> orders -> orders +(*i (* [square_root condition orders_list] returns a triple [(used, squares, interferences)] where [used] is a list of are all combinations of powers of coupling orders that appear at least once in [squares] or [interferences]. [squares] are the terms that satisfy [condition] when multiplied with themselves and the pairs in [interferences] satisfy [condition] when multiplied. *) val square_root : (orders -> bool) -> orders list -> orders list * orders list * (orders * orders) list +i*) (* Debugging: *) val to_string : orders -> string end module Coupling_Orders (M : sig type coupling_order val coupling_order_to_string : coupling_order -> string end) : Coupling_Orders with type coupling_order = M.coupling_order = struct type coupling_order = M.coupling_order type orders = (coupling_order * int) list let to_string ol = "{" ^ ThoList.to_string (fun (co, n) -> M.coupling_order_to_string co ^ ":" ^ string_of_int n) ol ^ "}" let null = [] let rec duplicates = function | [] | [_] -> false | (o1, _) :: ((o2, _) :: _ as tail) -> if o1 = o2 then true else duplicates tail let of_list o = let o = List.sort (fun (o1, _) (o2, _) -> Stdlib.compare o1 o2) o in if duplicates o then invalid_arg "Orders.Flavor.of_list: duplicates" else o let to_list o = o (* Here's a dedicated version, but \ldots *) - let rec add ol1 ol2 = + let rec _add ol1 ol2 = match ol1, ol2 with | [], [] -> [] - | [], tail | tail, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch" + | [], _ | _, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch" | (o1, n1) :: tail1, (o2, n2) :: tail2 -> if o1 = o2 then - (o1, n1 + n2) :: add tail1 tail2 + (o1, n1 + n2) :: _add tail1 tail2 else invalid_arg (Printf.sprintf "Orders.Coupling_Orders.add: mismatch '%s' <> '%s'" (M.coupling_order_to_string o1) (M.coupling_order_to_string o2)) (* Here's a tail recursive version. Once we can use a modern compiler with the tail-mod-cons optimization, we can go back to the first version. *) let add ol1 ol2 = let rec add' acc ol1 ol2 = match ol1, ol2 with | [], [] -> List.rev acc - | [], tail | tail, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch" + | [], _ | _, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch" | (o1, n1) :: tail1, (o2, n2) :: tail2 -> if o1 = o2 then add' ((o1, n1 + n2) :: acc) tail1 tail2 else invalid_arg (Printf.sprintf "Orders.Coupling_Orders.add: mismatch '%s' <> '%s'" (M.coupling_order_to_string o1) (M.coupling_order_to_string o2)) in add' [] ol1 ol2 (* This is very similar to [add], but coupling orders that appear only in the first, but not the second argument are ignored. *) - let rec incr ol1 ol2 = + let rec _incr ol1 ol2 = match ol1, ol2 with | _, [] -> (* we're done with the second argument, ignore the rest of the first *) [] | [], tail -> (* we're done with the first argument, keep the rest of the second *) tail | (o1, n1) :: tail1, (o2, n2 as on2) :: tail2 -> if o1 = o2 then (* coupling orders match, add the powers *) - (o1, n1 + n2) :: incr tail1 tail2 + (o1, n1 + n2) :: _incr tail1 tail2 else if o1 < o2 then (* [o1] does not appear in the second argument, ignore it *) - incr tail1 ol2 + _incr tail1 ol2 else (* [o2] does not appear in the first argument, keep it unchanged *) - on2 :: incr ol1 tail2 + on2 :: _incr ol1 tail2 (* Here's again a tail recursive version. *) let incr ol1 ol2 = let rec incr' acc ol1 ol2 = match ol1, ol2 with | _, [] -> (* we're done with the second argument, ignore the rest of the first *) List.rev acc | [], tail -> (* we're done with the first argument, keep the rest of the second *) List.rev_append acc tail | (o1, n1) :: tail1, (o2, n2 as on2) :: tail2 -> if o1 = o2 then (* coupling orders match, add the powers *) incr' ((o1, n1 + n2) :: acc) tail1 tail2 else if o1 < o2 then (* [o1] does not appear in the second argument, ignore it *) incr' acc tail1 ol2 else (* [o2] does not appear in the first argument, keep it unchanged *) incr' (on2 :: acc) ol1 tail2 in incr' [] ol1 ol2 let _add ol1 ol2 = let ol = add ol1 ol2 in Printf.eprintf "add %s %s -> %s\n" (to_string ol1) (to_string ol2) (to_string ol); ol let _incr ol1 ol2 = let ol = incr ol1 ol2 in Printf.eprintf "incr %s %s -> %s\n" (to_string ol1) (to_string ol2) (to_string ol); ol (* Resist the temptation to implement this as [List.fold_left add null olist], because then [add] would need to accept orders of different lengths. *) - let sum = function + let _sum = function | [] -> null | o :: rest -> List.fold_left add o rest (* We use the polymorphic compare, because we don't need a particular ordering to test of equality in a [Set]. *) module OSet = Set.Make(struct type t = orders let compare = Stdlib.compare end) (* Return the list of all pairs of elements of a list, where the first element appears before the second in the list. E.\,g.~[ ordered_pairs [1; 2; 3] = [(1, 2); (1, 3); (2, 3)] ] *) (* For longer lists for which the result will be passed to [List.fold], an implementation of the corresponding [fold] would be more efficient, but the lists will always be short. *) let rec ordered_pairs = function | [] -> [] | a1 :: a2_list -> List.map (fun a2 -> (a1, a2)) a2_list @ ordered_pairs a2_list - let square_root condition orders = + let _square_root condition orders = let used = OSet.empty in let squares, used = List.fold_right (fun o (squares, used as acc) -> if condition (add o o) then (o :: squares, OSet.add o used) else acc) orders ([], used) in let interferences, used = List.fold_right (fun (o1, o2 as o12) (interferences, used as acc) -> if condition (add o1 o2) then (o12 :: interferences, OSet.add o1 (OSet.add o2 used)) else acc) (ordered_pairs orders) ([], used) in (OSet.elements used, squares, interferences) end (* \begin{dubious} Conceptually, there is no need to demand a [Colorized] model as a functor argument. Nevertheless, we should first implement a working example for the common use case, before embarking on a generalization that is mostly of academic interest. \end{dubious} *) module Flavor (M : Model.Colorized) = struct module CO = Coupling_Orders(M) type orders = CO.orders let add_orders = CO.add let incr_orders = CO.incr let null = CO.null let orders_of_list = CO.of_list type t = { all_orders : M.flavor; orders : orders } let all_orders f = f.all_orders let pullback f a = f (all_orders a) let make all_orders orders = { all_orders; orders } let trivial f = make f null (* Resist the temptation to implement this as [List.fold_right (fun f -> add_orders f.orders) f_list null], because then [add_orders] would need to accept orders of different lengths. *) let fuse_orders = function | [] -> null | f :: rest -> List.fold_right (fun f -> add_orders f.orders) rest f.orders let orders_to_string = CO.to_string let digit_to_symbol i = if i < 0 then invalid_arg "Orders.Flavor.digit_to_symbol: negative" else if i < 10 then string_of_int i else if i < 36 then String.make 1 (Char.chr (Char.code 'A' + i - 10)) else invalid_arg "Orders.Flavor.digit_to_symbol: too large" let orders_symbol orders = match CO.to_list orders with | [] -> "" | orders -> if List.for_all (fun (_, n) -> n = 0) orders then "" else "_c" ^ String.concat "" (List.map (fun (_, n) -> digit_to_symbol n) orders) let to_string f = M.flavor_to_string f.all_orders ^ orders_to_string f.orders let to_symbol f = M.flavor_symbol f.all_orders ^ orders_symbol f.orders end (* \thocwmodulesection{Slice Amplitudes According to Coupling Constant Orders} *) let incomplete s = failwith ("Orders.Slice()." ^ s ^ " not done yet!") module Slice (CM : Model.Colorized) = struct module OCF = Flavor(CM) type flavor = OCF.t type flavor_sans_color = CM.flavor_sans_color type flavor_all_orders = CM.flavor type gauge = CM.gauge type constant = CM.constant type coupling_order = CM.coupling_order type orders = OCF.orders module Ch = CM.Ch let charges = OCF.pullback CM.charges let flavor_sans_color = OCF.pullback CM.flavor_sans_color let flavor_all_orders = OCF.all_orders let trivial = OCF.trivial let orders f = f.OCF.orders let add_orders = OCF.add_orders let incr_orders = OCF.incr_orders let orders_to_string = OCF.orders_to_string let orders_symbol = OCF.orders_symbol let flavor_equal f1 f2 = CM.flavor_equal (flavor_all_orders f1) (flavor_all_orders f2) && f1.orders = f2.orders let color = OCF.pullback CM.color let pdg = OCF.pullback CM.pdg let lorentz = OCF.pullback CM.lorentz let propagator = OCF.pullback CM.propagator let width = OCF.pullback CM.width let conjugate f = { f with OCF.all_orders = CM.conjugate f.OCF.all_orders } let conjugate_sans_color = CM.conjugate_sans_color let conjugate_all_orders = CM.conjugate let fermion = OCF.pullback CM.fermion let max_degree = CM.max_degree - let max_degree = CM.max_degree let vertices () = incomplete "vertices" let coupling = function | Coupling.V3 (_, _, c) | Coupling.V4 (_, _, c) | Coupling.Vn (_, _, c) -> c let incr_coupling_orders orders (f, c) = let coupling_orders = CM.coupling_orders (coupling c) in let orders = OCF.incr_orders (OCF.orders_of_list coupling_orders) orders in (OCF.make f orders, c) let fuse2 f1 f2 = let orders = OCF.fuse_orders [f1; f2] in List.map (incr_coupling_orders orders) (CM.fuse2 (flavor_all_orders f1) (flavor_all_orders f2)) let fuse3 f1 f2 f3 = let orders = OCF.fuse_orders [f1; f2; f3] in List.map (incr_coupling_orders orders) (CM.fuse3 (flavor_all_orders f1) (flavor_all_orders f2) (flavor_all_orders f3)) let fuse flavors = let orders = OCF.fuse_orders flavors in List.map (incr_coupling_orders orders) (CM.fuse (List.map flavor_all_orders flavors)) let flavors () = List.map OCF.trivial (CM.flavors ()) let all_coupling_orders = CM.all_coupling_orders let coupling_order_to_string = CM.coupling_order_to_string let coupling_orders = CM.coupling_orders let nc = CM.nc let external_flavors () = List.map (fun (group, flavors) -> (group, List.map OCF.trivial flavors)) (CM.external_flavors ()) let goldstone f = match CM.goldstone (OCF.all_orders f) with | None -> None | Some (f, c) -> Some (OCF.trivial f, c) let parameters = CM.parameters let flavor_of_string s = OCF.trivial (CM.flavor_of_string s) let flavor_to_string = OCF.to_string let flavor_to_TeX = OCF.pullback CM.flavor_to_TeX let flavor_symbol = OCF.to_symbol let gauge_symbol = CM.gauge_symbol let mass_symbol = OCF.pullback CM.mass_symbol let width_symbol = OCF.pullback CM.width_symbol let constant_symbol = CM.constant_symbol let options = CM.options let caveats = CM.caveats let amplitude orders fin fout = (List.map (fun f -> OCF.make f orders) fin, List.map (fun f -> OCF.make f orders) fout) let flow fin fout = CM.flow (List.map flavor_all_orders fin) (List.map flavor_all_orders fout) end (* \thocwmodulesection{Unit Tests} *) module Test = struct module O = Coupling_Orders (struct type coupling_order = int let coupling_order_to_string = string_of_int end) open OUnit let suite_add = "add" >::: [ "[(1,1); (2,4)] + [(1,2); (2,3)]" >:: (fun () -> assert_equal [(1,3); (2,7)] (O.add [(1,1); (2,4)] [(1,2); (2,3)])) ] let suite_incr = "incr" >::: [ "[(1,1); (3,4)] + [(2,2); (3,3)]" >:: (fun () -> assert_equal [(2,2); (3,7)] (O.incr [(1,1); (3,4)] [(2,2); (3,3)])) ] module M (* [: Model_CO] *) = struct - type constant = E | G | G2 | L + type constant = unit (*[ E | G | G2 | L ]*) type coupling_order = EW | QCD | BSM let all_coupling_orders () = [EW; QCD; BSM] let coupling_order_to_string = function | EW -> "EW" | QCD -> "QCD" | BSM -> "BSM" let coupling_orders = function - | E -> [(EW,1)] - | G -> [(QCD,1)] - | G2 -> [(QCD,2)] - | L -> [(BSM,1)] + | () -> [] + (*[ | E -> [(EW,1)] ]*) + (*[ | G -> [(QCD,1)] ]*) + (*[ | G2 -> [(QCD,2)] ]*) + (*[ | L -> [(BSM,1)] ]*) end module C = Conditions (M) let pup expected slist = assert_equal ~printer:(fun s -> "\"" ^ s ^ "\"") expected (C.to_string (C.of_strings slist)) let suite_parser = "parsing" >::: [ "EW=1" >:: (fun () -> pup "EW = 1" ["EW=1"]); "~EW" >:: (fun () -> pup "{QCD, BSM} = 0" ["~EW"]); "!BSM,QCD" >:: (fun () -> pup "BSM = 0; QCD = {1..2}" ["BSM; QCD={1..2}"]); "!BSM,QCD'" >:: (fun () -> pup "BSM = 0; QCD = {1..2}" ["BSM={0}; QCD={1..2}"]); "EW/QCD" >:: (fun () -> pup "EW = 2; QCD = 1" ["EW=2; QCD=1"]); "EW/QCD" >:: (fun () -> pup "EW = 1; QCD = 1" ["EW=1; QCD=1"]); "EW/QCD'" >:: (fun () -> pup "EW = 1; QCD = 1" ["{EW,QCD}=1"]); "EW=1,2,3" >:: (fun () -> pup "EW = 3" ["EW=1;EW=2;EW=3"]) ] let cos_option_to_string = function | None -> "*" | Some co_list -> ThoList.to_string (fun (co, n) -> M.coupling_order_to_string co ^ "=" ^ string_of_int n) co_list let sort orders = List.sort (fun (co1, _) (co2, _) -> compare co1 co2) orders let map_opt f = function | None -> None | Some a -> Some (f a) let assert_braket expected conditions orders = let conditions = C.of_strings conditions in assert_equal ~printer:cos_option_to_string (map_opt sort expected) (map_opt sort (C.braket conditions (sort orders))) let assert_fusion expected conditions orders = let conditions = C.of_strings conditions in assert_equal ~printer:string_of_bool expected (C.fusion conditions (sort orders)) - let suite_fusion = + let _suite_fusion = let open M in "fusion" >::: [ "BSM;EW=2;QCD=1: QCD=1" >:: (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(QCD,1)]); "BSM;EW=2;QCD=1: EW=1" >:: (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,1)]); "BSM;EW=2;QCD=1: EW=1;QCD=1" >:: (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,1)]); "BSM;EW=2;QCD=1: EW=2;QCD=1" >:: (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,2); (QCD,1)]); "BSM;EW=2;QCD=1: EW=1;QCD=2" >:: (fun () -> assert_fusion false ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,2)]); "BSM;EW=2;QCD=1: BSM=1" >:: (fun () -> assert_fusion false ["BSM;EW=2;QCD=1"] [(BSM,1)]); "BSM;EW=2;QCD=1: BSM=0" >:: (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(BSM,0)]) ] let suite_braket = let open M in "braket" >::: [ "BSM;EW=2;QCD=1: QCD=1" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(QCD,1)]); "BSM;EW=2;QCD=1: EW=1" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1)]); "BSM;EW=2;QCD=1: EW=1;QCD=1" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,1)]); "BSM;EW=2;QCD=1: EW=2;QCD=1" >:: (fun () -> assert_braket (Some [(EW,2); (QCD,1)]) ["BSM;EW=2;QCD=1"] [(EW,2); (QCD,1)]); "BSM;EW=2;QCD=1: EW=1;QCD=2" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,2)]); "BSM;EW=2;QCD=1: BSM=1" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(BSM,1)]); "BSM;EW=2;QCD=1: BSM=0" >:: (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(BSM,0)]); "EW={0..}: BSM=0" >:: (fun () -> assert_braket (Some [(EW,0)]) ["EW={0..}"] [(BSM,0)]); "EW={0..}: EW=1" >:: (fun () -> assert_braket (Some [(EW,1)]) ["EW={0..}"] [(EW,1)]); "EW={0..}: BSM=1;EW=1" >:: (fun () -> assert_braket (Some [(EW,1)]) ["EW={0..}"] [(BSM,1); (EW,1)]) ] (* \begin{dubious} We should add more unit tests, time permitting. \end{dubious} *) let suite = "Orders" >::: [ suite_add; suite_incr; suite_parser; (*[ suite_fusion;] *) suite_braket ] end Index: trunk/omega/src/UFO_parser.mly =================================================================== --- trunk/omega/src/UFO_parser.mly (revision 8919) +++ trunk/omega/src/UFO_parser.mly (revision 8920) @@ -1,193 +1,193 @@ /* vertex_parser.mly -- Copyright (C) 1999-2024 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 U = UFO_syntax let parse_error msg = raise (UFO_syntax.Syntax_Error (msg, symbol_start_pos (), symbol_end_pos ())) -let invalid_parameter_attr () = +let _invalid_parameter_attr () = parse_error "invalid parameter attribute" %} %token < int > INT %token < float > FLOAT %token < string > STRING ID %token DOT COMMA COLON %token EQUAL PLUS MINUS DIV %token LPAREN RPAREN %token LBRACE RBRACE %token LBRACKET RBRACKET %token END %start file %type < UFO_syntax.t > file %% file: | declarations END { $1 } ; declarations: | { [] } | declaration declarations { $1 :: $2 } ; declaration: | ID EQUAL name LPAREN RPAREN { { U.name = $1; U.kind = $3; U.attribs = [] } } | ID EQUAL name LPAREN attributes RPAREN { { U.name = $1; U.kind = $3; U.attribs = $5 } } | ID EQUAL STRING { U.macro $1 (U.String $3) } | ID EQUAL string_expr { U.macro $1 (U.String_Expr $3) } ; name: | ID { [$1] } | name DOT ID { $3 :: $1 } ; attributes: | attribute { [$1] } | attribute COMMA attributes { $1 :: $3 } ; attribute: | ID EQUAL value { { U.a_name = $1; U.a_value = $3 } } | ID EQUAL list { { U.a_name = $1; U.a_value = $3 } } | ID EQUAL dictionary { { U.a_name = $1; U.a_value = $3 } } ; value: | INT { U.Integer $1 } | INT DIV INT { U.Fraction ($1, $3) } | FLOAT { U.Float $1 } | string { U.String $1 } | string_expr { U.String_Expr $1 } | name { U.Name $1 } ; list: | LBRACKET RBRACKET { U.Empty_List } | LBRACKET names RBRACKET { U.Name_List $2 } | LBRACKET strings RBRACKET { U.String_List $2 } | LBRACKET integers RBRACKET { U.Integer_List $2 } | LBRACKET integer_lists RBRACKET { U.Young_Tableau $2 } ; integer_list: | LBRACKET RBRACKET { [] } | LBRACKET integers RBRACKET { $2 } ; dictionary: | LBRACE orders RBRACE { U.Order_Dictionary $2 } | LBRACE couplings RBRACE { U.Coupling_Dictionary $2 } | LBRACE decays RBRACE { U.Decay_Dictionary $2 } ; names: | name { [$1] } | name COMMA names { $1 :: $3 } ; integers: | INT { [$1] } | INT COMMA integers { $1 :: $3 } ; integer_lists: | integer_list { [$1] } | integer_list COMMA integer_lists { $1 :: $3 } ; /* We demand that a [U.String_Expr] contains no adjacent literal strings. Instead, they are concatenated already in the parser. Note that a [U.String_Expr] must have at least two elements: singletons are parsed as [U.Name] or [U.String] instead. */ string_expr: | literal_string_expr { $1 } | macro_string_expr { $1 } ; literal_string_expr: | string PLUS name { [U.Literal $1; U.Macro $3] } | string PLUS macro_string_expr { U.Literal $1 :: $3 } ; macro_string_expr: | name PLUS string { [U.Macro $1; U.Literal $3] } | name PLUS string_expr { U.Macro $1 :: $3 } ; strings: | string { [$1] } | string COMMA strings { $1 :: $3 } ; string: | STRING { $1 } | string PLUS STRING { $1 ^ $3 } ; orders: | order { [$1] } | order COMMA orders { $1 :: $3 } ; order: | STRING COLON INT { ($1, $3) } ; couplings: | coupling { [$1] } | coupling COMMA couplings { $1 :: $3 } ; coupling: | LPAREN INT COMMA INT RPAREN COLON name { ($2, $4, $7) } ; decays: | decay { [$1] } | decay COMMA decays { $1 :: $3 } ; decay: | LPAREN names RPAREN COLON STRING { ($2, $5) } ; Index: trunk/omega/src/fusion.ml =================================================================== --- trunk/omega/src/fusion.ml (revision 8919) +++ trunk/omega/src/fusion.ml (revision 8920) @@ -1,3527 +1,3531 @@ (* fusion.ml -- Copyright (C) 1999-2024 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 IMap = Map.Make(Int) module type T = sig val options : Options.t val vintage : bool type wf val conjugate : wf -> wf type flavor type flavor_all_orders type flavor_sans_color val flavor : wf -> flavor val flavor_all_orders : wf -> flavor_all_orders val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t 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 type slicings val amplitudes : bool -> selectors -> slicings option -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitudes_all_orders : bool -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> 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 type 'a slices val brakets : amplitude -> braket list slices val on_shell : amplitude -> wf -> bool val is_gauss : amplitude -> wf -> bool val constraints : amplitude -> string option val slicings : amplitude -> string list val symmetry : amplitude -> int val allowed : amplitude -> bool 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 = Orders.Slice(Colorize.It(M)).flavor and type flavor_all_orders = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig (* This will be [Model.T.flavor]. *) type flavor (* A record of the fermion lines in the 1POW. *) type stat (* Vertices with an odd number of fermion fields. *) exception Impossible (* External lines. *) val stat : flavor -> int -> stat (* [stat_fuse (Some flines) slist f] combines the fermion lines in the elements of [slist] according to the connections listed in [flines]. On the other hand, [stat_fuse None slist f] corresponds to the legacy mode with \emph{at most} two fermions. The resulting flavor [f] of the 1POW can be ignored for models with only Dirac fermions, except for debugging, since the direction of the arrows is unambiguous. However, in the case of Majorana fermions and/or fermion number violating interactions, the flavor [f] must be used. *) val stat_fuse : Coupling.fermion_lines option -> stat list -> flavor -> stat (* Analogous to [stat_fuse], but for the finalizing keystone instead of the 1POW. *) val stat_keystone : Coupling.fermion_lines option -> stat list -> flavor -> stat (* Compute the sign corresponding to the fermion lines in a 1POW or keystone. *) val stat_sign : stat -> int (* Debugging and consistency checks \ldots *) val stat_to_string : stat -> string val equal : stat -> stat -> bool val saturated : stat -> bool end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor (* \thocwmodulesection{Dirac Fermions} *) -let dirac_log silent logging = logging -let dirac_log silent logging = silent +let dirac_log silent _logging = silent exception Majorana module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor (* \begin{equation} \gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3) - \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1) \end{equation} *) (* The endpoints are [int option] instead of plain [int], so that we can use [None] for open ends in [stat_sign] below. \begin{dubious} We could do one level of unboxing as a performance hack by using [0] or [-1] for open ends. Then we just need to enforce that all line numbers are strictly positive. \end{dubious} *) type line = int option * int option let line_to_string = function | Some i, Some j -> Printf.sprintf "%d>%d" i j | Some i, None -> Printf.sprintf "%d>*" i | None, Some j -> Printf.sprintf "*>%d" j | None, None -> "*>*" type stat = | Fermion of int * line list | AntiFermion of int * line list | Boson of line list let lines_to_string lines = ThoList.to_string line_to_string lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> List.sort compare l1 = List.sort compare l2 | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && List.sort compare l1 = List.sort compare l2 | _ -> false let saturated = function | Boson _ -> true | _ -> false let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> raise Majorana | _ -> invalid_arg "Fusion.Stat_Dirac: invalid fermion number" exception Impossible - let stat_fuse_pair_legacy f s1 s2 = + let stat_fuse_pair_legacy _f s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion _, Fermion _ | AntiFermion _, AntiFermion _ -> raise Impossible let stat_fuse_legacy s1 s23__n f = List.fold_right (stat_fuse_pair_legacy f) s23__n s1 let stat_fuse_legacy_logging s1 s23__n f = let s = stat_fuse_legacy s1 s23__n f in Printf.eprintf "stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string s); s let stat_fuse_legacy = dirac_log stat_fuse_legacy stat_fuse_legacy_logging type partial = { stat : stat (* the [stat] accumulated so far *); fermions : int IMap.t (* a map from the indices in the vertex to open fermion lines *); antifermions : int IMap.t (* a map from the indices in the vertex to open antifermion lines *); n : int (* the number of incoming propagators *) } let partial_to_string p = Printf.sprintf "{ fermions=%s, antifermions=%s, state=%s, #=%d }" (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.fermions)) (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.antifermions)) (stat_to_string p.stat) p.n let add_lines l = function | Boson l' -> Boson (List.rev_append l l') | Fermion (n, l') -> Fermion (n, List.rev_append l l') | AntiFermion (n, l') -> AntiFermion (n, List.rev_append l l') let partial_of_slist slist = List.fold_left (fun acc s -> let n = succ acc.n in match s with | Boson l -> { acc with stat = add_lines l acc.stat; n } | Fermion (p, l) -> { acc with fermions = IMap.add n p acc.fermions; stat = add_lines l acc.stat; n } | AntiFermion (p, l) -> { acc with antifermions = IMap.add n p acc.antifermions; stat = add_lines l acc.stat; n } ) { stat = Boson []; fermions = IMap.empty; antifermions = IMap.empty; n = 0 } slist let match_fermion_line p (i, j) = if i <= p.n && j <= p.n then match IMap.find_opt i p.fermions, IMap.find_opt j p.antifermions with | (Some _ as f), (Some _ as fbar) -> { p with stat = add_lines [fbar, f] p.stat; fermions = IMap.remove i p.fermions; antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatched boson" else if i <= p.n then match IMap.find_opt i p.fermions, p.stat with | Some f, Boson l -> { p with stat = Fermion (f, l); fermions = IMap.remove i p.fermions } | _ -> invalid_arg "match_fermion_line: mismatched fermion" else if j <= p.n then match IMap.find_opt j p.antifermions, p.stat with | Some fbar, Boson l -> { p with stat = AntiFermion (fbar, l); antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatched antifermion" else failwith "match_fermion_line: impossible" let match_fermion_line_logging p (i, j) = Printf.eprintf "match_fermion_line %s (%d, %d)" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf " >> %s\n" (partial_to_string p'); p' let match_fermion_line = dirac_log match_fermion_line match_fermion_line_logging let match_fermion_lines flines s1 s23__n = let p = partial_of_slist (s1 :: s23__n) in List.fold_left match_fermion_line p flines - let stat_fuse_new flines s1 s23__n f = + let stat_fuse_new flines s1 s23__n _f = (match_fermion_lines flines s1 s23__n).stat let stat_fuse_new_checking flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end; stat let stat_fuse_new_logging flines s1 s23__n f = Printf.eprintf "stat_fuse_new: connecting fermion lines %s in %s <- %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)); stat_fuse_new_checking flines s1 s23__n f let stat_fuse_new = dirac_log stat_fuse_new stat_fuse_new_logging let stat_fuse flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_fuse: empty" | s1 :: s23__n -> begin match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f | None -> stat_fuse_legacy s1 s23__n f end let stat_fuse_logging flines_opt slist f = Printf.eprintf "stat_fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string slist); stat_fuse flines_opt slist f let stat_fuse = dirac_log stat_fuse stat_fuse_logging let stat_keystone_legacy s1 s23__n f = let s2 = List.hd s23__n and s34__n = List.tl s23__n in stat_fuse_legacy s1 [stat_fuse_legacy s2 s34__n (M.conjugate f)] f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf "stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s let stat_keystone_legacy = dirac_log stat_keystone_legacy stat_keystone_legacy_logging let stat_keystone flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: empty" - | [s] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: singleton" + | [_] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: singleton" | s1 :: (s2 :: s34__n as s23__n) -> begin match flines_opt with | None -> stat_keystone_legacy s1 s23__n f | Some flines -> (* The fermion line indices in [flines] must match the lines on one side of the keystone. *) let stat = stat_fuse_legacy s1 [stat_fuse_new flines s2 s34__n f] f in if saturated stat then stat else failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_keystone: incomplete %s!" (stat_to_string stat)) end let stat_keystone_logging flines_opt slist f = let s = stat_keystone flines_opt slist f in Printf.eprintf "stat_keystone: %s (%s) %s -> %s\n" (stat_to_string (List.hd slist)) (M.flavor_to_string f) (ThoList.to_string stat_to_string (List.tl slist)) (stat_to_string s); s let stat_keystone = dirac_log stat_keystone stat_keystone_logging (* \begin{figure} \begin{displaymath} \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f1,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f3,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \qquad\qquad-\qquad \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f3,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f1,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \end{displaymath} \caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.} \end{figure} *) (* \begin{equation} \epsilon \left(\left\{ (0,1), (2,3) \right\}\right) = - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right) \end{equation} *) let permutation lines = let fout, fin = List.split lines in let eps_in, _ = Combinatorics.sort_signed fin and eps_out, _ = Combinatorics.sort_signed fout in (eps_in * eps_out) (* \begin{dubious} This comparing of permutations of fermion lines is a bit tedious and takes a macroscopic fraction of time. However, it's less than 20\,\%, so we don't focus on improving on it yet. \end{dubious} *) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation ((None, Some p) :: lines) | AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines) end (* \thocwmodulesection{Amplitudes: Monochrome, Colored and Sliced} *) (* Computing the colored amplitudes from the uncolored amplitudes by adding color flows is the same algorithm as computing the uncolored amplitudes from the topology by adding flavors. The algorithm for adding powers of coupling constants is again almost identical, with only a small twist (see the type ['a slices] below). Therefore we define a common module that we can instantiate thrice: once without color, once with and once with powers coupling constants on top. *) (* In the future, we might want to have [Coupling] among the functor arguments. However, for the moment, [Coupling] is assumed to be comprehensive. *) module type Amplitude = sig (* An off-shell wavefunction is uniquely characterized by a [flavor] (which will contain the physical flavor and might contain color flows and coupling order powers) and a momentum *) type flavor type p type wf = { flavor : flavor; momentum : p } (* Conjugate the flavor, keeping the momentum. *) val conjugate : wf -> wf (* Extract flavor and momentum from a wave function. [momentum_list] is a convenience function that composes [momentum] and [Momentum.to_ints]. *) val flavor : wf -> flavor val momentum : wf -> p val momentum_list : wf -> int list (* An ordering that guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. For tree level amplitudes, this can be used to get the correct order of evaluation. *) val order_wf : wf -> wf -> int (* [external_wfs rank] constructs a list of wavefunctions from pairs of [flavor]s and indices of external momenta, using [rank] in the representation of momenta. *) val external_wfs : int -> (flavor * int) list -> wf list (* The couplings are model dependent, of course and we also must keep track of a sign for Fermi statistics. The value of [sign] must be either~$+1$ or~$-1$. *) type constant type coupling = { sign : int; coupling : constant Coupling.t } (* The incoming wavefunctions (a.\,k.\,a.~[children]) in a fusion can be represented by a [list] or a [Tuple] and we . *) type 'a children type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val children : rhs -> wf list (* In a [fusion], we can have more than one term contribute on the right hand side. *) type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list (* In a [braket], we can have more than one term contribute on the [ket], if we factor common [bra]s. *) type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list (* The small twist alluded to above is that in the case of counting powers coupling constants there will be different sets of [braket]s that correspond to different powers of coupling constants. Therefore, we wrap the [braket list] as [braket list Slicer.t] that can be implented in a functor argument either trivially as [braket list] in the module [Unsliced] or as a [(orders * braket list) list], as in the module [By_Orders] below. Note that slicing a list of whole amplitudes instead of the [braket list] would lead to unnecessary duplication of [fusion]s. *) type 'a slices val unsliced : 'a -> 'a slices (* That's the big bad DAG that implents the recursive construction of off-shell wave functions. *) module D : DAG.T with type node = wf and type edge = coupling and type children = wf children (* Return the list of all unique wavefunctions appearing in list of [braket]s on the left and right hand sides. *) val wavefunctions : braket list -> wf list (* That's the type that holds the result of our computations. *) type t = { fusions : fusion list; brakets : braket list slices; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; slicings : string list; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } (* The following accessor functions are redundant, since the type [t] is not abstract, but they are convenient, nevertheless. *) (* The [flavor]s of the incoming and outgoing particles. *) val incoming : t -> flavor list val outgoing : t -> flavor list (* The on-shell wave functions for the external particles in the crossed amplitude with all particles incoming. The outgoing flavors have been replaced by their charge conjugates. The [Target] must declare variables for them and initialize these from the momenta. *) val externals : t -> wf list (* All off-shell wave functions. The [Target] must declare variables for them. *) - val variables : t -> wf list + val _variables : t -> wf list (* All fusions. The [Target] uses them to recursively compute the off-shell wavefunctions. *) val fusions : t -> fusion list (* All slices of brakets. The [Target] evaluates each braket and adds the results for each slice to obtain the corresponding scattering amplitude. *) val brakets : t -> braket list slices (* Test if the user requested to replace the propagator for the off-shell wavefunction by an on-shell condition or a gaussian. *) val on_shell : t -> wf -> bool val is_gauss : t -> wf -> bool (* Human readable description of the constraints of type [Cascades().selectors] that have been applied to the amplitude. *) val constraints : t -> string option (* Human readable description of the requested slicings of type [Orders.Conditions.t] *) val slicings : t -> string list (* Size of the permutation symmetry group for identical outgoing patricles. *) val symmetry : t -> int (* The DAG that will be transformed by colorization and slicing. *) - val fusion_dag : t -> D.t + val _fusion_dag : t -> D.t (* This is used for diagnostics. *) val dependencies : t -> wf -> (wf, coupling) Tree2.t end (* \begin{dubious} Investigate if we can optimize also the unsliced amplitudes by keeping only one [DAG.t] and slice the brakets. \end{dubious} *) module type Slicer = sig type 'a t val all : 'a -> 'a t end module Unsliced = struct type 'a t = 'a let all a = a end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) (S : Slicer) : Amplitude with type p = P.t and type flavor = M.flavor and type constant = M.constant and type 'a children = 'a PT.t and type 'a slices = 'a S.t = struct type flavor = M.flavor type p = P.t type wf = { flavor : flavor; momentum : p } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else order_flavor wf1.flavor wf2.flavor (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type 'a children = 'a PT.t type constant = M.constant type coupling = { sign : int; coupling : constant Coupling.t } type rhs = coupling * wf children let sign (c, _) = c.sign let coupling (c, _) = c.coupling let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module WF = struct type t = wf let compare = order_wf end module CPL = struct type t = coupling let compare = compare end module D = DAG.Make(DAG.Forest(PT)(WF)(CPL)) module WFSet = Set.Make(WF) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type 'a slices = 'a S.t let unsliced a = S.all a type t = { fusions : fusion list; brakets : braket list slices; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; slicings : string list; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let slicings a = a.slicings - let variables a = List.map lhs a.fusions + let _variables a = List.map lhs a.fusions let dependencies a = a.dependencies - let fusion_dag a = a.fusion_dag + let _fusion_dag a = a.fusion_dag end (* \thocwmodulesection{The [Fusion.Make] Functor} *) module Make (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct let vintage = false let options = Options.create [ ] module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) (* \begin{dubious} This is copied from [Colorize] and should be factored! \end{dubious} *) (* \begin{dubious} In the long run, it will probably be beneficial to apply the permutations in [Modeltools.add_vertexn]! \end{dubious} *) - module PosMap = - Partial.Make (struct type t = int let compare = compare end) + module PosMap = Partial.Make (Int) let partial_map_undoing_permutation l l' = let module P = Permutation.Default in let p = P.of_list (List.map pred l') in PosMap.of_lists l (P.list p l) let partial_map_undoing_fuse fuse = partial_map_undoing_permutation (ThoList.range 1 (List.length fuse)) fuse let undo_permutation_of_fuse fuse = PosMap.apply_with_fallback (fun _ -> invalid_arg "permutation_of_fuse") (partial_map_undoing_fuse fuse) let fermion_lines = function | Coupling.V3 _ | Coupling.V4 _ -> None | Coupling.Vn (Coupling.UFO (_, _, _, fl, _), fuse, _) -> Some (UFO_Lorentz.map_fermion_lines (undo_permutation_of_fuse fuse) fl) type constant = M.constant (* \thocwmodulesubsection{Wave Functions} *) module A = Amplitude(PT)(P)(M)(Unsliced) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) - let is_goldstone_of g v = + let _is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list (* \begin{dubious} This is \emph{very} inefficient for [max_degree > 6]. Find a better approach that avoids precomputing the huge lookup table! \end{dubious} \begin{dubious} I should revive the above Idea to use [M.vertices] instead directly, instead of rebuilding it from [M.fuse2], [M.fuse3] and [M.fuse]! \end{dubious} *) let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold ~truncate:(pred max_degree) collect_vertices flavors VSet.empty) [] (* Performance hack: *) - type vertex_table = + 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 let vertices = vertices_nocache - let vertices' max_degree flavors = + let _vertices max_degree flavors = Printf.eprintf ">>> vertices %d ..." max_degree; flush stderr; let v = vertices max_degree flavors in Printf.eprintf " done.\n"; flush stderr; v 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{$K$-Matrix Filtering} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let timelike_sut momenta = let timelike p q = P.Scattering.timelike (P.add p q) in match PT.to_list momenta with | [q1; q2; q3] -> (timelike q1 q2, timelike q2 q3, timelike q1 q3) | _ -> raise PT.Mismatched_arity let kmatrix_cuts c momenta = let open Coupling in match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = timelike_sut momenta in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = timelike_sut momenta in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end (* \begin{dubious} Are the missing cases [1] and [2] for [disc] an oversight here? \end{dubious} *) | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = timelike_sut momenta in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* 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 }, 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'' }) f p') :: acc else acc with | PT.Mismatched_arity -> acc) f23 p23 []) (* 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 in let p = PT.fold_left_internal P.add momenta in 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 = S.stat_fuse (fermion_lines c) (PT.to_list ss) f in let flip = PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in ({ A.flavor = f; A.momentum = p }, s, ({ A.sign = flip; A.coupling = c }, wfs)) :: acc else acc) [] (fuse_rhs flavors) with | P.Duplicate _ | S.Impossible -> [] else [] (*i [let _ = Printf.eprintf "Fusion.fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string M.flavor_to_string (PT.to_list flavors)) in] i*) (* \begin{dubious} Eventually, the pairs of [tower] and [dag] in [fusion_tower'] below could and should be replaced by a graded [DAG]. This will look like, but currently [tower] containts statistics information that is missing from [dag]: \begin{quote} \verb+Type node = flavor * p is not compatible with type wf * stat+ \end{quote} This should be easy to fix. However, replacing [type t = wf] with [type t = wf * stat] is \emph{not} a good idea because the variable [stat] makes it impossible to test for the existance of a particular [wf] in a [DAG]. \end{dubious} \begin{dubious} In summary, it seems that [(wf * stat) list array * A.D.t] should be replaced by [(wf -> stat) * A.D.t]. \end{dubious} *) module GF = struct module Nodes = struct type t = A.wf - module G = struct type t = int let compare = compare end + module G = Int 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 _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 Stdlib.compare (PT.graded_sym_power_fold rank (fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower []) let add_offspring dag (wf, _, rhs) = A.D.add_offspring wf rhs dag let filter_offspring fusions = List.map (fun (wf, s, _) -> (wf, s)) fusions let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t = if Array.length tower >= n_max then (tower, dag) else let tower' = grow select_wf select_vtx tower in fusion_tower' n_max select_wf select_vtx (Array.append tower [|filter_offspring tower'|]) (List.fold_left add_offspring dag tower') (* Discard the tower and return a map from wave functions to Fermistatistics together with the DAG. *) let make_external_dag wfs = List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs let mixed_fold_left f acc lists = Array.fold_left (List.fold_left f) acc lists module WF = struct type t = A.wf let compare = A.order_wf end module FWMap = Map.Make(WF) let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = let tower, dag = fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in let stats = mixed_fold_left (fun m (wf, s) -> FWMap.add wf s m) FWMap.empty tower in ((fun wf -> FWMap.find wf stats), dag) (* Calculate the minimal tower of fusions that suffices for calculating the amplitude. *) let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (T.max_subtree n) select_wf select_vtx wfs (* Calculate the complete tower of fusions. It is much larger than required, but it allows a complete set of gauge checks. *) let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (List.length wfs - 1) select_wf select_vtx wfs (* \begin{dubious} There is a natural product of two DAGs using [fuse]. Can this be used in a replacement for [fusion_tower]? The hard part is to avoid double counting, of course. A straight forward solution could do a diagonal sum (in order to reject flipped offspring representing the same fusion) and rely on the uniqueness in [DAG] otherwise. However, this will (probably) slow down the procedure significanty, because most fusions (including Fermi signs!) will be calculated before being rejected by [DAG().add_offspring]. \end{dubious} *) (* Add to [dag] all Goldstone bosons defined in [tower] that correspond to gauge bosons in [dag]. This is only required for checking Slavnov-Taylor identities in unitarity gauge. Currently, it is not used, because we use the complete tower for gauge checking. *) - let harvest_goldstones tower dag = + let _harvest_goldstones tower dag = A.D.fold_nodes (fun wf dag' -> match M.goldstone wf.A.flavor with | Some (g, _) -> let wf' = { wf with A.flavor = g } in if A.D.is_node wf' tower then begin A.D.harvest tower wf' dag' end else begin dag' end | None -> dag') dag dag (* Calculate the sign from Fermi statistics that is not already included in the children. *) - let strip_fermion_lines = function + let _strip_fermion_lines = function | (Coupling.V3 _ | Coupling.V4 _ as v) -> v - | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> + | Coupling.Vn (Coupling.UFO (c, l, s, _, col), f, x) -> Coupling.Vn (Coupling.UFO (c, l, s, [], col), f, x) let num_fermion_lines_v3 = function | Coupling.FBF _ | Coupling.PBP _ | Coupling.BBB _ | Coupling.GBG _ -> 1 | _ -> 0 let num_fermion_lines = function - | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> List.length fl + | Coupling.Vn (Coupling.UFO (_, _, _, fl, _), _, _) -> List.length fl | Coupling.V3 (v3, _, _) -> num_fermion_lines_v3 v3 | Coupling.V4 _ -> 0 let stat_keystone v stats wf1 wfs = let wf1' = stats wf1 and wfs' = PT.map stats wfs in let f = A.flavor wf1 in let slist = wf1' :: PT.to_list wfs' in let stat = S.stat_keystone (fermion_lines v) slist f in (* We can compare with the legacy implementation only if there are no fermion line ambiguities possible, i.\,e.~for at most one line. *) if num_fermion_lines v < 2 then begin let legacy = S.stat_keystone None slist f in if not (S.equal stat legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: %s <> %s!" (S.stat_to_string legacy) (S.stat_to_string stat)); if not (S.saturated legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: legacy incomplete: %s!" (S.stat_to_string legacy)) end; if not (S.saturated stat) then failwith (Printf.sprintf "Fusion.stat_keystone: incomplete: %s!" (S.stat_to_string stat)); stat_sign stat * PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs' - let stat_keystone_logging v stats wf1 wfs = + let _stat_keystone_logging v stats wf1 wfs = let sign = stat_keystone v stats wf1 wfs in Printf.eprintf "Fusion.stat_keystone: %s * %s -> %d\n" (M.flavor_to_string (A.flavor wf1)) (ThoList.to_string (fun wf -> M.flavor_to_string (A.flavor wf)) (PT.to_list wfs)) sign; sign (* Test all members of a list of wave functions are defined by the DAG simultaneously: *) let test_rhs dag (_, wfs) = PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs (* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag] and calculate the statistical factor depending on [stats] \emph{en passant}: *) let filter_keystone stats dag (wf1, pairs) acc = if is_source wf1 && A.D.is_node wf1 dag then match List.filter (test_rhs dag) pairs with | [] -> acc | pairs' -> (wf1, List.map (fun (c, wfs) -> ({ A.sign = stat_keystone c stats wf1 wfs; A.coupling = c }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors type slicings = Orders.Conditions(Colorize.It(M)).t let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make(WF) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (min n (M.max_degree ())) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.slicings = []; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM)(Unsliced) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum } (* At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi = uncolorize_wf end) (* For now, we can live with simple aggregation: *) type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t } (* O'Caml is perfectly able to infer the types of the following functions by itself, but it helps our understanding to spell them out explicitely and to introduce type abbreviations. *) (* The function [f:wf_colorizer] takes a leaf wavefunction from the uncolored [DAG] and a [fibered_dag] and returns a colored node together with an updated bundle. *) type wf_colorizer = A.wf -> fibered_dag -> CA.wf * CWFBundle.t (* [colorize_sterile_nodes] applies this function and adds the colored wavefunction to the colored [DAG]. Below, closures build from [colorize_sterile_nodes] will be passed to [A.D.fold_nodes] to lay the foundation for the colorized [DAG]. *) let colorize_sterile_nodes : A.D.t -> wf_colorizer -> A.wf -> fibered_dag -> fibered_dag = fun dag f wf fibered_dag -> if A.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { dag = CA.D.add_node wf' fibered_dag.dag; bundle = wf_bundle' } else fibered_dag (* The function [f : node_colorizer] takes a fusion from the uncolored [DAG] and a [fibered_dag] and returns a list of colored fusions etc.~together with an updated bundle. *) type colored_fusion = CA.D.node * (CA.D.edge * CA.D.children) type node_colorizer = A.D.node -> A.D.edge * A.D.children -> fibered_dag -> colored_fusion list * CWFBundle.t (* The colored fusions are added to the colored [DAG]. Below, closures build from [colorize_nodes] will be passed to [A.D.fold] to complete the construction of the colorized [DAG]. *) let colorize_nodes : node_colorizer -> A.wf -> A.rhs -> fibered_dag -> fibered_dag = fun f wf rhs fibered_dag -> let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> CA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.dag in { dag = dag'; bundle = wf_bundle' } (* Build a colorized [DAG] as a [fibered_dag] from an uncolored [DAG] growing the [wf_bundle]. In our applications, the initial [wf_bundle] will contain the colorized external wavefunctions. *) let colorize_dag : node_colorizer -> wf_colorizer -> A.D.t -> CWFBundle.t -> fibered_dag = fun f_node f_ext dag wf_bundle -> A.D.fold (colorize_nodes f_node) dag (A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag { dag = CA.D.empty; bundle = wf_bundle }) (* This is only a consistency check, verifying that the fiber of the [fibered_dag] that projects to [wf] contains one and only one element. *) let colorize_external : wf_colorizer = fun wf fibered_dag -> match CWFBundle.inv_pi fibered_dag.bundle wf with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" (* Take the wavefunctions in the [rhs] and compute all colored fusions according to the colored Feynman rules. Keep only the flavors that match [wf] without colors and apply the [kmatrix_cuts] filter if necessary. While this ist color independent, it must be done again, because [CM.fuse] will reintroduce all couplings that might have been filtered out before. *) let fuse_c_wf : A.wf -> CA.wf CA.children -> (CM.flavor * CM.constant Coupling.t) list = fun wf rhs -> let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (f, c) -> CM.flavor_sans_color f = wf.A.flavor && kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) - let fuse_c_wf_logging wf rhs = + let _fuse_c_wf_logging wf rhs = let fusion = fuse_c_wf wf rhs in Printf.eprintf "fuse_c_wf %s(%s) %s => %s\n" (M.flavor_to_string wf.A.flavor) (ThoList.to_string string_of_int (P.to_ints wf.A.momentum)) (ThoList.to_string (fun wf -> Printf.sprintf "%s(%s)" (CM.flavor_to_string wf.CA.flavor) (ThoList.to_string string_of_int (P.to_ints wf.CA.momentum))) (PT.to_list rhs)) (ThoList.to_string (fun (f, _) -> CM.flavor_to_string f) fusion); fusion (*i let fuse_c_wf = fuse_c_wf_logging i*) let colorize_coupling c coupling = { CA.sign = coupling.A.sign; CA.coupling = c } (* Look up all colored versions of the [children] in the [fibered_dag]. *) let find_colored fibered_dag wf = CWFBundle.inv_pi fibered_dag.bundle wf (* All combinations of colored versions of the [children]. *) let colored_children_list fibered_dag children = PT.product (PT.map (find_colored fibered_dag) children) (* [colorize_fusion wf rhs fibered_dag] uses all colored versions of the wave functions on the [rhs] in the [fibered_dag] and returns all fusions (according to [fuse_c_wf]) with matching flavor together with the updated [fibered_dag], including the new colored wave functions. *) - let match_flavor f' (f, _) = + let _match_flavor f' (f, _) = CM.flavor_sans_color f = f' let colorize_fusion : node_colorizer = fun wf (coupling, children) fibered_dag -> let fuse colored_children = fuse_c_wf wf colored_children and colorize colored_children (f, c) = (colorize_wf f wf, (colorize_coupling c coupling, colored_children)) in let fusions = ThoList.flatmap (fun colored_children -> List.map (colorize colored_children) (fuse colored_children)) (colored_children_list fibered_dag children) in let bundle = List.fold_left (fun acc (c_wf, _) -> CWFBundle.add acc c_wf) fibered_dag.bundle fusions in (fusions, bundle) (* Since each [PArray.Alist.t] has a unique representation, we can write [CM.conjugate bra.CA.flavor = f] instead of [CM.flavor_equal (CM.conjugate bra.CA.flavor) f] again. *) (* Note that we must only keep the bras and kets with matching colors. *) (* \begin{dubious} TODO: avoid building intermediate lists that must be factorized again using the approach for coupling orders slicing below. \end{dubious} *) let colorize_braket1 fibered_dag wf (coupling, children) = Product.fold2 (fun bra ket acc -> let bra_bar = uncolorize_wf (CA.conjugate bra) in List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf bra_bar ket)) (find_colored fibered_dag wf) (PT.product (PT.map (find_colored fibered_dag) children)) [] (*i if CM.conjugate bra.CA.flavor = f then Printf.eprintf "< %s | %s >\n" (CM.flavor_to_string bra.CA.flavor) (CM.flavor_to_string f); i*) module CWF = struct type t = CA.wf let compare = CA.order_wf end module CRHS = struct type t = CA.rhs let compare = compare end module CWFSet = Set.Make(CWF) module CWFMap = Map.Make(CWF) module CRHSMap = ThoMap.Buckets(CWF)(CRHS) (* [CRHSMap.factorize] takes a list of [(bra, ket)] pairs and groups the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) let colorize_braket fibered_dag (wf, rhs_list) = CRHSMap.factorize_batches (List.map (colorize_braket1 fibered_dag wf) rhs_list) (* [colorize_amplitude a fin fout] takes an amplitude [a] for uncolored particles and colored incoming particles [fin] and outgoing particles [fout] and returns the corresponding colored amplitude. *) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (colorize_braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.slicings = a.A.slicings; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in match amp.CA.brakets with | [] -> amps | _ -> amp :: amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes_unsliced goldstones selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones selectors fin fout = amplitude goldstones selectors fin fout (* \thocwmodulesubsection{Coupling Order Slicing} *) (* The following is structurally rather similar to the application of [Colorize.It()] above. Unfortunately, there are enough differences that will make a unification rather complicated. *) (* Unfortunately, the O'Caml type checker insists on [Orders.Conditions(Colorize.It(M))] here and everywhere. The more concise and superficially equivalent [Orders.Conditions(CM)] will lead to type errors down the road, when the [Fusion.Make] functor is applied. The problem appears to be that [CM] is not available in the type constraints for the functors. *) (* The prefix [SC] to these and the following modules should be read as ``sliced-colorized'' or ``colorized and sliced'': *) module COC = Orders.Conditions(Colorize.It(M)) module SCM = Orders.Slice(Colorize.It(M)) module By_Orders = struct type orders = SCM.orders type 'a t = (orders * 'a) list let all a = [([], a)] end module SCA = Amplitude(PT)(P)(SCM)(By_Orders) type 'a slices = 'a SCA.slices type amplitude = SCA.t let slice_wf flavor wf = { SCA.flavor = flavor; SCA.momentum = wf.CA.momentum } let unslice_wf wf = { CA.flavor = SCM.flavor_all_orders wf.SCA.flavor; CA.momentum = wf.SCA.momentum } module SCWF = struct type t = SCA.wf let compare = SCA.order_wf end module SCWFSet = Set.Make(SCWF) module SCWFBundle = Bundle.Make (struct type elt = SCA.wf let compare_elt = compare type base = CA.wf let compare_base = compare let pi = unslice_wf end) let allowed amplitude = match amplitude.SCA.brakets with | [] -> false | _ -> true type flavor = SCA.flavor type flavor_all_orders = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = SCA.wf let conjugate = SCA.conjugate let flavor = SCA.flavor let flavor_sans_color wf = CM.flavor_sans_color (SCM.flavor_all_orders (SCA.flavor wf)) let momentum = SCA.momentum let momentum_list = SCA.momentum_list type coupling = SCA.coupling let sign = SCA.sign let coupling = SCA.coupling type 'a children = 'a SCA.children type rhs = SCA.rhs let children = SCA.children type fusion = SCA.fusion let lhs = SCA.lhs let rhs = SCA.rhs type braket = SCA.braket let bra = SCA.bra let ket = SCA.ket type amplitude_sans_color = A.t (* \thocwmodulesubsection{Accessor Functions} *) let incoming = SCA.incoming let outgoing = SCA.outgoing let externals = SCA.externals let fusions = SCA.fusions let brakets = SCA.brakets let symmetry = SCA.symmetry let on_shell = SCA.on_shell let is_gauss = SCA.is_gauss let constraints = SCA.constraints let slicings = SCA.slicings let variables a = List.map lhs (fusions a) let dependencies = SCA.dependencies let flavor_all_orders wf = SCM.flavor_all_orders (SCA.flavor wf) type sliced_fibered_dag = { sliced_dag : SCA.D.t; sliced_bundle : SCWFBundle.t } type wf_slicer = CA.wf -> sliced_fibered_dag -> SCA.wf * SCWFBundle.t let slice_sterile_nodes : CA.D.t -> wf_slicer -> CA.D.node -> sliced_fibered_dag -> sliced_fibered_dag = fun dag f wf fibered_dag -> if CA.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { sliced_dag = SCA.D.add_node wf' fibered_dag.sliced_dag; sliced_bundle = wf_bundle' } else fibered_dag type sliced_fusion = SCA.wf * SCA.rhs type node_slicer = CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fusion list * SCWFBundle.t let slice_nodes : node_slicer -> CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fibered_dag = fun f wf rhs fibered_dag -> let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> SCA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.sliced_dag in { sliced_dag = dag'; sliced_bundle = wf_bundle' } let slice_dag : node_slicer -> wf_slicer -> CA.D.t -> SCWFBundle.t -> sliced_fibered_dag = fun f_node f_ext dag wf_bundle -> CA.D.fold (slice_nodes f_node) dag (CA.D.fold_nodes (slice_sterile_nodes dag f_ext) dag { sliced_dag = SCA.D.empty; sliced_bundle = wf_bundle }) let slice_external : wf_slicer = fun wf fibered_dag -> match SCWFBundle.inv_pi fibered_dag.sliced_bundle wf with | [c_wf] -> (c_wf, fibered_dag.sliced_bundle) | [] -> failwith "slice_external: not found" | _ -> failwith "slice_external: not unique" let coupling_orders = function | Coupling.V3 (_, _, c) | Coupling.V4 (_, _, c) | Coupling.Vn (_, _, c) -> CM.coupling_orders c let coupling_orders_to_string co = "{" ^ String.concat "," (List.map (fun (o, n) -> CM.coupling_order_to_string o ^ ":" ^ string_of_int n) co) ^ "}" (* \begin{dubious} Ideally, one would want to test for the allowed coupling constants with [COC.constant] early inside of [SCM.fuse]. However, this requires a more general signature than [fuse] in [Model.T]. Let's see if this is worth the effort. \end{dubious} *) let fuse_s_wf : COC.t -> CA.wf -> SCA.wf SCA.children -> (SCM.flavor * SCM.constant Coupling.t) list = fun slicings wf rhs -> let momenta = PT.map (fun wf -> wf.SCA.momentum) rhs in List.filter (fun (f, c) -> SCM.flavor_all_orders f = wf.CA.flavor && COC.constant slicings (coupling_orders c) && COC.fusion slicings (SCM.orders f) && kmatrix_cuts c momenta) (SCM.fuse (List.map (fun wf -> wf.SCA.flavor) (PT.to_list rhs))) let slice_coupling c coupling = { SCA.sign = coupling.CA.sign; SCA.coupling = c } (* Look up all versions of the [children] in the [fibered_dag]. *) let find_sliced fibered_dag wf = SCWFBundle.inv_pi fibered_dag.sliced_bundle wf (* All combinations of the [children] with different coupling orders. *) let sliced_children_list fibered_dag children = PT.product (PT.map (find_sliced fibered_dag) children) let slice_fusion : COC.t -> node_slicer = fun slicings wf (coupling, children) fibered_dag -> let fuse sliced_children = fuse_s_wf slicings wf sliced_children and slice sliced_children (f, c) = (slice_wf f wf, (slice_coupling c coupling, sliced_children)) in let fusions = ThoList.flatmap (fun sliced_children -> List.map (slice sliced_children) (fuse sliced_children)) (sliced_children_list fibered_dag children) in let bundle = List.fold_left (fun acc (s_wf, _) -> SCWFBundle.add acc s_wf) fibered_dag.sliced_bundle fusions in (fusions, bundle) (* When producing all combinations of coupling orders, bras and kets, we need to group them by common coupling orders and by common bras. This is most straightforwardly (and asymptotically efficiently) done by constructing a map from coupling orders to maps from bras to sets of kets. *) (* For this we need to order the sets of coupling orders, bras (wave functions) and kets (right hand sides) *) module CO = struct type t = SCM.orders let compare = compare end module SCBra = struct type t = SCA.wf let compare = SCA.order_wf end module SCKet = struct type t = SCA.rhs let compare = compare end (* in order to define maps from coupling orders and from bras *) module COMap = Map.Make(CO) module SCBraMap = Map.Make(SCBra) (* as well a buckets for kets, indexed by bras: *) module SCKetBuckets = ThoMap.Buckets(SCBra)(SCKet) type comap = SCKetBuckets.t COMap.t let comap_to_lists : comap -> (SCM.orders * SCA.braket list) list = fun comap -> List.rev (COMap.fold (fun orders brakets acc -> (orders, SCKetBuckets.to_lists brakets) :: acc) comap []) (* Add [ket] to the set indexed by [bra] in the map from bras to sets of kets indexed by [orders] in [omap]. Initialize the inner map if it doesn't exist yet. *) let addto_orders_map : comap -> SCM.orders -> SCA.wf -> SCA.rhs -> comap = fun omap orders bra ket -> let bra_ket_map = match COMap.find_opt orders omap with | None -> SCKetBuckets.empty | Some bkmap -> bkmap in COMap.add orders (SCKetBuckets.add bra ket bra_ket_map) omap let _find_sliced fibered_dag wf = let wf_list = find_sliced fibered_dag wf in Printf.eprintf "find_sliced %s -> %s\n" (CM.flavor_to_string (CA.flavor wf)) (ThoList.to_string (fun wf -> SCM.flavor_to_string (SCA.flavor wf)) wf_list); wf_list (* Take a left hand side and a right hand side, construct all allowed combinations of coupling orders and add them to our collection. *) (*i let to_string ol = ThoList.to_string (fun (co, n) -> SCM.coupling_order_to_string co ^ ":" ^ string_of_int n) ol i*) let slice_braket1 : COC.t -> sliced_fibered_dag -> CA.wf -> CA.rhs -> comap -> comap = fun conditions fibered_dag wf (coupling, children) comap -> Product.fold2 (fun bra children comap -> let bra_bar = unslice_wf (SCA.conjugate bra) in List.fold_left (fun comap (f, c) -> let orders = SCM.add_orders (SCM.orders bra.SCA.flavor) (SCM.orders f) in match COC.braket conditions orders with | Some orders -> addto_orders_map comap orders bra (slice_coupling c coupling, children) | None -> comap) comap (fuse_s_wf conditions bra_bar children)) (find_sliced fibered_dag wf) (PT.product (PT.map (find_sliced fibered_dag) children)) comap let slice_braket : COC.t -> sliced_fibered_dag -> CA.braket -> comap -> comap = fun slicings fibered_dag (wf, rhs_list) comap -> List.fold_right (slice_braket1 slicings fibered_dag wf) rhs_list comap let slice_brakets : COC.t -> sliced_fibered_dag -> CA.braket list -> (SCM.orders * SCA.braket list) list = fun slicings fibered_dag brakets -> comap_to_lists (List.fold_right (slice_braket slicings fibered_dag) brakets COMap.empty) let slice_amplitude slicings a = let trivial = List.map (fun co -> (co, 0)) (COC.exclusive_fusion slicings) in let fin, fout = SCM.amplitude trivial a.CA.incoming a.CA.outgoing in let f = fin @ List.map SCM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = SCA.external_wfs n externals in let wf_bundle = SCWFBundle.of_list external_wfs in let fibered_dag = slice_dag (slice_fusion slicings) slice_external a.CA.fusion_dag wf_bundle in let sliced_brakets = slice_brakets slicings fibered_dag a.CA.brakets in let brakets = ThoList.flatmap snd sliced_brakets in let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in let dependencies_map = SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in { SCA.fusions = fusions; SCA.brakets = sliced_brakets; SCA.constraints = a.CA.constraints; SCA.slicings = COC.to_strings slicings; SCA.incoming = fin; SCA.outgoing = fout; SCA.externals = external_wfs; SCA.fusion_dag = dag; SCA.fusion_tower = dag; SCA.symmetry = a.CA.symmetry; SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf)); SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf)); SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) } let slice_amplitudes slicings amplitudes = List.map (slice_amplitude slicings) amplitudes (* For the benefit of [Targets], we also copy the amplitudes to equivalent sliced amplitudes with empty coupling orders. This way, we can use the same output routines for the sliced and unsliced amplitudes. *) (* [lift_amplitude] is equivalent to [slice_amplitude Orders.Condition.trivial], but it can shortcut [SCM.fuse], since all fusions and brakets are known. *) let lift_wf wf = slice_wf (SCM.trivial wf.CA.flavor) wf let lift_coupling coupling = { SCA.sign = coupling.CA.sign; SCA.coupling = coupling.CA.coupling } let lift_external : wf_slicer = fun wf fibered_dag -> (lift_wf wf, fibered_dag.sliced_bundle) let lift_fusion : node_slicer = fun wf (coupling, children) fibered_dag -> let wf = lift_wf wf and coupling = lift_coupling coupling and children = PT.map lift_wf children in let sliced_bundle = SCWFBundle.add fibered_dag.sliced_bundle wf in ( [ (wf, (coupling, children)) ], sliced_bundle ) let lift_dag : CA.D.t -> SCWFBundle.t -> sliced_fibered_dag = fun dag wf_bundle -> slice_dag lift_fusion lift_external dag wf_bundle let lift_braket : CA.braket -> SCA.braket = fun (wf, rhs) -> let wf = lift_wf wf and rhs = List.map (fun (coupling, children) -> (lift_coupling coupling, PT.map lift_wf children)) rhs in (wf, rhs) let lift_amplitude a = let fin = List.map SCM.trivial a.CA.incoming and fout = List.map SCM.trivial a.CA.outgoing in let f = fin @ List.map SCM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = SCA.external_wfs n externals in let wf_bundle = SCWFBundle.of_list external_wfs in let fibered_dag = lift_dag a.CA.fusion_dag wf_bundle in let brakets = List.map lift_braket a.CA.brakets in let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in let dependencies_map = SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in { SCA.fusions = fusions; SCA.brakets = SCA.unsliced brakets; SCA.constraints = a.CA.constraints; SCA.slicings = []; SCA.incoming = fin; SCA.outgoing = fout; SCA.externals = external_wfs; SCA.fusion_dag = dag; SCA.fusion_tower = dag; SCA.symmetry = a.CA.symmetry; SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf)); SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf)); SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) } let lift_amplitudes amplitudes = List.map lift_amplitude amplitudes let amplitudes goldstones selectors slicings fin fout = let a = amplitudes_unsliced goldstones selectors fin fout in match slicings with | None -> lift_amplitudes a | Some slicings -> slice_amplitudes slicings a let amplitudes_all_orders goldstones selectors fin fout = lift_amplitudes (amplitudes_unsliced goldstones selectors fin fout) let children_to_string children = "(" ^ String.concat "*" (List.map (fun wf -> SCM.flavor_to_string (SCA.flavor wf)) children) ^ ")" - let dump_sliced_amplitudes slicings sliced = + let dump_sliced_amplitudes _slicings sliced = List.iter (fun amplitude -> Printf.eprintf "amplitude %s -> %s\n" (String.concat " " (List.map SCM.flavor_to_string amplitude.SCA.incoming)) (String.concat " " (List.map SCM.flavor_to_string amplitude.SCA.outgoing)); List.iter (fun (orders, brakets) -> Printf.eprintf " order %s\n" (coupling_orders_to_string orders); List.iter (fun braket -> Printf.eprintf " braket (%s, [%s])\n" (SCM.flavor_to_string (SCA.flavor (SCA.bra braket))) (String.concat ";" (List.map (fun ket -> coupling_orders_to_string (coupling_orders (SCA.coupling ket)) ^ children_to_string (SCA.children ket)) (SCA.ket braket)))) brakets) amplitude.brakets) sliced (*i let amplitudes goldstones exclusions selectors slicings fin fout = let a = amplitudes goldstones exclusions selectors None fin fout in match slicings with | None -> a | Some slicings -> dump_sliced_amplitudes (lift_amplitudes a); begin match COC.to_strings slicings with | [] -> () | slicings -> Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n"; Printf.eprintf "! coupling orders selected\n"; List.iter (Printf.eprintf "! %s\n") slicings; Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n" end; let sliced = slice_amplitudes slicings a in dump_sliced_amplitudes sliced; a i*) let _amplitudes goldstones selectors slicings fin fout = let a = amplitudes goldstones selectors slicings fin fout in match slicings with | None -> a | Some slicings -> dump_sliced_amplitudes slicings a; begin match COC.to_strings slicings with | [] -> () | slicings -> Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n"; Printf.eprintf "! coupling orders selected\n"; List.iter (Printf.eprintf "! %s\n") slicings; Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n" end; a (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let all_brakets a = ThoList.flatmap snd a.SCA.brakets let count_propagators a = List.length a.SCA.fusions let count_fusions a = let brakets = all_brakets a in List.fold_left (fun n (_, a) -> n + List.length a) 0 a.SCA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 brakets + List.length brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + SCA.D.count_trees wf1 a.SCA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * SCA.D.count_trees wf a.SCA.fusion_dag) 1 wfs) 0 wf23)) 0 (all_brakets a) - exception Impossible - let forest' a = let below wf = SCA.D.forest_memoized wf a.SCA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) (all_brakets a) let cross wf = { SCA.flavor = SCM.conjugate wf.SCA.flavor; SCA.momentum = P.neg wf.SCA.momentum } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum } let fuse_trees_uncolored wf ts = Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest_sans_color wf a = List.map (fuse_trees_uncolored wf) (forest_uncolored' a) i*) (* \begin{dubious} There's a lot of redundancy here. This is not harmful, but very confusing and should be cleaned up. \end{dubious} *) let poles_beneath wf dag = - SCA.D.eval_memoized (fun wf' -> [[]]) + SCA.D.eval_memoized (fun _wf -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.SCA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.SCA.fusion_dag) wfs))) wf23)) (all_brakets a) - let s_channel a = + let _s_channel a = SCWFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.SCA.momentum then SCWFSet.add wf wfs else wfs) (poles a) SCWFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map SCA.lhs a.SCA.fusions let s_channel a = SCWFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.SCA.momentum then SCWFSet.add wf wfs else wfs) (poles' a) SCWFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = SCM.flavor_symbol wf.SCA.flavor ^ "_p" ^ String.concat "" (List.map p2s (P.to_ints wf.SCA.momentum)) let add_to_list i n m = IMap.add i (n :: try IMap.find i m with Not_found -> []) m let classify_nodes dag = IMap.fold (fun i n acc -> (i, n) :: acc) (SCA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.SCA.momentum) wf) dag IMap.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; SCA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); SCA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch (all_brakets a) a.SCA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch (all_brakets a) a.SCA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) - and e2s c = "" in + and e2s _ = "" 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 + and e2s _ = "" 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 Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary) (* \thocwmodulesection{Fusions with Majorana Fermions} *) -let majorana_log silent logging = logging -let majorana_log silent logging = silent -let force_legacy = true +let majorana_log silent _logging = silent let force_legacy = false module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) = struct exception Impossible type flavor = M.flavor (* \thocwmodulesubsection{Keeping Track of Fermion Lines} *) (* JRR's algorithm doesn't use lists of pairs representing directed arrows as in [Stat_Dirac().stat] above, but a list of integers denoting the external leg a fermion line connects to: *) type stat = | Fermion of int * int list | AntiFermion of int * int list | Boson of int list | Majorana of int * int list let sign_of_permutation lines = fst (Combinatorics.sort_signed lines) let lines_equivalent l1 l2 = sign_of_permutation l1 = sign_of_permutation l2 let stat_to_string s = let open Printf in let l2s = ThoList.to_string string_of_int in match s with | Boson lines -> sprintf "B%s" (l2s lines) | Fermion (p, lines) -> sprintf "F(%d, %s)" p (l2s lines) | AntiFermion (p, lines) -> sprintf "A(%d, %s)" p (l2s lines) | Majorana (p, lines) -> sprintf "M(%d, %s)" p (l2s lines) (* Writing all cases explicitely is tedious, but allows exhaustiveness checking. *) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> lines_equivalent l1 l2 | Majorana (p1, l1), Majorana (p2, l2) | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && lines_equivalent l1 l2 | Boson _, (Fermion _ | AntiFermion _ | Majorana _ ) | (Fermion _ | AntiFermion _ | Majorana _ ), Boson _ | Majorana _, (Fermion _ | AntiFermion _) | (Fermion _ | AntiFermion _), Majorana _ | Fermion _ , AntiFermion _ | AntiFermion _ , Fermion _ -> false (* The final amplitude must not be fermionic! *) let saturated = function | Boson _ -> true | Fermion _ | AntiFermion _ | Majorana _ -> false (* [stat f p] interprets the numeric fermion numbers of flavor [f] at external leg [p] at creates a leaf: *) let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> Majorana (p, []) | _ -> invalid_arg "Fusion.Stat_Majorana: invalid fermion number" (* The formalism of~\cite{Denner:Majorana} does not distinguish spinors from conjugate spinors, it is only important to know in which direction a fermion line is calculated. So the sign is made by the calculation together with an aditional one due to the permuation of the pairs of endpoints of fermion lines in the direction they are calculated. We propose a ``canonical'' direction from the right to the left child at a fusion point so we only have to keep in mind which external particle hangs at each side. Therefore we need not to have a list of pairs of conjugate spinors and spinors but just a list in which the pairs are right-left-right-left and so on. Unfortunately it is unavoidable to have couplings with clashing arrows in supersymmetric theories so we need transmutations from fermions in antifermions and vice versa as well. *) (* \thocwmodulesubsection{Merge Fermion Lines for Legacy Models with Implied Fermion Connections} *) (* In the legacy case with at most one fermion line, it was straight forward to determine the kind of outgoing line from the corresponding flavor. In the general case, it is not possible to maintain this constraint, when constructing the $n$-ary fusion from binary ones. *) (* We can break up the process into two steps however: first perform unconstrained fusions pairwise \ldots *) let stat_fuse_pair_unconstrained s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | (Majorana (p1, l1) | Fermion (p1, l1) | AntiFermion (p1, l1)), (Majorana (p2, l2) | Fermion (p2, l2) | AntiFermion (p2, l2)) -> Boson ([p2; p1] @ l1 @ l2) | Boson l1, Majorana (p, l2) -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2 -> Majorana (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) (* \ldots{} and only apply the constraint to the outgoing leg. *) let constrain_stat_fusion s f = match s, M.lorentz f with | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), (Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost) -> Majorana (p, l) | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), Coupling.Spinor -> Fermion (p, l) | (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)), Coupling.ConjSpinor -> AntiFermion (p, l) | (Majorana _ | Fermion _ | AntiFermion _ as s), (Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector | Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) -> invalid_arg (Printf.sprintf "Fusion.stat_fuse_pair_constrained: expected boson, got %s" (stat_to_string s)) - | Boson l as s, + | Boson _ as s, (Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost | Coupling.Spinor | Coupling.ConjSpinor) -> invalid_arg (Printf.sprintf "Fusion.stat_fuse_pair_constrained: expected fermion, got %s" (stat_to_string s)) | Boson l, (Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector | Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) -> Boson l - let stat_fuse_pair_legacy f s1 s2 = + let stat_fuse_pair_legacy _f s1 s2 = stat_fuse_pair_unconstrained s1 s2 let stat_fuse_pair_legacy_logging f s1 s2 = let stat = stat_fuse_pair_legacy f s1 s2 in Printf.eprintf "stat_fuse_pair_legacy: (%s, %s) -> %s = %s\n" (stat_to_string s1) (stat_to_string s2) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse_pair_legacy = majorana_log stat_fuse_pair_legacy stat_fuse_pair_legacy_logging (* Note that we are using [List.fold_left], therefore we perform the fusions as $f(f(\ldots(f(s_1,s_2),s_3),\ldots),s_n)$. Had we used [List.fold_right] instead, we would compute $f(s_1,f(s_2,\ldots f(s_{n-1},s_n))).$ For our Dirac algorithm, this makes no difference, but JRR's Majorana algorithm depends on the order! *) (* Also not that we \emph{must not} apply [constrain_stat_fusion] here, because [stat_fuse_legacy] will be used in [stat_keystone_legacy] again, where we always expect [Boson _]. *) let stat_fuse_legacy s1 s23__n f = List.fold_left (stat_fuse_pair_legacy f) s1 s23__n (*i let stat_fuse_legacy' s1 s23__n f = match List.rev (s1 :: s23__n) with | s1 :: s23__n -> List.fold_left (stat_fuse_pair_legacy f) s1 s23__n | [] -> failwith "stat_fuse_legacy: impossible" let stat_fuse_legacy' s1 s23__n f = List.fold_right (stat_fuse_pair_legacy f) s23__n s1 i*) let stat_fuse_legacy_logging s1 s23__n f = let stat = stat_fuse_legacy s1 s23__n f in Printf.eprintf "stat_fuse_legacy: %s -> %s = %s\n" (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse_legacy = majorana_log stat_fuse_legacy stat_fuse_legacy_logging (* \thocwmodulesubsection{Merge Fermion Lines using Explicit Fermion Connections} *) (* Partially combined [stat]s of the incoming propagators and keeping track of the fermion lines, while we're scanning them. *) type partial = { stat : stat (* the [stat] accumulated so far *); fermions : int IMap.t (* a map from the indices in the vertex to open (anti)fermion lines *); n : int (* the number of incoming propagators *) } (* We will perform two passes: \begin{enumerate} \item collect the saturated fermion lines in a [Boson], while building a map from the indices in the vertex to the open fermion lines \item connect the open fermion lines using the [int -> int] map [fermions]. \end{enumerate} *) let empty_partial = { stat = Boson []; fermions = IMap.empty; n = 0 } (* Only for debugging: *) let partial_to_string p = Printf.sprintf "{ fermions=%s, stat=%s, #=%d }" (ThoList.to_string (fun (i, particle) -> Printf.sprintf "%d@%d" particle i) (IMap.bindings p.fermions)) (stat_to_string p.stat) p.n (* Add a list of saturated fermion lines at the top of the list of lines in a [stat]. *) let add_lines l = function | Boson l' -> Boson (l @ l') | Fermion (n, l') -> Fermion (n, l @ l') | AntiFermion (n, l') -> AntiFermion (n, l @ l') | Majorana (n, l') -> Majorana (n, l @ l') (* Process one line in the first pass: add the saturated fermion lines to the partial stat [p.stat] and add a pointer to an open fermion line in case of a fermion. *) let add_lines_to_partial p stat = let n = succ p.n in match stat with | Boson l -> { fermions = p.fermions; stat = add_lines l p.stat; n } | Majorana (f, l) -> { fermions = IMap.add n f p.fermions; stat = add_lines l p.stat; n } - | Fermion (p, l) -> - invalid_arg - "add_lines_to_partial: unexpected Fermion" - | AntiFermion (p, l) -> - invalid_arg - "add_lines_to_partial: unexpected AntiFermion" + | Fermion (_, _) -> invalid_arg "add_lines_to_partial: unexpected Fermion" + | AntiFermion (_, _) -> invalid_arg "add_lines_to_partial: unexpected AntiFermion" (* Do it for all lines: *) let partial_of_slist stat_list = List.fold_left add_lines_to_partial empty_partial stat_list - let partial_of_rev_slist stat_list = + let _partial_of_rev_slist stat_list = List.fold_left add_lines_to_partial empty_partial (List.rev stat_list) (* The building blocks for a single step of the second pass: saturate a fermion line or pass it through. *) (* The indices [i] and [j] refer to incoming lines: add a saturated line to [p.stat] and remove the corresponding open lines from the map. *) let saturate_fermion_line p i j = match IMap.find_opt i p.fermions, IMap.find_opt j p.fermions with | Some f, Some f' -> { stat = add_lines [f'; f] p.stat; fermions = IMap.remove i (IMap.remove j p.fermions); n = p.n } | Some _, None -> invalid_arg "saturate_fermion_line: no open outgoing fermion line" | None, Some _ -> invalid_arg "saturate_fermion_line: no open incoming fermion line" | None, None -> invalid_arg "saturate_fermion_line: no open fermion lines" (* The index [i] refers to an incoming line: add the open line to [p.stat] and remove it from the map. *) let pass_through_fermion_line p i = match IMap.find_opt i p.fermions, p.stat with | Some f, Boson l -> { stat = Majorana (f, l); fermions = IMap.remove i p.fermions; n = p.n } | Some _ , (Majorana _ | Fermion _ | AntiFermion _) -> invalid_arg "pass_through_fermion_line: more than one open line" | None, _ -> invalid_arg "pass_through_fermion_line: expected fermion not found" (* Ignoring the direction of the fermion line reproduces JRR's algorithm. *) let sort_pair (i, j) = if i < j then (i, j) else (j, i) (* The index [p.n + 1] corresponds to the outgoing line: *) let is_incoming p i = i <= p.n let match_fermion_line p (i, j) = let i, j = sort_pair (i, j) in if is_incoming p i && is_incoming p j then saturate_fermion_line p i j else if is_incoming p i then pass_through_fermion_line p i else if is_incoming p j then pass_through_fermion_line p j else failwith "match_fermion_line: both lines outgoing" let match_fermion_line_logging p (i, j) = Printf.eprintf "match_fermion_line %s [%d->%d]" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf " >> %s\n" (partial_to_string p'); p' let match_fermion_line = majorana_log match_fermion_line match_fermion_line_logging (* Combine the passes \ldots *) let match_fermion_lines flines s1 s23__n = List.fold_left match_fermion_line (partial_of_slist (s1 :: s23__n)) flines (* \ldots{} and keep only the [stat]. *) let stat_fuse_new flines s1 s23__n _ = (match_fermion_lines flines s1 s23__n).stat (* If there is at most a single fermion line, we can compare [stat] against the result of [stat_fuse_legacy] for checking [stat_fuse_new] (admittedly, this case is rather trivial) \ldots *) let stat_fuse_new_check stat flines s1 s23__n f = if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end (* \ldots{} do it, but only when we are writing debugging output. *) let stat_fuse_new_logging flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in Printf.eprintf "stat_fuse_new: %s: %s -> %s = %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string stat) (M.flavor_to_string f); stat_fuse_new_check stat flines s1 s23__n f; stat let stat_fuse_new = majorana_log stat_fuse_new stat_fuse_new_logging (* Use [stat_fuse_new], whenever fermion connections are available. NB: [Some []] is \emph{not} the same as [None]! *) let stat_fuse flines_opt slist f = match slist with | [] -> invalid_arg "stat_fuse: empty" | s1 :: s23__n -> constrain_stat_fusion (match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f | None -> stat_fuse_legacy s1 s23__n f) f let stat_fuse_logging flines_opt slist f = let stat = stat_fuse flines_opt slist f in Printf.eprintf "stat_fuse: %s -> %s = %s\n" (ThoList.to_string stat_to_string slist) (stat_to_string stat) (M.flavor_to_string f); stat let stat_fuse = majorana_log stat_fuse stat_fuse_logging (* \thocwmodulesubsection{Final Step using Implied Fermion Connections} *) let stat_keystone_legacy s1 s23__n f = stat_fuse_legacy s1 s23__n f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf "stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s let stat_keystone_legacy = majorana_log stat_keystone_legacy stat_keystone_legacy_logging (* \thocwmodulesubsection{Final Step using Explicit Fermion Connections} *) let stat_keystone_new flines slist f = match slist with | [] -> invalid_arg "stat_keystone: empty" - | [s] -> invalid_arg "stat_keystone: singleton" + | [_] -> invalid_arg "stat_keystone: singleton" | s1 :: s2 :: s34__n -> let stat = stat_fuse_pair_unconstrained s1 (stat_fuse_new flines s2 s34__n f) in if saturated stat then stat else failwith (Printf.sprintf "stat_keystone: incomplete %s!" (stat_to_string stat)) let stat_keystone_new_check stat slist f = match slist with | [] -> invalid_arg "stat_keystone_check: empty" | s1 :: s23__n -> let legacy = stat_keystone_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "stat_keystone_check: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) let stat_keystone flines_opt slist f = match flines_opt with | Some flines -> stat_keystone_new flines slist f | None -> begin match slist with | [] -> invalid_arg "stat_keystone: empty" | s1 :: s23__n -> stat_keystone_legacy s1 s23__n f end let stat_keystone_logging flines_opt slist f = let stat = stat_keystone flines_opt slist f in Printf.eprintf "stat_keystone: %s (%s) %s -> %s\n" (stat_to_string (List.hd slist)) (M.flavor_to_string f) (ThoList.to_string stat_to_string (List.tl slist)) (stat_to_string stat); stat_keystone_new_check stat slist f; stat let stat_keystone = majorana_log stat_keystone stat_keystone_logging (* Force the legacy version w/o checking against the new implementation for comparing generated code against the hard coded models: *) let stat_fuse flines_opt slist f = if force_legacy then stat_fuse_legacy (List.hd slist) (List.tl slist) f else stat_fuse flines_opt slist f let stat_keystone flines_opt slist f = if force_legacy then stat_keystone_legacy (List.hd slist) (List.tl slist) f else stat_keystone flines_opt slist f (* \thocwmodulesubsection{Evaluate Signs from Fermion Permuations} *) let stat_sign = function | Boson lines -> sign_of_permutation lines | Fermion (p, lines) -> sign_of_permutation (p :: lines) | AntiFermion (pbar, lines) -> sign_of_permutation (pbar :: lines) | Majorana (pm, lines) -> sign_of_permutation (pm :: lines) let stat_sign_logging stat = let sign = stat_sign stat in Printf.eprintf "stat_sign: %s -> %d\n" (stat_to_string stat) sign; sign let stat_sign = majorana_log stat_sign stat_sign_logging end module Binary_Majorana = Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary) module Nary (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B)) module Nary_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B)) module Mixed23 = Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23) module Mixed23_Majorana = Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23) module Helac (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B)) module Helac_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B)) module B2 = struct let max_arity () = 2 end module B3 = struct let max_arity () = 3 end module Helac_Binary = Helac(B2) module Helac_Binary_Majorana = Helac(B2) module Helac_Mixed23 = Helac(B3) module Helac_Mixed23_Majorana = Helac(B3) (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type selectors type slicings type coupling_order type amplitudes val amplitudes : bool -> int option -> selectors -> slicings option -> process list -> amplitudes val empty : amplitudes val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val coupling_orders : amplitudes -> (coupling_order list * int list list) option val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list - val process_table : amplitudes -> amplitude option array array - val process_table_new : amplitudes -> amplitude option array array array + val process_table : + amplitudes -> amplitude option array array + val process_table_new : + amplitudes -> ((coupling_order * int) list * amplitude) option array array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option val slicings : amplitudes -> string list end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors and type slicings = Orders.Conditions(Colorize.It(M)).t and type coupling_order = Orders.Slice(Colorize.It(M)).coupling_order module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module SCM = Orders.Slice(Colorize.It(M)) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) module COC = Orders.Conditions(Colorize.It(M)) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), " report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "file write progress report to file" ] type flavor = M.flavor - type p = F.p + type _p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type selectors = F.selectors type slicings = COC.t type coupling_order = SCM.coupling_order - type flavors = flavor list array - type helicities = int list array - type colors = Color.Flow.t array + type _flavors = flavor list array + type _helicities = int list array + type _colors = Color.Flow.t array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; coupling_orders : (coupling_order list * int list list) option; processes : amplitude list; process_table : amplitude option array array; - process_table_new : amplitude option array array array; + process_table_new : ((coupling_order * int) list * amplitude) option array array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option; slicings : string list } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let coupling_orders a = a.coupling_orders let processes a = a.processes let process_table a = a.process_table let process_table_new a = a.process_table_new let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let slicings a = a.slicings let sans_colors f = List.map CM.flavor_sans_color (List.map SCM.flavor_all_orders f) - let colors (fin, fout) = + 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 = SCM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) - let rec unphysical_of_lorentz = function + let 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*) + (* NB: [let compare = ThoList.compare] doesn't typecheck, due to the optional + argument~[cmp]. The alternative [let compare = (ThoList.compare : t -> t -> int)] + is even more verbose. *) module COPMap = Map.Make(struct type t = int list let compare = ThoList.compare ~cmp:Stdlib.compare end) module COBundle = Bundle.Make (struct type elt = (coupling_order * int) list let compare_elt = compare type base = coupling_order list let compare_base = compare let pi = List.map fst end) let collect_coupling_orders processes = let bundle = List.fold_right (fun process -> List.fold_right (fun (orders, _) bundle -> COBundle.add bundle orders) (F.brakets process)) processes COBundle.empty in match COBundle.fibers bundle with | [] | [([], _)] -> None | [(coupling_orders, orders)] -> Some (coupling_orders, List.map (List.map snd) orders) | _ -> invalid_arg "Fusion.Multi().exclusive_coupling_orders: not unique" (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical select_wf slicings processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones select_wf slicings fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let allowed_coupling_orders = collect_coupling_orders allowed in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) and co_index = match allowed_coupling_orders with | None -> COPMap.empty | Some (_, powers) -> fst (List.fold_left (fun (m, i) c -> (COPMap.add c i m, succ i)) (COPMap.empty, 0) powers) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; + let num_coupling_orders = COPMap.cardinal co_index in + let table_new = - ThoArray.rank3 1 (List.length flavors) (List.length color_flows) None in + ThoArray.rank3 (max num_coupling_orders 1) (List.length flavors) (List.length color_flows) None in List.iter (fun a -> - let co = 0 - and f = FMap.find (process_sans_color a) f_index + let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in - table_new.(co).(f).(c) <- Some (a)) + if num_coupling_orders < 1 then + table_new.(0).(f).(c) <- Some (([], a)) + else + List.iter + (fun (orders, _) -> + match COPMap.find_opt (List.map snd orders) co_index with + | Some co -> table_new.(co).(f).(c) <- Some (orders, a) + | None -> failwith "table_new") + (F.brakets a)) allowed; let color_factor_table = Color.Flow.factor_table color_flows in let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in let slicings = match slicings with | None -> [] | Some slicings -> COC.to_strings slicings in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; coupling_orders = allowed_coupling_orders; processes = allowed; process_table = table; process_table_new = table_new; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf; slicings = slicings } let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; coupling_orders = None; processes = []; process_table = Array.make_matrix 0 0 None; process_table_new = ThoArray.rank3 0 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None; slicings = [] } end Index: trunk/omega/src/progress.ml =================================================================== --- trunk/omega/src/progress.ml (revision 8919) +++ trunk/omega/src/progress.ml (revision 8920) @@ -1,166 +1,153 @@ (* progress.ml -- Copyright (C) 1999-2024 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 channel = | Channel of out_channel | File of string | Open_File of string * out_channel type state = { channel : channel; mutable steps : int; mutable digits : int; mutable step : int; created : float; mutable last_reset : float; mutable last_begin : float; } type t = state option let digits n = if n > 0 then succ (truncate (log10 (float n))) else invalid_arg "Progress.digits: non-positive argument" let mod_float2 a b = let modulus = mod_float a b in ((a -. modulus) /. b, modulus) let time_to_string seconds = let minutes, seconds = mod_float2 seconds 60. in if minutes > 0.0 then let hours, minutes = mod_float2 minutes 60. in if hours > 0.0 then let days, hours = mod_float2 hours 24. in if days > 0.0 then Printf.sprintf "%.0f:%02.0f days" days hours else Printf.sprintf "%.0f:%02.0f hrs" hours minutes else Printf.sprintf "%.0f:%02.0f mins" minutes seconds else Printf.sprintf "%.2f secs" seconds let create channel steps = let now = Sys.time () in Some { channel = channel; steps = steps; digits = digits steps; step = 0; created = now; last_reset = now; last_begin = now } let dummy = None let channel oc = create (Channel oc) let file name = let oc = open_out name in close_out oc; create (File name) let open_file name = let oc = open_out name in create (Open_File (name, oc)) let close_channel state = match state.channel with | Channel oc -> flush oc | File _ -> () | Open_File (_, oc) -> flush oc; close_out oc let use_channel state f = match state.channel with | Channel oc | Open_File (_, oc) -> f oc; flush oc | File name -> let oc = open_out_gen [Open_append; Open_creat] 0o644 name in f oc; flush oc; close_out oc -let reset state steps msg = +let reset state steps _msg = match state with | None -> () | Some state -> let now = Sys.time () in state.steps <- steps; state.digits <- digits steps; state.step <- 0; state.last_reset <- now; state.last_begin <- now let begin_step state msg = match state with | None -> () | Some state -> let now = Sys.time () in state.step <- succ state.step; state.last_begin <- now; use_channel state (fun oc -> Printf.fprintf oc "[%0*d/%0*d] %s ..." state.digits state.step state.digits state.steps msg) let end_step state msg = match state with | None -> () | Some state -> let now = Sys.time () in let last = now -. state.last_begin in let elapsed = now -. state.last_reset in let estimated = float state.steps *. elapsed /. float state.step in let remaining = estimated -. elapsed in use_channel state (fun oc -> Printf.fprintf oc " %s. [time: %s, total: %s, remaining: %s]\n" msg (time_to_string last) (time_to_string estimated) (time_to_string remaining)) let summary state msg = match state with | None -> () | Some state -> let now = Sys.time () in use_channel state (fun oc -> Printf.fprintf oc "%s. [total time: %s]\n" msg (time_to_string (now -. state.created))); close_channel state - -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) - - - - - Index: trunk/omega/src/young.mli =================================================================== --- trunk/omega/src/young.mli (revision 8919) +++ trunk/omega/src/young.mli (revision 8920) @@ -1,156 +1,169 @@ (* young.mli -- Copyright (C) 2022-2024 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. *) (* Caveat: the following are not optimized for large Young diagrams and tableaux. They are straightforward implementations of the definitions, since we are unlikely to meet large diagrams. To make matters worse, native integer arithmetic will overflow already for diagrams with more than 20 cells. Since the [Num] library has been removed from the O'Caml distribution with version 4.06, we can not use it as a shortcut. Requiring Whizard/O'Mega users to install [Num] or its successor [Zarith] is probably not worth the effort. *) (* \ytableausetup{centertableaux,smalltableaux} *) (* \thocwmodulesection{Young Diagrams} *) (* Young diagrams can be represented by a non-increasing list of positive integers, corresponding to the number of boxes in each row: \begin{equation} \ydiagram{5,4,4,2} \Longleftrightarrow \lbrack 5;4;4;2 \rbrack \end{equation} *) type diagram = int list (* Check that the diagram is valid, i.\,e.~the number of boxes is non-increasing from top to bottom. *) val valid_diagram : diagram -> bool (* Count the number of cells. *) val num_cells_diagram : diagram -> int (* Conjugate a diagram: \begin{equation} \ydiagram{5,4,4,2} \mapsto \ydiagram{4,4,3,3,1} \end{equation} *) val conjugate_diagram : diagram -> diagram (* The product of all the ``hook lengths'' in the diagram, e.\,g. \begin{equation} \ydiagram{5,4,4,2} \mapsto \ytableaushort{87541,6532,5421,21} \mapsto 8 \cdot 7 \cdot 6 \cdot 5^3 \cdot 4^2 \cdot 3 \cdot 2^3 = 16128000 \end{equation} where the intermediate step is only for illustration and does not represent a Young tableau! *) val hook_lengths_product : diagram -> int (* Number of standard tableaux corresponding to the diagram. Also, the dimension of the representation of~$S_n$ described by this diagram \begin{equation} d = \frac{n!}{\prod_{i=1}^n h_i} \end{equation} with~$n$ the number of cells and~$h_i$ the hook length of the $i$th cell. *) val num_standard_tableaux : diagram -> int (* Normalization of the projector on the representation of $\mathrm{GL(N)}$ described by the diagram \begin{equation} \alpha = \frac{\prod_{R} |R|!\prod_{C} |C|!}{\prod_{i=1}^n h_i} \end{equation} with~$|R|$ and~$|C|$ the lengths of the row~$R$ and column~$C$, respectively. Returned as a pair of numerator and denominator, because it is not guaranteed to be integer. *) val normalization : diagram -> int * int +(* Dimension of the representation of $\mathrm{GL(N)}$ + described by the diagram + \begin{equation} + d = \frac{\prod_{i=1}^n(N-k_i)}{\prod_{i=1}^n h_i} = \prod_{i=1}^n \frac{N-k_i}{h_i} + \end{equation} + where~$k_i$ starts with~$0$ in the upper left corner, grows towards the right and + shrinks towards the bottom. *) +val dimension : diagram -> Algebra.Laurent.t + (* \thocwmodulesection{Young Tableaux} *) (* There is an obvious representation as a list of lists: \begin{equation} \ytableaushort{023,14} \Longleftrightarrow \lbrack \lbrack 0; 2; 3 \rbrack; \lbrack 1; 4 \rbrack \rbrack \end{equation} *) type 'a tableau = 'a list list (* Ignoring the contents of the cells of a Young tableau produces a unique corresponding Young diagram. \begin{equation} \ytableaushort{023,14} \mapsto \ydiagram{3,2} \end{equation} *) val diagram_of_tableau : 'a tableau -> diagram (* The number of columns must be non-increasing. Obviously, [valid_tableau] is the composition of [diagram_of_tableau] and [valid_diagram].*) val valid_tableau : 'a tableau -> bool (* A tableau is called \textit{semistandard}, iff the entries don't decrease along rows and strictly increase along columns. Therefore, the conjugate of a semistandard tableau is \emph{not} necessarily semistandard. *) val semistandard_tableau : 'a tableau -> bool (* A tableau is called \textit{standard}, iff it is semistandard and the entries are an uninterrupted sequence of natural numbers. If the optional [offset] is specified, it must match the smallest of these numbers. Some authors expect [offset=1], but we want to be able to start from 0 as well. The conjugate of a standard tableau is again a standard tableau. *) val standard_tableau : ?offset:int -> int tableau -> bool (* The contents of the cells and their number. *) val cells_tableau : 'a tableau -> 'a list val num_cells_tableau : 'a tableau -> int +(* Return [Some cells] with [cells] in increasing order, if the tableau + semistandard and all cells are different. [None] otherwise. *) +val quasi_standard_tableau : 'a tableau -> 'a list option + (* Conjugate a Young tableau \begin{equation} \ytableaushort{023,14} \mapsto \ytableaushort{01,24,3} \end{equation} *) val conjugate_tableau : 'a tableau -> 'a tableau (* Transform the contents cell-by-cell. *) val map: ('a -> 'b) -> 'a tableau -> 'b tableau (* Debugging and diagnostics. *) val tableau_to_string : ('a -> string) -> 'a tableau -> string (* Toplevel *) val pp : Format.formatter -> int tableau -> unit (* \thocwmodulesection{Unit Tests} *) module type Test = sig val suite : OUnit.test val suite_long : OUnit.test end module Test : Test Index: trunk/omega/src/UFO_syntax.ml =================================================================== --- trunk/omega/src/UFO_syntax.ml (revision 8919) +++ trunk/omega/src/UFO_syntax.ml (revision 8920) @@ -1,68 +1,68 @@ (* vertex_syntax.ml -- Copyright (C) 1999-2024 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{Abstract Syntax} *) exception Syntax_Error of string * Lexing.position * Lexing.position type name = string list type string_atom = | Macro of name | Literal of string type value = | Name of name | Integer of int | Float of float | Fraction of int * int | String of string | String_Expr of string_atom list | Empty_List | Name_List of name list | Integer_List of int list | String_List of string list | Young_Tableau of int Young.tableau | Order_Dictionary of (string * int) list | Coupling_Dictionary of (int * int * name) list | Decay_Dictionary of (name list * string) list type attrib = { a_name : string; a_value : value } type declaration = { name : string; kind : name; attribs : attrib list } type t = declaration list let macro name expansion = { name; kind = ["$"]; attribs = [ { a_name = name; a_value = expansion } ] } -let to_strings declarations = +let to_strings _declarations = [] Index: trunk/omega/src/bundle.ml =================================================================== --- trunk/omega/src/bundle.ml (revision 8919) +++ trunk/omega/src/bundle.ml (revision 8920) @@ -1,145 +1,145 @@ (* bundle.ml -- Copyright (C) 1999-2024 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 Elt_Base = sig type elt type base val compare_elt : elt -> elt -> int val compare_base : base -> base -> int end module type Dyn = sig type t type elt type fiber = elt list type base val empty : t val add : (elt -> base) -> t -> elt -> t val of_list : (elt -> base) -> elt list -> t val inv_pi : t -> base -> fiber val base : t -> base list val fiber : (elt -> base) -> t -> elt -> fiber val fibers : t -> (base * fiber) list end module Dyn (P : Elt_Base) = struct type elt = P.elt type base = P.base type fiber = elt list module InvPi = Map.Make (struct type t = P.base let compare = P.compare_base end) module Fiber = Set.Make (struct type t = P.elt let compare = P.compare_elt end) type t = Fiber.t InvPi.t let empty = InvPi.empty let add pi fibers element = let base = pi element in let fiber = try InvPi.find base fibers with Not_found -> Fiber.empty in InvPi.add base (Fiber.add element fiber) fibers let of_list pi list = List.fold_left (add pi) InvPi.empty list let fibers bundle = InvPi.fold (fun base fiber acc -> (base, Fiber.elements fiber) :: acc) bundle [] let base bundle = - InvPi.fold (fun base fiber acc -> base :: acc) bundle [] + InvPi.fold (fun base _fiber acc -> base :: acc) bundle [] let inv_pi bundle base = try Fiber.elements (InvPi.find base bundle) with | Not_found -> [] let fiber pi bundle elt = inv_pi bundle (pi elt) end module type Projection = sig include Elt_Base val pi : elt -> base end module type T = sig type t type elt type fiber = elt list type base val empty : t val add : t -> elt -> t val of_list : elt list -> t val pi : elt -> base val inv_pi : t -> base -> fiber val base : t -> base list val fiber : t -> elt -> fiber val fibers : t -> (base * fiber) list end module Make (P : Projection) = struct module D = Dyn (P) type elt = D.elt type base = D.base type fiber = D.fiber type t = D.t let empty = D.empty let pi = P.pi let add = D.add pi let of_list = D.of_list pi let base = D.base let inv_pi = D.inv_pi let fibers = D.fibers let fiber bundle elt = inv_pi bundle (pi elt) end (*i module Test = Make (struct type fiber = int type base = int let compare_fiber = compare let compare_base = compare let pi = abs end) let sample = [-1; -4; 7; -8; 9; 42; -137; -42; 42; 4; 1; -9] Test.fibers (Test.classify sample);; i*) Index: trunk/omega/src/target_Fortran.ml =================================================================== --- trunk/omega/src/target_Fortran.ml (revision 8919) +++ trunk/omega/src/target_Fortran.ml (revision 8920) @@ -1,2521 +1,2620 @@ (* target_Fortran.ml -- Copyright (C) 1999-2024 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 Make_Fortran (Names : Target_Fortran_Names.T) (Vintage_Fermions : Targets_vintage.Fermion_Maker) (Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) = struct let require_library = Names.require_library @ [ "omega_vectors_2010_01_A"; "omega_polarizations_2010_01_A"; "omega_couplings_2010_01_A"; "omega_color_2010_01_A"; "omega_utils_2010_01_A" ] module Fermions = Vintage_Fermions(Names) module CM = Colorize.It(M) module SCM = Orders.Slice(Colorize.It(M)) module F = Fusion_Maker(P)(M) module CF = Fusion.Multi(Fusion_Maker)(P)(M) type amplitudes = CF.amplitudes open Coupling open Format type output_mode = | Single_Function | Single_Module of int | Single_File of int | Multi_File of int let line_length = ref 80 let continuation_lines = ref (-1) (* 255 *) let kind = ref "default" let fortran95 = ref true let module_name = ref "omega_amplitude" let output_mode = ref (Single_Module 10) let use_modules = ref [] let whizard = ref false let amp_triv = ref false let parameter_module = ref "" let md5sum = ref None let no_write = ref false let km_write = ref false let km_pure = ref false let km_2_write = ref false let km_2_pure = ref false let openmp = ref false let pure_unless_openmp = false let options = Options.create [ "90", Arg.Clear fortran95, " use only Fortran90 features"; "kind", Arg.String (fun s -> kind := s), "kind real and complex kind (default: '" ^ !kind ^ "')"; "width", Arg.Int (fun w -> line_length := w), "n maximum line length"; "continuation", Arg.Int (fun l -> continuation_lines := l), "n maximum # of continuation lines"; "module", Arg.String (fun s -> module_name := s), "name module name"; "single_function", Arg.Unit (fun () -> output_mode := Single_Function), " compute the matrix element in one function"; "split_function", Arg.Int (fun n -> output_mode := Single_Module n), "size split the matrix element into small functions"; "split_module", Arg.Int (fun n -> output_mode := Single_File n), "size split the matrix element into small modules"; "split_file", Arg.Int (fun n -> output_mode := Multi_File n), "size split the matrix element into small files"; "use", Arg.String (fun s -> use_modules := s :: !use_modules), "name use module"; "parameter_module", Arg.String (fun s -> parameter_module := s), "name parameter_module"; "md5sum", Arg.String (fun s -> md5sum := Some s), "sum transfer MD5 checksum"; "whizard", Arg.Set whizard, " include WHIZARD interface"; "amp_triv", Arg.Set amp_triv, " only print trivial amplitude"; "no_write", Arg.Set no_write, " no 'write' statements"; "kmatrix_write", Arg.Set km_2_write, " write K matrix functions"; "kmatrix_2_write", Arg.Set km_write, " write K matrix 2 functions"; "kmatrix_write_pure", Arg.Set km_pure, " write K matrix pure functions"; "kmatrix_2_write_pure", Arg.Set km_2_pure, " write Kmatrix2pure functions"; "openmp", Arg.Set openmp, " activate OpenMP support in generated code"] (* Fortran style line continuation: *) let nl = Format_Fortran.newline let print_list = function | [] -> () | a :: rest -> print_string a; List.iter (fun s -> printf ",@ %s" s) rest (* \thocwmodulesubsection{Variables and Declarations} *) (* ["NC"] is already used up in the module ["constants"]: *) let nc_parameter = "N_" let omega_color_factor_abbrev = "OCF" let openmp_tld_type = "thread_local_data" let openmp_tld = "tld" let flavors_symbol ?(decl = false) ?orders flavors = let flavors_all_orders = List.map SCM.flavor_all_orders flavors in let orders_tag = match orders with | None -> "" | Some orders -> SCM.orders_symbol orders in (if !openmp && not decl then openmp_tld ^ "%" else "" ) ^ "oks_" ^ String.concat "_" (List.map CM.flavor_symbol flavors_all_orders) ^ orders_tag let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" (* \begin{dubious} There many similar functions for formatting momenta. This is grown historically and should be cleaned up! \end{dubious} *) (* Prefix with a ["p"] to make a variable name holding a four momentum. *) let format_momentum : int list -> string = fun p -> "p" ^ String.concat "" (List.map p2s p) (* No prefix, to be used as part of a variable name holding a wavefunction. *) let format_p : F.wf -> string = fun wf -> String.concat "" (List.map p2s (F.momentum_list wf)) let ext_momentum wf = match F.momentum_list wf with | [n] -> n | _ -> invalid_arg "Targets.Fortran.ext_momentum" module PSet = Set.Make (struct type t = int list let compare = compare end) module WFSet = Set.Make (struct type t = F.wf let compare = compare end) let variable ?(decl = false) wf = (if !openmp && not decl then openmp_tld ^ "%" else "") ^ "owf_" ^ SCM.flavor_symbol (F.flavor wf) ^ "_p" ^ format_p wf let momentum wf = "p" ^ format_p wf let spin wf = "s(" ^ string_of_int (ext_momentum wf) ^ ")" let format_multiple_variable ?(decl = false) wf i = variable ~decl wf ^ "_X" ^ string_of_int i let multiple_variable ?(decl = false) amplitude dictionary wf = try format_multiple_variable ~decl wf (dictionary amplitude wf) with | Not_found -> variable wf let multiple_variables ?(decl = false) multiplicity wf = try List.map (format_multiple_variable ~decl wf) (ThoList.range 1 (multiplicity wf)) with | Not_found -> [variable ~decl wf] let declaration_chunk_size = 64 let declare_list_chunk multiplicity t = function | [] -> () | wfs -> printf " @[<2>%s :: " t; print_list (ThoList.flatmap (multiple_variables ~decl:true multiplicity) wfs); nl () let declare_list multiplicity t = function | [] -> () | wfs -> List.iter (declare_list_chunk multiplicity t) (ThoList.chopn declaration_chunk_size wfs) type declarations = { scalars : F.wf list; spinors : F.wf list; conjspinors : F.wf list; realspinors : F.wf list; ghostspinors : F.wf list; vectorspinors : F.wf list; vectors : F.wf list; ward_vectors : F.wf list; massive_vectors : F.wf list; tensors_1 : F.wf list; tensors_2 : F.wf list; brs_scalars : F.wf list; brs_spinors : F.wf list; brs_conjspinors : F.wf list; brs_realspinors : F.wf list; brs_vectorspinors : F.wf list; brs_vectors : F.wf list; brs_massive_vectors : F.wf list } let rec classify_wfs' acc = function | [] -> acc | wf :: rest -> classify_wfs' (match SCM.lorentz (F.flavor wf) with | Scalar -> {acc with scalars = wf :: acc.scalars} | Spinor -> {acc with spinors = wf :: acc.spinors} | ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors} | Majorana -> {acc with realspinors = wf :: acc.realspinors} | Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors} | Vectorspinor -> {acc with vectorspinors = wf :: acc.vectorspinors} | Vector -> {acc with vectors = wf :: acc.vectors} (*i | Ward_Vector -> {acc with ward_vectors = wf :: acc.ward_vectors} i*) | Massive_Vector -> {acc with massive_vectors = wf :: acc.massive_vectors} | Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1} | Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2} | BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars} | BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors} | BRS ConjSpinor -> {acc with brs_conjspinors = wf :: acc.brs_conjspinors} | BRS Majorana -> {acc with brs_realspinors = wf :: acc.brs_realspinors} | BRS Vectorspinor -> {acc with brs_vectorspinors = wf :: acc.brs_vectorspinors} | BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors} | BRS Massive_Vector -> {acc with brs_massive_vectors = wf :: acc.brs_massive_vectors} | BRS _ -> invalid_arg "Targets.wfs_classify': not needed here") rest let classify_wfs wfs = classify_wfs' { scalars = []; spinors = []; conjspinors = []; realspinors = []; ghostspinors = []; vectorspinors = []; vectors = []; ward_vectors = []; massive_vectors = []; tensors_1 = []; tensors_2 = []; brs_scalars = [] ; brs_spinors = []; brs_conjspinors = []; brs_realspinors = []; brs_vectorspinors = []; brs_vectors = []; brs_massive_vectors = []} wfs (* \thocwmodulesubsection{Parameters} *) type 'a parameters = { real_singles : 'a list; real_arrays : ('a * int) list; complex_singles : 'a list; complex_arrays : ('a * int) list } let rec classify_singles acc = function | [] -> acc | Real p :: rest -> classify_singles { acc with real_singles = p :: acc.real_singles } rest | Complex p :: rest -> classify_singles { acc with complex_singles = p :: acc.complex_singles } rest let rec classify_arrays acc = function | [] -> acc | (Real_Array p, rhs) :: rest -> classify_arrays { acc with real_arrays = (p, List.length rhs) :: acc.real_arrays } rest | (Complex_Array p, rhs) :: rest -> classify_arrays { acc with complex_arrays = (p, List.length rhs) :: acc.complex_arrays } rest let classify_parameters params = classify_arrays (classify_singles { real_singles = []; real_arrays = []; complex_singles = []; complex_arrays = [] } (List.map fst params.derived)) params.derived_arrays let schisma = ThoList.chopn let schisma_num i n l = ThoList.enumerate i (schisma n l) let declare_parameters' t = function | [] -> () | plist -> printf " @[<2>%s(kind=%s), public, save :: " t !kind; print_list (List.map SCM.constant_symbol plist); nl () let declare_parameters t plist = List.iter (declare_parameters' t) plist let declare_parameter_array t (p, n) = printf " @[<2>%s(kind=%s), dimension(%d), public, save :: %s" t !kind n (SCM.constant_symbol p); nl () (* NB: we use [string_of_float] to make sure that a decimal point is included to make Fortran compilers happy. *) let default_parameter (x, v) = printf "@ %s = %s_%s" (SCM.constant_symbol x) (string_of_float v) !kind let declare_default_parameters t = function | [] -> () | p :: plist -> printf " @[<2>%s(kind=%s), public, save ::" t !kind; default_parameter p; List.iter (fun p' -> printf ","; default_parameter p') plist; nl () let format_constant = function | I -> "(0,1)" | Integer c -> if c < 0 then sprintf "(%d.0_%s)" c !kind else sprintf "%d.0_%s" c !kind | Float x -> if x < 0. then "(" ^ string_of_float x ^ "_" ^ !kind ^ ")" else string_of_float x ^ "_" ^ !kind | _ -> invalid_arg "format_constant" let rec eval_parameter' = function | (I | Integer _ | Float _) as c -> printf "%s" (format_constant c) | Atom x -> printf "%s" (SCM.constant_symbol x) | Sum [] -> printf "0.0_%s" !kind | Sum [x] -> eval_parameter' x | Sum (x :: xs) -> printf "@,("; eval_parameter' x; List.iter (fun x -> printf "@, + "; eval_parameter' x) xs; printf ")" | Diff (x, y) -> printf "@,("; eval_parameter' x; printf " - "; eval_parameter' y; printf ")" | Neg x -> printf "@,( - "; eval_parameter' x; printf ")" | Prod [] -> printf "1.0_%s" !kind | Prod [x] -> eval_parameter' x | Prod (x :: xs) -> printf "@,("; eval_parameter' x; List.iter (fun x -> printf " * "; eval_parameter' x) xs; printf ")" | Quot (x, y) -> printf "@,("; eval_parameter' x; printf " / "; eval_parameter' y; printf ")" | Rec x -> printf "@, (1.0_%s / " !kind; eval_parameter' x; printf ")" | Pow (x, n) -> printf "@,("; eval_parameter' x; if n < 0 then printf "**(%d)" n else printf "**%d" n; printf ")" | PowX (x, y) -> printf "@,("; eval_parameter' x; printf "**"; eval_parameter' y; printf ")" | Sqrt x -> printf "@,sqrt ("; eval_parameter' x; printf ")" | Sin x -> printf "@,sin ("; eval_parameter' x; printf ")" | Cos x -> printf "@,cos ("; eval_parameter' x; printf ")" | Tan x -> printf "@,tan ("; eval_parameter' x; printf ")" | Cot x -> printf "@,cot ("; eval_parameter' x; printf ")" | Asin x -> printf "@,asin ("; eval_parameter' x; printf ")" | Acos x -> printf "@,acos ("; eval_parameter' x; printf ")" | Atan x -> printf "@,atan ("; eval_parameter' x; printf ")" | Atan2 (y, x) -> printf "@,atan2 ("; eval_parameter' y; printf ",@ "; eval_parameter' x; printf ")" | Sinh x -> printf "@,sinh ("; eval_parameter' x; printf ")" | Cosh x -> printf "@,cosh ("; eval_parameter' x; printf ")" | Tanh x -> printf "@,tanh ("; eval_parameter' x; printf ")" | Exp x -> printf "@,exp ("; eval_parameter' x; printf ")" | Log x -> printf "@,log ("; eval_parameter' x; printf ")" | Log10 x -> printf "@,log10 ("; eval_parameter' x; printf ")" | Conj (Integer _ | Float _ as x) -> eval_parameter' x | Conj x -> printf "@,cconjg ("; eval_parameter' x; printf ")" | Abs x -> printf "@,abs ("; eval_parameter' x; printf ")" let strip_single_tag = function | Real x -> x | Complex x -> x let strip_array_tag = function | Real_Array x -> x | Complex_Array x -> x let eval_parameter (lhs, rhs) = let x = SCM.constant_symbol (strip_single_tag lhs) in printf " @[<2>%s = " x; eval_parameter' rhs; nl () let eval_para_list n l = printf " subroutine setup_parameters_%03d ()" n; nl (); List.iter eval_parameter l; printf " end subroutine setup_parameters_%03d" n; nl () let eval_parameter_pair (lhs, rhs) = let x = SCM.constant_symbol (strip_array_tag lhs) in let _ = List.fold_left (fun i rhs' -> printf " @[<2>%s(%d) = " x i; eval_parameter' rhs'; nl (); succ i) 1 rhs in () let eval_para_pair_list n l = printf " subroutine setup_parameters_%03d ()" n; nl (); List.iter eval_parameter_pair l; printf " end subroutine setup_parameters_%03d" n; nl () let print_echo fmt p = let s = CM.constant_symbol p in printf " write (unit = *, fmt = fmt_%s) \"%s\", %s" fmt s s; nl () let print_echo_array fmt (p, n) = let s = CM.constant_symbol p in for i = 1 to n do printf " write (unit = *, fmt = fmt_%s_array) " fmt ; printf "\"%s\", %d, %s(%d)" s i s i; nl () done let contains params couplings = List.exists (fun (name, _) -> List.mem (SCM.constant_symbol name) params) couplings.input let rec depends_on params = function | I | Integer _ | Float _ -> false | Atom name -> List.mem (SCM.constant_symbol name) params | Sum es | Prod es -> List.exists (depends_on params) es | Diff (e1, e2) | Quot (e1, e2) | PowX (e1, e2) -> depends_on params e1 || depends_on params e2 | Neg e | Rec e | Pow (e, _) -> depends_on params e | Sqrt e | Exp e | Log e | Log10 e | Sin e | Cos e | Tan e | Cot e | Asin e | Acos e | Atan e | Sinh e | Cosh e | Tanh e | Conj e | Abs e -> depends_on params e | Atan2 (e1, e2) -> depends_on params e1 || depends_on params e2 let dependencies params couplings = if contains params couplings then List.rev (fst (List.fold_left (fun (deps, plist) (param, v) -> match param with | Real name | Complex name -> if depends_on plist v then ((param, v) :: deps, CM.constant_symbol name :: plist) else (deps, plist)) ([], params) couplings.derived)) else [] let dependencies_arrays params couplings = if contains params couplings then List.rev (fst (List.fold_left (fun (deps, plist) (param, vlist) -> match param with | Real_Array name | Complex_Array name -> if List.exists (depends_on plist) vlist then ((param, vlist) :: deps, CM.constant_symbol name :: plist) else (deps, plist)) ([], params) couplings.derived_arrays)) else [] let parameters_to_fortran oc params = Format_Fortran.set_formatter_out_channel ~width:!line_length oc; let declarations = classify_parameters params in printf "module %s" !parameter_module; nl (); printf " use kinds"; nl (); printf " use constants"; nl (); printf " implicit none"; nl (); printf " private"; nl (); printf " @[<2>public :: setup_parameters"; printf ",@ import_from_whizard"; printf ",@ model_update_alpha_s"; if !no_write then begin printf "! No print_parameters"; end else begin printf ",@ print_parameters"; end; nl (); declare_default_parameters "real" params.input; declare_parameters "real" (schisma 69 declarations.real_singles); List.iter (declare_parameter_array "real") declarations.real_arrays; declare_parameters "complex" (schisma 69 declarations.complex_singles); List.iter (declare_parameter_array "complex") declarations.complex_arrays; printf " interface cconjg"; nl (); printf " module procedure cconjg_real, cconjg_complex"; nl (); printf " end interface"; nl (); printf " private :: cconjg_real, cconjg_complex"; nl (); printf "contains"; nl (); printf " function cconjg_real (x) result (xc)"; nl (); printf " real(kind=default), intent(in) :: x"; nl (); printf " real(kind=default) :: xc"; nl (); printf " xc = x"; nl (); printf " end function cconjg_real"; nl (); printf " function cconjg_complex (z) result (zc)"; nl (); printf " complex(kind=default), intent(in) :: z"; nl (); printf " complex(kind=default) :: zc"; nl (); printf " zc = conjg (z)"; nl (); printf " end function cconjg_complex"; nl (); printf " ! derived parameters:"; nl (); let shredded = schisma_num 1 120 params.derived in let shredded_arrays = schisma_num 1 120 params.derived_arrays in let num_sub = List.length shredded in let num_sub_arrays = List.length shredded_arrays in List.iter (fun (i,l) -> eval_para_list i l) shredded; List.iter (fun (i,l) -> eval_para_pair_list (num_sub + i) l) shredded_arrays; printf " subroutine setup_parameters ()"; nl (); for i = 1 to num_sub + num_sub_arrays do printf " call setup_parameters_%03d ()" i; nl (); done; printf " end subroutine setup_parameters"; nl (); printf " subroutine import_from_whizard (par_array, scheme)"; nl (); printf " real(%s), dimension(%d), intent(in) :: par_array" !kind (List.length params.input); nl (); printf " integer, intent(in) :: scheme"; nl (); let i = ref 1 in List.iter (fun (p, _) -> printf " %s = par_array(%d)" (SCM.constant_symbol p) !i; nl (); incr i) params.input; printf " call setup_parameters ()"; nl (); printf " end subroutine import_from_whizard"; nl (); printf " subroutine model_update_alpha_s (alpha_s)"; nl (); printf " real(%s), intent(in) :: alpha_s" !kind; nl (); begin match (dependencies ["aS"] params, dependencies_arrays ["aS"] params) with | [], [] -> printf " ! 'aS' not among the input parameters"; nl (); | deps, deps_arrays -> printf " aS = alpha_s"; nl (); List.iter eval_parameter deps; List.iter eval_parameter_pair deps_arrays end; printf " end subroutine model_update_alpha_s"; nl (); if !no_write then begin printf "! No print_parameters"; nl (); end else begin printf " subroutine print_parameters ()"; nl (); printf " @[<2>character(len=*), parameter ::"; printf "@ fmt_real = \"(A12,4X,' = ',E25.18)\","; printf "@ fmt_complex = \"(A12,4X,' = ',E25.18,' + i*',E25.18)\","; printf "@ fmt_real_array = \"(A12,'(',I2.2,')',' = ',E25.18)\","; printf "@ fmt_complex_array = "; printf "\"(A12,'(',I2.2,')',' = ',E25.18,' + i*',E25.18)\""; nl (); printf " @[<2>write (unit = *, fmt = \"(A)\") @,"; printf "\"default values for the input parameters:\""; nl (); List.iter (fun (p, _) -> print_echo "real" p) params.input; printf " @[<2>write (unit = *, fmt = \"(A)\") @,"; printf "\"derived parameters:\""; nl (); List.iter (print_echo "real") declarations.real_singles; List.iter (print_echo "complex") declarations.complex_singles; List.iter (print_echo_array "real") declarations.real_arrays; List.iter (print_echo_array "complex") declarations.complex_arrays; printf " end subroutine print_parameters"; nl (); end; printf "end module %s" !parameter_module; nl () (* \thocwmodulesubsection{Run-Time Diagnostics} *) type diagnostic = All | Arguments | Momenta | Gauge type diagnostic_mode = Off | Warn | Panic let warn mode = match !mode with | Off -> false | Warn -> true | Panic -> true let panic mode = match !mode with | Off -> false | Warn -> false | Panic -> true let suffix mode = if panic mode then "panic" else "warn" let diagnose_arguments = ref Off let diagnose_momenta = ref Off let diagnose_gauge = ref Off let rec parse_diagnostic = function | All, panic -> parse_diagnostic (Arguments, panic); parse_diagnostic (Momenta, panic); parse_diagnostic (Gauge, panic) | Arguments, panic -> diagnose_arguments := if panic then Panic else Warn | Momenta, panic -> diagnose_momenta := if panic then Panic else Warn | Gauge, panic -> diagnose_gauge := if panic then Panic else Warn (* If diagnostics are required, we have to switch off Fortran95 features like pure functions. *) let parse_diagnostics = function | [] -> () | diagnostics -> fortran95 := false; List.iter parse_diagnostic diagnostics (* \thocwmodulesubsection{Amplitude} *) let declare_momenta_chunk = function | [] -> () | momenta -> printf " @[<2>type(momentum) :: "; print_list (List.map format_momentum momenta); nl () let declare_momenta = function | [] -> () | momenta -> List.iter declare_momenta_chunk (ThoList.chopn declaration_chunk_size momenta) let declare_wavefunctions multiplicity wfs = let wfs' = classify_wfs wfs in declare_list multiplicity ("complex(kind=" ^ !kind ^ ")") (wfs'.scalars @ wfs'.brs_scalars); declare_list multiplicity ("type(" ^ Names.psi_type ^ ")") (wfs'.spinors @ wfs'.brs_spinors); declare_list multiplicity ("type(" ^ Names.psibar_type ^ ")") (wfs'.conjspinors @ wfs'.brs_conjspinors); declare_list multiplicity ("type(" ^ Names.chi_type ^ ")") (wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors); declare_list multiplicity ("type(" ^ Names.grav_type ^ ")") wfs'.vectorspinors; declare_list multiplicity "type(vector)" (wfs'.vectors @ wfs'.massive_vectors @ wfs'.brs_vectors @ wfs'.brs_massive_vectors @ wfs'.ward_vectors); declare_list multiplicity "type(tensor2odd)" wfs'.tensors_1; declare_list multiplicity "type(tensor)" wfs'.tensors_2 let flavors a = F.incoming a @ F.outgoing a - let declare_brakets_chunk = function + let declare_brakets_chunk ?orders = function | [] -> () | amplitudes -> printf " @[<2>complex(kind=%s) :: " !kind; - print_list (List.map (fun a -> flavors_symbol ~decl:true (flavors a)) amplitudes); nl () + print_list (List.map (fun a -> flavors_symbol ~decl:true ?orders (flavors a)) amplitudes); nl () - let declare_brakets = function + let declare_brakets ?orders = function | [] -> () | amplitudes -> List.iter - declare_brakets_chunk + (declare_brakets_chunk ?orders) (ThoList.chopn declaration_chunk_size amplitudes) let print_variable_declarations amplitudes = let multiplicity = CF.multiplicity amplitudes and processes = CF.processes amplitudes in if not !amp_triv then begin declare_momenta (PSet.elements (List.fold_left (fun set a -> PSet.union set (List.fold_right (fun wf -> PSet.add (F.momentum_list wf)) (F.externals a) PSet.empty)) PSet.empty processes)); declare_momenta (PSet.elements (List.fold_left (fun set a -> PSet.union set (List.fold_right (fun wf -> PSet.add (F.momentum_list wf)) (F.variables a) PSet.empty)) PSet.empty processes)); if !openmp then begin printf " type %s@[<2>" openmp_tld_type; nl (); end ; declare_wavefunctions multiplicity (WFSet.elements (List.fold_left (fun set a -> WFSet.union set (List.fold_right WFSet.add (F.externals a) WFSet.empty)) WFSet.empty processes)); declare_wavefunctions multiplicity (WFSet.elements (List.fold_left (fun set a -> WFSet.union set (List.fold_right WFSet.add (F.variables a) WFSet.empty)) WFSet.empty processes)); declare_brakets processes; if !openmp then begin printf "@] end type %s\n" openmp_tld_type; printf " type(%s) :: %s" openmp_tld_type openmp_tld; nl (); end; end (* [print_current] is the most important function that has to match the functions in \verb+omega95+ (see appendix~\ref{sec:fortran}). It offers plentiful opportunities for making mistakes, in particular those related to signs. We start with a few auxiliary functions: *) let children2 rhs = match F.children rhs with | [wf1; wf2] -> (wf1, wf2) | _ -> failwith "Targets.children2: can't happen" let children3 rhs = match F.children rhs with | [wf1; wf2; wf3] -> (wf1, wf2, wf3) | _ -> invalid_arg "Targets.children3: can't happen" let print_current amplitude dictionary rhs = let module Vintage = Targets_vintage.Make_Fortran(Names)(Vintage_Fermions)(Fusion_Maker)(P)(M) in match F.coupling rhs with | V3 (vertex, fusion, constant) -> Vintage.print_current_V3 multiple_variable momentum amplitude dictionary rhs vertex fusion constant | V4 (vertex, fusion, constant) -> Vintage.print_current_V4 multiple_variable momentum amplitude dictionary rhs vertex fusion constant (* \begin{dubious} This reproduces the hack on page~\pageref{hack:sign(V4)} and gives the correct results up to quartic vertices. Make sure that it is also correct in light of~\eqref{eq:factors-of-i}, i.\,e. \begin{equation*} \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots = \ii^{n-2}\ii^{n-3} \cdots = -\ii(-1)^n \cdots \end{equation*} \end{dubious} *) | Vn (UFO (c, v, s, fl, color), fusion, constant) -> if Birdtracks.is_unit color then let g = CM.constant_symbol constant and chn = F.children rhs in let wfs = List.map (multiple_variable amplitude dictionary) chn and ps = List.map momentum chn in let n = List.length fusion in let eps = if n mod 2 = 0 then -1 else 1 in printf "@, %s " (if (eps * F.sign rhs) < 0 then "-" else "+"); UFO.Targets.Fortran.fuse c v s fl g wfs ps fusion else failwith "print_current: nontrivial color structure" let print_propagator f p m gamma = let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in let w = begin match SCM.width f with | Vanishing | Fudged -> "0.0_" ^ !kind | Constant | Complex_Mass -> gamma | Timelike -> "wd_tl(" ^ p ^ "," ^ gamma ^ ")" | Running -> "wd_run(" ^ p ^ "," ^ m ^ "," ^ gamma ^ ")" | Custom f -> f ^ "(" ^ p ^ "," ^ gamma ^ ")" end in let cms = begin match SCM.width f with | Complex_Mass -> ".true." | _ -> ".false." end in match SCM.propagator f with | Prop_Scalar -> printf "pr_phi(%s,%s,%s," p m w | Prop_Col_Scalar -> printf "%s * pr_phi(%s,%s,%s," minus_third p m w | Prop_Ghost -> printf "(0,1) * pr_phi(%s, %s, %s," p m w | Prop_Spinor -> printf "%s(%s,%s,%s,%s," Names.psi_propagator p m w cms | Prop_ConjSpinor -> printf "%s(%s,%s,%s,%s," Names.psibar_propagator p m w cms | Prop_Majorana -> printf "%s(%s,%s,%s,%s," Names.chi_propagator p m w cms | Prop_Col_Majorana -> printf "%s * %s(%s,%s,%s,%s," minus_third Names.chi_propagator p m w cms | Prop_Unitarity -> printf "pr_unitarity(%s,%s,%s,%s," p m w cms | Prop_Col_Unitarity -> printf "%s * pr_unitarity(%s,%s,%s,%s," minus_third p m w cms | Prop_Feynman -> printf "pr_feynman(%s," p | Prop_Col_Feynman -> printf "%s * pr_feynman(%s," minus_third p | Prop_Gauge xi -> printf "pr_gauge(%s,%s," p (SCM.gauge_symbol xi) | Prop_Rxi xi -> printf "pr_rxi(%s,%s,%s,%s," p m w (SCM.gauge_symbol xi) | Prop_Tensor_2 -> printf "pr_tensor(%s,%s,%s," p m w | Prop_Tensor_pure -> printf "pr_tensor_pure(%s,%s,%s," p m w | Prop_Vector_pure -> printf "pr_vector_pure(%s,%s,%s," p m w | Prop_Vectorspinor -> printf "pr_grav(%s,%s,%s," p m w | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana | Aux_Vector | Aux_Tensor_1 -> printf "(" | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third | Only_Insertion -> printf "(" | Prop_UFO name -> printf "pr_U_%s(%s,%s,%s," name p m w let print_projector f p m gamma = let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in match SCM.propagator f with | Prop_Scalar -> printf "pj_phi(%s,%s," m gamma | Prop_Col_Scalar -> printf "%s * pj_phi(%s,%s," minus_third m gamma | Prop_Ghost -> printf "(0,1) * pj_phi(%s,%s," m gamma | Prop_Spinor -> printf "%s(%s,%s,%s," Names.psi_projector p m gamma | Prop_ConjSpinor -> printf "%s(%s,%s,%s," Names.psibar_projector p m gamma | Prop_Majorana -> printf "%s(%s,%s,%s," Names.chi_projector p m gamma | Prop_Col_Majorana -> printf "%s * %s(%s,%s,%s," minus_third Names.chi_projector p m gamma | Prop_Unitarity -> printf "pj_unitarity(%s,%s,%s," p m gamma | Prop_Col_Unitarity -> printf "%s * pj_unitarity(%s,%s,%s," minus_third p m gamma | Prop_Feynman | Prop_Col_Feynman -> invalid_arg "no on-shell Feynman propagator!" | Prop_Gauge _ -> invalid_arg "no on-shell massless gauge propagator!" | Prop_Rxi _ -> invalid_arg "no on-shell Rxi propagator!" | Prop_Vectorspinor -> printf "pj_grav(%s,%s,%s," p m gamma | Prop_Tensor_2 -> printf "pj_tensor(%s,%s,%s," p m gamma | Prop_Tensor_pure -> invalid_arg "no on-shell pure Tensor propagator!" | Prop_Vector_pure -> invalid_arg "no on-shell pure Vector propagator!" | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana | Aux_Vector | Aux_Tensor_1 -> printf "(" | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third | Only_Insertion -> printf "(" | Prop_UFO name -> invalid_arg "no on shell UFO propagator" let print_gauss f p m gamma = let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in match SCM.propagator f with | Prop_Scalar -> printf "pg_phi(%s,%s,%s," p m gamma | Prop_Ghost -> printf "(0,1) * pg_phi(%s,%s,%s," p m gamma | Prop_Spinor -> printf "%s(%s,%s,%s," Names.psi_projector p m gamma | Prop_ConjSpinor -> printf "%s(%s,%s,%s," Names.psibar_projector p m gamma | Prop_Majorana -> printf "%s(%s,%s,%s," Names.chi_projector p m gamma | Prop_Col_Majorana -> printf "%s * %s(%s,%s,%s," minus_third Names.chi_projector p m gamma | Prop_Unitarity -> printf "pg_unitarity(%s,%s,%s," p m gamma | Prop_Feynman | Prop_Col_Feynman -> invalid_arg "no on-shell Feynman propagator!" | Prop_Gauge _ -> invalid_arg "no on-shell massless gauge propagator!" | Prop_Rxi _ -> invalid_arg "no on-shell Rxi propagator!" | Prop_Tensor_2 -> printf "pg_tensor(%s,%s,%s," p m gamma | Prop_Tensor_pure -> invalid_arg "no pure tensor propagator!" | Prop_Vector_pure -> invalid_arg "no pure vector propagator!" | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana | Aux_Vector | Aux_Tensor_1 -> printf "(" | Only_Insertion -> printf "(" | Prop_UFO name -> invalid_arg "no UFO gauss insertion" | _ -> invalid_arg "targets:print_gauss: not available" let print_fusion_diagnostics amplitude dictionary fusion = if warn diagnose_gauge then begin let lhs = F.lhs fusion in let f = F.flavor lhs and v = variable lhs and p = momentum lhs in let mass = SCM.mass_symbol f in match SCM.propagator f with | Prop_Gauge _ | Prop_Feynman | Prop_Rxi _ | Prop_Unitarity -> printf " @[<2>%s =" v; List.iter (print_current amplitude dictionary) (F.rhs fusion); nl (); begin match SCM.goldstone f with | None -> printf " call omega_ward_%s(\"%s\",%s,%s,%s)" (suffix diagnose_gauge) v mass p v; nl () | Some (g, phase) -> let gv = SCM.flavor_symbol g ^ "_" ^ format_p lhs in printf " call omega_slavnov_%s" (suffix diagnose_gauge); printf "(@[\"%s\",%s,%s,%s,@,%s*%s)" v mass p v (format_constant phase) gv; nl () end | _ -> () end let print_fusion amplitude dictionary fusion = let lhs = F.lhs fusion in let f = F.flavor lhs in printf " @[<2>%s =@, " (multiple_variable amplitude dictionary lhs); if F.on_shell amplitude lhs then print_projector f (momentum lhs) (SCM.mass_symbol f) (SCM.width_symbol f) else if F.is_gauss amplitude lhs then print_gauss f (momentum lhs) (SCM.mass_symbol f) (SCM.width_symbol f) else print_propagator f (momentum lhs) (SCM.mass_symbol f) (SCM.width_symbol f); List.iter (print_current amplitude dictionary) (F.rhs fusion); printf ")"; nl () let print_momenta seen_momenta amplitude = List.fold_left (fun seen f -> let wf = F.lhs f in let p = F.momentum_list wf in if not (PSet.mem p seen) then begin let rhs1 = List.hd (F.rhs f) in printf " %s = %s" (momentum wf) (String.concat " + " (List.map momentum (F.children rhs1))); nl () end; PSet.add p seen) seen_momenta (F.fusions amplitude) let print_fusions dictionary fusions = List.iter (fun (f, amplitude) -> print_fusion_diagnostics amplitude dictionary f; print_fusion amplitude dictionary f) fusions (* \begin{dubious} The following will need a bit more work, because the decision when to [reverse_braket] for UFO models with Majorana fermions needs collaboration from [UFO.Targets.Fortran.fuse] which is called by [print_current]. See the function [UFO_targets.Fortran.jrr_print_majorana_current_transposing] for illustration (the function is never used and only for documentation). \end{dubious} *) let spins_of_rhs rhs = List.map (fun wf -> SCM.lorentz (F.flavor wf)) (F.children rhs) let spins_of_ket ket = match ThoList.uniq (List.map spins_of_rhs ket) with | [spins] -> spins | [] -> failwith "Targets.Fortran.spins_of_ket: empty" | _ -> [] (* HACK! *) let print_braket amplitude dictionary name braket = let bra = F.bra braket and ket = F.ket braket in let spin_bra = SCM.lorentz (F.flavor bra) and spins_ket = spins_of_ket ket in let vintage = true (* [F.vintage] *) in printf " @[<2>%s =@ %s@, + " name name; if Fermions.reverse_braket vintage spin_bra spins_ket then begin printf "@,("; List.iter (print_current amplitude dictionary) ket; printf ")*%s" (multiple_variable amplitude dictionary bra) end else begin printf "%s*@,(" (multiple_variable amplitude dictionary bra); List.iter (print_current amplitude dictionary) ket; printf ")" end; nl () (* \begin{equation} \label{eq:factors-of-i} \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots = \ii^{n-2}\ii^{n-3} \cdots = -\ii(-1)^n \cdots \end{equation} *) (* \begin{dubious} [tho:] we write some brakets twice using different names. Is it useful to cache them? \end{dubious} *) let print_braket_slice ?orders dictionary amplitude brakets = let name = flavors_symbol ?orders (flavors amplitude) in printf " %s = 0" name; nl (); List.iter (print_braket amplitude dictionary name) brakets; let n = List.length (F.externals amplitude) in if n mod 2 = 0 then begin printf " @[<2>%s =@, - %s ! %d vertices, %d propagators" name name (n - 2) (n - 3); nl () end else begin printf " ! %s = %s ! %d vertices, %d propagators" name name (n - 2) (n - 3); nl () end; let s = F.symmetry amplitude in if s > 1 then printf " @[<2>%s =@, %s@, / sqrt(%d.0_%s) ! symmetry factor" name name s !kind else printf " ! unit symmetry factor"; nl () let print_brakets dictionary amplitude = match F.brakets amplitude with |[([], brakets)] -> print_braket_slice dictionary amplitude brakets - |[(orders, brakets)] -> - Printf.eprintf "omega: implementation of coupling order slices not complete yet!\n"; - print_braket_slice ~orders dictionary amplitude brakets + |[(orders, brakets)] -> print_braket_slice ~orders dictionary amplitude brakets | slices -> - Printf.eprintf "omega: implementation of coupling order slices not complete yet!\n"; List.iter (fun (orders, brakets) -> print_braket_slice ~orders dictionary amplitude brakets) slices let print_incoming wf = let p = momentum wf and s = spin wf and f = F.flavor wf in let m = SCM.mass_symbol f in match SCM.lorentz f with | Scalar -> printf "1" | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m | Spinor -> printf "%s (%s, - %s, %s)" Names.psi_incoming m p s | BRS Spinor -> printf "%s (%s, - %s, %s)" Names.brs_psi_incoming m p s | ConjSpinor -> printf "%s (%s, - %s, %s)" Names.psibar_incoming m p s | BRS ConjSpinor -> printf "%s (%s, - %s, %s)" Names.brs_psibar_incoming m p s | Majorana -> printf "%s (%s, - %s, %s)" Names.chi_incoming m p s | Maj_Ghost -> printf "ghost (%s, - %s, %s)" m p s | BRS Majorana -> printf "%s (%s, - %s, %s)" Names.brs_chi_incoming m p s | Vector | Massive_Vector -> printf "eps (%s, - %s, %s)" m p s (*i | Ward_Vector -> printf "%s" p i*) | BRS Vector | BRS Massive_Vector -> printf "(0,1) * (%s * %s - %s**2) * eps (%s, -%s, %s)" p p m m p s | Vectorspinor | BRS Vectorspinor -> printf "%s (%s, - %s, %s)" Names.grav_incoming m p s | Tensor_1 -> invalid_arg "Tensor_1 only internal" | Tensor_2 -> printf "eps2 (%s, - %s, %s)" m p s | _ -> invalid_arg "no such BRST transformations" let print_outgoing wf = let p = momentum wf and s = spin wf and f = F.flavor wf in let m = SCM.mass_symbol f in match SCM.lorentz f with | Scalar -> printf "1" | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m | Spinor -> printf "%s (%s, %s, %s)" Names.psi_outgoing m p s | BRS Spinor -> printf "%s (%s, %s, %s)" Names.brs_psi_outgoing m p s | ConjSpinor -> printf "%s (%s, %s, %s)" Names.psibar_outgoing m p s | BRS ConjSpinor -> printf "%s (%s, %s, %s)" Names.brs_psibar_outgoing m p s | Majorana -> printf "%s (%s, %s, %s)" Names.chi_outgoing m p s | BRS Majorana -> printf "%s (%s, %s, %s)" Names.brs_chi_outgoing m p s | Maj_Ghost -> printf "ghost (%s, %s, %s)" m p s | Vector | Massive_Vector -> printf "conjg (eps (%s, %s, %s))" m p s (*i | Ward_Vector -> printf "%s" p i*) | BRS Vector | BRS Massive_Vector -> printf "(0,1) * (%s*%s-%s**2) * (conjg (eps (%s, %s, %s)))" p p m m p s | Vectorspinor | BRS Vectorspinor -> printf "%s (%s, %s, %s)" Names.grav_incoming m p s | Tensor_1 -> invalid_arg "Tensor_1 only internal" | Tensor_2 -> printf "conjg (eps2 (%s, %s, %s))" m p s | BRS _ -> invalid_arg "no such BRST transformations" let print_external_momenta amplitude = let externals = List.combine (F.externals amplitude) (List.map (fun _ -> true) (F.incoming amplitude) @ List.map (fun _ -> false) (F.outgoing amplitude)) in - List.iter (fun (wf, incoming) -> - if incoming then - printf " %s = - k(:,%d) ! incoming" - (momentum wf) (ext_momentum wf) - else - printf " %s = k(:,%d) ! outgoing" - (momentum wf) (ext_momentum wf); nl ()) externals + 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 + (List.map (fun _ -> print_incoming) (F.incoming amplitude) @ + List.map (fun _ -> print_outgoing) (F.outgoing amplitude)) in + List.fold_left + (fun seen (wf, print_wf) -> + if not (WFSet.mem wf seen) then + begin + printf " @[<2>%s =@, " (variable wf); + print_wf wf; nl () + end; + WFSet.add wf seen) + seen_wfs externals let flavors_to_string flavors = String.concat " " (List.map (fun f -> CM.flavor_to_string (SCM.flavor_all_orders f)) flavors) let process_to_string amplitude = - flavors_to_string (F.incoming amplitude) ^ " -> " ^ - flavors_to_string (F.outgoing amplitude) + flavors_to_string (F.incoming amplitude) ^ " -> " ^ flavors_to_string (F.outgoing amplitude) let flavors_sans_color_to_string flavors = String.concat " " (List.map M.flavor_to_string flavors) let process_sans_color_to_string (fin, fout) = flavors_sans_color_to_string fin ^ " -> " ^ flavors_sans_color_to_string fout - let print_fudge_factor amplitude = - let name = flavors_symbol (flavors amplitude) in - List.iter (fun wf -> - let p = momentum wf - and f = F.flavor wf in - match SCM.width f with - | Fudged -> - let m = SCM.mass_symbol f - and w = SCM.width_symbol f in - printf " if (%s > 0.0_%s) then" w !kind; nl (); - printf " @[<2>%s = %s@ * (%s*%s - %s**2)" - name name p p m; - printf "@ / cmplx (%s*%s - %s**2, %s*%s, kind=%s)" - p p m m w !kind; nl (); - printf " end if"; nl () - | _ -> ()) (F.s_channel amplitude) + let print_fudge_factor ?orders amplitude = + let name = flavors_symbol ?orders (flavors amplitude) in + List.iter + (fun wf -> + let p = momentum wf + and f = F.flavor wf in + match SCM.width f with + | Fudged -> + let m = SCM.mass_symbol f + and w = SCM.width_symbol f in + printf " if (%s > 0.0_%s) then" w !kind; nl (); + printf " @[<2>%s = %s@ * (%s*%s - %s**2)" name name p p m; + printf "@ / cmplx (%s*%s - %s**2, %s*%s, kind=%s)" p p m m w !kind; nl (); + printf " end if"; nl () + | _ -> ()) + (F.s_channel amplitude) let num_helicities amplitudes = List.length (CF.helicities amplitudes) - let num_coupling_orders amplitudes = + let coupling_orders amplitudes = match CF.coupling_orders amplitudes with - | None -> 0 - | Some (co_list, _) -> List.length co_list + | None -> [] + | Some (co_list, _) -> co_list - let num_coupling_order_powers amplitudes = + let num_coupling_orders amplitudes = + List.length (coupling_orders amplitudes) + + let len_coupling_orders amplitudes = + ThoString.max_length (List.map CM.coupling_order_to_string (coupling_orders amplitudes)) + + let num_coupling_powers amplitudes = match CF.coupling_orders amplitudes with - | None -> 0 - | Some (_, powers) -> List.length powers + | None -> 1 + | Some (_, powers) -> max 1 (List.length powers) (* \thocwmodulesubsection{Spin, Flavor \&\ Color Tables} *) (* The following abomination is required to keep the number of continuation lines as low as possible. FORTRAN77-style \texttt{DATA} statements are actually a bit nicer here, but they are not available for \emph{constant} arrays. *) (* \begin{dubious} We used to have a more elegant design with a sentinel~0 added to each initializer, but some revisions of the Compaq/Digital Compiler have a bug that causes them to reject this variant. \end{dubious} *) (* \begin{dubious} The actual table writing code using \texttt{reshape} should be factored, since it's the same algorithm every time. \end{dubious} *) let print_integer_parameter name value = printf " @[<2>integer, parameter :: %s = %d" name value; nl () let print_real_parameter name value = printf " @[<2>real(kind=%s), parameter :: %s = %d" !kind name value; nl () let print_logical_parameter name value = printf " @[<2>logical, parameter :: %s = .%s." name (if value then "true" else "false"); nl () let num_particles_in amplitudes = match CF.flavors amplitudes with | [] -> 0 | (fin, _) :: _ -> List.length fin let num_particles_out amplitudes = match CF.flavors amplitudes with | [] -> 0 | (_, fout) :: _ -> List.length fout let num_particles amplitudes = match CF.flavors amplitudes with | [] -> 0 | (fin, fout) :: _ -> List.length fin + List.length fout module CFlow = Color.Flow let num_color_flows amplitudes = if !amp_triv then 1 else List.length (CF.color_flows amplitudes) let num_color_indices_default = 2 (* Standard model *) let num_color_indices amplitudes = try CFlow.rank (List.hd (CF.color_flows amplitudes)) with _ -> num_color_indices_default let color_to_string c = "(" ^ (String.concat "," (List.map (Printf.sprintf "%3d") c)) ^ ")" let cflow_to_string cflow = String.concat " " (List.map color_to_string (CFlow.in_to_lists cflow)) ^ " -> " ^ String.concat " " (List.map color_to_string (CFlow.out_to_lists cflow)) let protected = ", protected" (* Fortran 2003! *) let print_coupling_orders_table amplitudes = - printf " @[<2>integer, dimension(n_co,n_cop), save%s :: table_coupling_orders" protected; nl (); + begin match List.map CM.coupling_order_to_string (coupling_orders amplitudes) with + | [] -> + printf " @[<2>character(len=0), dimension(n_co), save%s :: table_coupling_orders" protected; nl (); + | co_head :: co_tail -> + printf " @[<2>character(len=n_co_len), dimension(n_co), save%s :: table_coupling_orders" protected; + nl (); + printf " @[<2>data table_coupling_orders / \"%s\"" co_head; + List.iter (fun co -> printf ",@ \"%s\"" co) co_tail; + printf " /"; + nl () + end; + nl () + + let print_coupling_powers_table amplitudes = + printf " @[<2>integer, dimension(n_co,n_cp), save%s :: table_coupling_powers" protected; nl (); begin match CF.coupling_orders amplitudes with | None | Some (_, []) -> () | Some (_, powers) -> List.iteri (fun i powers -> - printf " @[<2>data table_coupling_orders(:,%4d) / %s /" (succ i) + printf " @[<2>data table_coupling_powers(:,%4d) / %s /" (succ i) (String.concat ", " (List.map (Printf.sprintf "%2d") powers)); nl ()) powers end; nl () let print_spin_table name tuples = printf " @[<2>integer, dimension(n_prt,n_hel), save%s :: table_spin_%s" protected name; nl (); match tuples with | [] -> () | _ -> List.iteri (fun i (tuple1, tuple2) -> printf " @[<2>data table_spin_%s(:,%4d) / %s /" name (succ i) (String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2))); nl ()) tuples let print_spin_tables amplitudes = print_spin_table "states" (CF.helicities amplitudes); nl () let print_flavor_table name tuples = printf " @[<2>integer, dimension(n_prt,n_flv), save%s :: table_flavor_%s" protected name; nl (); match tuples with | [] -> () | _ -> List.iteri (fun i tuple -> printf " @[<2>data table_flavor_%s(:,%4d) / %s / ! %s" name (succ i) (String.concat ", " (List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple)) (String.concat " " (List.map M.flavor_to_string tuple)); nl ()) tuples let print_flavor_tables amplitudes = print_flavor_table "states" (List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes)); nl () let num_flavors amplitudes = List.length (CF.flavors amplitudes) let print_color_flows_table tuples = if !amp_triv then begin printf " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows = 0" protected; nl (); end else begin printf " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows" protected; nl (); end; if not !amp_triv then begin match tuples with | [] -> () | _ :: _ as tuples -> List.iteri (fun i tuple -> begin match CFlow.to_lists tuple with | [] -> () | cf1 :: cfn -> printf " @[<2>data table_color_flows(:,:,%4d) /" (succ i); printf "@ %s" (String.concat "," (List.map string_of_int cf1)); List.iter (fun cf -> printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn; printf "@ /"; nl () end) tuples end let print_ghost_flags_table tuples = if !amp_triv then begin printf " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags = F" protected; nl (); end else begin printf " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags" protected; nl (); match tuples with | [] -> () | _ -> List.iteri (fun i tuple -> begin match CFlow.ghost_flags tuple with | [] -> () | gf1 :: gfn -> printf " @[<2>data table_ghost_flags(:,%4d) /" (succ i); printf "@ %s" (if gf1 then "T" else "F"); List.iter (fun gf -> printf ",@ %s" (if gf then "T" else "F")) gfn; printf " /"; nl () end) tuples end let format_power_of x { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } = match num, den, pwr with | _, 0, _ -> invalid_arg "format_power_of: zero denominator" | 0, _, _ -> "+zero" | 1, 1, 0 | -1, -1, 0 -> "+one" | -1, 1, 0 | 1, -1, 0 -> "-one" | 1, 1, 1 | -1, -1, 1 -> "+" ^ x | -1, 1, 1 | 1, -1, 1 -> "-" ^ x | 1, 1, -1 | -1, -1, -1 -> "+1/" ^ x | -1, 1, -1 | 1, -1, -1 -> "-1/" ^ x | 1, 1, p | -1, -1, p -> "+" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p) | -1, 1, p | 1, -1, p -> "-" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p) | n, 1, 0 -> (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind | n, d, 0 -> (if n * d < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^ string_of_int (abs d) | n, 1, 1 -> (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "*" ^ x | n, 1, -1 -> (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "/" ^ x | n, d, 1 -> (if n * d < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^ string_of_int (abs d) ^ "*" ^ x | n, d, -1 -> (if n * d < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^ string_of_int (abs d) ^ "/" ^ x | n, 1, p -> (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p) | n, d, p -> (if n * d < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^ string_of_int (abs d) ^ (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p) let format_powers_of x = function | [] -> "zero" | powers -> String.concat "" (List.map (format_power_of x) powers) - (*i unused value - let print_color_factor_table_old table = - let n_cflow = Array.length table in - let n_cfactors = ref 0 in - for c1 = 0 to pred n_cflow do - for c2 = 0 to pred n_cflow do - match table.(c1).(c2) with - | [] -> () - | _ -> incr n_cfactors - done - done; - print_integer_parameter "n_cfactors" !n_cfactors; - if n_cflow <= 0 then begin - printf " @[<2>type(%s), dimension(n_cfactors) ::" - omega_color_factor_abbrev; - printf "@ table_color_factors"; nl () - end else begin - printf - " @[<2>type(%s), dimension(n_cfactors), parameter ::" - omega_color_factor_abbrev; - printf "@ table_color_factors = (/@ "; - let comma = ref "" in - for c1 = 0 to pred n_cflow do - for c2 = 0 to pred n_cflow do - match table.(c1).(c2) with - | [] -> () - | cf -> - printf "%s@ %s(%d,%d,%s)" !comma omega_color_factor_abbrev - (succ c1) (succ c2) (format_powers_of nc_parameter cf); - comma := "," - done - done; - printf "@ /)"; nl () - end - i*) - (* \begin{dubious} We can optimize the following slightly by reusing common color factor [parameter]s. \end{dubious} *) let print_color_factor_table table = let n_cflow = Array.length table in let n_cfactors = ref 0 in for c1 = 0 to pred n_cflow do for c2 = 0 to pred n_cflow do match table.(c1).(c2) with | [] -> () | _ -> incr n_cfactors done done; print_integer_parameter "n_cfactors" !n_cfactors; printf " @[<2>type(%s), dimension(n_cfactors), save%s ::" omega_color_factor_abbrev protected; printf "@ table_color_factors"; nl (); if not !amp_triv then begin let i = ref 1 in if n_cflow > 0 then begin for c1 = 0 to pred n_cflow do for c2 = 0 to pred n_cflow do match table.(c1).(c2) with | [] -> () | cf -> printf " @[<2>real(kind=%s), parameter, private :: color_factor_%06d = %s" !kind !i (format_powers_of nc_parameter cf); nl (); printf " @[<2>data table_color_factors(%6d) / %s(%d,%d,color_factor_%06d) /" !i omega_color_factor_abbrev (succ c1) (succ c2) !i; incr i; nl (); done done end; end let print_color_tables amplitudes = let cflows = CF.color_flows amplitudes and cfactors = CF.color_factors amplitudes in - (* [print_color_flows_table_old "c" cflows; nl ();] *) print_color_flows_table cflows; nl (); - (* [print_ghost_flags_table_old "g" cflows; nl ();] *) print_ghost_flags_table cflows; nl (); - (* [print_color_factor_table_old cfactors; nl ();] *) print_color_factor_table cfactors; nl () let option_to_logical = function | Some _ -> "T" | None -> "F" - (*i unused value - let print_flavor_color_table_old abbrev n_flv n_cflow table = - if n_flv <= 0 || n_cflow <= 0 then begin - printf " @[<2>logical, dimension(n_flv, n_cflow) ::"; - printf "@ flv_col_is_allowed"; nl () - end else begin - for c = 0 to pred n_cflow do - printf - " @[<2>logical, dimension(n_flv), parameter, private ::"; - printf "@ %s%04d = (/@ %s" abbrev (succ c) (option_to_logical table.(0).(c)); - for f = 1 to pred n_flv do - printf ",@ %s" (option_to_logical table.(f).(c)) - done; - printf "@ /)"; nl () - done; - printf - " @[<2>logical, dimension(n_flv, n_cflow), parameter ::"; - printf "@ flv_col_is_allowed_old =@ reshape ( (/@ %s%04d" abbrev 1; - for c = 1 to pred n_cflow do - printf ",@ %s%04d" abbrev (succ c) - done; - printf "@ /),@ (/ n_flv, n_cflow /) )"; nl () - end - i*) - let print_flavor_color_table n_flv n_cflow table = if !amp_triv then begin printf - " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed = T" + " @[<2>logical, dimension(n_flv,n_cflow), save%s :: @ flv_col_is_allowed = T" protected; nl (); end else begin printf - " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed" + " @[<2>logical, dimension(n_flv,n_cflow), save%s :: @ flv_col_is_allowed" protected; nl (); if n_flv > 0 then begin for c = 0 to pred n_cflow do printf " @[<2>data flv_col_is_allowed(:,%4d) /" (succ c); printf "@ %s" (option_to_logical table.(0).(c)); for f = 1 to pred n_flv do printf ",@ %s" (option_to_logical table.(f).(c)) done; printf "@ /"; nl () done; end; end + let print_orders_flavor_color_table n_orders n_flv n_cflow table = + if !amp_triv then begin + printf + " @[<2>logical, dimension(n_cp,n_flv,n_cflow), save%s :: @ co_flv_col_is_allowed = T" + protected; nl (); + end + else begin + printf + " @[<2>logical, dimension(n_cp,n_flv,n_cflow), save%s :: @ co_flv_col_is_allowed" + protected; nl (); + if n_flv > 0 then begin + for c = 0 to pred n_cflow do + for f = 0 to pred n_flv do + printf + " @[<2>data co_flv_col_is_allowed(:,%4d,%4d) /" (succ f) (succ c); + printf "@ %s" (option_to_logical table.(0).(f).(c)); + for co = 1 to pred n_orders do + printf ",@ %s" (option_to_logical table.(co).(f).(c)) + done; + printf "@ /"; nl () + done + done + end + end + + let _print_orders_flavor_color_table n_orders n_flv n_cflow table = + () + 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 (); + print_orders_flavor_color_table + (match CF.coupling_orders a with None -> 1 | Some (_, co) -> List.length co) + (num_flavors a) (List.length (CF.color_flows a)) (CF.process_table_new a); + nl (); printf - " @[<2>complex(kind=%s), dimension(n_flv, n_cflow, n_hel), save :: amp" !kind; + " @[<2>complex(kind=%s), dimension(n_flv,n_cflow,n_hel), save :: amp_all_orders" !kind; + nl (); + printf + " @[<2>complex(kind=%s), dimension(n_cp,n_flv,n_cflow,n_hel), save :: amp_by_orders" !kind; nl (); nl () let print_helicity_selection_table () = printf " @[<2>logical, dimension(n_hel), save :: "; printf "hel_is_allowed = T"; nl (); printf " @[<2>real(kind=%s), dimension(n_hel), save :: " !kind; printf "hel_max_abs = 0"; nl (); printf " @[<2>real(kind=%s), save :: " !kind; printf "hel_sum_abs = 0, "; printf "hel_threshold = 1E10_%s" !kind; nl (); printf " @[<2>integer, save :: "; printf "hel_count = 0, "; printf "hel_cutoff = 100"; nl (); printf " @[<2>integer :: "; printf "i"; nl (); printf " @[<2>integer, save, dimension(n_hel) :: "; printf "hel_map = (/(i, i = 1, n_hel)/)"; nl (); printf " @[<2>integer, save :: hel_finite = n_hel"; nl (); nl () (* \thocwmodulesubsection{Optional MD5 sum function} *) let print_md5sum_functions = function | Some s -> printf " @[<5>"; if !fortran95 then printf "pure "; printf "function md5sum ()"; nl (); printf " character(len=32) :: md5sum"; nl (); printf " ! DON'T EVEN THINK of modifying the following line!"; nl (); printf " md5sum = \"%s\"" s; nl (); printf " end function md5sum"; nl (); nl () | None -> () (* \thocwmodulesubsection{Maintenance \&\ Inquiry Functions} *) let print_maintenance_functions () = if !whizard then begin printf " subroutine init (par, scheme)"; nl (); printf " real(kind=%s), dimension(*), intent(in) :: par" !kind; nl (); printf " integer, intent(in) :: scheme"; nl (); printf " call import_from_whizard (par, scheme)"; nl (); printf " end subroutine init"; nl (); nl (); printf " subroutine final ()"; nl (); printf " end subroutine final"; nl (); nl (); printf " subroutine update_alpha_s (alpha_s)"; nl (); printf " real(kind=%s), intent(in) :: alpha_s" !kind; nl (); printf " call model_update_alpha_s (alpha_s)"; nl (); printf " end subroutine update_alpha_s"; nl (); nl () end let print_inquiry_function_openmp () = begin printf " pure function openmp_supported () result (status)"; nl (); printf " logical :: status"; nl (); printf " status = %s" (if !openmp then ".true." else ".false."); nl (); printf " end function openmp_supported"; nl (); nl () end - (*i unused value - let print_inquiry_function_declarations name = - printf " @[<2>public :: number_%s,@ %s" name name; - nl () - i*) - - (*i unused value - let print_numeric_inquiry_functions () = - printf " @[<5>"; if !fortran95 then printf "pure "; - printf "function number_particles_in () result (n)"; nl (); - printf " integer :: n"; nl (); - printf " n = n_in"; nl (); - printf " end function number_particles_in"; nl (); - nl (); - printf " @[<5>"; if !fortran95 then printf "pure "; - printf "function number_particles_out () result (n)"; nl (); - printf " integer :: n"; nl (); - printf " n = n_out"; nl (); - printf " end function number_particles_out"; nl (); - nl () - i*) - let print_external_mass_case flv (fin, fout) = printf " case (%3d)" (succ flv); nl (); List.iteri (fun i f -> printf " m(%2d) = %s" (succ i) (M.mass_symbol f); nl ()) (fin @ fout) let print_external_masses amplitudes = printf " @[<5>"; if !fortran95 then printf "pure "; printf "subroutine external_masses (m, flv)"; nl (); printf " real(kind=%s), dimension(:), intent(out) :: m" !kind; nl (); printf " integer, intent(in) :: flv"; nl (); printf " select case (flv)"; nl (); List.iteri print_external_mass_case (CF.flavors amplitudes); printf " end select"; nl (); printf " end subroutine external_masses"; nl (); nl () let print_numeric_inquiry_functions (f, v) = printf " @[<5>"; if !fortran95 then printf "pure "; printf "function %s () result (n)" f; nl (); printf " integer :: n"; nl (); printf " n = %s" v; nl (); printf " end function %s" f; nl (); nl () let print_inquiry_functions name = printf " @[<5>"; if !fortran95 then printf "pure "; printf "function number_%s () result (n)" name; nl (); printf " integer :: n"; nl (); printf " n = size (table_%s, dim=2)" name; nl (); printf " end function number_%s" name; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; printf "subroutine %s (a)" name; nl (); printf " integer, dimension(:,:), intent(out) :: a"; nl (); printf " a = table_%s" name; nl (); printf " end subroutine %s" name; nl (); nl () + (* Fortran doesn't allow subroutines +\begin{verbatim} + subroutine copy_allocatable_1 (exported, local) + dimension(:), allocatable, intent(inout) :: exported + dimension(:), intent(in) :: local + ... + end subroutine copy_allocatable_1 +\end{verbatim} + with assumed shape arguments that are not \texttt{allocatable}. + Therefore we have to generate a separate function for each table. *) + + (* We return allocated arrays. The subroutines can be used safely multiple times + on the same array, without generating memory leaks. If the shape of the array + to be returned has not changed, we just copy the contents, otherwise we + reallocate. Of course, if the caller calls the subroutines for many + different arrays, he is responsible for deallocating them after use. *) + + let dimension rank = + if rank > 0 then + "dimension(" ^ String.concat "," (ThoList.clone ":" rank) ^ ")" + else + invalid_arg "dimension: rank <= 0" + + type fortran_array = + | Integer of int + | Real of int + | Character of int + + let fortran_array_to_string = function + | Integer rank -> "integer, " ^ dimension rank + | Real rank -> "real(kind=default), " ^ dimension rank + | Character rank -> "character(len=:), " ^ dimension rank + + let print_table_inquiry_function name ?(table = "table_" ^ name) fortran_array = + printf " @[<5>"; if !fortran95 then printf "pure "; + printf "subroutine %s (exported)" name; nl (); + printf " %s, allocatable, intent(inout) :: exported" (fortran_array_to_string fortran_array); nl (); + printf " exported = %s" table; nl (); + printf " end subroutine %s" name; nl (); + nl () + + let _print_table_inquiry_function_explicit_allocation name ?(table = "table_" ^ name) fortran_array = + printf " @[<5>"; if !fortran95 then printf "pure "; + printf "subroutine %s (exported)" name; nl (); + printf " %s, allocatable, intent(inout) :: exported" (fortran_array_to_string fortran_array); nl (); + printf " if (allocated (exported)) then"; nl (); + printf " if (all (shape (exported) == shape (%s))) then" table; nl (); + printf " exported = %s" table; nl (); + printf " else"; nl (); + printf " deallocate (exported)"; nl (); + printf " allocate (exported, source=%s)" table; nl (); + printf " end if"; nl (); + printf " else"; nl (); + printf " allocate (exported, source=%s)" table; nl (); + printf " end if"; nl (); + printf " end subroutine %s" name; nl (); + nl () + + let print_coupling_orders_inquiry_functions () = + print_table_inquiry_function "coupling_orders" (Character 1); + print_table_inquiry_function "coupling_powers" (Integer 2) + let print_color_flows () = printf " @[<5>"; if !fortran95 then printf "pure "; printf "function number_color_indices () result (n)"; nl (); printf " integer :: n"; nl (); if !amp_triv then begin printf " n = n_cindex"; nl (); end else begin printf " n = size (table_color_flows, dim=1)"; nl (); end; printf " end function number_color_indices"; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; printf "function number_color_flows () result (n)"; nl (); printf " integer :: n"; nl (); if !amp_triv then begin printf " n = n_cflow"; nl (); end else begin printf " n = size (table_color_flows, dim=3)"; nl (); end; printf " end function number_color_flows"; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; printf "subroutine color_flows (a, g)"; nl (); printf " integer, dimension(:,:,:), intent(out) :: a"; nl (); printf " logical, dimension(:,:), intent(out) :: g"; nl (); printf " a = table_color_flows"; nl (); printf " g = table_ghost_flags"; nl (); printf " end subroutine color_flows"; nl (); nl () let print_color_factors () = printf " @[<5>"; if !fortran95 then printf "pure "; printf "function number_color_factors () result (n)"; nl (); printf " integer :: n"; nl (); printf " n = size (table_color_factors)"; nl (); printf " end function number_color_factors"; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; printf "subroutine color_factors (cf)"; nl (); printf " type(%s), dimension(:), intent(out) :: cf" omega_color_factor_abbrev; nl (); printf " cf = table_color_factors"; nl (); printf " end subroutine color_factors"; nl (); nl (); printf " @[<5>"; if !fortran95 && pure_unless_openmp then printf "pure "; printf "function color_sum (flv, hel) result (amp2)"; nl (); printf " integer, intent(in) :: flv, hel"; nl (); printf " real(kind=%s) :: amp2" !kind; nl (); - printf " amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"; nl (); + printf " amp2 = real (omega_color_sum (flv, hel, amp_all_orders, 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 " call calculate_amplitudes (amp_by_orders, p, hel_is_allowed)"; nl (); + printf " amp_all_orders = sum (amp_by_orders, dim=1)"; 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 " call @[<3>omega_update_helicity_selection@ (hel_count,@ amp_all_orders,@ "; printf "hel_max_abs,@ hel_sum_abs,@ hel_is_allowed,@ hel_threshold,@ hel_cutoff,@ mask_dirty)"; nl (); printf " if (mask_dirty) then"; nl (); printf " hel_finite = 0"; nl (); printf " do hel = 1, n_hel"; nl (); printf " if (hel_is_allowed(hel)) then"; nl (); printf " hel_finite = hel_finite + 1"; nl (); printf " hel_map(hel_finite) = hel"; nl (); printf " end if"; nl (); printf " end do"; nl (); printf " end if"; nl (); printf " end if"; nl (); printf " end subroutine new_event"; nl (); nl (); printf " @[<5>"; printf "subroutine reset_helicity_selection (threshold, cutoff)"; nl (); printf " real(kind=%s), intent(in) :: threshold" !kind; nl (); printf " integer, intent(in) :: cutoff"; nl (); printf " integer :: i"; nl (); printf " hel_is_allowed = T"; nl (); printf " hel_max_abs = 0"; nl (); printf " hel_sum_abs = 0"; nl (); printf " hel_count = 0"; nl (); printf " hel_threshold = threshold"; nl (); printf " hel_cutoff = cutoff"; nl (); printf " hel_map = (/(i, i = 1, n_hel)/)"; nl (); printf " hel_finite = n_hel"; nl (); printf " end subroutine reset_helicity_selection"; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; printf "function is_allowed (flv, hel, col) result (yorn)"; nl (); printf " logical :: yorn"; nl (); printf " integer, intent(in) :: flv, hel, col"; nl (); if !amp_triv then begin printf " ! print *, 'inside is_allowed'"; nl (); end; if not !amp_triv then begin printf " yorn = hel_is_allowed(hel) .and. "; printf "flv_col_is_allowed(flv,col)"; nl (); end else begin printf " yorn = .false."; nl (); end; printf " end function is_allowed"; nl (); nl (); printf " @[<5>"; if !fortran95 then printf "pure "; - printf "function get_amplitude (flv, hel, col) result (amp_result)"; nl (); - printf " complex(kind=%s) :: amp_result" !kind; nl (); + printf "function get_amplitude (flv, hel, col) result (amp)"; nl (); + printf " complex(kind=%s) :: amp" !kind; nl (); printf " integer, intent(in) :: flv, hel, col"; nl (); - printf " amp_result = amp(flv, col, hel)"; nl (); + printf " amp = amp_all_orders(flv, col, hel)"; nl (); printf " end function get_amplitude"; nl (); nl () (* \thocwmodulesubsection{Main Function} *) let format_power_of_nc { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } = match num, den, pwr with | _, 0, _ -> invalid_arg "format_power_of_nc: zero denominator" | 0, _, _ -> "" | 1, 1, 0 | -1, -1, 0 -> "+ 1" | -1, 1, 0 | 1, -1, 0 -> "- 1" | 1, 1, 1 | -1, -1, 1 -> "+ N" | -1, 1, 1 | 1, -1, 1 -> "- N" | 1, 1, -1 | -1, -1, -1 -> "+ 1/N" | -1, 1, -1 | 1, -1, -1 -> "- 1/N" | 1, 1, p | -1, -1, p -> "+ " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p) | -1, 1, p | 1, -1, p -> "- " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p) | n, 1, 0 -> (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) | n, d, 0 -> (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) | n, 1, 1 -> (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "N" | n, 1, -1 -> (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/N" | n, d, 1 -> (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "N" | n, d, -1 -> (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "/N" | n, 1, p -> (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p) | n, d, p -> (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p) let format_powers_of_nc = function | [] -> "0" | powers -> String.concat " " (List.map format_power_of_nc powers) let dump_amplitude_slices amplitudes = match CF.coupling_orders amplitudes with | None -> () | Some (co_list, cop_list) -> - printf "! coupling orders:"; nl (); + printf "! coupling orders appearing:"; nl (); printf "!"; nl (); - printf "! %s" (String.concat ", " (List.map CM.coupling_order_to_string co_list)); nl (); List.iter (fun cop_list -> - printf "! %s" (String.concat ", " (List.map string_of_int cop_list)); nl ()) + printf "! "; + List.iter2 + (fun co cp -> printf " %s=%d" (CM.coupling_order_to_string co) cp) + co_list cop_list; + nl ()) cop_list; - printf "!"; nl (); - List.iter - (fun amplitude -> - printf "! %s" (process_to_string amplitude); nl (); - match F.brakets amplitude with - | [] -> () - | lines -> - let order_to_string (order, n) = - Printf.sprintf "%s = %d" (CM.coupling_order_to_string order) n in - let orders_to_string orders = - String.concat ", " (List.map order_to_string orders) in - List.iter (fun (orders, _) -> printf "! %s" (orders_to_string orders); nl ()) lines; - printf "!"; nl ()) - (CF.processes amplitudes); printf "!"; nl () let print_description cmdline amplitudes () = printf "! File generated automatically by O'Mega %s %s %s" Config.version Config.status Config.date; nl (); List.iter (fun s -> printf "! %s" s; nl ()) (M.caveats ()); printf "!"; nl (); printf "! %s" cmdline; nl (); printf "!"; nl (); printf "! with all scattering amplitudes for the process(es)"; nl (); printf "!"; nl (); printf "! flavor combinations:"; nl (); printf "!"; nl (); ThoList.iteri (fun i process -> printf "! %3d: %s" i (process_sans_color_to_string process); nl ()) 1 (CF.flavors amplitudes); printf "!"; nl (); printf "! color flows:"; nl (); if not !amp_triv then begin printf "!"; nl (); ThoList.iteri (fun i cflow -> printf "! %3d: %s" i (cflow_to_string cflow); nl ()) 1 (CF.color_flows amplitudes); printf "!"; nl (); printf "! NB: i.g. not all color flows contribute to all flavor"; nl (); printf "! combinations. Consult the array FLV_COL_IS_ALLOWED"; nl (); printf "! below for the allowed combinations."; nl (); end; printf "!"; nl (); printf "! Color Factors:"; nl (); printf "!"; nl (); if not !amp_triv then begin let cfactors = CF.color_factors amplitudes in for c1 = 0 to pred (Array.length cfactors) do for c2 = 0 to c1 do match cfactors.(c1).(c2) with | [] -> () | cfactor -> printf "! (%3d,%3d): %s" (succ c1) (succ c2) (format_powers_of_nc cfactor); nl () done done; end; if not !amp_triv then begin printf "!"; nl (); printf "! vanishing or redundant flavor combinations:"; nl (); printf "!"; nl (); List.iter (fun process -> printf "! %s" (process_sans_color_to_string process); nl ()) (CF.vanishing_flavors amplitudes); printf "!"; nl (); end; begin match CF.constraints amplitudes with | None -> () | Some s -> printf "! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!):"; nl (); printf "!"; nl (); printf "! %s" s; nl (); printf "!"; nl () end; begin match CF.slicings amplitudes with | [] -> () | lines -> printf "! coupling constant selections ('slicings'):"; nl (); printf "!"; nl (); List.iter (fun s -> printf "! %s" s; nl ()) lines; printf "!"; nl () end; dump_amplitude_slices amplitudes; printf "!"; nl () (* \thocwmodulesubsection{Printing Modules} *) type accessibility = | Public | Private | Protected (* Fortran 2003 *) let accessibility_to_string = function | Public -> "public" | Private -> "private" | Protected -> "protected" type used_symbol = | As_Is of string | Aliased of string * string let print_used_symbol = function | As_Is name -> printf "%s" name | Aliased (orig, alias) -> printf "%s => %s" alias orig type used_module = | Full of string | Full_Aliased of string * (string * string) list | Subset of string * used_symbol list + let subset_of name symbols = + Subset (name, List.map (fun s -> As_Is s) symbols) + 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; + 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 } + { description : string list; + 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 = + begin match m.description with + | [] -> () + | lines -> + printf "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; nl (); + List.iter (fun l -> printf "! %s" l; nl ()) lines; + printf "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"; nl () + end; 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 (); + print_public m.public_symbols; begin match m.print_declarations with | [] -> () | print_declarations -> List.iter (fun f -> f ()) print_declarations; nl () end; begin match m.print_implementations with | [] -> () | print_implementations -> printf "contains"; nl (); nl (); List.iter (fun f -> f ()) print_implementations; nl (); end; printf "end module %s" m.module_name; nl () let print_modules modules = List.iter print_module modules; print_flush () let module_to_file line_length oc prelude m = output_string oc (m.module_name ^ "\n"); let filename = m.module_name ^ ".f90" in let channel = open_out filename in Format_Fortran.set_formatter_out_channel ~width:line_length channel; prelude (); print_modules [m]; close_out channel let modules_to_file line_length oc prelude = function | [] -> () | m :: mlist -> module_to_file line_length oc prelude m; List.iter (module_to_file line_length oc (fun () -> ())) mlist (* \thocwmodulesubsection{Chopping Up Amplitudes} *) let all_brakets process = ThoList.flatmap snd (F.brakets process) let num_fusions_brakets size amplitudes = let num_fusions = max 1 size in let count_brakets = List.fold_left (fun sum process -> sum + List.length (all_brakets process)) 0 (CF.processes amplitudes) and count_processes = List.length (CF.processes amplitudes) in if count_brakets > 0 then let num_brakets = max 1 ((num_fusions * count_processes) / count_brakets) in (num_fusions, num_brakets) else (num_fusions, 1) let chop_amplitudes size amplitudes = let num_fusions, num_brakets = num_fusions_brakets size amplitudes in (ThoList.enumerate 1 (ThoList.chopn num_fusions (CF.fusions amplitudes)), ThoList.enumerate 1 (ThoList.chopn num_brakets (CF.processes amplitudes))) let print_compute_fusions1 dictionary (n, fusions) = if not !amp_triv then begin if !openmp then begin printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl (); printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl (); end else begin printf " @[<5>subroutine compute_fusions_%04d ()" n; nl (); end; print_fusions dictionary fusions; printf " end subroutine compute_fusions_%04d" n; nl (); end and print_compute_brakets1 dictionary (n, processes) = if not !amp_triv then begin if !openmp then begin printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl (); printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl (); end else begin printf " @[<5>subroutine compute_brakets_%04d ()" n; nl (); end; List.iter (print_brakets dictionary) processes; printf " end subroutine compute_brakets_%04d" n; nl (); end (* \thocwmodulesubsection{Common Stuff} *) let omega_public_symbols = - ["number_particles_in"; "number_particles_out"; - "number_color_indices"; + ["number_particles_in"; "number_particles_out"; "number_color_indices"; "reset_helicity_selection"; "new_event"; "is_allowed"; "get_amplitude"; "color_sum"; - "external_masses"; "openmp_supported"] @ + "external_masses"; "openmp_supported"; + "table_coupling_orders"; "table_coupling_powers"; + "amp_by_orders"; "table_spin_states"; "table_flavor_states"] @ ThoList.flatmap (fun n -> ["number_" ^ n; n]) ["spin_states"; "flavor_states"; "color_flows"; "color_factors"] let whizard_public_symbols md5sum = ["init"; "final"; "update_alpha_s"] @ (match md5sum with Some _ -> ["md5sum"] | None -> []) let used_modules () = [Full "kinds"; Full Names.use_module; Full_Aliased ("omega_color", ["omega_color_factor", omega_color_factor_abbrev])] @ List.map (fun m -> Full m) (match !parameter_module with | "" -> !use_modules | pm -> pm :: !use_modules) let public_symbols () = if !whizard then omega_public_symbols @ (whizard_public_symbols !md5sum) else omega_public_symbols let print_constants amplitudes = printf " ! DON'T EVEN THINK of removing the following!"; nl (); printf " ! If the compiler complains about undeclared"; nl (); printf " ! or undefined variables, you are compiling"; nl (); printf " ! against an incompatible omega95 module!"; nl (); printf " @[<2>integer, dimension(%d), parameter, private :: " (List.length require_library); printf "require =@ (/ @["; print_list require_library; printf " /)"; nl (); nl (); (* Using these parameters makes sense for documentation, but in practice, there is no need to ever change them. *) List.iter (function name, value -> print_integer_parameter name (value amplitudes)) [ ("n_prt", num_particles); ("n_in", num_particles_in); ("n_out", num_particles_out); ("n_cflow", num_color_flows); (* Number of different color amplitudes. *) ("n_cindex", num_color_indices); (* Maximum rank of color tensors. *) ("n_flv", num_flavors); (* Number of different flavor amplitudes. *) ("n_hel", num_helicities); (* Number of different helicity amplitudes. *) ("n_co", num_coupling_orders); (* Number of different coupling orders. *) - ("n_cop", num_coupling_order_powers) (* Number of different powers of coupling orders. *) ]; + ("n_co_len", len_coupling_orders); (* Number of different coupling orders. *) + ("n_cp", num_coupling_powers) (* Number of different powers of coupling orders. *) ]; nl (); (* Abbreviations. *) printf " ! NB: you MUST NOT change the value of %s here!!!" nc_parameter; nl (); printf " ! It is defined here for convenience only and must be"; nl (); printf " ! compatible with hardcoded values in the amplitude!"; nl (); print_real_parameter nc_parameter (SCM.nc ()); (* $N_C$ *) List.iter (function name, value -> print_logical_parameter name value) [ ("F", false); ("T", true) ]; nl (); print_coupling_orders_table amplitudes; + print_coupling_powers_table amplitudes; print_spin_tables amplitudes; print_flavor_tables amplitudes; print_color_tables amplitudes; print_amplitude_table amplitudes; print_helicity_selection_table () let print_interface amplitudes = print_md5sum_functions !md5sum; print_maintenance_functions (); List.iter print_numeric_inquiry_functions [("number_particles_in", "n_in"); ("number_particles_out", "n_out")]; List.iter print_inquiry_functions ["spin_states"; "flavor_states"]; print_external_masses amplitudes; print_inquiry_function_openmp (); print_color_flows (); print_color_factors (); print_dispatch_functions (); nl (); (* Is this really necessary? *) Format_Fortran.switch_line_continuation false; + + (* \begin{dubious} + The following is \emph{not} part of the interface, but a set of + functions to be called during the evaluation of the amplitudes. + Find a better place for it. + \end{dubious} *) if !km_write || !km_pure then (Targets_Kmatrix.Fortran.print !km_pure); if !km_2_write || !km_2_pure then (Targets_Kmatrix_2.Fortran.print !km_2_pure); Format_Fortran.switch_line_continuation true; nl () let print_calculate_amplitudes declarations computations amplitudes = printf " @[<5>subroutine calculate_amplitudes (amp, k, mask)"; nl (); - printf " complex(kind=%s), dimension(:,:,:), intent(out) :: amp" !kind; nl (); + printf " 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; + if not !amp_triv then + begin + begin match CF.processes amplitudes with + | p :: _ -> print_external_momenta p + | _ -> () + end; + List.fold_left print_momenta PSet.empty (CF.processes amplitudes) |> ignore; + 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; + 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 (); + List.fold_left print_externals WFSet.empty (CF.processes amplitudes) |> ignore; + computations (); + + (* \begin{dubious} + TODO: add fudge factors for processes exclusive in coupling orders. + \end{dubious} *) + List.iter print_fudge_factor (CF.processes amplitudes); + + (* Write in column-major order to improve cache locality (not that it matters much). *) + let a = CF.process_table_new amplitudes in + for flow = 1 to num_color_flows amplitudes do + for flv = 1 to num_flavors amplitudes do + for co = 1 to num_coupling_powers amplitudes do + match a.(pred co).(pred flv).(pred flow) with + | Some (orders, a) -> printf " amp(%d,%d,%d,h) = %s" co flv flow (flavors_symbol ~orders (flavors a)); nl () + | None -> () + done + done + done; + printf " end do"; nl (); + if !openmp then + begin + printf "!$OMP END PARALLEL DO"; nl () + end; + end; + end; printf " end subroutine calculate_amplitudes"; nl () let print_compute_chops chopped_fusions chopped_brakets () = List.iter (fun (i, _) -> printf " call compute_fusions_%04d (%s)" i (if !openmp then openmp_tld else ""); nl ()) chopped_fusions; List.iter (fun (i, _) -> printf " call compute_brakets_%04d (%s)" i (if !openmp then openmp_tld else ""); nl ()) chopped_brakets (* \thocwmodulesubsection{UFO Fusions} *) module VSet = Set.Make (struct type t = F.constant Coupling.t let compare = compare end) let ufo_fusions_used amplitudes = let couplings = List.fold_left (fun acc p -> let fusions = ThoList.flatmap F.rhs (F.fusions p) and brakets = ThoList.flatmap F.ket (all_brakets p) in let couplings = VSet.of_list (List.map F.coupling (fusions @ brakets)) in VSet.union acc couplings) VSet.empty (CF.processes amplitudes) in VSet.fold (fun v acc -> match v with | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) -> Sets.String.add v acc | _ -> acc) couplings Sets.String.empty +(* \thocwmodulesubsection{Versioned API} *) + + let api_module_v1 computation_module = + { description = ["O'Mega API Version 1"]; + module_name = !module_name ^ "_api_v1"; + used_modules = [subset_of computation_module.module_name (public_symbols ())]; + default_accessibility = Public; + public_symbols = []; + print_declarations = []; + print_implementations = [] } + + let api_module_v1_alias api_module = + { description = ["Backward compatible alias for O'Mega API Version 1"]; + module_name = !module_name; + used_modules = [Full (api_module_v1 api_module).module_name]; + default_accessibility = Public; + public_symbols = []; + print_declarations = []; + print_implementations = [] } + + let print_declarations_api_v3 () = + printf "! DUMMY DECLARATIONS FOR TESTING!"; nl (); + printf " integer, parameter, public :: n_incoming = 2"; nl (); + printf " integer, parameter, public :: n_outgoing = 2"; nl (); + printf " integer, parameter, public :: n_particles = 4"; nl (); + printf " integer, parameter, public :: n_colorflows = 2"; nl (); + printf " integer, parameter :: max_rank_inflowing = 1"; nl (); + printf " integer, parameter :: max_rank_outflowing = 1"; nl (); + printf " integer, parameter :: max_n_eps = 0"; nl (); + printf " integer, parameter :: max_n_eps_bar = 0"; nl (); + printf " integer, dimension(n_particles,n_colorflows), save :: rank_inflowing, rank_outflowing"; nl (); + printf " integer, dimension(n_colorflows), save :: n_eps, n_eps_bar"; nl (); + printf " integer, dimension(max_rank_inflowing,n_particles,n_colorflows), save :: inflowing, outflowing"; nl (); + printf " logical, dimension(n_particles,n_colorflows), save :: is_ghost"; nl (); + printf " integer, dimension(3,max_n_eps,n_colorflows), save :: eps"; nl (); + printf " integer, dimension(3,max_n_eps_bar,n_colorflows), save :: eps_bar"; nl () + + let print_implementations_api_v3 () = + printf " @[<5>"; if !fortran95 then printf "pure "; + printf "subroutine load_amplidude (a)"; nl (); + printf " type(amplitude), intent(inout) :: a"; nl (); + printf " call copy_amplitude &"; nl (); + printf " (a, n_incoming, table_flavor_states, table_spin_states, &"; nl (); + printf " rank_inflowing, inflowing, rank_outflowing, outflowing, is_ghost, &"; nl (); + printf " n_eps, eps, n_eps_bar, eps_bar, &"; nl (); + printf " table_coupling_orders, table_coupling_powers, amp_by_orders)"; nl (); + printf " end subroutine load_amplidude"; nl () + + let api_module_v3 computation_module = + { description = ["O'Mega API Version 3"; + "WORK IN PROCESS !!!!"; + "NOT FOR PRODUCTION !" ]; + module_name = !module_name ^ "_api_v3"; + used_modules = [Full "omega_birdtracks"; + Full "omega_api_v3"; + Full computation_module.module_name]; + default_accessibility = Private; + public_symbols = ["load_amplidude"]; + print_declarations = [print_declarations_api_v3]; + print_implementations = [print_implementations_api_v3] } + (* \thocwmodulesubsection{Single Function} *) let amplitudes_to_channel_single_function cmdline oc amplitudes = let print_declarations () = print_constants amplitudes and print_implementations () = print_interface amplitudes; print_calculate_amplitudes (fun () -> print_variable_declarations amplitudes) (fun () -> print_fusions (CF.dictionary amplitudes) (CF.fusions amplitudes); List.iter (print_brakets (CF.dictionary amplitudes)) (CF.processes amplitudes)) amplitudes in let fortran_module = - { module_name = !module_name; + { description = ["Amplitude computation module"; "NOT to be USEd by application programs"]; + module_name = !module_name ^ "_computation"; used_modules = used_modules (); default_accessibility = Private; public_symbols = public_symbols (); print_declarations = [print_declarations]; print_implementations = [print_implementations] } in Format_Fortran.set_formatter_out_channel ~width:!line_length oc; print_description cmdline amplitudes (); - print_modules [fortran_module] + print_modules [fortran_module; api_module_v1 fortran_module; + api_module_v1_alias fortran_module; api_module_v3 fortran_module] (* \thocwmodulesubsection{Single Module} *) let amplitudes_to_channel_single_module cmdline oc size amplitudes = let print_declarations () = print_constants amplitudes; print_variable_declarations amplitudes and print_implementations () = print_interface amplitudes in let chopped_fusions, chopped_brakets = chop_amplitudes size amplitudes in let dictionary = CF.dictionary amplitudes in let print_compute_amplitudes () = print_calculate_amplitudes (fun () -> ()) (print_compute_chops chopped_fusions chopped_brakets) amplitudes and print_compute_fusions () = List.iter (print_compute_fusions1 dictionary) chopped_fusions and print_compute_brakets () = List.iter (print_compute_brakets1 dictionary) chopped_brakets in let fortran_module = - { module_name = !module_name; + { description = ["Amplitude computation module"; "NOT to be USEd by application programs"]; + module_name = !module_name ^ "_computation"; used_modules = used_modules (); default_accessibility = Private; public_symbols = public_symbols (); print_declarations = [print_declarations]; print_implementations = [print_implementations; print_compute_amplitudes; print_compute_fusions; print_compute_brakets] } in Format_Fortran.set_formatter_out_channel ~width:!line_length oc; print_description cmdline amplitudes (); - print_modules [fortran_module] + print_modules [fortran_module; api_module_v1 fortran_module; + api_module_v1_alias fortran_module; api_module_v3 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"; + { description = ["Constants shared among splitted computation modules"]; + 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"; + { description = ["Variables shared among splitted computation modules"]; + 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; + { description = []; + 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; + { description = []; + module_name = name ^ tag; used_modules = (used_modules () @ [Full constants_module.module_name; Full variables_module.module_name]); default_accessibility = Private; public_symbols = ["compute" ^ tag]; print_declarations = []; print_implementations = [print_compute_brakets processes] } in let chopped_fusions, chopped_brakets = chop_amplitudes size amplitudes in let fusions_modules = List.map fusions_module chopped_fusions in let brakets_modules = List.map brakets_module chopped_brakets in let print_implementations () = print_interface amplitudes; print_calculate_amplitudes (fun () -> ()) (print_compute_chops chopped_fusions chopped_brakets) amplitudes in - let public_module = - { module_name = name; - used_modules = (used_modules () @ - [Full constants_module.module_name; - Full variables_module.module_name ] @ - List.map - (fun m -> Full m.module_name) - (fusions_modules @ brakets_modules)); - default_accessibility = Private; - public_symbols = public_symbols (); - print_declarations = []; - print_implementations = [print_implementations] } + let public_modules = + let computation_module = + { description = ["Amplitude computation module"; "NOT to be USEd by application programs"]; + module_name = name ^ "_computation"; + 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] } in + [computation_module; api_module_v1 computation_module; + api_module_v1_alias computation_module; api_module_v3 computation_module] and private_modules = [constants_module; variables_module] @ fusions_modules @ brakets_modules in - (public_module, private_modules) + (public_modules, private_modules) let amplitudes_to_channel_single_file cmdline oc size amplitudes = - let public_module, private_modules = + let public_modules, private_modules = modules_of_amplitudes cmdline oc size amplitudes in Format_Fortran.set_formatter_out_channel ~width:!line_length oc; print_description cmdline amplitudes (); - print_modules (private_modules @ [public_module]) + print_modules (private_modules @ public_modules) let amplitudes_to_channel_multi_file cmdline oc size amplitudes = - let public_module, private_modules = + let public_modules, private_modules = modules_of_amplitudes cmdline oc size amplitudes in modules_to_file !line_length oc (print_description cmdline amplitudes) - (public_module :: private_modules) + (public_modules @ private_modules) (* \thocwmodulesubsection{Dispatch} *) let amplitudes_to_channel cmdline oc diagnostics amplitudes = parse_diagnostics diagnostics; let ufo_fusions = let ufo_fusions_set = ufo_fusions_used amplitudes in if Sets.String.is_empty ufo_fusions_set then None else Some ufo_fusions_set in begin match ufo_fusions with | Some only -> let name = !module_name ^ "_ufo" and fortran_module = Names.use_module in use_modules := name :: !use_modules; UFO.Targets.Fortran.lorentz_module ~only ~name ~fortran_module ~parameter_module:!parameter_module (Format_Fortran.formatter_of_out_channel oc) () | None -> () end; match !output_mode with | Single_Function -> amplitudes_to_channel_single_function cmdline oc amplitudes | Single_Module size -> amplitudes_to_channel_single_module cmdline oc size amplitudes | Single_File size -> amplitudes_to_channel_single_file cmdline oc size amplitudes | Multi_File size -> amplitudes_to_channel_multi_file cmdline oc size amplitudes let parameters_to_channel oc = parameters_to_fortran oc (CM.parameters ()) end module Make = Make_Fortran(Target_Fortran_Names.Dirac)(Targets_vintage.Fortran_Fermions) module Make_Majorana = Make_Fortran(Target_Fortran_Names.Majorana)(Targets_vintage.Fortran_Majorana_Fermions) Index: trunk/ChangeLog =================================================================== --- trunk/ChangeLog (revision 8919) +++ trunk/ChangeLog (revision 8920) @@ -1,2432 +1,2436 @@ ChangeLog -- Summary of changes to the WHIZARD package Use git log/svn log to see detailed changes. Version 3.1.4.1 +2024-04-24 + O'Mega: merge versioned API (API v3 work in progress) + O'Mega: birdtrack library improvements + ################################################################## 2023-11-08 RELEASE: version 3.1.4 2023-11-02 Pythia8 interface: support for Pythia v8.310+ UFO interface: allow backslash escaped new lines Add missing O'Mega comparison files to distribution Minimal Intel compiler version: 21.10 (oneAPI 23.2) 2023-10-20 Infrastructure for NLO hadron collisions with GoSam ################################################################## 2023-10-06 RELEASE: version 3.1.3 2023-10-02 CIRCE2: add 'null' maps for regions with not enough statistics O'Mega/CIRCE2: remove pre OCaml 4.08 workarounds 2023-09-25 Minimal compiler versions: OCaml 4.08, gfortran 9.1.0 2023-09-22 Bug fix UFO interface: parsing of tokens corrected 2023-06-01 Common folder 'contrib' for external codes shipped with WHIZARD 2023-05-28 Bug fix UFO interface: workaround for case-sensitive parameters 2023-05-05 Update of meson and baryon listings in SM hadrons model 2023-03-28 Workaround for Intel oneAPI 2022/23 regression(s) ################################################################## 2023-03-21 RELEASE: version 3.1.2 2023-03-21 Bug fix in cyclic build dependence of WHIZARD core 2023-03-11 Resolve minor inconsistency in manual for NLO real partition ################################################################## 2023-03-10 RELEASE: version 3.1.1 2023-03-09 Bug fix in UFO file parser Small bug fix in NLO EW infrastructure 2023-03-01 Bug fix: numerical mapping stability for peaked PDFs 2023-02-28 Bug fix UFO interface: avoid too long ME code lines 2023-02-22 Infrastructure for calculation of kinematic MT2 variable 2023-02-17 Bug fix UFO interface: correct parentheses in rational functions ################################################################## 2022-12-14 RELEASE: version 3.1.0 2022-12-12 Bug fix Pythia8 interface: production vertices, shower history O'Mega support for epsilon tensor color structures 2023-01-27 Support for loop-induced processes 2022-11-30 O'Mega support for general SU(N) color representations 2022-11-07 Modernize configure checks for Python versions v3.10+ 2022-10-21 General POWHEG matching with optional NLO real phase space partitioning 2022-09-26 Bug fix: accept negative scale values in SLHA block header 2022-08-08 Numerical stability of testsuite for Apple M1 processors 2022-08-07 Technically allow for muons as CIRCE2 beam spectra 2022-06-22 POWHEG matching for Drell-Yan and similar processes 2022-06-12 Add unit tests for Lorentz and phase-space modules 2022-05-09 Massive eikonals: Numeric robustness at ultrahigh energies 2022-04-20 Bug fix for VAMP2 event generation with indefinite samples ################################################################## 2022-04-06 RELEASE: version 3.0.3 2022-04-05 POWHEG matching for single flavor hadron collisions 2022-03-31 NLO EW processes with massless leptons and jets (i.e. jet clustering and photon recombination) supported NLO EW for massive initial leptons validated 2022-03-27 Complete implementation/validation of NLL electron PDFs 2022-02-22 Bug fix: correct normalization for CIRCE2+EPA+polarization 2022-02-21 WHIZARD core now uses Fortran modules and submodules 2022-01-27 Infrastructure for POWHEG matching for hadron collisions 2021-12-16 Event files can be written/read also for decay processes Implementation of running QED coupling alpha 2021-12-10 Independent variations of renormalization/factorization scale ################################################################## 2021-11-23 RELEASE: version 3.0.2 2021-11-19 Support for a wide class of mixed NLO QCD/EW processes 2021-11-18 Add pp processes for NLO EW corrections to testsuite 2021-11-11 Output numerically critical values with LCIO 2.17+ as double 2021-11-05 Minor refactoring on phase space points and kinematics 2021-10-21 NLO (QCD) differential distributions supported for full lepton collider setup: polarization, QED ISR, beamstrahlung 2021-10-15 SINDARIN now has a sum and product function of expressions, SINDARIN supports observables defined on full (sub)events First application: transverse mass Bug fix: 2HDM did not allow H+, H- as external particles 2021-10-14 CT18 PDFs included (NLO, NNLO) 2021-09-30 Bug fix: keep non-recombined photons in the event record 2021-09-13 Modular NLO event generation with real partition 2021-08-20 Bug fix: correctly reading in NLO fixed order events 2021-08-06 Generalize optional partitioning of the NLO real phase space ################################################################## 2021-07-08 RELEASE: version 3.0.1 2021-07-06 MPI parallelization now comes with two incarnations: - standard MPI parallelization ("simple", default) - MPI with load balancer ("load") 2021-07-05 Bug fix for C++17 default compilers w/ HepMC3/ROOT interface 2021-07-02 Improvement for POWHEG matching: - implement massless recoil case - enable reading in existing POWHEG grids - support kinematic cuts at generator level 2021-07-01 Distinguish different cases of photons in NLO EW corrections 2021-06-21 Option to keep negative PDF entries or set them zero 2021-05-31 Full LCIO MC production files can be properly recasted 2021-05-24 Use defaults for UFO models without propagators.py 2021-05-21 Bug fix: prevent invalid code for UFO models containing hyphens 2021-05-20 UFO files with scientific notation float constants allowed UFO files: max. n-arity of vertices bound by process multiplicity ################################################################## 2021-04-27 RELEASE: version 3.0.0 2021-04-20 Minimal required OCaml version is now 4.05.0. Bug fix for tau polarization from stau decays 2021-04-19 NLO EW splitting functions and collinear remnants completed Photon recombination implemented 2021-04-14 Bug fix for vertices/status codes with HepMC2/3 event format 2021-04-08 Correct Lorentz statistics for UFO model with Majorana fermions 2021-04-06 Bug fix for rare script failure in system_dependencies.f90.in Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model 2021-04-04 Support for UFO extensions in SMEFTSim 3.0 2021-02-25 Enable VAMP and VAMP2 channel equivalences for NLO integrations 2021-02-04 Bug fix if user does not set a prefix at configuration 2020-12-10 Generalize NLO calculations to non-CMS lab frames 2020-12-08 Bug fix in expanded p-wave form factor for top threshold 2020-12-06 Patch for macOS Big Sur shared library handling due to libtool; the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5 2020-12-04 O'Mega only inserts non-vanishing couplings from UFO models 2020-11-21 Bug fix for fractional hypercharges in UFO models 2020-11-11 Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh) 2020-11-09 Correct flavor assignment for NLO fixed-order events 2020-11-05 Bug fix for ISR handler not working with unstable particles 2020-10-08 Bug fix in LHAPDF interface for photon PDFs 2020-10-07 Bug fix for structure function setup with asymmetric beams 2020-10-02 Python/Cython layer for WHIZARD API 2020-09-30 Allow mismatches of Python and name attributes in UFO models 2020-09-26 Support for negative PDG particles from certain UFO models 2020-09-24 Allow for QNUMBERS blocks in BSM SLHA files 2020-09-22 Full support for compilation with clang(++) on Darwin/macOS More documentation in the manual Minor clean-ups 2020-09-16 Bug fix enables reading LCIO events with LCIO v2.15+ ################################################################## 2020-09-16 RELEASE: version 2.8.5 2020-09-11 Bug fix for H->tau tau transverse polarization with PYTHIA6 (thanks to Junping Tian / Akiya Miyamoto) 2020-09-09 Fix a long standing bug (since 2.0) in the calculation of color factors when particles of different color were combined in a particle class. NB: O'Mega never produced a wrong number, it only declared all processes as invalid. 2020-09-08 Enable Openloops matrix element equivalences for optimization 2020-09-02 Compatibility fix for PYTHIA v8.301+ interface 2020-09-01 Support exclusive jet clustering in ee for Fastjet interface ################################################################## 2020-08-30 RELEASE: version 3.0.0_beta 2020-08-27 Major revision of NLO distributions and events for processes with structure functions: - Use parton momenta/flavors (instead of beams) for events - Bug fix for Lorentz boosts and Lorentz frames of momenta - Bug fix: apply cuts to virtual NLO component in correct frame - Correctly assign ISR radiation momenta in data structures - Refactoring on quantum numbers for NLO event data structures - Functional tests for hadron collider NLO distributions - many minor bug fixes regarding NLO hadron collider physics 2020-08-11 Bug fix for linking problem with OpenMPI 2020-08-07 New WHIZARD API: WHIZARD can be externally linked as a library, added examples for Fortran, C, C++ programs ################################################################## 2020-07-08 RELEASE: version 2.8.4 2020-07-07 Bug fix: steering of UFO Majorana models from WHIZARD ################################################################## 2020-07-06 Combined integration also for hadron collider processes at NLO 2020-07-05 Bug fix: correctly steer e+e- FastJet clustering algorithms Major revision of NLO differential distributions and events: - Correctly assign quantum numbers to NLO fixed-order events - Correctly assign weights to NLO fixed-order events for combined simulation - Cut all NLO fixed-order subevents in event groups individually - Only allow "sigma" normalization for NLO fixed-order events - Use correct PDF setup for NLO counter events - Several technical fixes and updates of the NLO testsuite ################################################################## 2020-07-03 RELEASE: version 2.8.3 2020-07-02 Feature-complete UFO implementation for Majorana fermions 2020-06-22 Running width scheme supported for O'Mega matrix elements 2020-06-20 Adding H-s-s coupling to SM_Higgs(_CKM) models 2020-06-17 Completion of ILC 2->6 fermion extended test suite 2020-06-15 Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays 2020-06-09 Bug fix: correctly update calls for additional VAMP/2 iterations Bug fix: correct assignment for tau spins from PYTHIA6 interface 2020-06-04 Bug fix: cascades2 tree merge with empty subtree(s) 2020-05-31 Switch $epa_mode for different EPA implementations 2020-05-26 Bug fix: spin information transferred for resonance histories 2020-04-13 HepMC: correct weighted events for non-xsec event normalizations 2020-04-04 Improved HepMC3 interface: HepMC3 Root/RootTree interface 2020-03-24 ISR: Fix on-shell kinematics for events with ?isr_handler=true (set ?isr_handler_keep_mass=false for old behavior) 2020-03-11 Beam masses are correctly passed to hard matrix element for CIRCE2 EPA with polarized beams: double-counting corrected ################################################################## 2020-03-03 RELEASE: version 3.0.0_alpha 2020-02-25 Bug fix: Scale and alphas can be retrieved from internal event format to external formats 2020-02-17 Bug fix: ?keep_failed_events now forces output of actual event data Bug fix: particle-set reconstruction (rescanning events w/o radiation) 2020-01-28 Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max) 2020-01-23 Bug fix for real components of NLO QCD 2->1 processes 2020-01-22 Bug fix: correct random number sequencing during parallel MPI event generation with rng_stream 2020-01-21 Consistent distribution of events during parallel MPI event generation 2020-01-20 Bug fix for configure setup for automake v1.16+ 2020-01-18 General SLHA parameter files for UFO models supported 2020-01-08 Bug fix: correctly register RECOLA processes with flavor sums 2019-12-19 Support for UFO customized propagators O'Mega unit tests for fermion-number violating interactions 2019-12-10 For distribution building: check for graphviz/dot version 2.40 or newer 2019-11-21 Bug fix: alternate setups now work correctly Infrastructure for accessing alpha_QED event-by-event Guard against tiny numbers that break ASCII event output Enable inverse hyperbolic functions as SINDARIN observables Remove old compiler bug workarounds 2019-11-20 Allow quoted -e argument, implemented -f option 2019-11-19 Bug fix: resonance histories now work also with UFO models Fix in numerical precision of ASCII VAMP2 grids 2019-11-06 Add squared matrix elements to the LCIO event header 2019-11-05 Do not include RNG state in MD5 sum for CIRCE1/2 2019-11-04 Full CIRCE2 ILC 250 and 500 GeV beam spectra added Minor update on LCIO event header information 2019-10-30 NLO QCD for final states completed When using Openloops, v2.1.1+ mandatory 2019-10-25 Binary grid files for VAMP2 integrator ################################################################## 2019-10-24 RELEASE: version 2.8.2 2019-10-20 Bug fix for HepMC linker flags 2019-10-19 Support for spin-2 particles from UFO files 2019-09-27 LCIO event format allows rescan and alternate weights 2019-09-24 Compatibility fix for OCaml v4.08.0+ ################################################################## 2019-09-21 RELEASE: version 2.8.1 2019-09-19 Carriage return characters in UFO models can be parsed Mathematica symbols in UFO models possible Unused/undefined parameters in UFO models handled 2019-09-13 New extended NLO test suite for ee and pp processes 2019-09-09 Photon isolation (separation of perturbative and fragmentation part a la Frixione) 2019-09-05 Major progress on NLO QCD for hadron collisions: - correctly assign flavor structures for alpha regions - fix crossing of particles for initial state splittings - correct assignment for PDF factors for real subtractions - fix kinematics for collinear splittings - bug fix for integrated virtual subtraction terms 2019-09-03 b and c jet selection in cuts and analysis 2019-08-27 Support for Intel MPI 2019-08-20 Complete (preliminary) HepMC3 support (incl. backwards HepMC2 write/read mode) 2019-08-08 Bug fix: handle carriage returns in UFO files (non-Unix OS) ################################################################## 2019-08-07 RELEASE: version 2.8.0 2019-07-31 Complete WHIZARD UFO interface: - general Lorentz structures - matrix element support for general color factors - missing features: Majorana fermions and SLHA 2019-07-20 Make WHIZARD compatible with OCaml 4.08.0+ 2019-07-19 Fix version testing for LHAPDF 6.2.3 and newer Minimal required OCaml version is now 4.02.3. 2019-04-18 Correctly generate ordered FKS tuples for alpha regions from all possible underlying Born processes 2019-04-08 Extended O'Mega/Recola matrix element test suite 2019-03-29 Correct identical particle symmetry factors for FKS subtraction 2019-03-28 Correct assertion of spin-correlated matrix elements for hadron collisions 2019-03-27 Bug fix for cut-off parameter delta_i for collinear plus/minus regions ################################################################## 2019-03-27 RELEASE: version 2.7.1 2019-02-19 Further infrastructure for HepMC3 interface (v3.01.00) 2019-02-07 Explicit configure option for using debugging options Bug fix for performance by removing unnecessary debug operations 2019-01-29 Bug fix for DGLAP remnants with cut-off parameter delta_i 2019-01-24 Radiative decay neu2 -> neu1 A added to MSSM_Hgg model ################################################################## 2019-01-21 RELEASE: version 2.7.0 2018-12-18 Support RECOLA for integrated und unintegrated subtractions 2018-12-11 FCNC top-up sector in model SM_top_anom 2018-12-05 Use libtirpc instead of SunRPC on Arch Linux etc. 2018-11-30 Display rescaling factor for weighted event samples with cuts 2018-11-29 Reintroduce check against different masses in flavor sums Bug fix for wrong couplings in the Littlest Higgs model(s) 2018-11-22 Bug fix for rescanning events with beam structure 2018-11-09 Major refactoring of internal process data 2018-11-02 PYTHIA8 interface 2018-10-29 Flat phase space parametrization with RAMBO (on diet) implemented 2018-10-17 Revise extended test suite 2018-09-27 Process container for RECOLA processes 2018-09-15 Fixes by M. Berggren for PYTHIA6 interface 2018-09-14 First fixes after HepForge modernization ################################################################## 2018-08-23 RELEASE: version 2.6.4 2018-08-09 Infrastructure to check colored subevents 2018-07-10 Infrastructure for running WHIZARD in batch mode 2018-07-04 MPI available from distribution tarball 2018-06-03 Support Intel Fortran Compiler under MAC OS X 2018-05-07 FKS slicing parameter delta_i (initial state) implementend 2018-05-03 Refactor structure function assignment for NLO 2018-05-02 FKS slicing parameter xi_cut, delta_0 implemented 2018-04-20 Workspace subdirectory for process integration (grid/phs files) Packing/unpacking of files at job end/start Exporting integration results from scan loops 2018-04-13 Extended QCD NLO test suite 2018-04-09 Bug fix for Higgs Singlet Extension model 2018-04-06 Workspace subdirectory for process generation and compilation --job-id option for creating job-specific names 2018-03-20 Bug fix for color flow matching in hadron collisions with identical initial state quarks 2018-03-08 Structure functions quantum numbers correctly assigned for NLO 2018-02-24 Configure setup includes 'pgfortran' and 'flang' 2018-02-21 Include spin-correlated matrix elements in interactions 2018-02-15 Separate module for QED ISR structure functions ################################################################## 2018-02-10 RELEASE: version 2.6.3 2018-02-08 Improvements in memory management for PS generation 2018-01-31 Partial refactoring: quantum number assigment NLO Initial-state QCD splittings for hadron collisions 2018-01-25 Bug fix for weighted events with VAMP2 2018-01-17 Generalized interface for Recola versions 1.3+ and 2.1+ 2018-01-15 Channel equivalences also for VAMP2 integrator 2018-01-12 Fix for OCaml compiler 4.06 (and newer) 2017-12-19 RECOLA matrix elements with flavor sums can be integrated 2017-12-18 Bug fix for segmentation fault in empty resonance histories 2017-12-16 Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers from transferral between PYTHIA and WHIZARD event records 2017-12-15 Event index for multiple processes in event file correct ################################################################## 2017-12-13 RELEASE: version 2.6.2 2017-12-07 User can set offset in event numbers 2017-11-29 Possibility to have more than one RECOLA process in one file 2017-11-23 Transversal/mixed (and unitarized) dim-8 operators 2017-11-16 epa_q_max replaces epa_e_max (trivial factor 2) 2017-11-15 O'Mega matrix element compilation silent now 2017-11-14 Complete expanded P-wave form factor for top threshold 2017-11-10 Incoming particles can be accessed in SINDARIN 2017-11-08 Improved handling of resonance insertion, additional parameters 2017-11-04 Added Higgs-electron coupling (SM_Higgs) ################################################################## 2017-11-03 RELEASE: version 2.6.1 2017-10-20 More than 5 NLO components possible at same time 2017-10-19 Gaussian cutoff for shower resonance matching 2017-10-12 Alternative (more efficient) method to generate phase space file 2017-10-11 Bug fix for shower resonance histories for processes with multiple components 2017-09-25 Bug fix for process libraries in shower resonance histories 2017-09-21 Correctly generate pT distribution for EPA remnants 2017-09-20 Set branching ratios for unstable particles also by hand 2017-09-14 Correctly generate pT distribution for ISR photons ################################################################## 2017-09-08 RELEASE: version 2.6.0 2017-09-05 Bug fix for initial state NLO QCD flavor structures Real and virtual NLO QCD hadron collider processes work with internal interactions 2017-09-04 Fully validated MPI integration and event generation 2017-09-01 Resonance histories for shower: full support Bug fix in O'Mega model constraints O'Mega allows to output a parsable form of the DAG 2017-08-24 Resonance histories in events for transferral to parton shower (e.g. in ee -> jjjj) 2017-08-01 Alpha version of HepMC v3 interface (not yet really functional) 2017-07-31 Beta version for RECOLA OLP support 2017-07-06 Radiation generator fix for LHC processes 2017-06-30 Fix bug for NLO with structure functions and/or polarization 2017-06-23 Collinear limit for QED corrections works 2017-06-17 POWHEG grids generated already during integration 2017-06-12 Soft limit for QED corrections works 2017-05-16 Beta version of full MPI parallelization (VAMP2) Check consistency of POWHEG grid files Logfile config-summary.log for configure summary 2017-05-12 Allow polarization in top threshold 2017-05-09 Minimal demand automake 1.12.2 Silent rules for make procedures 2017-05-07 Major fix for POWHEG damping Correctly initialize FKS ISR phasespace ################################################################## 2017-05-06 RELEASE: version 2.5.0 2017-05-05 Full UFO support (SM-like models) Fixed-beam ISR FKS phase space 2017-04-26 QED splittings in radiation generator 2017-04-10 Retire deprecated O'Mega vertex cache files ################################################################## 2017-03-24 RELEASE: version 2.4.1 2017-03-16 Distinguish resonance charge in phase space channels Keep track of resonance histories in phase space Complex mass scheme default for OpenLoops amplitudes 2017-03-13 Fix helicities for polarized OpenLoops calculations 2017-03-09 Possibility to advance RNG state in rng_stream 2017-03-04 General setup for partitioning real emission phase space 2017-03-06 Bug fix on rescan command for converting event files 2017-02-27 Alternative multi-channel VEGAS implementation VAMP2: serial backbone for MPI setup Smoothstep top threshold matching 2017-02-25 Single-beam structure function with s-channel mapping supported Safeguard against invalid process libraries 2017-02-16 Radiation generator for photon emission 2017-02-10 Fixes for NLO QCD processes (color correlations) 2017-01-16 LCIO variable takes precedence over LCIO_DIR 2017-01-13 Alternative random number generator rng_stream (cf. L'Ecuyer et al.) 2017-01-01 Fix for multi-flavor BLHA tree matrix elements 2016-12-31 Grid path option for VAMP grids 2016-12-28 Alpha version of Recola OLP support 2016-12-27 Dalitz plots for FKS phase space 2016-12-14 NLO multi-flavor events possible 2016-12-09 LCIO event header information added 2016-12-02 Alpha version of RECOLA interface Bug fix for generator status in LCIO ################################################################## 2016-11-28 RELEASE: version 2.4.0 2016-11-24 Bug fix for OpenLoops interface: EW scheme is set by WHIZARD Bug fixes for top threshold implementation 2016-11-11 Refactoring of dispatching 2016-10-18 Bug fix for LCIO output 2016-10-10 First implementation for collinear soft terms 2016-10-06 First full WHIZARD models from UFO files 2016-10-05 WHIZARD does not support legacy gcc 4.7.4 any longer 2016-09-30 Major refactoring of process core and NLO components 2016-09-23 WHIZARD homogeneous entity: discarding subconfigures for CIRCE1/2, O'Mega, VAMP subpackages; these are reconstructable by script projectors 2016-09-06 Introduce main configure summary 2016-08-26 Fix memory leak in event generation ################################################################## 2016-08-25 RELEASE: version 2.3.1 2016-08-19 Bug fix for EW-scheme dependence of gluino propagators 2016-08-01 Beta version of complex mass scheme support 2016-07-26 Fix bug in POWHEG damping for the matching ################################################################## 2016-07-21 RELEASE: version 2.3.0 2016-07-20 UFO file support (alpha version) in O'Mega 2016-07-13 New (more) stable of WHIZARD GUI Support for EW schemes for OpenLoops Factorized NLO top decays for threshold model 2016-06-15 Passing factorization scale to PYTHIA6 Adding charge and neutral observables 2016-06-14 Correcting angular distribution/tweaked kinematics in non-collinear structure functions splittings 2016-05-10 Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6 (backwards validation of LC CDR/TDR samples) 2016-04-27 Within OpenLoops virtuals: support for Collier library 2016-04-25 O'Mega vertex tables only loaded at first usage 2016-04-21 New CJ15 PDF parameterizations added 2016-04-21 Support for hadron collisions at NLO QCD 2016-04-05 Support for different (parameter) schemes in model files 2016-03-31 Correct transferral of lifetime/vertex from PYTHIA/TAUOLA into the event record 2016-03-21 New internal implementation of polarization via Bloch vectors, remove pointer constructions 2016-03-13 Extension of cascade syntax for processes: exclude propagators/vertices etc. possible 2016-02-24 Full support for OpenLoops QCD NLO matrix elements, inclusion in test suite 2016-02-12 Substantial progress on QCD NLO support 2016-02-02 Automated resonance mapping for FKS subtraction 2015-12-17 New BSM model WZW for diphoton resonances ################################################################## 2015-11-22 RELEASE: version 2.2.8 2015-11-21 Bug fix for fixed-order NLO events 2015-11-20 Anomalous FCNC top-charm vertices 2015-11-19 StdHEP output via HEPEVT/HEPEV4 supported 2015-11-18 Full set of electroweak dim-6 operators included 2015-10-22 Polarized one-loop amplitudes supported 2015-10-21 Fixes for event formats for showered events 2015-10-14 Callback mechanism for event output 2015-09-22 Bypass matrix elements in pure event sample rescans StdHep frozen final version v5.06.01 included internally 2015-09-21 configure option --with-precision to demand 64bit, 80bit, or 128bit Fortran and bind C precision types 2015-09-07 More extensive tests of NLO infrastructure and POWHEG matching 2015-09-01 NLO decay infrastructure User-defined squared matrix elements Inclusive FastJet algorithm plugin Numerical improvement for small boosts ################################################################## 2015-08-11 RELEASE: version 2.2.7 2015-08-10 Infrastructure for damped POWHEG Massive emitters in POWHEG Born matrix elements via BLHA GoSam filters via SINDARIN Minor running coupling bug fixes Fixed-order NLO events 2015-08-06 CT14 PDFs included (LO, NLO, NNLL) 2015-07-07 Revalidation of ILC WHIZARD-PYTHIA event chain Extended test suite for showered events Alpha version of massive FSR for POWHEG 2015-06-09 Fix memory leak in interaction for long cascades Catch mismatch between beam definition and CIRCE2 spectrum 2015-06-08 Automated POWHEG matching: beta version Infrastructure for GKS matching Alpha version of fixed-order NLO events CIRCE2 polarization averaged spectra with explicitly polarized beams 2015-05-12 Abstract matching type: OO structure for matching/merging 2015-05-07 Bug fix in event record WHIZARD-PYTHIA6 transferral Gaussian beam spectra for lepton colliders ################################################################## 2015-05-02 RELEASE: version 2.2.6 2015-05-01 Models for (unitarized) tensor resonances in VBS 2015-04-28 Bug fix in channel weights for event generation. 2015-04-18 Improved event record transfer WHIZARD/PYTHIA6 2015-03-19 POWHEG matching: alpha version ################################################################## 2015-02-27 RELEASE: version 2.2.5 2015-02-26 Abstract types for quantum numbers 2015-02-25 Read-in of StdHEP events, self-tests 2015-02-22 Bug fix for mother-daughter relations in showered/hadronized events 2015-02-20 Projection on polarization in intermediate states 2015-02-13 Correct treatment of beam remnants in event formats (also LC remnants) ################################################################## 2015-02-06 RELEASE: version 2.2.4 2015-02-06 Bug fix in event output 2015-02-05 LCIO event format supported 2015-01-30 Including state matrices in WHIZARD's internal IO Versioning for WHIZARD's internal IO Libtool update from 2.4.3 to 2.4.5 LCIO event output (beta version) 2015-01-27 Progress on NLO integration Fixing a bug for multiple processes in a single event file when using beam event files 2015-01-19 Bug fix for spin correlations evaluated in the rest frame of the mother particle 2015-01-17 Regression fix for statically linked processes from SARAH and FeynRules 2015-01-10 NLO: massive FKS emitters supported (experimental) 2015-01-06 MMHT2014 PDF sets included 2015-01-05 Handling mass degeneracies in auto_decays 2014-12-19 Fixing bug in rescan of event files ################################################################## 2014-11-30 RELEASE: version 2.2.3 2014-11-29 Beta version of LO continuum/NLL-threshold matched top threshold model for e+e- physics 2014-11-28 More internal refactoring: disentanglement of module dependencies 2014-11-21 OVM: O'Mega Virtual Machine, bytecode instructions instead of compiled Fortran code 2014-11-01 Higgs Singlet extension model included 2014-10-18 Internal restructuring of code; half-way WHIZARD main code file disassembled 2014-07-09 Alpha version of NLO infrastructure ################################################################## 2014-07-06 RELEASE: version 2.2.2 2014-07-05 CIRCE2: correlated LC beam spectra and GuineaPig Interface to LC machine parameters 2014-07-01 Reading LHEF for decayed/factorized/showered/ hadronized events 2014-06-25 Configure support for GoSAM/Ninja/Form/QGraf 2014-06-22 LHAPDF6 interface 2014-06-18 Module for automatic generation of radiation and loop infrastructure code 2014-06-11 Improved internal directory structure ################################################################## 2014-06-03 RELEASE: version 2.2.1 2014-05-30 Extensions of internal PDG arrays 2014-05-26 FastJet interface 2014-05-24 CJ12 PDFs included 2014-05-20 Regression fix for external models (via SARAH or FeynRules) ################################################################## 2014-05-18 RELEASE: version 2.2.0 2014-04-11 Multiple components: inclusive process definitions, syntax: process A + B + ... 2014-03-13 Improved PS mappings for e+e- ISR ILC TDR and CLIC spectra included in CIRCE1 2014-02-23 New models: AltH w\ Higgs for exclusion purposes, SM_rx for Dim 6-/Dim-8 operators, SSC for general strong interactions (w/ Higgs), and NoH_rx (w\ Higgs) 2014-02-14 Improved s-channel mapping, new on-shell production mapping (e.g. Drell-Yan) 2014-02-03 PRE-RELEASE: version 2.2.0_beta 2014-01-26 O'Mega: Feynman diagram generation possible (again) 2013-12-16 HOPPET interface for b parton matching 2013-11-15 PRE-RELEASE: version 2.2.0_alpha-4 2013-10-27 LHEF standards 1.0/2.0/3.0 implemented 2013-10-15 PRE-RELEASE: version 2.2.0_alpha-3 2013-10-02 PRE-RELEASE: version 2.2.0_alpha-2 2013-09-25 PRE-RELEASE: version 2.2.0_alpha-1 2013-09-12 PRE-RELEASE: version 2.2.0_alpha 2013-09-03 General 2HDM implemented 2013-08-18 Rescanning/recalculating events 2013-06-07 Reconstruction of complete event from 4-momenta possible 2013-05-06 Process library stacks 2013-05-02 Process stacks 2013-04-29 Single-particle phase space module 2013-04-26 Abstract interface for random number generator 2013-04-24 More object-orientation on modules Midpoint-rule integrator 2013-04-05 Object-oriented integration and event generation 2013-03-12 Processes recasted object-oriented: MEs, scales, structure functions First infrastructure for general Lorentz structures 2013-01-17 Object-orientated reworking of library and process core, more variable internal structure, unit tests 2012-12-14 Update Pythia version to 6.4.27 2012-12-04 Fix the phase in HAZ vertices 2012-11-21 First O'Mega unit tests, some infrastructure 2012-11-13 Bug fix in anom. HVV Lorentz structures ################################################################## 2012-09-18 RELEASE: version 2.1.1 2012-09-11 Model MSSM_Hgg with Hgg and HAA vertices 2012-09-10 First version of implementation of multiple interactions in WHIZARD 2012-09-05 Infrastructure for internal CKKW matching 2012-09-02 C, C++, Python API 2012-07-19 Fixing particle numbering in HepMC format ################################################################## 2012-06-15 RELEASE: version 2.1.0 2012-06-14 Analytical and kT-ordered shower officially released PYTHIA interface officially released 2012-05-09 Intrisince PDFs can be used for showering 2012-05-04 Anomalous Higgs couplings a la hep-ph/9902321 ################################################################## 2012-03-19 RELEASE: version 2.0.7 2012-03-15 Run IDs are available now More event variables in analysis Modified raw event format (compatibility mode exists) 2012-03-12 Bug fix in decay-integration order MLM matching steered completely internally now 2012-03-09 Special phase space mapping for narrow resonances decaying to 4-particle final states with far off-shell intermediate states Running alphas from PDF collaborations with builtin PDFs 2012-02-16 Bug fix in cascades decay infrastructure 2012-02-04 WHIZARD documentation compatible with TeXLive 2011 2012-02-01 Bug fix in FeynRules interface with --prefix flag 2012-01-29 Bug fix with name clash of O'Mega variable names 2012-01-27 Update internal PYTHIA to version 6.4.26 Bug fix in LHEF output 2012-01-21 Catching stricter automake 1.11.2 rules 2011-12-23 Bug fix in decay cascade setup 2011-12-20 Bug fix in helicity selection rules 2011-12-16 Accuracy goal reimplemented 2011-12-14 WHIZARD compatible with TeXLive 2011 2011-12-09 Option --user-target added ################################################################## 2011-12-07 RELEASE: version 2.0.6 2011-12-07 Bug fixes in SM_top_anom Added missing entries to HepMC format 2011-12-06 Allow to pass options to O'Mega Bug fix for HEPEVT block for showered/hadronized events 2011-12-01 Reenabled user plug-in for external code for cuts, structure functions, routines etc. 2011-11-29 Changed model SM_Higgs for Higgs phenomenology 2011-11-25 Supporting a Y, (B-L) Z' model 2011-11-23 Make WHIZARD compatible for MAC OS X Lion/XCode 4 2011-09-25 WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742 2011-08-16 Model SM_QCD: QCD with one EW insertion 2011-07-19 Explicit output channel for dvips avoids printing 2011-07-10 Test suite for WHIZARD unit tests 2011-07-01 Commands for matrix element tests More OpenMP parallelization of kinematics Added unit tests 2011-06-23 Conversion of CIRCE2 from F77 to F90, major clean-up 2011-06-14 Conversion of CIRCE1 from F77 to F90 2011-06-10 OpenMP parallelization of channel kinematics (by Matthias Trudewind) 2011-05-31 RELEASE: version 1.97 2011-05-24 Minor bug fixes: update grids and elsif statement. ################################################################## 2011-05-10 RELEASE: version 2.0.5 2011-05-09 Fixed bug in final state flavor sums Minor improvements on phase-space setup 2011-05-05 Minor bug fixes 2011-04-15 WHIZARD as a precompiled 64-bit binary available 2011-04-06 Wall clock instead of cpu time for time estimates 2011-04-05 Major improvement on the phase space setup 2011-04-02 OpenMP parallelization for helicity loop in O'Mega matrix elements 2011-03-31 Tools for relocating WHIZARD and use in batch environments 2011-03-29 Completely static builds possible, profiling options 2011-03-28 Visualization of integration history 2011-03-27 Fixed broken K-matrix implementation 2011-03-23 Including the GAMELAN manual in the distribution 2011-01-26 WHIZARD analysis can handle hadronized event files 2011-01-17 MSTW2008 and CT10 PDF sets included 2010-12-23 Inclusion of NMSSM with Hgg couplings 2010-12-21 Advanced options for integration passes 2010-11-16 WHIZARD supports CTEQ6 and possibly other PDFs directly; data files included in the distribution ################################################################## 2010-10-26 RELEASE: version 2.0.4 2010-10-06 Bug fix in MSSM implementation 2010-10-01 Update to libtool 2.4 2010-09-29 Support for anomalous top couplings (form factors etc.) Bug fix for running gauge Yukawa SUSY couplings 2010-09-28 RELEASE: version 1.96 2010-09-21 Beam remnants and pT spectra for lepton collider re-enabled Restructuring subevt class 2010-09-16 Shower and matching are disabled by default PYTHIA as a conditional on these two options 2010-09-14 Possibility to read in beam spectra re-enabled (e.g. Guinea Pig) 2010-09-13 Energy scan as (pseudo-) structure functions re-implemented 2010-09-10 CIRCE2 included again in WHIZARD 2 and validated 2010-09-02 Re-implementation of asymmetric beam energies and collision angles, e-p collisions work, inclusion of a HERA DIS test case ################################################################## 2010-10-18 RELEASE: version 2.0.3 2010-08-08 Bug in CP-violating anomalous triple TGCs fixed 2010-08-06 Solving backwards compatibility problem with O'Caml 3.12.0 2010-07-12 Conserved quantum numbers speed up O'Mega code generation 2010-07-07 Attaching full ISR/FSR parton shower and MPI/ISR module Added SM model containing Hgg, HAA, HAZ vertices 2010-07-02 Matching output available as LHEF and STDHEP 2010-06-30 Various bug fixes, missing files, typos 2010-06-26 CIRCE1 completely re-enabled Chaining structure functions supported 2010-06-25 Partial support for conserved quantum numbers in O'Mega 2010-06-21 Major upgrade of the graphics package: error bars, smarter SINDARIN steering, documentation, and all that... 2010-06-17 MLM matching with PYTHIA shower included 2010-06-16 Added full CIRCE1 and CIRCE2 versions including full documentation and miscellanea to the trunk 2010-06-12 User file management supported, improved variable and command structure 2010-05-24 Improved handling of variables in local command lists 2010-05-20 PYTHIA interface re-enabled 2010-05-19 ASCII file formats for interfacing ROOT and gnuplot in data analysis ################################################################## 2010-05-18 RELEASE: version 2.0.2 2010-05-14 Reimplementation of visualization of phase space channels Minor bug fixes 2010-05-12 Improved phase space - elimination of redundancies 2010-05-08 Interface for polarization completed: polarized beams etc. 2010-05-06 Full quantum numbers appear in process log Integration results are usable as user variables Communication with external programs 2010-05-05 Split module commands into commands, integration, simulation modules 2010-05-04 FSR+ISR for the first time connected to the WHIZARD 2 core ################################################################## 2010-04-25 RELEASE: version 2.0.1 2010-04-23 Automatic compile and integrate if simulate is called Minor bug fixes in O'Mega 2010-04-21 Checkpointing for event generation Flush statements to use WHIZARD inside a pipe 2010-04-20 Reimplementation of signal handling in WGIZARD 2.0 2010-04-19 VAMP is now a separately configurable and installable unit of WHIZARD, included VAMP self-checks Support again compilation in quadruple precision 2010-04-06 Allow for logarithmic plots in GAMELAN, reimplement the possibility to set the number of bins 2010-04-15 Improvement on time estimates for event generation ################################################################## 2010-04-12 RELEASE: version 2.0.0 2010-04-09 Per default, the code for the amplitudes is subdivided to allow faster compiler optimization More advanced and unified and straightforward command language syntax Final bug fixes 2010-04-07 Improvement on SINDARIN syntax; printf, sprintf function thorugh a C interface 2010-04-05 Colorizing DAGs instead of model vertices: speed boost in colored code generation 2010-03-31 Generalized options for normalization of weighted and unweighted events Grid and weight histories added again to log files Weights can be used in analyses 2010-03-28 Cascade decays completely implemented including color and spin correlations 2010-03-07 Added new WHIZARD header with logo 2010-03-05 Removed conflict in O'Mega amplitudes between flavour sums and cascades StdHEP interface re-implemented 2010-03-03 RELEASE: version 2.0.0rc3 Several bug fixes for preventing abuse in input files OpenMP support for amplitudes Reimplementation of WHIZARD 1 HEPEVT ASCII event formats FeynRules interface successfully passed MSSM test 2010-02-26 Eliminating ghost gluons from multi-gluon amplitudes 2010-02-25 RELEASE: version 1.95 HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2 2010-02-23 Running alpha_s implemented in the FeynRules interface 2010-02-19 MSSM (semi-) automatized self-tests finalized 2010-02-17 RELEASE: version 1.94 2010-02-16 Closed memory corruption in WHIZARD 1 Fixed problems of old MadGraph and CompHep drivers with modern compilers Uncolored vertex selection rules for colored amplitudes in O'Mega 2010-02-15 Infrastructure for color correlation computation in O'Mega finished Forbidden processes are warned about, but treated as non-fatal 2010-02-14 Color correlation computation in O'Mega finalized 2010-02-10 Improving phase space mappings for identical particles in initial and final states Introduction of more extended multi-line error message 2010-02-08 First O'Caml code for computation of color correlations in O'Mega 2010-02-07 First MLM matching with e+ e- -> jets ################################################################## 2010-02-06 RELEASE: version 2.0.0rc2 2010-02-05 Reconsidered the Makefile structure and more extended tests Catch a crash between WHIZARD and O'Mega for forbidden processes Tensor products of arbitrary color structures in jet definitions 2010-02-04 Color correlation computation in O'Mega finalized ################################################################## 2010-02-03 RELEASE: version 2.0.0rc1 ################################################################## 2010-01-31 Reimplemented numerical helicity selection rules Phase space functionality of version 1 restored and improved 2009-12-05 NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam) 2009-12-04 RELEASE: version 2.0.0alpha ################################################################## 2009-04-16 RELEASE: version 1.93 2009-04-15 Clean-up of Makefiles and configure scripts Reconfiguration of BSM model implementation extended supersymmetric models 2008-12-23 New model NMSSM (Felix Braam) SLHA2 added Bug in LHAPDF interface fixed 2008-08-16 Bug fixed in K matrix implementation Gravitino option in the MSSM added 2008-03-20 Improved color and flavor sums ################################################################## 2008-03-12 RELEASE: version 1.92 LHEF (Les Houches Event File) format added Fortran 2003 command-line interface (if supported by the compiler) Automated interface to colored models More bug fixes and workarounds for compiler compatibility ################################################################## 2008-03-06 RELEASE: version 1.91 New model K-matrix (resonances and anom. couplings in WW scattering) EWA spectrum Energy-scan pseudo spectrum Preliminary parton shower module (only from final-state quarks) Cleanup and improvements of configure process Improvements for O'Mega parameter files Quadruple precision works again More plotting options: lines, symbols, errors Documentation with PDF bookmarks enabled Various bug fixes 2007-11-29 New model UED ################################################################## 2007-11-23 RELEASE: version 1.90 O'Mega now part of the WHIZARD tree Madgraph/CompHEP disabled by default (but still usable) Support for LHAPDF (preliminary) Added new models: SMZprime, SM_km, Template Improved compiler recognition and compatibility Minor bug fixes ################################################################## 2006-06-15 RELEASE: version 1.51 Support for anomaly-type Higgs couplings (to gluon and photon/Z) Support for spin 3/2 and spin 2 New models: Little Higgs (4 versions), toy models for extra dimensions and gravitinos Fixes to the whizard.nw source documentation to run through LaTeX Intel 9.0 bug workaround (deallocation of some arrays) 2006-05-15 O'Mega RELEASE: version 0.11 merged JRR's O'Mega extensions ################################################################## 2006-02-07 RELEASE: version 1.50 To avoid confusion: Mention outdated manual example in BUGS file O'Mega becomes part of the WHIZARD generator 2006-02-02 [bug fix update] Bug fix: spurious error when writing event files for weighted events Bug fix: 'r' option for omega produced garbage for some particle names Workaround for ifort90 bug (crash when compiling whizard_event) Workaround for ifort90 bug (crash when compiling hepevt_common) 2006-01-27 Added process definition files for MSSM 2->2 processes Included beam recoil for EPA (T.Barklow) Updated STDHEP byte counts (for STDHEP 5.04.02) Fixed STDHEP compatibility (avoid linking of incomplete .so libs) Fixed issue with comphep requiring Xlibs on Opteron Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface) Fixed color-flow code: was broken for omega with option 'c' and 'w' Workaround hacks for g95 compatibility 2005-11-07 O'Mega RELEASE: version 0.10 O'Mega, merged JRR's and WK's color hack for WHiZard O'Mega, EXPERIMENTAL: cache fusion tables (required for colors a la JRR/WK) O'Mega, make JRR's MSSM official ################################################################## 2005-10-25 RELEASE: version 1.43 Minor fixes in MSSM couplings (Higgs/3rd gen squarks). This should be final, since the MSSM results agree now completely with Madgraph and Sherpa User-defined lower and upper limits for split event file count Allow for counters (events, bytes) exceeding $2^{31}$ Revised checksum treatment and implementation (now MD5) Bug fix: missing process energy scale in raw event file ################################################################## 2005-09-30 RELEASE: version 1.42 Graphical display of integration history ('make history') Allow for switching off signals even if supported (configure option) 2005-09-29 Revised phase space generation code, in particular for flavor sums Negative cut and histogram codes use initial beams instead of initial parton momenta. This allows for computing, e.g., E_miss Support constant-width and zero-width options for O'Mega Width options now denoted by w:X (X=f,c,z). f option obsolescent Bug fix: colorized code: flipped indices could screw up result Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem) Bug fix: dvips on systems where dvips defaults to lpr Bug fix: integer overflow if too many events are requested 2005-07-29 Allow for 2 -> 1 processes (if structure functions are on) 2005-07-26 Fixed and expanded the 'test' matrix element: Unit matrix element with option 'u' / default: normalized phase space ################################################################## 2005-07-15 RELEASE: version 1.41 Bug fix: no result for particle decay processes with width=0 Bug fix: line breaks in O'Mega files with color decomposition 2005-06-02 New self-tests (make test-QED / test-QCD / test-SM) check lists of 2->2 processes Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex) 2005-05-25 Revised Makefile structure Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA) 2005-05-19 Support for color in O'Mega (using color flow decomposition) New model QCD Parameter file changes that correspond to replaced SM module in O'Mega Bug fixes in MSSM (O'Mega) parameter file 2005-05-18 New event file formats, useful for LHC applications: ATHENA and Les Houches Accord (external fragmentation) Naive (i.e., leading 1/N) color factor now implemented both for incoming and outgoing partons 2005-01-26 include missing HELAS files for bundle pgf90 compatibility issues [note: still internal error in pgf90] ################################################################## 2004-12-13 RELEASE: version 1.40 compatibility fix: preprocessor marks in helas code now commented out minor bug fix: format string in madgraph source 2004-12-03 support for arbitray beam energies and directions allow for pT kick in structure functions bug fix: rounding error could result in zero cross section (compiler-dependent) 2004-10-07 simulate decay processes list fraction (of total width/cross section) instead of efficiency in process summary new cut/analysis parameters AA, AAD, CTA: absolute polar angle 2004-10-04 Replaced Madgraph I by Madgraph II. Main improvement: model no longer hardcoded introduced parameter reset_seed_each_process (useful for debugging) bug fix: color initialization for some processes was undefined 2004-09-21 don't compile unix_args module if it is not required ################################################################## 2004-09-20 RELEASE: version 1.30 g95 compatibility issues resolved some (irrelevant) memory leaks closed removed obsolete warning in circe1 manual update (essentially) finished 2004-08-03 O'Mega RELEASE: version 0.9 O'Mega, src/trie.mli, src/trie.ml: make interface compatible with the O'Caml 3.08 library (remains compatible with older versions). Implementation of unused functions still incomplete. 2004-07-26 minor fixes and improvements in make process 2004-06-29 workarounds for new Intel compiler bugs ... no rebuild of madgraph/comphep executables after 'make clean' bug fix in phase space routine: wrong energy for massive initial particles bug fix in (new) model interface: name checks for antiparticles pre-run checks for comphep improved ww-strong model file extended Model files particle name fixes, chep SM vertices included 2004-06-22 O'Mega RELEASE: version 0.8 O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings 2004-05-05 Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO) NAG compiler: set number of continuation lines to 200 as default Extended format for cross section summary; appears now in whizard.out Fixed 'bundle' feature 2004-04-28 Fixed compatibility with revised O'Mega SM_ac model Fixed problem with x=0 or x=1 when calling PDFLIB (ThO) Fixed bug in comphep module: Vtb was overlooked ################################################################## 2004-04-15 RELEASE: version 1.28 Fixed bug: Color factor was missing for O'Mega processes with four quarks and more Manual partially updated 2004-04-08 Support for grid files in binary format New default value show_histories=F (reduce output file size) Revised phase space switches: removed annihilation_lines, removed s_channel_resonance, changed meaning of extra_off_shell_lines, added show_deleted_channels Bug fixed which lead to omission of some phase space channels Color flow guessed only if requested by guess_color_flow 2004-03-10 New model interface: Only one model name specified in whizard.prc All model-dependent files reside in conf/models (modellib removed) 2004-03-03 Support for input/output in SUSY Les Houches Accord format Split event files if requested Support for overall time limit Support for CIRCE and CIRCE2 generator mode Support for reading beam events from file 2004-02-05 Fixed compiler problems with Intel Fortran 7.1 and 8.0 Support for catching signals ################################################################## 2003-08-06 RELEASE: version 1.27 User-defined PDF libraries as an alternative to the standard PDFLIB 2003-07-23 Revised phase space module: improved mappings for massless particles, equivalences of phase space channels are exploited Improved mapping for PDF (hadron colliders) Madgraph module: increased max number of color flows from 250 to 1000 ################################################################## 2003-06-23 RELEASE: version 1.26 CIRCE2 support Fixed problem with 'TC' integer kind [Intel compiler complained] 2003-05-28 Support for drawing histograms of grids Bug fixes for MSSM definitions ################################################################## 2003-05-22 RELEASE: version 1.25 Experimental MSSM support with ISAJET interface Improved capabilities of generating/analyzing weighted events Optional drawing phase space diagrams using FeynMF ################################################################## 2003-01-31 RELEASE: version 1.24 A few more fixes and workarounds (Intel and Lahey compiler) 2003-01-15 Fixes and workarounds needed for WHIZARD to run with Intel compiler Command-line option interface for the Lahey compiler Bug fix: problem with reading whizard.phs ################################################################## 2002-12-10 RELEASE: version 1.23 Command-line options (on some systems) Allow for initial particles in the event record, ordered: [beams, initials] - [remnants] - outgoing partons Support for PYTHIA 6.2: Les Houches external process interface String pythia_parameters can be up to 1000 characters long Select color flow states in (internal) analysis Bug fix in color flow content of raw event files Support for transversal polarization of fermion beams Cut codes: PHI now for absolute azimuthal angle, DPHI for distance 'Test' matrix elements optionally respect polarization User-defined code can be inserted for spectra, structure functions and fragmentation Time limits can be specified for adaptation and simulation User-defined file names and file directory Initial weights in input file no longer supported Bug fix in MadGraph (wave function counter could overflow) Bug fix: Gamelan (graphical analysis) was not built if noweb absent ################################################################## 2002-03-16 RELEASE: version 1.22 Allow for beam remnants in the event record 2002-03-01 Handling of aliases in whizard.prc fixed (aliases are whole tokens) 2002-02-28 Optimized phase space handling routines (total execution time reduced by 20-60%, depending on process) ################################################################## 2002-02-26 RELEASE: version 1.21 Fixed ISR formula (ISR was underestimated in previous versions). New version includes ISR in leading-log approximation up to third order. Parameter ISR_sqrts renamed to ISR_scale. ################################################################## 2002-02-19 RELEASE: version 1.20 New process-generating method 'test' (dummy matrix element) Compatibility with autoconf 2.50 and current O'Mega version 2002-02-05 Prevent integration channels from being dropped (optionally) New internal mapping for structure functions improves performance Old whizard.phx file deleted after recompiling (could cause trouble) 2002-01-24 Support for user-defined cuts and matrix element reweighting STDHEP output now written by write_events_format=20 (was 3) 2002-01-16 Improved structure function handling; small changes in user interface: new parameter structured_beams in &process_input parameter fixed_energy in &beam_input removed Support for multiple initial states Eta-phi (cone) cut possible (hadron collider applications) Fixed bug: Whizard library was not always recompiled when necessary Fixed bug: Default cuts were insufficient in some cases Fixed bug: Unusable phase space mappings generated in some cases 2001-12-06 Reorganized document source 2001-12-05 Preliminary CIRCE2 support (no functionality yet) 2001-11-27 Intel compiler support (does not yet work because of compiler bugs) New cut and analysis mode cos-theta* and related Fixed circular jetset_interface dependency warning Some broadcast routines removed (parallel support disabled anyway) Minor shifts in cleanup targets (Makefiles) Modified library search, check for pdflib8* 2001-08-06 Fixed bug: I/O unit number could be undefined when reading phase space Fixed bug: Unitialized variable could cause segfault when event generation was disabled Fixed bug: Undefined subroutine in CIRCE replacement module Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements (CompHEP model sm-GF #5, O'Mega model SM_ac) Fixed portability issue: Makefile did rely on PWD environment variable Fixed portability issue: PYTHIA library search ambiguity resolved 2001-08-01 Default whizard.prc and whizard.in depend on activated modules Fixed bug: TEX=latex was not properly enabled when making plots 2001-07-20 Fixed output settings in PERL script calls Cache enabled in various configure checks 2001-07-13 Support for multiple processes in a single WHIZARD run. The integrations are kept separate, but the generated events are mixed The whizard.evx format has changed (incompatible), including now the color flow information for PYTHIA fragmentation Output files are now process-specific, except for the event file Phase space file whizard.phs (if present) is used only as input, program-generated phase space is now in whizard.phx 2001-07-10 Bug fix: Undefined parameters in parameters_SM_ac.f90 removed 2001-07-04 Bug fix: Compiler options for the case OMEGA is disabled Small inconsistencies in whizard.out format fixed 2001-07-01 Workaround for missing PDFLIB dummy routines in PYTHIA library ################################################################## 2001-06-30 RELEASE: version 1.13 Default path /cern/pro/lib in configure script 2001-06-20 New fragmentation option: Interface for PYTHIA with full color flow information, beam remnants etc. 2001-06-18 Severe bug fixed in madgraph interface: 3-gluon coupling was missing Enabled color flow information in madgraph 2001-06-11 VAMP interface module rewritten Revised output format: Multiple VAMP iterations count as one WHIZARD iteration in integration passes 1 and 3 Improved message and error handling Bug fix in VAMP: handle exceptional cases in rebinning_weights 2001-05-31 new parameters for grid adaptation: accuracy_goal and efficiency_goal ################################################################## 2001-05-29 RELEASE: version 1.12 bug fixes (compilation problems): deleted/modified unused functions 2001-05-16 diagram selection improved and documented 2001-05-06 allow for disabling packages during configuration 2001-05-03 slight changes in whizard.out format; manual extended ################################################################## 2001-04-20 RELEASE: version 1.11 fixed some configuration and compilation problems (PDFLIB etc.) 2001-04-18 linked PDFLIB: support for quark/gluon structure functions 2001-04-05 parameter interface written by PERL script SM_ac model file: fixed error in continuation line 2001-03-13 O'Mega, O'Caml 3.01: incompatible changes O'Mega, src/trie.mli: add covariance annotation to T.t This breaks O'Caml 3.00, but is required for O'Caml 3.01. O'Mega, many instances: replace `sig include Module.T end' by `Module.T', since the bug is fixed in O'Caml 3.01 2001-02-28 O'Mega, src/model.mli: new field Model.vertices required for model functors, will retire Model.fuse2, Model.fuse3, Model.fusen soon. ################################################################## 2001-03-27 RELEASE: version 1.10 reorganized the modules as libraries linked PYTHIA: support for parton fragmentation 2000-12-14 fixed some configuration problems (if noweb etc. are absent) ################################################################## 2000-12-01 RELEASE of first public version: version 1.00beta