No OneTemporary
Actions

Size

562 KB

Subscribers

None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.

	Index: trunk/src/qft/qft.nw
	===================================================================
	--- trunk/src/qft/qft.nw (revision 8159)
	+++ trunk/src/qft/qft.nw (revision 8160)
	@@ -1,15427 +1,15425 @@
	%% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: Quantum Field Theory concepts
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Quantum Field Theory Concepts}
	\includemodulegraph{qft}

	The objects and methods defined here implement concepts and data for
	the underlying quantum field theory that we use for computing matrix
	elements and processes.
	\begin{description}
	\item[model\_data]
	Fields and coupling parameters, operators as vertex structures, for
	a specific model.
	\item[model\_testbed]
	Provide hooks to deal with a [[model_data]] extension without
	referencing it explicitly.
	\item[helicities]
	Types and methods for spin density matrices.
	\item[colors]
	Dealing with colored particles, using the color-flow representation.
	\item[flavors]
	PDG codes and particle properties, depends on the model.
	\item[quantum\_numbers]
	Quantum numbers and density matrices for entangled particle systems.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Model Data}

	These data represent a specific Lagrangian in numeric terms. That is,
	we have the fields with their quantum numbers, the masses, widths and
	couplings as numerical values, and the vertices as arrays of fields.

	We do not store the relations between coupling parameters. They
	should be represented by expressions for evaluation, implemented as
	Sindarin objects in a distinct data structure. Neither do we need the
	algebraic structure of vertices. The field content of vertices is
	required for the sole purpose of setting up phase space.
	<<[[model_data.f90]]>>=
	<<File header>>

	module model_data

	use, intrinsic :: iso_c_binding !NODEP!

	<<Use kinds>>
	use kinds, only: i8, i32
	use kinds, only: c_default_float
	<<Use strings>>
	use format_defs, only: FMT_19
	use io_units
	use diagnostics
	use md5
	use hashes, only: hash
	use physics_defs, only: UNDEFINED, SCALAR

	<<Standard module head>>

	<<Model data: public>>

	<<Model data: parameters>>

	<<Model data: types>>

	contains

	<<Model data: procedures>>

	end module model_data
	@ %def model_data
	@
	\subsection{Physics Parameters}
	Couplings, masses, and widths are physics parameters. Each parameter
	has a unique name (used, essentially, for diagnostics output and
	debugging) and a value. The value may be a real or a complex number,
	so we provide to implementations of an abstract type.
	<<Model data: public>>=
	public :: modelpar_data_t
	<<Model data: types>>=
	type, abstract :: modelpar_data_t
	private
	type(string_t) :: name
	contains
	<<Model data: par data: TBP>>
	end type modelpar_data_t

	type, extends (modelpar_data_t) :: modelpar_real_t
	private
	real(default) :: value
	end type modelpar_real_t

	type, extends (modelpar_data_t) :: modelpar_complex_t
	private
	complex(default) :: value
	end type modelpar_complex_t

	@ %def modelpar_data_t modelpar_real_t modelpar_complex_t
	@
	Output for diagnostics. Non-advancing.
	<<Model data: par data: TBP>>=
	procedure :: write => par_write
	<<Model data: procedures>>=
	subroutine par_write (par, unit)
	class(modelpar_data_t), intent(in) :: par
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A,1x,A)", advance="no") char (par%name), "= "
	select type (par)
	type is (modelpar_real_t)
	write (u, "(" // FMT_19 // ")", advance="no") par%value
	type is (modelpar_complex_t)
	write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", &
	advance="no") par%value
	end select
	end subroutine par_write

	@ %def par_write
	@
	Pretty-printed on separate line, with fixed line length
	<<Model data: par data: TBP>>=
	procedure :: show => par_show
	<<Model data: procedures>>=
	subroutine par_show (par, l, u)
	class(modelpar_data_t), intent(in) :: par
	integer, intent(in) :: l, u
	character(len=l) :: buffer
	buffer = par%name
	select type (par)
	type is (modelpar_real_t)
	write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")") buffer, par%value
	type is (modelpar_complex_t)
	write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," &
	// FMT_19 // ",1x,'I')") buffer, par%value
	end select
	end subroutine par_show

	@ %def par_show
	@
	Initialize with name and value. The type depends on the argument
	type. If the type does not match, the value is converted following
	Fortran rules.
	<<Model data: par data: TBP>>=
	generic :: init => modelpar_data_init_real, modelpar_data_init_complex
	procedure, private :: modelpar_data_init_real
	procedure, private :: modelpar_data_init_complex
	<<Model data: procedures>>=
	subroutine modelpar_data_init_real (par, name, value)
	class(modelpar_data_t), intent(out) :: par
	type(string_t), intent(in) :: name
	real(default), intent(in) :: value
	par%name = name
	par = value
	end subroutine modelpar_data_init_real

	subroutine modelpar_data_init_complex (par, name, value)
	class(modelpar_data_t), intent(out) :: par
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: value
	par%name = name
	par = value
	end subroutine modelpar_data_init_complex

	@ %def modelpar_data_init_real modelpar_data_init_complex
	@
	Modify the value. We assume that the parameter has been
	initialized. The type (real or complex) must not be changed, and the
	name is also fixed.
	<<Model data: par data: TBP>>=
	generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex
	procedure, private :: modelpar_data_set_real
	procedure, private :: modelpar_data_set_complex
	<<Model data: procedures>>=
	elemental subroutine modelpar_data_set_real (par, value)
	class(modelpar_data_t), intent(inout) :: par
	real(default), intent(in) :: value
	select type (par)
	type is (modelpar_real_t)
	par%value = value
	type is (modelpar_complex_t)
	par%value = value
	end select
	end subroutine modelpar_data_set_real

	elemental subroutine modelpar_data_set_complex (par, value)
	class(modelpar_data_t), intent(inout) :: par
	complex(default), intent(in) :: value
	select type (par)
	type is (modelpar_real_t)
	par%value = value
	type is (modelpar_complex_t)
	par%value = value
	end select
	end subroutine modelpar_data_set_complex

	@ %def modelpar_data_set_real modelpar_data_set_complex
	@
	Return the parameter name.
	<<Model data: par data: TBP>>=
	procedure :: get_name => modelpar_data_get_name
	<<Model data: procedures>>=
	function modelpar_data_get_name (par) result (name)
	class(modelpar_data_t), intent(in) :: par
	type(string_t) :: name
	name = par%name
	end function modelpar_data_get_name

	@ %def modelpar_data_get_name
	@
	Return the value. In case of a type mismatch, follow Fortran conventions.
	<<Model data: par data: TBP>>=
	procedure, pass :: get_real => modelpar_data_get_real
	procedure, pass :: get_complex => modelpar_data_get_complex
	<<Model data: procedures>>=
	elemental function modelpar_data_get_real (par) result (value)
	class(modelpar_data_t), intent(in), target :: par
	real(default) :: value
	select type (par)
	type is (modelpar_real_t)
	value = par%value
	type is (modelpar_complex_t)
	value = par%value
	end select
	end function modelpar_data_get_real

	elemental function modelpar_data_get_complex (par) result (value)
	class(modelpar_data_t), intent(in), target :: par
	complex(default) :: value
	select type (par)
	type is (modelpar_real_t)
	value = par%value
	type is (modelpar_complex_t)
	value = par%value
	end select
	end function modelpar_data_get_complex

	@ %def modelpar_data_get_real
	@ %def modelpar_data_get_complex
	@
	Return a pointer to the value. This makes sense only for matching types.
	<<Model data: par data: TBP>>=
	procedure :: get_real_ptr => modelpar_data_get_real_ptr
	procedure :: get_complex_ptr => modelpar_data_get_complex_ptr
	<<Model data: procedures>>=
	function modelpar_data_get_real_ptr (par) result (ptr)
	class(modelpar_data_t), intent(in), target :: par
	real(default), pointer :: ptr
	select type (par)
	type is (modelpar_real_t)
	ptr => par%value
	class default
	ptr => null ()
	end select
	end function modelpar_data_get_real_ptr

	function modelpar_data_get_complex_ptr (par) result (ptr)
	class(modelpar_data_t), intent(in), target :: par
	complex(default), pointer :: ptr
	select type (par)
	type is (modelpar_complex_t)
	ptr => par%value
	class default
	ptr => null ()
	end select
	end function modelpar_data_get_complex_ptr

	@ %def modelpar_data_get_real_ptr
	@ %def modelpar_data_get_complex_ptr
	@
	\subsection{Field Data}
	The field-data type holds all information that pertains to a particular field
	(or particle) within a particular model. Information such as spin type,
	particle code etc.\ is stored within the object itself, while mass and width
	are associated to parameters, otherwise assumed zero.
	<<Model data: public>>=
	public :: field_data_t
	<<Model data: types>>=
	type :: field_data_t
	private
	type(string_t) :: longname
	integer :: pdg = UNDEFINED
	logical :: visible = .true.
	logical :: parton = .false.
	logical :: gauge = .false.
	logical :: left_handed = .false.
	logical :: right_handed = .false.
	logical :: has_anti = .false.
	logical :: p_is_stable = .true.
	logical :: p_decays_isotropically = .false.
	logical :: p_decays_diagonal = .false.
	logical :: p_has_decay_helicity = .false.
	integer :: p_decay_helicity = 0
	logical :: a_is_stable = .true.
	logical :: a_decays_isotropically = .false.
	logical :: a_decays_diagonal = .false.
	logical :: a_has_decay_helicity = .false.
	integer :: a_decay_helicity = 0
	logical :: p_polarized = .false.
	logical :: a_polarized = .false.
	type(string_t), dimension(:), allocatable :: name, anti
	type(string_t) :: tex_name, tex_anti
	integer :: spin_type = UNDEFINED
	integer :: isospin_type = 1
	integer :: charge_type = 1
	integer :: color_type = 1
	real(default), pointer :: mass_val => null ()
	class(modelpar_data_t), pointer :: mass_data => null ()
	real(default), pointer :: width_val => null ()
	class(modelpar_data_t), pointer :: width_data => null ()
	integer :: multiplicity = 1
	type(string_t), dimension(:), allocatable :: p_decay
	type(string_t), dimension(:), allocatable :: a_decay
	contains
	<<Model data: field data: TBP>>
	end type field_data_t

	@ %def field_data_t
	@ Initialize field data with PDG long name and PDG code. \TeX\
	names should be initialized to avoid issues with accessing
	unallocated string contents.
	<<Model data: field data: TBP>>=
	procedure :: init => field_data_init
	<<Model data: procedures>>=
	subroutine field_data_init (prt, longname, pdg)
	class(field_data_t), intent(out) :: prt
	type(string_t), intent(in) :: longname
	integer, intent(in) :: pdg
	prt%longname = longname
	prt%pdg = pdg
	prt%tex_name = ""
	prt%tex_anti = ""
	end subroutine field_data_init

	@ %def field_data_init
	@ Copy quantum numbers from another particle. Do not compute the multiplicity
	yet, because this depends on the association of the [[mass_data]] pointer.
	<<Model data: field data: TBP>>=
	procedure :: copy_from => field_data_copy_from
	<<Model data: procedures>>=
	subroutine field_data_copy_from (prt, prt_src)
	class(field_data_t), intent(inout) :: prt
	class(field_data_t), intent(in) :: prt_src
	prt%visible = prt_src%visible
	prt%parton = prt_src%parton
	prt%gauge = prt_src%gauge
	prt%left_handed = prt_src%left_handed
	prt%right_handed = prt_src%right_handed
	prt%p_is_stable = prt_src%p_is_stable
	prt%p_decays_isotropically = prt_src%p_decays_isotropically
	prt%p_decays_diagonal = prt_src%p_decays_diagonal
	prt%p_has_decay_helicity = prt_src%p_has_decay_helicity
	prt%p_decay_helicity = prt_src%p_decay_helicity
	prt%p_decays_diagonal = prt_src%p_decays_diagonal
	prt%a_is_stable = prt_src%a_is_stable
	prt%a_decays_isotropically = prt_src%a_decays_isotropically
	prt%a_decays_diagonal = prt_src%a_decays_diagonal
	prt%a_has_decay_helicity = prt_src%a_has_decay_helicity
	prt%a_decay_helicity = prt_src%a_decay_helicity
	prt%p_polarized = prt_src%p_polarized
	prt%a_polarized = prt_src%a_polarized
	prt%spin_type = prt_src%spin_type
	prt%isospin_type = prt_src%isospin_type
	prt%charge_type = prt_src%charge_type
	prt%color_type = prt_src%color_type
	prt%has_anti = prt_src%has_anti
	if (allocated (prt_src%name)) then
	if (allocated (prt%name)) deallocate (prt%name)
	allocate (prt%name (size (prt_src%name)), source = prt_src%name)
	end if
	if (allocated (prt_src%anti)) then
	if (allocated (prt%anti)) deallocate (prt%anti)
	allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti)
	end if
	prt%tex_name = prt_src%tex_name
	prt%tex_anti = prt_src%tex_anti
	if (allocated (prt_src%p_decay)) then
	if (allocated (prt%p_decay)) deallocate (prt%p_decay)
	allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay)
	end if
	if (allocated (prt_src%a_decay)) then
	if (allocated (prt%a_decay)) deallocate (prt%a_decay)
	allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay)
	end if
	end subroutine field_data_copy_from

	@ %def field_data_copy_from
	@ Set particle quantum numbers.
	<<Model data: field data: TBP>>=
	procedure :: set => field_data_set
	<<Model data: procedures>>=
	subroutine field_data_set (prt, &
	is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, &
	p_is_stable, p_decays_isotropically, p_decays_diagonal, &
	p_decay_helicity, &
	a_is_stable, a_decays_isotropically, a_decays_diagonal, &
	a_decay_helicity, &
	p_polarized, a_polarized, &
	name, anti, tex_name, tex_anti, &
	spin_type, isospin_type, charge_type, color_type, &
	mass_data, width_data, &
	p_decay, a_decay)
	class(field_data_t), intent(inout) :: prt
	logical, intent(in), optional :: is_visible, is_parton, is_gauge
	logical, intent(in), optional :: is_left_handed, is_right_handed
	logical, intent(in), optional :: p_is_stable
	logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal
	integer, intent(in), optional :: p_decay_helicity
	logical, intent(in), optional :: a_is_stable
	logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal
	integer, intent(in), optional :: a_decay_helicity
	logical, intent(in), optional :: p_polarized, a_polarized
	type(string_t), dimension(:), intent(in), optional :: name, anti
	type(string_t), intent(in), optional :: tex_name, tex_anti
	integer, intent(in), optional :: spin_type, isospin_type
	integer, intent(in), optional :: charge_type, color_type
	class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data
	type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay
	if (present (is_visible)) prt%visible = is_visible
	if (present (is_parton)) prt%parton = is_parton
	if (present (is_gauge)) prt%gauge = is_gauge
	if (present (is_left_handed)) prt%left_handed = is_left_handed
	if (present (is_right_handed)) prt%right_handed = is_right_handed
	if (present (p_is_stable)) prt%p_is_stable = p_is_stable
	if (present (p_decays_isotropically)) &
	prt%p_decays_isotropically = p_decays_isotropically
	if (present (p_decays_diagonal)) &
	prt%p_decays_diagonal = p_decays_diagonal
	if (present (p_decay_helicity)) then
	prt%p_has_decay_helicity = .true.
	prt%p_decay_helicity = p_decay_helicity
	end if
	if (present (a_is_stable)) prt%a_is_stable = a_is_stable
	if (present (a_decays_isotropically)) &
	prt%a_decays_isotropically = a_decays_isotropically
	if (present (a_decays_diagonal)) &
	prt%a_decays_diagonal = a_decays_diagonal
	if (present (a_decay_helicity)) then
	prt%a_has_decay_helicity = .true.
	prt%a_decay_helicity = a_decay_helicity
	end if
	if (present (p_polarized)) prt%p_polarized = p_polarized
	if (present (a_polarized)) prt%a_polarized = a_polarized
	if (present (name)) then
	if (allocated (prt%name)) deallocate (prt%name)
	allocate (prt%name (size (name)), source = name)
	end if
	if (present (anti)) then
	if (allocated (prt%anti)) deallocate (prt%anti)
	allocate (prt%anti (size (anti)), source = anti)
	prt%has_anti = .true.
	end if
	if (present (tex_name)) prt%tex_name = tex_name
	if (present (tex_anti)) prt%tex_anti = tex_anti
	if (present (spin_type)) prt%spin_type = spin_type
	if (present (isospin_type)) prt%isospin_type = isospin_type
	if (present (charge_type)) prt%charge_type = charge_type
	if (present (color_type)) prt%color_type = color_type
	if (present (mass_data)) then
	prt%mass_data => mass_data
	if (associated (mass_data)) then
	prt%mass_val => mass_data%get_real_ptr ()
	else
	prt%mass_val => null ()
	end if
	end if
	if (present (width_data)) then
	prt%width_data => width_data
	if (associated (width_data)) then
	prt%width_val => width_data%get_real_ptr ()
	else
	prt%width_val => null ()
	end if
	end if
	if (present (spin_type) .or. present (mass_data)) then
	call prt%set_multiplicity ()
	end if
	if (present (p_decay)) then
	if (allocated (prt%p_decay)) deallocate (prt%p_decay)
	if (size (p_decay) > 0) &
	allocate (prt%p_decay (size (p_decay)), source = p_decay)
	end if
	if (present (a_decay)) then
	if (allocated (prt%a_decay)) deallocate (prt%a_decay)
	if (size (a_decay) > 0) &
	allocate (prt%a_decay (size (a_decay)), source = a_decay)
	end if
	end subroutine field_data_set

	@ %def field_data_set
	@ Calculate the multiplicity given spin type and mass.
	<<Model data: field data: TBP>>=
	procedure, private :: &
	set_multiplicity => field_data_set_multiplicity
	<<Model data: procedures>>=
	subroutine field_data_set_multiplicity (prt)
	class(field_data_t), intent(inout) :: prt
	if (prt%spin_type /= SCALAR) then
	if (associated (prt%mass_data)) then
	prt%multiplicity = prt%spin_type
	else if (prt%left_handed .or. prt%right_handed) then
	prt%multiplicity = 1
	else
	prt%multiplicity = 2
	end if
	end if
	end subroutine field_data_set_multiplicity

	@ %def field_data_set_multiplicity
	@ Set the mass/width value (not the pointer). The mass/width pointer
	must be allocated.
	<<Model data: field data: TBP>>=
	procedure, private :: set_mass => field_data_set_mass
	procedure, private :: set_width => field_data_set_width
	<<Model data: procedures>>=
	subroutine field_data_set_mass (prt, mass)
	class(field_data_t), intent(inout) :: prt
	real(default), intent(in) :: mass
	if (associated (prt%mass_val)) prt%mass_val = mass
	end subroutine field_data_set_mass

	subroutine field_data_set_width (prt, width)
	class(field_data_t), intent(inout) :: prt
	real(default), intent(in) :: width
	if (associated (prt%width_val)) prt%width_val = width
	end subroutine field_data_set_width

	@ %def field_data_set_mass field_data_set_width
	@ Loose ends: name arrays should be allocated.
	<<Model data: field data: TBP>>=
	procedure :: freeze => field_data_freeze
	<<Model data: procedures>>=
	elemental subroutine field_data_freeze (prt)
	class(field_data_t), intent(inout) :: prt
	if (.not. allocated (prt%name)) allocate (prt%name (0))
	if (.not. allocated (prt%anti)) allocate (prt%anti (0))
	end subroutine field_data_freeze

	@ %def field_data_freeze
	@ Output
	<<Model data: field data: TBP>>=
	procedure :: write => field_data_write
	<<Model data: procedures>>=
	subroutine field_data_write (prt, unit)
	class(field_data_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname)
	write (u, "(1x,I0)", advance="no") prt%pdg
	if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible"
	if (prt%parton) write (u, "(2x,A)", advance="no") "parton"
	if (prt%gauge) write (u, "(2x,A)", advance="no") "gauge"
	if (prt%left_handed) write (u, "(2x,A)", advance="no") "left"
	if (prt%right_handed) write (u, "(2x,A)", advance="no") "right"
	write (u, *)
	write (u, "(5x,A)", advance="no") "name"
	if (allocated (prt%name)) then
	do i = 1, size (prt%name)
	write (u, "(1x,A)", advance="no") '"' // char (prt%name(i)) // '"'
	end do
	write (u, *)
	if (prt%has_anti) then
	write (u, "(5x,A)", advance="no") "anti"
	do i = 1, size (prt%anti)
	write (u, "(1x,A)", advance="no") '"' // char (prt%anti(i)) // '"'
	end do
	write (u, *)
	end if
	if (prt%tex_name /= "") then
	write (u, "(5x,A)") &
	"tex_name " // '"' // char (prt%tex_name) // '"'
	end if
	if (prt%has_anti .and. prt%tex_anti /= "") then
	write (u, "(5x,A)") &
	"tex_anti " // '"' // char (prt%tex_anti) // '"'
	end if
	else
	write (u, "(A)") "???"
	end if
	write (u, "(5x,A)", advance="no") "spin "
	select case (mod (prt%spin_type - 1, 2))
	case (0); write (u, "(I0)", advance="no") (prt%spin_type-1) / 2
	case default; write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2"
	end select
	! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]"
	if (abs (prt%isospin_type) /= 1) then
	write (u, "(2x,A)", advance="no") "isospin "
	select case (mod (abs (prt%isospin_type) - 1, 2))
	case (0); write (u, "(I0)", advance="no") &
	sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2
	case default; write (u, "(I0,A)", advance="no") &
	sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2"
	end select
	end if
	if (abs (prt%charge_type) /= 1) then
	write (u, "(2x,A)", advance="no") "charge "
	select case (mod (abs (prt%charge_type) - 1, 3))
	case (0); write (u, "(I0)", advance="no") &
	sign (abs (prt%charge_type) - 1, prt%charge_type) / 3
	case default; write (u, "(I0,A)", advance="no") &
	sign (abs (prt%charge_type) - 1, prt%charge_type), "/3"
	end select
	end if
	if (prt%color_type /= 1) then
	write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type
	end if
	write (u, *)
	if (associated (prt%mass_data)) then
	write (u, "(5x,A)", advance="no") &
	"mass " // char (prt%mass_data%get_name ())
	if (associated (prt%width_data)) then
	write (u, "(2x,A)") &
	"width " // char (prt%width_data%get_name ())
	else
	write (u, *)
	end if
	end if
	call prt%write_decays (u)
	end subroutine field_data_write

	@ %def field_data_write
	@ Write decay and polarization data.
	<<Model data: field data: TBP>>=
	procedure :: write_decays => field_data_write_decays
	<<Model data: procedures>>=
	subroutine field_data_write_decays (prt, unit)
	class(field_data_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	if (.not. prt%p_is_stable) then
	if (allocated (prt%p_decay)) then
	write (u, "(5x,A)", advance="no") "p_decay"
	do i = 1, size (prt%p_decay)
	write (u, "(1x,A)", advance="no") char (prt%p_decay(i))
	end do
	if (prt%p_decays_isotropically) then
	write (u, "(1x,A)", advance="no") "isotropic"
	else if (prt%p_decays_diagonal) then
	write (u, "(1x,A)", advance="no") "diagonal"
	else if (prt%p_has_decay_helicity) then
	write (u, "(1x,A,I0)", advance="no") "helicity = ", &
	prt%p_decay_helicity
	end if
	write (u, *)
	end if
	else if (prt%p_polarized) then
	write (u, "(5x,A)") "p_polarized"
	end if
	if (.not. prt%a_is_stable) then
	if (allocated (prt%a_decay)) then
	write (u, "(5x,A)", advance="no") "a_decay"
	do i = 1, size (prt%a_decay)
	write (u, "(1x,A)", advance="no") char (prt%a_decay(i))
	end do
	if (prt%a_decays_isotropically) then
	write (u, "(1x,A)", advance="no") "isotropic"
	else if (prt%a_decays_diagonal) then
	write (u, "(1x,A)", advance="no") "diagonal"
	else if (prt%a_has_decay_helicity) then
	write (u, "(1x,A,I0)", advance="no") "helicity = ", &
	prt%a_decay_helicity
	end if
	write (u, *)
	end if
	else if (prt%a_polarized) then
	write (u, "(5x,A)") "a_polarized"
	end if
	end subroutine field_data_write_decays

	@ %def field_data_write_decays
	@ Screen version of output.
	<<Model data: field data: TBP>>=
	procedure :: show => field_data_show
	<<Model data: procedures>>=
	subroutine field_data_show (prt, l, u)
	class(field_data_t), intent(in) :: prt
	integer, intent(in) :: l, u
	character(len=l) :: buffer
	integer :: i
	type(string_t), dimension(:), allocatable :: decay
	buffer = prt%get_name (.false.)
	write (u, "(4x,A,1x,I8)", advance="no") buffer, &
	prt%get_pdg ()
	if (prt%is_polarized ()) then
	write (u, "(3x,A)") "polarized"
	else if (.not. prt%is_stable ()) then
	write (u, "(3x,A)", advance="no") "decays:"
	call prt%get_decays (decay)
	do i = 1, size (decay)
	write (u, "(1x,A)", advance="no") char (decay(i))
	end do
	write (u, *)
	else
	write (u, *)
	end if
	if (prt%has_antiparticle ()) then
	buffer = prt%get_name (.true.)
	write (u, "(4x,A,1x,I8)", advance="no") buffer, &
	prt%get_pdg_anti ()
	if (prt%is_polarized (.true.)) then
	write (u, "(3x,A)") "polarized"
	else if (.not. prt%is_stable (.true.)) then
	write (u, "(3x,A)", advance="no") "decays:"
	call prt%get_decays (decay, .true.)
	do i = 1, size (decay)
	write (u, "(1x,A)", advance="no") char (decay(i))
	end do
	write (u, *)
	else
	write (u, *)
	end if
	end if
	end subroutine field_data_show

	@ %def field_data_show
	@ Retrieve data:
	<<Model data: field data: TBP>>=
	procedure :: get_pdg => field_data_get_pdg
	procedure :: get_pdg_anti => field_data_get_pdg_anti
	<<Model data: procedures>>=
	elemental function field_data_get_pdg (prt) result (pdg)
	integer :: pdg
	class(field_data_t), intent(in) :: prt
	pdg = prt%pdg
	end function field_data_get_pdg

	elemental function field_data_get_pdg_anti (prt) result (pdg)
	integer :: pdg
	class(field_data_t), intent(in) :: prt
	if (prt%has_anti) then
	pdg = - prt%pdg
	else
	pdg = prt%pdg
	end if
	end function field_data_get_pdg_anti

	@ %def field_data_get_pdg field_data_get_pdg_anti
	@ Predicates:
	<<Model data: field data: TBP>>=
	procedure :: is_visible => field_data_is_visible
	procedure :: is_parton => field_data_is_parton
	procedure :: is_gauge => field_data_is_gauge
	procedure :: is_left_handed => field_data_is_left_handed
	procedure :: is_right_handed => field_data_is_right_handed
	procedure :: has_antiparticle => field_data_has_antiparticle
	procedure :: is_stable => field_data_is_stable
	procedure :: get_decays => field_data_get_decays
	procedure :: decays_isotropically => field_data_decays_isotropically
	procedure :: decays_diagonal => field_data_decays_diagonal
	procedure :: has_decay_helicity => field_data_has_decay_helicity
	procedure :: decay_helicity => field_data_decay_helicity
	procedure :: is_polarized => field_data_is_polarized
	<<Model data: procedures>>=
	elemental function field_data_is_visible (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%visible
	end function field_data_is_visible

	elemental function field_data_is_parton (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%parton
	end function field_data_is_parton

	elemental function field_data_is_gauge (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%gauge
	end function field_data_is_gauge

	elemental function field_data_is_left_handed (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%left_handed
	end function field_data_is_left_handed

	elemental function field_data_is_right_handed (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%right_handed
	end function field_data_is_right_handed

	elemental function field_data_has_antiparticle (prt) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	flag = prt%has_anti
	end function field_data_has_antiparticle

	elemental function field_data_is_stable (prt, anti) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	flag = prt%a_is_stable
	else
	flag = prt%p_is_stable
	end if
	else
	flag = prt%p_is_stable
	end if
	end function field_data_is_stable

	subroutine field_data_get_decays (prt, decay, anti)
	class(field_data_t), intent(in) :: prt
	type(string_t), dimension(:), intent(out), allocatable :: decay
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	allocate (decay (size (prt%a_decay)), source = prt%a_decay)
	else
	allocate (decay (size (prt%p_decay)), source = prt%p_decay)
	end if
	else
	allocate (decay (size (prt%p_decay)), source = prt%p_decay)
	end if
	end subroutine field_data_get_decays

	elemental function field_data_decays_isotropically &
	(prt, anti) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	flag = prt%a_decays_isotropically
	else
	flag = prt%p_decays_isotropically
	end if
	else
	flag = prt%p_decays_isotropically
	end if
	end function field_data_decays_isotropically

	elemental function field_data_decays_diagonal &
	(prt, anti) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	flag = prt%a_decays_diagonal
	else
	flag = prt%p_decays_diagonal
	end if
	else
	flag = prt%p_decays_diagonal
	end if
	end function field_data_decays_diagonal

	elemental function field_data_has_decay_helicity &
	(prt, anti) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	flag = prt%a_has_decay_helicity
	else
	flag = prt%p_has_decay_helicity
	end if
	else
	flag = prt%p_has_decay_helicity
	end if
	end function field_data_has_decay_helicity

	elemental function field_data_decay_helicity &
	(prt, anti) result (hel)
	integer :: hel
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	if (present (anti)) then
	if (anti) then
	hel = prt%a_decay_helicity
	else
	hel = prt%p_decay_helicity
	end if
	else
	hel = prt%p_decay_helicity
	end if
	end function field_data_decay_helicity

	elemental function field_data_is_polarized (prt, anti) result (flag)
	logical :: flag
	class(field_data_t), intent(in) :: prt
	logical, intent(in), optional :: anti
	logical :: a
	if (present (anti)) then
	a = anti
	else
	a = .false.
	end if
	if (a) then
	flag = prt%a_polarized
	else
	flag = prt%p_polarized
	end if
	end function field_data_is_polarized

	@ %def field_data_is_visible field_data_is_parton
	@ %def field_data_is_gauge
	@ %def field_data_is_left_handed field_data_is_right_handed
	@ %def field_data_has_antiparticle
	@ %def field_data_is_stable
	@ %def field_data_decays_isotropically
	@ %def field_data_decays_diagonal
	@ %def field_data_has_decay_helicity
	@ %def field_data_decay_helicity
	@ %def field_data_polarized
	@ Names. Return the first name in the list (or the first antiparticle name)
	<<Model data: field data: TBP>>=
	procedure :: get_longname => field_data_get_longname
	procedure :: get_name => field_data_get_name
	procedure :: get_name_array => field_data_get_name_array
	<<Model data: procedures>>=
	pure function field_data_get_longname (prt) result (name)
	type(string_t) :: name
	class(field_data_t), intent(in) :: prt
	name = prt%longname
	end function field_data_get_longname

	pure function field_data_get_name (prt, is_antiparticle) result (name)
	type(string_t) :: name
	class(field_data_t), intent(in) :: prt
	logical, intent(in) :: is_antiparticle
	name = prt%longname
	if (is_antiparticle) then
	if (prt%has_anti) then
	if (allocated (prt%anti)) then
	if (size(prt%anti) > 0) name = prt%anti(1)
	end if
	else
	if (allocated (prt%name)) then
	if (size (prt%name) > 0) name = prt%name(1)
	end if
	end if
	else
	if (allocated (prt%name)) then
	if (size (prt%name) > 0) name = prt%name(1)
	end if
	end if
	end function field_data_get_name

	subroutine field_data_get_name_array (prt, is_antiparticle, name)
	class(field_data_t), intent(in) :: prt
	logical, intent(in) :: is_antiparticle
	type(string_t), dimension(:), allocatable, intent(inout) :: name
	if (allocated (name)) deallocate (name)
	if (is_antiparticle) then
	if (prt%has_anti) then
	allocate (name (size (prt%anti)))
	name = prt%anti
	else
	allocate (name (0))
	end if
	else
	allocate (name (size (prt%name)))
	name = prt%name
	end if
	end subroutine field_data_get_name_array

	@ %def field_data_get_name
	@ Same for the \TeX\ name.
	<<Model data: field data: TBP>>=
	procedure :: get_tex_name => field_data_get_tex_name
	<<Model data: procedures>>=
	elemental function field_data_get_tex_name &
	(prt, is_antiparticle) result (name)
	type(string_t) :: name
	class(field_data_t), intent(in) :: prt
	logical, intent(in) :: is_antiparticle
	if (is_antiparticle) then
	if (prt%has_anti) then
	name = prt%tex_anti
	else
	name = prt%tex_name
	end if
	else
	name = prt%tex_name
	end if
	if (name == "") name = prt%get_name (is_antiparticle)
	end function field_data_get_tex_name

	@ %def field_data_get_tex_name
	@ Check if any of the field names matches the given string.
	<<Model data: field data: TBP>>=
	procedure, private :: matches_name => field_data_matches_name
	<<Model data: procedures>>=
	function field_data_matches_name (field, name, is_antiparticle) result (flag)
	class(field_data_t), intent(in) :: field
	type(string_t), intent(in) :: name
	logical, intent(in) :: is_antiparticle
	logical :: flag
	if (is_antiparticle) then
	if (field%has_anti) then
	flag = any (name == field%anti)
	else
	flag = .false.
	end if
	else
	flag = name == field%longname .or. any (name == field%name)
	end if
	end function field_data_matches_name

	@ %def field_data_matches_name
	@ Quantum numbers
	<<Model data: field data: TBP>>=
	procedure :: get_spin_type => field_data_get_spin_type
	procedure :: get_multiplicity => field_data_get_multiplicity
	procedure :: get_isospin_type => field_data_get_isospin_type
	procedure :: get_charge_type => field_data_get_charge_type
	procedure :: get_color_type => field_data_get_color_type
	<<Model data: procedures>>=
	elemental function field_data_get_spin_type (prt) result (type)
	integer :: type
	class(field_data_t), intent(in) :: prt
	type = prt%spin_type
	end function field_data_get_spin_type

	elemental function field_data_get_multiplicity (prt) result (type)
	integer :: type
	class(field_data_t), intent(in) :: prt
	type = prt%multiplicity
	end function field_data_get_multiplicity

	elemental function field_data_get_isospin_type (prt) result (type)
	integer :: type
	class(field_data_t), intent(in) :: prt
	type = prt%isospin_type
	end function field_data_get_isospin_type

	elemental function field_data_get_charge_type (prt) result (type)
	integer :: type
	class(field_data_t), intent(in) :: prt
	type = prt%charge_type
	end function field_data_get_charge_type

	elemental function field_data_get_color_type (prt) result (type)
	integer :: type
	class(field_data_t), intent(in) :: prt
	type = prt%color_type
	end function field_data_get_color_type

	@ %def field_data_get_spin_type
	@ %def field_data_get_multiplicity
	@ %def field_data_get_isospin_type
	@ %def field_data_get_charge_type
	@ %def field_data_get_color_type
	@ In the MSSM, neutralinos can have a negative mass. This is
	relevant for computing matrix elements. However, within the
	\whizard\ main program we are interested only in kinematics, therefore
	we return the absolute value of the particle mass. If desired, we can
	extract the sign separately.
	<<Model data: field data: TBP>>=
	procedure :: get_charge => field_data_get_charge
	procedure :: get_isospin => field_data_get_isospin
	procedure :: get_mass => field_data_get_mass
	procedure :: get_mass_sign => field_data_get_mass_sign
	procedure :: get_width => field_data_get_width
	<<Model data: procedures>>=
	elemental function field_data_get_charge (prt) result (charge)
	real(default) :: charge
	class(field_data_t), intent(in) :: prt
	if (prt%charge_type /= 0) then
	charge = real (sign ((abs(prt%charge_type) - 1), &
	prt%charge_type), default) / 3
	else
	charge = 0
	end if
	end function field_data_get_charge

	elemental function field_data_get_isospin (prt) result (isospin)
	real(default) :: isospin
	class(field_data_t), intent(in) :: prt
	if (prt%isospin_type /= 0) then
	isospin = real (sign (abs(prt%isospin_type) - 1, &
	prt%isospin_type), default) / 2
	else
	isospin = 0
	end if
	end function field_data_get_isospin

	elemental function field_data_get_mass (prt) result (mass)
	real(default) :: mass
	class(field_data_t), intent(in) :: prt
	if (associated (prt%mass_val)) then
	mass = abs (prt%mass_val)
	else
	mass = 0
	end if
	end function field_data_get_mass

	elemental function field_data_get_mass_sign (prt) result (sgn)
	integer :: sgn
	class(field_data_t), intent(in) :: prt
	if (associated (prt%mass_val)) then
	sgn = sign (1._default, prt%mass_val)
	else
	sgn = 0
	end if
	end function field_data_get_mass_sign

	elemental function field_data_get_width (prt) result (width)
	real(default) :: width
	class(field_data_t), intent(in) :: prt
	if (associated (prt%width_val)) then
	width = prt%width_val
	else
	width = 0
	end if
	end function field_data_get_width

	@ %def field_data_get_charge field_data_get_isospin
	@ %def field_data_get_mass field_data_get_mass_sign
	@ %def field_data_get_width
	@ Find the [[model]] containing the [[PDG]] given two model files.
	<<Model data: public>>=
	public :: find_model
	<<Model data: procedures>>=
	subroutine find_model (model, PDG, model_A, model_B)
	class(model_data_t), pointer, intent(out) :: model
	integer, intent(in) :: PDG
	class(model_data_t), intent(in), target :: model_A, model_B
	character(len=5) :: buffer
	if (model_A%test_field (PDG)) then
	model => model_A
	else if (model_B%test_field (PDG)) then
	model => model_B
	else
	write (buffer, "(I5)") PDG
	call msg_fatal ("Parton " // buffer // &
	" not found in the given model files")
	end if
	end subroutine find_model

	@ %def find_model
	@
	\subsection{Vertex data}
	The vertex object contains an array of particle-data pointers, for
	which we need a separate type. (We could use the flavor type defined
	in another module.)

	The program does not (yet?) make use of vertex definitions, so they
	are not stored here.
	<<Model data: types>>=
	type :: field_data_p
	type(field_data_t), pointer :: p => null ()
	end type field_data_p

	@ %def field_data_p
	<<Model data: types>>=
	type :: vertex_t
	private
	logical :: trilinear
	integer, dimension(:), allocatable :: pdg
	type(field_data_p), dimension(:), allocatable :: prt
	contains
	<<Model data: vertex: TBP>>
	end type vertex_t

	@ %def vertex_t
	<<Model data: vertex: TBP>>=
	procedure :: write => vertex_write
	<<Model data: procedures>>=
	subroutine vertex_write (vtx, unit)
	class(vertex_t), intent(in) :: vtx
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(3x,A)", advance="no") "vertex"
	do i = 1, size (vtx%prt)
	if (associated (vtx%prt(i)%p)) then
	write (u, "(1x,A)", advance="no") &
	'"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) &
	// '"'
	else
	write (u, "(1x,I7)", advance="no") vtx%pdg(i)
	end if
	end do
	write (u, *)
	end subroutine vertex_write

	@ %def vertex_write
	@ Initialize using PDG codes. The model is used for finding particle
	data pointers associated with the pdg codes.
	<<Model data: vertex: TBP>>=
	procedure :: init => vertex_init
	<<Model data: procedures>>=
	subroutine vertex_init (vtx, pdg, model)
	class(vertex_t), intent(out) :: vtx
	integer, dimension(:), intent(in) :: pdg
	type(model_data_t), intent(in), target, optional :: model
	integer :: i
	allocate (vtx%pdg (size (pdg)))
	allocate (vtx%prt (size (pdg)))
	vtx%trilinear = size (pdg) == 3
	vtx%pdg = pdg
	if (present (model)) then
	do i = 1, size (pdg)
	vtx%prt(i)%p => model%get_field_ptr (pdg(i))
	end do
	end if
	end subroutine vertex_init

	@ %def vertex_init
	@ Copy vertex: we must reassign the field-data pointer to a new model.
	<<Model data: vertex: TBP>>=
	procedure :: copy_from => vertex_copy_from
	<<Model data: procedures>>=
	subroutine vertex_copy_from (vtx, old_vtx, new_model)
	class(vertex_t), intent(out) :: vtx
	class(vertex_t), intent(in) :: old_vtx
	type(model_data_t), intent(in), target, optional :: new_model
	call vtx%init (old_vtx%pdg, new_model)
	end subroutine vertex_copy_from

	@ %def vertex_copy_from
	@ Single-particle lookup: Given a particle code, we return matching
	codes if present, otherwise zero. Actually, we return the
	antiparticles of the matching codes, as appropriate for computing
	splittings.
	<<Model data: vertex: TBP>>=
	procedure :: get_match => vertex_get_match
	<<Model data: procedures>>=
	subroutine vertex_get_match (vtx, pdg1, pdg2)
	class(vertex_t), intent(in) :: vtx
	integer, intent(in) :: pdg1
	integer, dimension(:), allocatable, intent(out) :: pdg2
	integer :: i, j
	do i = 1, size (vtx%pdg)
	if (vtx%pdg(i) == pdg1) then
	allocate (pdg2 (size (vtx%pdg) - 1))
	do j = 1, i-1
	pdg2(j) = anti (j)
	end do
	do j = i, size (pdg2)
	pdg2(j) = anti (j+1)
	end do
	exit
	end if
	end do
	contains
	function anti (i) result (pdg)
	integer, intent(in) :: i
	integer :: pdg
	if (vtx%prt(i)%p%has_antiparticle ()) then
	pdg = - vtx%pdg(i)
	else
	pdg = vtx%pdg(i)
	end if
	end function anti
	end subroutine vertex_get_match

	@ %def vertex_get_match
	@ To access this from the outside, we create an iterator. The iterator has
	the sole purpose of returning the matching particles for a given array of PDG
	codes.
	<<Model data: public>>=
	public :: vertex_iterator_t
	<<Model data: types>>=
	type :: vertex_iterator_t
	private
	class(model_data_t), pointer :: model => null ()
	integer, dimension(:), allocatable :: pdg
	integer :: vertex_index = 0
	integer :: pdg_index = 0
	logical :: save_pdg_index
	contains
	procedure :: init => vertex_iterator_init
	procedure :: get_next_match => vertex_iterator_get_next_match
	end type vertex_iterator_t

	@ %def vertex_iterator_t
	@ We initialize the iterator for a particular model with the [[pdg]] index of
	the particle we are looking at.
	<<Model data: procedures>>=
	subroutine vertex_iterator_init (it, model, pdg, save_pdg_index)
	class(vertex_iterator_t), intent(out) :: it
	class(model_data_t), intent(in), target :: model
	integer, dimension(:), intent(in) :: pdg
	logical, intent(in) :: save_pdg_index
	it%model => model
	allocate (it%pdg (size (pdg)), source = pdg)
	it%save_pdg_index = save_pdg_index
	end subroutine vertex_iterator_init

	subroutine vertex_iterator_get_next_match (it, pdg_match)
	class(vertex_iterator_t), intent(inout) :: it
	integer, dimension(:), allocatable, intent(out) :: pdg_match
	integer :: i, j
	do i = it%vertex_index + 1, size (it%model%vtx)
	do j = it%pdg_index + 1, size (it%pdg)
	call it%model%vtx(i)%get_match (it%pdg(j), pdg_match)
	if (it%save_pdg_index) then
	if (allocated (pdg_match) .and. j < size (it%pdg)) then
	it%pdg_index = j
	return
	else if (allocated (pdg_match) .and. j == size (it%pdg)) then
	it%vertex_index = i
	it%pdg_index = 0
	return
	end if
	else if (allocated (pdg_match)) then
	it%vertex_index = i
	return
	end if
	end do
	end do
	it%vertex_index = 0
	it%pdg_index = 0
	end subroutine vertex_iterator_get_next_match

	@ %def vertex_iterator_get_next_match
	@
	\subsection{Vertex lookup table}
	The vertex lookup table is a hash table: given two particle codes, we
	check which codes are allowed for the third one.

	The size of the hash table should be large enough that collisions are
	rare. We first select a size based on the number of vertices
	(multiplied by six because all permutations count), with some margin,
	and then choose the smallest integer power of two larger than this.
	<<Model data: parameters>>=
	integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60
	@ %def VERTEX_TABLE_SCALE_FACTOR
	<<Model data: procedures>>=
	function vertex_table_size (n_vtx) result (n)
	integer(i32) :: n
	integer, intent(in) :: n_vtx
	integer :: i, s
	s = VERTEX_TABLE_SCALE_FACTOR * n_vtx
	n = 1
	do i = 1, 31
	n = ishft (n, 1)
	s = ishft (s,-1)
	if (s == 0) exit
	end do
	end function vertex_table_size

	@ %def vertex_table_size
	@ The specific hash function takes two particle codes (arbitrary
	integers) and returns a 32-bit integer. It makes use of the universal
	function [[hash]] which operates on a byte array.
	<<Model data: procedures>>=
	function hash2 (pdg1, pdg2)
	integer(i32) :: hash2
	integer, intent(in) :: pdg1, pdg2
	integer(i8), dimension(1) :: mold
	hash2 = hash (transfer ([pdg1, pdg2], mold))
	end function hash2

	@ %def hash2
	@ Each entry in the vertex table stores the two particle codes and an
	array of possibilities for the third code.
	<<Model data: types>>=
	type :: vertex_table_entry_t
	private
	integer :: pdg1 = 0, pdg2 = 0
	integer :: n = 0
	integer, dimension(:), allocatable :: pdg3
	end type vertex_table_entry_t

	@ %def vertex_table_entry_t
	@ The vertex table:
	<<Model data: types>>=
	type :: vertex_table_t
	type(vertex_table_entry_t), dimension(:), allocatable :: entry
	integer :: n_collisions = 0
	integer(i32) :: mask
	contains
	<<Model data: vertex table: TBP>>
	end type vertex_table_t

	@ %def vertex_table_t
	@ Output.
	<<Model data: vertex table: TBP>>=
	procedure :: write => vertex_table_write
	<<Model data: procedures>>=
	subroutine vertex_table_write (vt, unit)
	class(vertex_table_t), intent(in) :: vt
	integer, intent(in), optional :: unit
	integer :: u, i
	character(9) :: size_pdg3
	u = given_output_unit (unit)
	write (u, "(A)") "vertex hash table:"
	write (u, "(A,I7)") " size = ", size (vt%entry)
	write (u, "(A,I7)") " used = ", count (vt%entry%n /= 0)
	write (u, "(A,I7)") " coll = ", vt%n_collisions
	do i = lbound (vt%entry, 1), ubound (vt%entry, 1)
	if (vt%entry(i)%n /= 0) then
	write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3)
	write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // &
	size_pdg3 // "(1x,I7))") &
	" ", i, ":", vt%entry(i)%pdg1, &
	vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3
	end if
	end do
	end subroutine vertex_table_write

	@ %def vertex_table_write
	@ Initializing the vertex table: This is done in two passes. First,
	we scan all permutations for all vertices and count the number of
	entries in each bucket of the hashtable. Then, the buckets are
	allocated accordingly and filled.

	Collision resolution is done by just incrementing the hash value until
	an empty bucket is found. The vertex table size is fixed, since we
	know from the beginning the number of entries.
	<<Model data: vertex table: TBP>>=
	procedure :: init => vertex_table_init
	<<Model data: procedures>>=
	subroutine vertex_table_init (vt, prt, vtx)
	class(vertex_table_t), intent(out) :: vt
	type(field_data_t), dimension(:), intent(in) :: prt
	type(vertex_t), dimension(:), intent(in) :: vtx
	integer :: n_vtx, vt_size, i, p1, p2, p3
	integer, dimension(3) :: p
	n_vtx = size (vtx)
	vt_size = vertex_table_size (count (vtx%trilinear))
	vt%mask = vt_size - 1
	allocate (vt%entry (0:vt_size-1))
	do i = 1, n_vtx
	if (vtx(i)%trilinear) then
	p = vtx(i)%pdg
	p1 = p(1); p2 = p(2)
	call create (hash2 (p1, p2))
	if (p(2) /= p(3)) then
	p2 = p(3)
	call create (hash2 (p1, p2))
	end if
	if (p(1) /= p(2)) then
	p1 = p(2); p2 = p(1)
	call create (hash2 (p1, p2))
	if (p(1) /= p(3)) then
	p2 = p(3)
	call create (hash2 (p1, p2))
	end if
	end if
	if (p(1) /= p(3)) then
	p1 = p(3); p2 = p(1)
	call create (hash2 (p1, p2))
	if (p(1) /= p(2)) then
	p2 = p(2)
	call create (hash2 (p1, p2))
	end if
	end if
	end if
	end do
	do i = 0, vt_size - 1
	allocate (vt%entry(i)%pdg3 (vt%entry(i)%n))
	end do
	vt%entry%n = 0
	do i = 1, n_vtx
	if (vtx(i)%trilinear) then
	p = vtx(i)%pdg
	p1 = p(1); p2 = p(2); p3 = p(3)
	call register (hash2 (p1, p2))
	if (p(2) /= p(3)) then
	p2 = p(3); p3 = p(2)
	call register (hash2 (p1, p2))
	end if
	if (p(1) /= p(2)) then
	p1 = p(2); p2 = p(1); p3 = p(3)
	call register (hash2 (p1, p2))
	if (p(1) /= p(3)) then
	p2 = p(3); p3 = p(1)
	call register (hash2 (p1, p2))
	end if
	end if
	if (p(1) /= p(3)) then
	p1 = p(3); p2 = p(1); p3 = p(2)
	call register (hash2 (p1, p2))
	if (p(1) /= p(2)) then
	p2 = p(2); p3 = p(1)
	call register (hash2 (p1, p2))
	end if
	end if
	end if
	end do
	contains
	recursive subroutine create (hashval)
	integer(i32), intent(in) :: hashval
	integer :: h
	h = iand (hashval, vt%mask)
	if (vt%entry(h)%n == 0) then
	vt%entry(h)%pdg1 = p1
	vt%entry(h)%pdg2 = p2
	vt%entry(h)%n = 1
	else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
	vt%entry(h)%n = vt%entry(h)%n + 1
	else
	vt%n_collisions = vt%n_collisions + 1
	call create (hashval + 1)
	end if
	end subroutine create
	recursive subroutine register (hashval)
	integer(i32), intent(in) :: hashval
	integer :: h
	h = iand (hashval, vt%mask)
	if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
	vt%entry(h)%n = vt%entry(h)%n + 1
	vt%entry(h)%pdg3(vt%entry(h)%n) = p3
	else
	call register (hashval + 1)
	end if
	end subroutine register
	end subroutine vertex_table_init

	@ %def vertex_table_init
	@ Return the array of particle codes that match the given pair.
	<<Model data: vertex table: TBP>>=
	procedure :: match => vertex_table_match
	<<Model data: procedures>>=
	subroutine vertex_table_match (vt, pdg1, pdg2, pdg3)
	class(vertex_table_t), intent(in) :: vt
	integer, intent(in) :: pdg1, pdg2
	integer, dimension(:), allocatable, intent(out) :: pdg3
	call match (hash2 (pdg1, pdg2))
	contains
	recursive subroutine match (hashval)
	integer(i32), intent(in) :: hashval
	integer :: h
	h = iand (hashval, vt%mask)
	if (vt%entry(h)%n == 0) then
	allocate (pdg3 (0))
	else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
	allocate (pdg3 (size (vt%entry(h)%pdg3)))
	pdg3 = vt%entry(h)%pdg3
	else
	call match (hashval + 1)
	end if
	end subroutine match
	end subroutine vertex_table_match

	@ %def vertex_table_match
	@ Return true if the triplet is represented as a vertex.
	<<Model data: vertex table: TBP>>=
	procedure :: check => vertex_table_check
	<<Model data: procedures>>=
	function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag)
	class(vertex_table_t), intent(in) :: vt
	integer, intent(in) :: pdg1, pdg2, pdg3
	logical :: flag
	flag = check (hash2 (pdg1, pdg2))
	contains
	recursive function check (hashval) result (flag)
	integer(i32), intent(in) :: hashval
	integer :: h
	logical :: flag
	h = iand (hashval, vt%mask)
	if (vt%entry(h)%n == 0) then
	flag = .false.
	else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
	flag = any (vt%entry(h)%pdg3 == pdg3)
	else
	flag = check (hashval + 1)
	end if
	end function check
	end function vertex_table_check

	@ %def vertex_table_check
	@
	\subsection{Model Data Record}
	This type collects the model data as defined above.

	We deliberately implement the parameter arrays as pointer arrays. We
	thus avoid keeping track of TARGET attributes.

	The [[scheme]] identifier provides meta information. It doesn't give the
	client code an extra parameter, but it tells something about the
	interpretation of the parameters. If the scheme ID is left as default (zero),
	it is ignored.
	<<Model data: public>>=
	public :: model_data_t
	<<Model data: types>>=
	type :: model_data_t
	private
	type(string_t) :: name
	integer :: scheme = 0
	type(modelpar_real_t), dimension(:), pointer :: par_real => null ()
	type(modelpar_complex_t), dimension(:), pointer :: par_complex => null ()
	type(field_data_t), dimension(:), allocatable :: field
	type(vertex_t), dimension(:), allocatable :: vtx
	type(vertex_table_t) :: vt
	contains
	<<Model data: model data: TBP>>
	end type model_data_t

	@ %def model_data_t
	@ Finalizer, deallocate pointer arrays.
	<<Model data: model data: TBP>>=
	procedure :: final => model_data_final
	<<Model data: procedures>>=
	subroutine model_data_final (model)
	class(model_data_t), intent(inout) :: model
	if (associated (model%par_real)) then
	deallocate (model%par_real)
	end if
	if (associated (model%par_complex)) then
	deallocate (model%par_complex)
	end if
	end subroutine model_data_final

	@ %def model_data_final
	@ Output. The signature matches the signature of the high-level
	[[model_write]] procedure, so some of the options don't actually apply.
	<<Model data: model data: TBP>>=
	procedure :: write => model_data_write
	<<Model data: procedures>>=
	subroutine model_data_write (model, unit, verbose, &
	show_md5sum, show_variables, show_parameters, &
	show_particles, show_vertices, show_scheme)
	class(model_data_t), intent(in) :: model
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	logical, intent(in), optional :: show_md5sum
	logical, intent(in), optional :: show_variables
	logical, intent(in), optional :: show_parameters
	logical, intent(in), optional :: show_particles
	logical, intent(in), optional :: show_vertices
	logical, intent(in), optional :: show_scheme
	logical :: show_sch, show_par, show_prt, show_vtx
	integer :: u, i
	u = given_output_unit (unit)
	show_sch = .false.; if (present (show_scheme)) &
	show_sch = show_scheme
	show_par = .true.; if (present (show_parameters)) &
	show_par = show_parameters
	show_prt = .true.; if (present (show_particles)) &
	show_prt = show_particles
	show_vtx = .true.; if (present (show_vertices)) &
	show_vtx = show_vertices
	if (show_sch) then
	write (u, "(3x,A,1X,I0)") "scheme =", model%scheme
	end if
	if (show_par) then
	do i = 1, size (model%par_real)
	call model%par_real(i)%write (u)
	write (u, "(A)")
	end do
	do i = 1, size (model%par_complex)
	call model%par_complex(i)%write (u)
	write (u, "(A)")
	end do
	end if
	if (show_prt) then
	write (u, "(A)")
	call model%write_fields (u)
	end if
	if (show_vtx) then
	write (u, "(A)")
	call model%write_vertices (u, verbose)
	end if
	end subroutine model_data_write

	@ %def model_data_write
	@ Initialize, allocating pointer arrays. The second version makes a
	deep copy.
	<<Model data: model data: TBP>>=
	generic :: init => model_data_init
	procedure, private :: model_data_init
	<<Model data: procedures>>=
	subroutine model_data_init (model, name, &
	n_par_real, n_par_complex, n_field, n_vtx)
	class(model_data_t), intent(out) :: model
	type(string_t), intent(in) :: name
	integer, intent(in) :: n_par_real, n_par_complex
	integer, intent(in) :: n_field
	integer, intent(in) :: n_vtx
	model%name = name
	allocate (model%par_real (n_par_real))
	allocate (model%par_complex (n_par_complex))
	allocate (model%field (n_field))
	allocate (model%vtx (n_vtx))
	end subroutine model_data_init

	@ %def model_data_init
	@ Set the scheme ID.
	<<Model data: model data: TBP>>=
	procedure :: set_scheme_num => model_data_set_scheme_num
	<<Model data: procedures>>=
	subroutine model_data_set_scheme_num (model, scheme)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: scheme
	model%scheme = scheme
	end subroutine model_data_set_scheme_num

	@ %def model_data_set_scheme_num
	@ Complete model data initialization.
	<<Model data: model data: TBP>>=
	procedure :: freeze_fields => model_data_freeze_fields
	<<Model data: procedures>>=
	subroutine model_data_freeze_fields (model)
	class(model_data_t), intent(inout) :: model
	call model%field%freeze ()
	end subroutine model_data_freeze_fields

	@ %def model_data_freeze
	@ Deep copy. The new model should already be initialized, so we do
	not allocate memory.
	<<Model data: model data: TBP>>=
	procedure :: copy_from => model_data_copy
	<<Model data: procedures>>=
	subroutine model_data_copy (model, src)
	class(model_data_t), intent(inout), target :: model
	class(model_data_t), intent(in), target :: src
	class(modelpar_data_t), pointer :: data, src_data
	integer :: i
	model%scheme = src%scheme
	model%par_real = src%par_real
	model%par_complex = src%par_complex
	do i = 1, size (src%field)
	associate (field => model%field(i), src_field => src%field(i))
	call field%init (src_field%get_longname (), src_field%get_pdg ())
	call field%copy_from (src_field)
	src_data => src_field%mass_data
	if (associated (src_data)) then
	data => model%get_par_data_ptr (src_data%get_name ())
	call field%set (mass_data = data)
	end if
	src_data => src_field%width_data
	if (associated (src_data)) then
	data => model%get_par_data_ptr (src_data%get_name ())
	call field%set (width_data = data)
	end if
	call field%set_multiplicity ()
	end associate
	end do
	do i = 1, size (src%vtx)
	call model%vtx(i)%copy_from (src%vtx(i), model)
	end do
	call model%freeze_vertices ()
	end subroutine model_data_copy

	@ %def model_data_copy
	@ Return the model name and numeric scheme.
	<<Model data: model data: TBP>>=
	procedure :: get_name => model_data_get_name
	procedure :: get_scheme_num => model_data_get_scheme_num
	<<Model data: procedures>>=
	function model_data_get_name (model) result (name)
	class(model_data_t), intent(in) :: model
	type(string_t) :: name
	name = model%name
	end function model_data_get_name

	function model_data_get_scheme_num (model) result (scheme)
	class(model_data_t), intent(in) :: model
	integer :: scheme
	scheme = model%scheme
	end function model_data_get_scheme_num

	@ %def model_data_get_name
	@ %def model_data_get_scheme
	@ Retrieve a MD5 sum for the current model parameter values and
	decay/polarization settings. This is
	done by writing them to a temporary file, using a standard format. If the
	model scheme is nonzero, it is also written.
	<<Model data: model data: TBP>>=
	procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum
	<<Model data: procedures>>=
	function model_data_get_parameters_md5sum (model) result (par_md5sum)
	character(32) :: par_md5sum
	class(model_data_t), intent(in) :: model
	real(default), dimension(:), allocatable :: par
	type(field_data_t), pointer :: field
	integer :: unit, i
	allocate (par (model%get_n_real ()))
	call model%real_parameters_to_array (par)
	unit = free_unit ()
	open (unit, status="scratch", action="readwrite")
	if (model%scheme /= 0) write (unit, "(I0)") model%scheme
	write (unit, "(" // FMT_19 // ")") par
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) &
	.or. field%is_polarized (.false.) .or. field%is_polarized (.true.))&
	then
	write (unit, "(3x,A)") char (field%get_longname ())
	call field%write_decays (unit)
	end if
	end do
	rewind (unit)
	par_md5sum = md5sum (unit)
	close (unit)
	end function model_data_get_parameters_md5sum

	@ %def model_get_parameters_md5sum
	@ Return the MD5 sum. This is a placeholder, to be overwritten
	for the complete model definition.
	<<Model data: model data: TBP>>=
	procedure :: get_md5sum => model_data_get_md5sum
	<<Model data: procedures>>=
	function model_data_get_md5sum (model) result (md5sum)
	class(model_data_t), intent(in) :: model
	character(32) :: md5sum
	md5sum = model%get_parameters_md5sum ()
	end function model_data_get_md5sum

	@ %def model_data_get_md5sum
	@ Initialize a real or complex parameter.
	<<Model data: model data: TBP>>=
	generic :: init_par => model_data_init_par_real, model_data_init_par_complex
	procedure, private :: model_data_init_par_real
	procedure, private :: model_data_init_par_complex
	<<Model data: procedures>>=
	subroutine model_data_init_par_real (model, i, name, value)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	real(default), intent(in) :: value
	call model%par_real(i)%init (name, value)
	end subroutine model_data_init_par_real

	subroutine model_data_init_par_complex (model, i, name, value)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: value
	call model%par_complex(i)%init (name, value)
	end subroutine model_data_init_par_complex

	@ %def model_data_init_par_real model_data_init_par_complex
	@ After initialization, return size of parameter array.
	<<Model data: model data: TBP>>=
	procedure :: get_n_real => model_data_get_n_real
	procedure :: get_n_complex => model_data_get_n_complex
	<<Model data: procedures>>=
	function model_data_get_n_real (model) result (n)
	class(model_data_t), intent(in) :: model
	integer :: n
	n = size (model%par_real)
	end function model_data_get_n_real

	function model_data_get_n_complex (model) result (n)
	class(model_data_t), intent(in) :: model
	integer :: n
	n = size (model%par_complex)
	end function model_data_get_n_complex

	@ %def model_data_get_n_real
	@ %def model_data_get_n_complex
	@ After initialization, extract the whole parameter array.
	<<Model data: model data: TBP>>=
	procedure :: real_parameters_to_array &
	=> model_data_real_par_to_array
	procedure :: complex_parameters_to_array &
	=> model_data_complex_par_to_array
	<<Model data: procedures>>=
	subroutine model_data_real_par_to_array (model, array)
	class(model_data_t), intent(in) :: model
	real(default), dimension(:), intent(inout) :: array
	array = model%par_real%get_real ()
	end subroutine model_data_real_par_to_array

	subroutine model_data_complex_par_to_array (model, array)
	class(model_data_t), intent(in) :: model
	complex(default), dimension(:), intent(inout) :: array
	array = model%par_complex%get_complex ()
	end subroutine model_data_complex_par_to_array

	@ %def model_data_real_par_to_array
	@ %def model_data_complex_par_to_array
	@ After initialization, set the whole parameter array.
	<<Model data: model data: TBP>>=
	procedure :: real_parameters_from_array &
	=> model_data_real_par_from_array
	procedure :: complex_parameters_from_array &
	=> model_data_complex_par_from_array
	<<Model data: procedures>>=
	subroutine model_data_real_par_from_array (model, array)
	class(model_data_t), intent(inout) :: model
	real(default), dimension(:), intent(in) :: array
	model%par_real = array
	end subroutine model_data_real_par_from_array

	subroutine model_data_complex_par_from_array (model, array)
	class(model_data_t), intent(inout) :: model
	complex(default), dimension(:), intent(in) :: array
	model%par_complex = array
	end subroutine model_data_complex_par_from_array

	@ %def model_data_real_par_from_array
	@ %def model_data_complex_par_from_array
	@ Analogous, for a C parameter array.
	<<Model data: model data: TBP>>=
	procedure :: real_parameters_to_c_array &
	=> model_data_real_par_to_c_array
	<<Model data: procedures>>=
	subroutine model_data_real_par_to_c_array (model, array)
	class(model_data_t), intent(in) :: model
	real(c_default_float), dimension(:), intent(inout) :: array
	array = model%par_real%get_real ()
	end subroutine model_data_real_par_to_c_array

	@ %def model_data_real_par_to_c_array
	@ After initialization, set the whole parameter array.
	<<Model data: model data: TBP>>=
	procedure :: real_parameters_from_c_array &
	=> model_data_real_par_from_c_array
	<<Model data: procedures>>=
	subroutine model_data_real_par_from_c_array (model, array)
	class(model_data_t), intent(inout) :: model
	real(c_default_float), dimension(:), intent(in) :: array
	model%par_real = real (array, default)
	end subroutine model_data_real_par_from_c_array

	@ %def model_data_real_par_from_c_array
	@ After initialization, get pointer to a real or complex parameter,
	directly by index.
	<<Model data: model data: TBP>>=
	procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index
	procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index
	<<Model data: procedures>>=
	function model_data_get_par_real_ptr_index (model, i) result (ptr)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: i
	class(modelpar_data_t), pointer :: ptr
	ptr => model%par_real(i)
	end function model_data_get_par_real_ptr_index

	function model_data_get_par_complex_ptr_index (model, i) result (ptr)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: i
	class(modelpar_data_t), pointer :: ptr
	ptr => model%par_complex(i)
	end function model_data_get_par_complex_ptr_index

	@ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr
	@ After initialization, get pointer to a parameter by name.
	<<Model data: model data: TBP>>=
	procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name
	<<Model data: procedures>>=
	function model_data_get_par_data_ptr_name (model, name) result (ptr)
	class(model_data_t), intent(in) :: model
	type(string_t), intent(in) :: name
	class(modelpar_data_t), pointer :: ptr
	integer :: i
	do i = 1, size (model%par_real)
	if (model%par_real(i)%name == name) then
	ptr => model%par_real(i)
	return
	end if
	end do
	do i = 1, size (model%par_complex)
	if (model%par_complex(i)%name == name) then
	ptr => model%par_complex(i)
	return
	end if
	end do
	ptr => null ()
	end function model_data_get_par_data_ptr_name

	@ %def model_data_get_par_data_ptr
	@ Return the value by name. Again, type conversion is allowed.
	<<Model data: model data: TBP>>=
	procedure :: get_real => model_data_get_par_real_value
	procedure :: get_complex => model_data_get_par_complex_value
	<<Model data: procedures>>=
	function model_data_get_par_real_value (model, name) result (value)
	class(model_data_t), intent(in) :: model
	type(string_t), intent(in) :: name
	class(modelpar_data_t), pointer :: par
	real(default) :: value
	par => model%get_par_data_ptr (name)
	value = par%get_real ()
	end function model_data_get_par_real_value

	function model_data_get_par_complex_value (model, name) result (value)
	class(model_data_t), intent(in) :: model
	type(string_t), intent(in) :: name
	class(modelpar_data_t), pointer :: par
	complex(default) :: value
	par => model%get_par_data_ptr (name)
	value = par%get_complex ()
	end function model_data_get_par_complex_value

	@ %def model_data_get_real
	@ %def model_data_get_complex
	@ Modify a real or complex parameter.
	<<Model data: model data: TBP>>=
	generic :: set_par => model_data_set_par_real, model_data_set_par_complex
	procedure, private :: model_data_set_par_real
	procedure, private :: model_data_set_par_complex
	<<Model data: procedures>>=
	subroutine model_data_set_par_real (model, name, value)
	class(model_data_t), intent(inout) :: model
	type(string_t), intent(in) :: name
	real(default), intent(in) :: value
	class(modelpar_data_t), pointer :: par
	par => model%get_par_data_ptr (name)
	par = value
	end subroutine model_data_set_par_real

	subroutine model_data_set_par_complex (model, name, value)
	class(model_data_t), intent(inout) :: model
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: value
	class(modelpar_data_t), pointer :: par
	par => model%get_par_data_ptr (name)
	par = value
	end subroutine model_data_set_par_complex

	@ %def model_data_set_par_real model_data_set_par_complex
	@ List all fields in the model.
	<<Model data: model data: TBP>>=
	procedure :: write_fields => model_data_write_fields
	<<Model data: procedures>>=
	subroutine model_data_write_fields (model, unit)
	class(model_data_t), intent(in) :: model
	integer, intent(in), optional :: unit
	integer :: i
	do i = 1, size (model%field)
	call model%field(i)%write (unit)
	end do
	end subroutine model_data_write_fields

	@ %def model_data_write_fields
	@ After initialization, return number of fields (particles):
	<<Model data: model data: TBP>>=
	procedure :: get_n_field => model_data_get_n_field
	<<Model data: procedures>>=
	function model_data_get_n_field (model) result (n)
	class(model_data_t), intent(in) :: model
	integer :: n
	n = size (model%field)
	end function model_data_get_n_field

	@ %def model_data_get_n_field
	@ Return the PDG code of a field. The field is identified by name or
	by index. If the field is not found, return zero.
	<<Model data: model data: TBP>>=
	generic :: get_pdg => &
	model_data_get_field_pdg_index, &
	model_data_get_field_pdg_name
	procedure, private :: model_data_get_field_pdg_index
	procedure, private :: model_data_get_field_pdg_name
	<<Model data: procedures>>=
	function model_data_get_field_pdg_index (model, i) result (pdg)
	class(model_data_t), intent(in) :: model
	integer, intent(in) :: i
	integer :: pdg
	pdg = model%field(i)%get_pdg ()
	end function model_data_get_field_pdg_index

	function model_data_get_field_pdg_name (model, name, check) result (pdg)
	class(model_data_t), intent(in) :: model
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: check
	integer :: pdg
	integer :: i
	do i = 1, size (model%field)
	associate (field => model%field(i))
	if (field%matches_name (name, .false.)) then
	pdg = field%get_pdg ()
	return
	else if (field%matches_name (name, .true.)) then
	pdg = - field%get_pdg ()
	return
	end if
	end associate
	end do
	pdg = 0
	call model%field_error (check, name)
	end function model_data_get_field_pdg_name

	@ %def model_data_get_field_pdg
	@ Return an array of all PDG codes, including antiparticles. The antiparticle
	are sorted after all particles.
	<<Model data: model data: TBP>>=
	procedure :: get_all_pdg => model_data_get_all_pdg
	<<Model data: procedures>>=
	subroutine model_data_get_all_pdg (model, pdg)
	class(model_data_t), intent(in) :: model
	integer, dimension(:), allocatable, intent(inout) :: pdg
	integer :: n0, n1, i, k
	n0 = size (model%field)
	n1 = n0 + count (model%field%has_antiparticle ())
	allocate (pdg (n1))
	pdg(1:n0) = model%field%get_pdg ()
	k = n0
	do i = 1, size (model%field)
	associate (field => model%field(i))
	if (field%has_antiparticle ()) then
	k = k + 1
	pdg(k) = - field%get_pdg ()
	end if
	end associate
	end do
	end subroutine model_data_get_all_pdg

	@ %def model_data_get_all_pdg
	@ Return pointer to the field array.
	<<Model data: model data: TBP>>=
	procedure :: get_field_array_ptr => model_data_get_field_array_ptr
	<<Model data: procedures>>=
	function model_data_get_field_array_ptr (model) result (ptr)
	class(model_data_t), intent(in), target :: model
	type(field_data_t), dimension(:), pointer :: ptr
	ptr => model%field
	end function model_data_get_field_array_ptr

	@ %def model_data_get_field_array_ptr
	@ Return pointer to a field. The identifier should be the unique long
	name, the PDG code, or the index.

	We can issue an error message, if the [[check]] flag is set. We never return
	an error if the PDG code is zero, this yields just a null pointer.
	<<Model data: model data: TBP>>=
	generic :: get_field_ptr => &
	model_data_get_field_ptr_name, &
	model_data_get_field_ptr_pdg
	procedure, private :: model_data_get_field_ptr_name
	procedure, private :: model_data_get_field_ptr_pdg
	procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
	<<Model data: procedures>>=
	function model_data_get_field_ptr_name (model, name, check) result (ptr)
	class(model_data_t), intent(in), target :: model
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: check
	type(field_data_t), pointer :: ptr
	integer :: i
	do i = 1, size (model%field)
	if (model%field(i)%matches_name (name, .false.)) then
	ptr => model%field(i)
	return
	else if (model%field(i)%matches_name (name, .true.)) then
	ptr => model%field(i)
	return
	end if
	end do
	ptr => null ()
	call model%field_error (check, name)
	end function model_data_get_field_ptr_name

	function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr)
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: pdg
	logical, intent(in), optional :: check
	type(field_data_t), pointer :: ptr
	integer :: i, pdg_abs
	if (pdg == 0) then
	ptr => null ()
	return
	end if
	pdg_abs = abs (pdg)
	do i = 1, size (model%field)
	if (model%field(i)%get_pdg () == pdg_abs) then
	ptr => model%field(i)
	return
	end if
	end do
	ptr => null ()
	call model%field_error (check, pdg=pdg)
	end function model_data_get_field_ptr_pdg

	function model_data_get_field_ptr_index (model, i) result (ptr)
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: i
	type(field_data_t), pointer :: ptr
	ptr => model%field(i)
	end function model_data_get_field_ptr_index

	@ %def model_data_get_field_ptr
	@ Don't assign a pointer, just check.
	<<Model data: model data: TBP>>=
	procedure :: test_field => model_data_test_field_pdg
	<<Model data: procedures>>=
	function model_data_test_field_pdg (model, pdg, check) result (exist)
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: pdg
	logical, intent(in), optional :: check
	logical :: exist
	exist = associated (model%get_field_ptr (pdg, check))
	end function model_data_test_field_pdg

	@ %def model_data_test_field_pdg
	@ Error message, if [[check]] is set.
	<<Model data: model data: TBP>>=
	procedure :: field_error => model_data_field_error
	<<Model data: procedures>>=
	subroutine model_data_field_error (model, check, name, pdg)
	class(model_data_t), intent(in) :: model
	logical, intent(in), optional :: check
	type(string_t), intent(in), optional :: name
	integer, intent(in), optional :: pdg
	if (present (check)) then
	if (check) then
	if (present (name)) then
	write (msg_buffer, "(A,1x,A,1x,A,1x,A)") &
	"No particle with name", char (name), &
	"is contained in model", char (model%name)
	else if (present (pdg)) then
	write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") &
	"No particle with PDG code", pdg, &
	"is contained in model", char (model%name)
	else
	write (msg_buffer, "(A,1x,A,1x,A)") &
	"Particle missing", &
	"in model", char (model%name)
	end if
	call msg_fatal ()
	end if
	end if
	end subroutine model_data_field_error

	@ %def model_data_field_error
	@ Assign mass and width value, which are associated via pointer.
	Identify the particle via pdg.
	<<Model data: model data: TBP>>=
	procedure :: set_field_mass => model_data_set_field_mass_pdg
	procedure :: set_field_width => model_data_set_field_width_pdg
	<<Model data: procedures>>=
	subroutine model_data_set_field_mass_pdg (model, pdg, value)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: pdg
	real(default), intent(in) :: value
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg, check = .true.)
	call field%set_mass (value)
	end subroutine model_data_set_field_mass_pdg

	subroutine model_data_set_field_width_pdg (model, pdg, value)
	class(model_data_t), intent(inout) :: model
	integer, intent(in) :: pdg
	real(default), intent(in) :: value
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg, check = .true.)
	call field%set_width (value)
	end subroutine model_data_set_field_width_pdg

	@ %def model_data_set_field_mass
	@ %def model_data_set_field_width
	@ Mark a particle as unstable and provide a list of names for its
	decay processes. In contrast with the previous subroutine which is
	for internal use, we address the particle by its PDG code. If the
	index is negative, we address the antiparticle.
	<<Model data: model data: TBP>>=
	procedure :: set_unstable => model_data_set_unstable
	procedure :: set_stable => model_data_set_stable
	<<Model data: procedures>>=
	subroutine model_data_set_unstable &
	(model, pdg, decay, isotropic, diagonal, decay_helicity)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: pdg
	type(string_t), dimension(:), intent(in) :: decay
	logical, intent(in), optional :: isotropic, diagonal
	integer, intent(in), optional :: decay_helicity
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg)
	if (pdg > 0) then
	call field%set ( &
	p_is_stable = .false., p_decay = decay, &
	p_decays_isotropically = isotropic, &
	p_decays_diagonal = diagonal, &
	p_decay_helicity = decay_helicity)
	else
	call field%set ( &
	a_is_stable = .false., a_decay = decay, &
	a_decays_isotropically = isotropic, &
	a_decays_diagonal = diagonal, &
	a_decay_helicity = decay_helicity)
	end if
	end subroutine model_data_set_unstable

	subroutine model_data_set_stable (model, pdg)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: pdg
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg)
	if (pdg > 0) then
	call field%set (p_is_stable = .true.)
	else
	call field%set (a_is_stable = .true.)
	end if
	end subroutine model_data_set_stable

	@ %def model_data_set_unstable
	@ %def model_data_set_stable
	@ Mark a particle as polarized.
	<<Model data: model data: TBP>>=
	procedure :: set_polarized => model_data_set_polarized
	procedure :: set_unpolarized => model_data_set_unpolarized
	<<Model data: procedures>>=
	subroutine model_data_set_polarized (model, pdg)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: pdg
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg)
	if (pdg > 0) then
	call field%set (p_polarized = .true.)
	else
	call field%set (a_polarized = .true.)
	end if
	end subroutine model_data_set_polarized

	subroutine model_data_set_unpolarized (model, pdg)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: pdg
	type(field_data_t), pointer :: field
	field => model%get_field_ptr (pdg)
	if (pdg > 0) then
	call field%set (p_polarized = .false.)
	else
	call field%set (a_polarized = .false.)
	end if
	end subroutine model_data_set_unpolarized

	@ %def model_data_set_polarized
	@ %def model_data_set_unpolarized
	@ Revert all polarized (unstable) particles to unpolarized (stable)
	status, respectively.
	<<Model data: model data: TBP>>=
	procedure :: clear_unstable => model_clear_unstable
	procedure :: clear_polarized => model_clear_polarized
	<<Model data: procedures>>=
	subroutine model_clear_unstable (model)
	class(model_data_t), intent(inout), target :: model
	integer :: i
	type(field_data_t), pointer :: field
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	call field%set (p_is_stable = .true.)
	if (field%has_antiparticle ()) then
	call field%set (a_is_stable = .true.)
	end if
	end do
	end subroutine model_clear_unstable

	subroutine model_clear_polarized (model)
	class(model_data_t), intent(inout), target :: model
	integer :: i
	type(field_data_t), pointer :: field
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	call field%set (p_polarized = .false.)
	if (field%has_antiparticle ()) then
	call field%set (a_polarized = .false.)
	end if
	end do
	end subroutine model_clear_polarized

	@ %def model_clear_unstable
	@ %def model_clear_polarized
	@ List all vertices, optionally also the hash table.
	<<Model data: model data: TBP>>=
	procedure :: write_vertices => model_data_write_vertices
	<<Model data: procedures>>=
	subroutine model_data_write_vertices (model, unit, verbose)
	class(model_data_t), intent(in) :: model
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: i, u
	u = given_output_unit (unit)
	do i = 1, size (model%vtx)
	call vertex_write (model%vtx(i), unit)
	end do
	if (present (verbose)) then
	if (verbose) then
	write (u, *)
	call vertex_table_write (model%vt, unit)
	end if
	end if
	end subroutine model_data_write_vertices

	@ %def model_data_write_vertices
	@ Vertex definition.
	<<Model data: model data: TBP>>=
	generic :: set_vertex => &
	model_data_set_vertex_pdg, model_data_set_vertex_names
	procedure, private :: model_data_set_vertex_pdg
	procedure, private :: model_data_set_vertex_names
	<<Model data: procedures>>=
	subroutine model_data_set_vertex_pdg (model, i, pdg)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: pdg
	call vertex_init (model%vtx(i), pdg, model)
	end subroutine model_data_set_vertex_pdg

	subroutine model_data_set_vertex_names (model, i, name)
	class(model_data_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), dimension(:), intent(in) :: name
	integer, dimension(size(name)) :: pdg
	integer :: j
	do j = 1, size (name)
	pdg(j) = model%get_pdg (name(j))
	end do
	call model%set_vertex (i, pdg)
	end subroutine model_data_set_vertex_names

	@ %def model_data_set_vertex
	@ Finalize vertex definition: set up the hash table.
	<<Model data: model data: TBP>>=
	procedure :: freeze_vertices => model_data_freeze_vertices
	<<Model data: procedures>>=
	subroutine model_data_freeze_vertices (model)
	class(model_data_t), intent(inout) :: model
	call model%vt%init (model%field, model%vtx)
	end subroutine model_data_freeze_vertices

	@ %def model_data_freeze_vertices
	@ Number of vertices in model
	<<Model data: model data: TBP>>=
	procedure :: get_n_vtx => model_data_get_n_vtx
	<<Model data: procedures>>=
	function model_data_get_n_vtx (model) result (n)
	class(model_data_t), intent(in) :: model
	integer :: n
	n = size (model%vtx)
	end function model_data_get_n_vtx

	@ %def model_data_get_n_vtx
	@ Lookup functions
	<<Model data: model data: TBP>>=
	procedure :: match_vertex => model_data_match_vertex
	<<Model data: procedures>>=
	subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3)
	class(model_data_t), intent(in) :: model
	integer, intent(in) :: pdg1, pdg2
	integer, dimension(:), allocatable, intent(out) :: pdg3
	call model%vt%match (pdg1, pdg2, pdg3)
	end subroutine model_data_match_vertex

	@ %def model_data_match_vertex
	<<Model data: model data: TBP>>=
	procedure :: check_vertex => model_data_check_vertex
	<<Model data: procedures>>=
	function model_data_check_vertex (model, pdg1, pdg2, pdg3) result (flag)
	logical :: flag
	class(model_data_t), intent(in) :: model
	integer, intent(in) :: pdg1, pdg2, pdg3
	flag = model%vt%check (pdg1, pdg2, pdg3)
	end function model_data_check_vertex

	@ %def model_data_check_vertex
	@
	\subsection{Toy Models}
	This is a stripped-down version of the (already trivial) model 'Test'.
	<<Model data: model data: TBP>>=
	procedure :: init_test => model_data_init_test
	<<Model data: procedures>>=
	subroutine model_data_init_test (model)
	class(model_data_t), intent(out) :: model
	type(field_data_t), pointer :: field
	integer, parameter :: n_real = 4
	integer, parameter :: n_field = 2
	integer, parameter :: n_vertex = 2
	integer :: i
	call model%init (var_str ("Test"), &
	n_real, 0, n_field, n_vertex)
	i = 0
	i = i + 1
	call model%init_par (i, var_str ("gy"), 1._default)
	i = i + 1
	call model%init_par (i, var_str ("ms"), 125._default)
	i = i + 1
	call model%init_par (i, var_str ("ff"), 1.5_default)
	i = i + 1
	call model%init_par (i, var_str ("mf"), 1.5_default * 125._default)
	i = 0
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("SCALAR"), 25)
	call field%set (spin_type=1)
	call field%set (mass_data=model%get_par_real_ptr (2))
	call field%set (name = [var_str ("s")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("FERMION"), 6)
	call field%set (spin_type=2)
	call field%set (mass_data=model%get_par_real_ptr (4))
	call field%set (name = [var_str ("f")], anti = [var_str ("fbar")])
	call model%freeze_fields ()
	i = 0
	i = i + 1
	call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")])
	i = i + 1
	call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")])
	call model%freeze_vertices ()
	end subroutine model_data_init_test

	@ %def model_data_init_test
	@
	This procedure prepares a subset of QED for testing purposes.
	<<Model data: model data: TBP>>=
	procedure :: init_qed_test => model_data_init_qed_test
	<<Model data: procedures>>=
	subroutine model_data_init_qed_test (model)
	class(model_data_t), intent(out) :: model
	type(field_data_t), pointer :: field
	integer, parameter :: n_real = 1
	integer, parameter :: n_field = 2
	integer :: i
	call model%init (var_str ("QED_test"), &
	n_real, 0, n_field, 0)
	i = 0
	i = i + 1
	call model%init_par (i, var_str ("me"), 0.000510997_default)
	i = 0
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("E_LEPTON"), 11)
	call field%set (spin_type=2, charge_type=-4)
	call field%set (mass_data=model%get_par_real_ptr (1))
	call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("PHOTON"), 22)
	call field%set (spin_type=3)
	call field%set (name = [var_str ("A")])
	call model%freeze_fields ()
	call model%freeze_vertices ()
	end subroutine model_data_init_qed_test

	@ %def model_data_init_qed_test
	@
	This procedure prepares a subset of the Standard Model for testing purposes.
	We can thus avoid dependencies on model I/O, which is not defined here.
	<<Model data: model data: TBP>>=
	procedure :: init_sm_test => model_data_init_sm_test
	<<Model data: procedures>>=
	subroutine model_data_init_sm_test (model)
	class(model_data_t), intent(out) :: model
	type(field_data_t), pointer :: field
	integer, parameter :: n_real = 11
	integer, parameter :: n_field = 19
	integer, parameter :: n_vtx = 9
	integer :: i
	call model%init (var_str ("SM_test"), &
	n_real, 0, n_field, n_vtx)
	i = 0
	i = i + 1
	call model%init_par (i, var_str ("mZ"), 91.1882_default)
	i = i + 1
	call model%init_par (i, var_str ("mW"), 80.419_default)
	i = i + 1
	call model%init_par (i, var_str ("me"), 0.000510997_default)
	i = i + 1
	call model%init_par (i, var_str ("mmu"), 0.105658389_default)
	i = i + 1
	call model%init_par (i, var_str ("mb"), 4.2_default)
	i = i + 1
	call model%init_par (i, var_str ("mtop"), 173.1_default)
	i = i + 1
	call model%init_par (i, var_str ("wZ"), 2.443_default)
	i = i + 1
	call model%init_par (i, var_str ("wW"), 2.049_default)
	i = i + 1
	call model%init_par (i, var_str ("ee"), 0.3079561542961_default)
	i = i + 1
	call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default)
	i = i + 1
	call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default)
	i = 0
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("D_QUARK"), 1)
	call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
	call field%set (name = [var_str ("d")], anti = [var_str ("dbar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("U_QUARK"), 2)
	call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
	call field%set (name = [var_str ("u")], anti = [var_str ("ubar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("S_QUARK"), 3)
	call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
	call field%set (name = [var_str ("s")], anti = [var_str ("sbar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("C_QUARK"), 4)
	call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
	call field%set (name = [var_str ("c")], anti = [var_str ("cbar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("B_QUARK"), 5)
	call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
	call field%set (mass_data=model%get_par_real_ptr (5))
	call field%set (name = [var_str ("b")], anti = [var_str ("bbar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("T_QUARK"), 6)
	call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
	call field%set (mass_data=model%get_par_real_ptr (6))
	call field%set (name = [var_str ("t")], anti = [var_str ("tbar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("E_LEPTON"), 11)
	call field%set (spin_type=2)
	call field%set (mass_data=model%get_par_real_ptr (3))
	call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("E_NEUTRINO"), 12)
	call field%set (spin_type=2, is_left_handed=.true.)
	call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("MU_LEPTON"), 13)
	call field%set (spin_type=2)
	call field%set (mass_data=model%get_par_real_ptr (4))
	call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("MU_NEUTRINO"), 14)
	call field%set (spin_type=2, is_left_handed=.true.)
	call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("GLUON"), 21)
	call field%set (spin_type=3, color_type=8)
	call field%set (name = [var_str ("gl")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("PHOTON"), 22)
	call field%set (spin_type=3)
	call field%set (name = [var_str ("A")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("Z_BOSON"), 23)
	call field%set (spin_type=3)
	call field%set (mass_data=model%get_par_real_ptr (1))
	call field%set (width_data=model%get_par_real_ptr (7))
	call field%set (name = [var_str ("Z")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("W_BOSON"), 24)
	call field%set (spin_type=3)
	call field%set (mass_data=model%get_par_real_ptr (2))
	call field%set (width_data=model%get_par_real_ptr (8))
	call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("HIGGS"), 25)
	call field%set (spin_type=1)
	! call field%set (mass_data=model%get_par_real_ptr (2))
	! call field%set (width_data=model%get_par_real_ptr (8))
	call field%set (name = [var_str ("H")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("PROTON"), 2212)
	call field%set (spin_type=2)
	call field%set (name = [var_str ("p")], anti = [var_str ("pbar")])
	! call field%set (mass_data=model%get_par_real_ptr (12))
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91)
	call field%set (color_type=1)
	call field%set (name = [var_str ("hr1")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92)
	call field%set (color_type=3)
	call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("HADRON_REMNANT_OCTET"), 93)
	call field%set (color_type=8)
	call field%set (name = [var_str ("hr8")])
	call model%freeze_fields ()
	i = 0
	i = i + 1
	call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
	call model%freeze_vertices ()
	end subroutine model_data_init_sm_test

	@ %def model_data_init_sm_test
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Model Testbed}
	The standard way of defining a model uses concrete variables and expressions to
	interpret the model file. Some of this is not available at the point of use. This
	is no problem for the \whizard\ program as a whole, but unit tests are
	kept local to their respective module and don't access all definitions.

	Instead, we introduce a separate module that provides hooks, one for
	initializing a model and one for finalizing a model. The main program can
	assign real routines to the hooks (procedure pointers of abstract type) before
	unit tests are called. The unit tests can call the abstract routines without
	knowing about their implementation.
	<<[[model_testbed.f90]]>>=
	<<File header>>

	module model_testbed

	<<Use strings>>
	use model_data
	use var_base

	<<Standard module head>>

	<<Model testbed: public>>

	<<Model testbed: variables>>

	<<Model testbed: interfaces>>

	end module model_testbed
	@ %def model_testbed
	@
	\subsection{Abstract Model Handlers}
	Both routines take a polymorphic model (data) pointer, which
	is allocated/deallocated inside the subroutine. The model constructor
	[[prepare_model]] requires the model name as input. It can, optionally,
	return a link to the variable list of the model.
	<<Model testbed: public>>=
	public :: prepare_model
	public :: cleanup_model
	<<Model testbed: variables>>=
	procedure (prepare_model_proc), pointer :: prepare_model => null ()
	procedure (cleanup_model_proc), pointer :: cleanup_model => null ()
	<<Model testbed: interfaces>>=
	abstract interface
	subroutine prepare_model_proc (model, name, vars)
	import
	class(model_data_t), pointer, intent(inout) :: model
	type(string_t), intent(in) :: name
	class(vars_t), pointer, intent(out), optional :: vars
	end subroutine prepare_model_proc
	end interface

	abstract interface
	subroutine cleanup_model_proc (model)
	import
	class(model_data_t), pointer, intent(inout) :: model
	end subroutine cleanup_model_proc
	end interface

	@ %def prepare_model
	@ %def cleanup_model
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Helicities}
	This module defines types and tools for dealing with helicity
	information.
	<<[[helicities.f90]]>>=
	<<File header>>

	module helicities

	use io_units

	<<Standard module head>>

	<<Helicities: public>>

	<<Helicities: types>>

	<<Helicities: interfaces>>

	contains

	<<Helicities: procedures>>

	end module helicities
	@ %def helicities
	@
	\subsection{Helicity types}
	Helicities may be defined or undefined, corresponding to a polarized
	or unpolarized state. Each helicity is actually a pair of helicities,
	corresponding to an entry in the spin density matrix. Obviously,
	diagonal entries are distinguished.
	<<Helicities: public>>=
	public :: helicity_t
	<<Helicities: types>>=
	type :: helicity_t
	private
	logical :: defined = .false.
	integer :: h1, h2
	contains
	<<Helicities: helicity: TBP>>
	end type helicity_t

	@ %def helicity_t
	@ Constructor functions, for convenience:
	<<Helicities: public>>=
	public :: helicity
	<<Helicities: interfaces>>=
	interface helicity
	module procedure helicity0, helicity1, helicity2
	end interface helicity

	<<Helicities: procedures>>=
	pure function helicity0 () result (hel)
	type(helicity_t) :: hel
	end function helicity0

	elemental function helicity1 (h) result (hel)
	type(helicity_t) :: hel
	integer, intent(in) :: h
	call hel%init (h)
	end function helicity1

	elemental function helicity2 (h2, h1) result (hel)
	type(helicity_t) :: hel
	integer, intent(in) :: h1, h2
	call hel%init (h2, h1)
	end function helicity2

	@ %def helicity
	@ Initializers.

	Note: conceptually, the argument to initializers should be INTENT(OUT).
	However, Interp.\ F08/0033 prohibited this. The reason is that, in principle,
	the call could result in the execution of an impure finalizer for a type
	extension of [[hel]] (ugh).
	<<Helicities: helicity: TBP>>=
	generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different
	procedure, private :: helicity_init_empty
	procedure, private :: helicity_init_same
	procedure, private :: helicity_init_different
	<<Helicities: procedures>>=
	elemental subroutine helicity_init_empty (hel)
	class(helicity_t), intent(inout) :: hel
	hel%defined = .false.
	end subroutine helicity_init_empty

	elemental subroutine helicity_init_same (hel, h)
	class(helicity_t), intent(inout) :: hel
	integer, intent(in) :: h
	hel%defined = .true.
	hel%h1 = h
	hel%h2 = h
	end subroutine helicity_init_same

	elemental subroutine helicity_init_different (hel, h2, h1)
	class(helicity_t), intent(inout) :: hel
	integer, intent(in) :: h1, h2
	hel%defined = .true.
	hel%h2 = h2
	hel%h1 = h1
	end subroutine helicity_init_different

	@ %def helicity_init
	@ Undefine:
	<<Helicities: helicity: TBP>>=
	procedure :: undefine => helicity_undefine
	<<Helicities: procedures>>=
	elemental subroutine helicity_undefine (hel)
	class(helicity_t), intent(inout) :: hel
	hel%defined = .false.
	end subroutine helicity_undefine

	@ %def helicity_undefine
	@ Diagonalize by removing the second entry (use with care!)
	<<Helicities: helicity: TBP>>=
	procedure :: diagonalize => helicity_diagonalize
	<<Helicities: procedures>>=
	elemental subroutine helicity_diagonalize (hel)
	class(helicity_t), intent(inout) :: hel
	hel%h2 = hel%h1
	end subroutine helicity_diagonalize

	@ %def helicity_diagonalize
	@ Flip helicity indices by sign.
	<<Helicities: helicity: TBP>>=
	procedure :: flip => helicity_flip
	<<Helicities: procedures>>=
	elemental subroutine helicity_flip (hel)
	class(helicity_t), intent(inout) :: hel
	hel%h1 = - hel%h1
	hel%h2 = - hel%h2
	end subroutine helicity_flip

	@ %def helicity_flip
	@
	<<Helicities: helicity: TBP>>=
	procedure :: get_indices => helicity_get_indices
	<<Helicities: procedures>>=
	subroutine helicity_get_indices (hel, h1, h2)
	class(helicity_t), intent(in) :: hel
	integer, intent(out) :: h1, h2
	h1 = hel%h1; h2 = hel%h2
	end subroutine helicity_get_indices

	@ %def helicity_get_indices
	@ Output (no linebreak). No output if undefined.
	<<Helicities: helicity: TBP>>=
	procedure :: write => helicity_write
	<<Helicities: procedures>>=
	subroutine helicity_write (hel, unit)
	class(helicity_t), intent(in) :: hel
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (hel%defined) then
	write (u, "(A)", advance="no") "h("
	write (u, "(I0)", advance="no") hel%h1
	if (hel%h1 /= hel%h2) then
	write (u, "(A)", advance="no") "\|"
	write (u, "(I0)", advance="no") hel%h2
	end if
	write (u, "(A)", advance="no") ")"
	end if
	end subroutine helicity_write

	@ %def helicity_write
	@ Binary I/O. Write contents only if defined.
	<<Helicities: helicity: TBP>>=
	procedure :: write_raw => helicity_write_raw
	procedure :: read_raw => helicity_read_raw
	<<Helicities: procedures>>=
	subroutine helicity_write_raw (hel, u)
	class(helicity_t), intent(in) :: hel
	integer, intent(in) :: u
	write (u) hel%defined
	if (hel%defined) then
	write (u) hel%h1, hel%h2
	end if
	end subroutine helicity_write_raw

	subroutine helicity_read_raw (hel, u, iostat)
	class(helicity_t), intent(out) :: hel
	integer, intent(in) :: u
	integer, intent(out), optional :: iostat
	read (u, iostat=iostat) hel%defined
	if (hel%defined) then
	read (u, iostat=iostat) hel%h1, hel%h2
	end if
	end subroutine helicity_read_raw

	@ %def helicity_write_raw helicity_read_raw
	@
	\subsection{Predicates}
	Check if the helicity is defined:
	<<Helicities: helicity: TBP>>=
	procedure :: is_defined => helicity_is_defined
	<<Helicities: procedures>>=
	elemental function helicity_is_defined (hel) result (defined)
	logical :: defined
	class(helicity_t), intent(in) :: hel
	defined = hel%defined
	end function helicity_is_defined

	@ %def helicity_is_defined
	@ Return true if the two helicities are equal or the particle is unpolarized:
	<<Helicities: helicity: TBP>>=
	procedure :: is_diagonal => helicity_is_diagonal
	<<Helicities: procedures>>=
	elemental function helicity_is_diagonal (hel) result (diagonal)
	logical :: diagonal
	class(helicity_t), intent(in) :: hel
	if (hel%defined) then
	diagonal = hel%h1 == hel%h2
	else
	diagonal = .true.
	end if
	end function helicity_is_diagonal

	@ %def helicity_is_diagonal
	@
	\subsection{Accessing contents}
	This returns a two-element array and thus cannot be elemental. The
	result is unpredictable if the helicity is undefined.
	<<Helicities: helicity: TBP>>=
	procedure :: to_pair => helicity_to_pair
	<<Helicities: procedures>>=
	pure function helicity_to_pair (hel) result (h)
	integer, dimension(2) :: h
	class(helicity_t), intent(in) :: hel
	h(1) = hel%h2
	h(2) = hel%h1
	end function helicity_to_pair

	@ %def helicity_to_pair
	@
	\subsection{Comparisons}
	When comparing helicities, if either one is undefined, they are
	considered to match. In other words, an unpolarized particle matches
	any polarization. In the [[dmatch]] variant, it matches only diagonal
	helicity.
	<<Helicities: helicity: TBP>>=
	generic :: operator(.match.) => helicity_match
	generic :: operator(.dmatch.) => helicity_match_diagonal
	generic :: operator(==) => helicity_eq
	generic :: operator(/=) => helicity_neq
	procedure, private :: helicity_match
	procedure, private :: helicity_match_diagonal
	procedure, private :: helicity_eq
	procedure, private :: helicity_neq
	@ %def .match. .dmatch. == /=
	<<Helicities: procedures>>=
	elemental function helicity_match (hel1, hel2) result (eq)
	logical :: eq
	class(helicity_t), intent(in) :: hel1, hel2
	if (hel1%defined .and. hel2%defined) then
	eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
	else
	eq = .true.
	end if
	end function helicity_match

	elemental function helicity_match_diagonal (hel1, hel2) result (eq)
	logical :: eq
	class(helicity_t), intent(in) :: hel1, hel2
	if (hel1%defined .and. hel2%defined) then
	eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
	else if (hel1%defined) then
	eq = hel1%h1 == hel1%h2
	else if (hel2%defined) then
	eq = hel2%h1 == hel2%h2
	else
	eq = .true.
	end if
	end function helicity_match_diagonal

	@ %def helicity_match helicity_match_diagonal
	<<Helicities: procedures>>=
	elemental function helicity_eq (hel1, hel2) result (eq)
	logical :: eq
	class(helicity_t), intent(in) :: hel1, hel2
	if (hel1%defined .and. hel2%defined) then
	eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
	else if (.not. hel1%defined .and. .not. hel2%defined) then
	eq = .true.
	else
	eq = .false.
	end if
	end function helicity_eq

	@ %def helicity_eq
	<<Helicities: procedures>>=
	elemental function helicity_neq (hel1, hel2) result (neq)
	logical :: neq
	class(helicity_t), intent(in) :: hel1, hel2
	if (hel1%defined .and. hel2%defined) then
	neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2)
	else if (.not. hel1%defined .and. .not. hel2%defined) then
	neq = .false.
	else
	neq = .true.
	end if
	end function helicity_neq

	@ %def helicity_neq
	@
	\subsection{Tools}
	Merge two helicity objects by taking the first entry from the first and
	the second entry from the second argument. Makes sense only if the
	input helicities were defined and diagonal. The handling of ghost
	flags is not well-defined; one should verify beforehand that they
	match.
	<<Helicities: helicity: TBP>>=
	generic :: operator(.merge.) => merge_helicities
	procedure, private :: merge_helicities
	@ %def .merge.
	<<Helicities: procedures>>=
	elemental function merge_helicities (hel1, hel2) result (hel)
	type(helicity_t) :: hel
	class(helicity_t), intent(in) :: hel1, hel2
	if (hel1%defined .and. hel2%defined) then
	call hel%init (hel2%h1, hel1%h1)
	else if (hel1%defined) then
	call hel%init (hel1%h2, hel1%h1)
	else if (hel2%defined) then
	call hel%init (hel2%h2, hel2%h1)
	end if
	end function merge_helicities

	@ %def merge_helicities
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Colors}
	This module defines a type and tools for dealing with color information.

	Each particle can have zero or more (in practice, usually not more
	than two) color indices. Color indices are positive; flow direction
	can be determined from the particle nature.

	While parton shower matrix elements are diagonal in color, some
	special applications (e.g., subtractions for NLO matrix elements)
	require non-diagonal color matrices.
	<<[[colors.f90]]>>=
	<<File header>>

	module colors

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use diagnostics

	<<Standard module head>>

	<<Colors: public>>

	<<Colors: types>>

	<<Colors: interfaces>>

	contains

	<<Colors: procedures>>

	end module colors
	@ %def colors
	@
	\subsection{The color type}
	A particle may have an arbitrary number of color indices (in practice,
	from zero to two, but more are possible). This object acts as a
	container. (The current implementation has a fixed array of length two.)

	The fact that color comes as an array prohibits elemental procedures
	in some places. (May add interfaces and multi versions where
	necessary.)

	The color may be undefined.

	NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable
	but fixed-size arrays with dimension 2. Only nonzero entries count.
	This may be more efficient anyway, but gives up some flexibility.
	However, the squaring algorithm currently works only for singlets,
	(anti)triplets and octets anyway, so two components are enough.

	This type has to be generalized (abstract type and specific
	implementations) when trying to pursue generalized color flows or
	Monte Carlo over continuous color.
	<<Colors: public>>=
	public :: color_t
	<<Colors: types>>=
	type :: color_t
	private
	logical :: defined = .false.
	integer, dimension(2) :: c1 = 0, c2 = 0
	logical :: ghost = .false.
	contains
	<<Colors: color: TBP>>
	end type color_t

	@ %def color_t
	@ Initializers:
	<<Colors: color: TBP>>=
	generic :: init => &
	color_init_trivial, color_init_trivial_ghost, &
	color_init_array, color_init_array_ghost, &
	color_init_arrays, color_init_arrays_ghost
	procedure, private :: color_init_trivial
	procedure, private :: color_init_trivial_ghost
	procedure, private :: color_init_array
	procedure, private :: color_init_array_ghost
	procedure, private :: color_init_arrays
	procedure, private :: color_init_arrays_ghost
	@ Undefined color: array remains unallocated
	<<Colors: procedures>>=
	pure subroutine color_init_trivial (col)
	class(color_t), intent(inout) :: col
	col%defined = .true.
	col%c1 = 0
	col%c2 = 0
	col%ghost = .false.
	end subroutine color_init_trivial

	pure subroutine color_init_trivial_ghost (col, ghost)
	class(color_t), intent(inout) :: col
	logical, intent(in) :: ghost
	col%defined = .true.
	col%c1 = 0
	col%c2 = 0
	col%ghost = ghost
	end subroutine color_init_trivial_ghost

	@ This defines color from an arbitrary length color array, suitable
	for any representation. We may have two color arrays (non-diagonal
	matrix elements). This cannot be elemental. The third version
	assigns an array of colors, using a two-dimensional array as input.
	<<Colors: procedures>>=
	pure subroutine color_init_array (col, c1)
	class(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1
	col%defined = .true.
	col%c1 = pack (c1, c1 /= 0, [0,0])
	col%c2 = col%c1
	col%ghost = .false.
	end subroutine color_init_array

	pure subroutine color_init_array_ghost (col, c1, ghost)
	class(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1
	logical, intent(in) :: ghost
	call color_init_array (col, c1)
	col%ghost = ghost
	end subroutine color_init_array_ghost

	pure subroutine color_init_arrays (col, c1, c2)
	class(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1, c2
	col%defined = .true.
	if (size (c1) == size (c2)) then
	col%c1 = pack (c1, c1 /= 0, [0,0])
	col%c2 = pack (c2, c2 /= 0, [0,0])
	else if (size (c1) /= 0) then
	col%c1 = pack (c1, c1 /= 0, [0,0])
	col%c2 = col%c1
	else if (size (c2) /= 0) then
	col%c1 = pack (c2, c2 /= 0, [0,0])
	col%c2 = col%c1
	end if
	col%ghost = .false.
	end subroutine color_init_arrays

	pure subroutine color_init_arrays_ghost (col, c1, c2, ghost)
	class(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1, c2
	logical, intent(in) :: ghost
	call color_init_arrays (col, c1, c2)
	col%ghost = ghost
	end subroutine color_init_arrays_ghost

	@ %def color_init
	@ This version is restricted to singlets, triplets, antitriplets, and
	octets: The input contains the color and anticolor index, each of the
	may be zero.
	<<Colors: color: TBP>>=
	procedure :: init_col_acl => color_init_col_acl
	<<Colors: procedures>>=
	elemental subroutine color_init_col_acl (col, col_in, acl_in)
	class(color_t), intent(inout) :: col
	integer, intent(in) :: col_in, acl_in
	integer, dimension(0) :: null_array
	select case (col_in)
	case (0)
	select case (acl_in)
	case (0)
	call color_init_array (col, null_array)
	case default
	call color_init_array (col, [-acl_in])
	end select
	case default
	select case (acl_in)
	case (0)
	call color_init_array (col, [col_in])
	case default
	call color_init_array (col, [col_in, -acl_in])
	end select
	end select
	end subroutine color_init_col_acl

	@ %def color_init_col_acl
	@ This version is used for the external interface. We convert a
	fixed-size array of colors (for each particle) to the internal form by
	packing only the nonzero entries.

	Some of these procedures produce an arry, so they can't be all
	type-bound. We implement them as ordinary procedures.
	<<Colors: public>>=
	public :: color_init_from_array
	<<Colors: interfaces>>=
	interface color_init_from_array
	module procedure color_init_from_array1
	module procedure color_init_from_array1g
	module procedure color_init_from_array2
	module procedure color_init_from_array2g
	end interface color_init_from_array

	@ %def color_init_from_array
	<<Colors: procedures>>=
	pure subroutine color_init_from_array1 (col, c1)
	type(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1
	logical, dimension(size(c1)) :: mask
	mask = c1 /= 0
	col%defined = .true.
	col%c1 = pack (c1, mask, col%c1)
	col%c2 = col%c1
	col%ghost = .false.
	end subroutine color_init_from_array1

	pure subroutine color_init_from_array1g (col, c1, ghost)
	type(color_t), intent(inout) :: col
	integer, dimension(:), intent(in) :: c1
	logical, intent(in) :: ghost
	call color_init_from_array1 (col, c1)
	col%ghost = ghost
	end subroutine color_init_from_array1g

	pure subroutine color_init_from_array2 (col, c1)
	integer, dimension(:,:), intent(in) :: c1
	type(color_t), dimension(:), intent(inout) :: col
	integer :: i
	do i = 1, size (c1,2)
	call color_init_from_array1 (col(i), c1(:,i))
	end do
	end subroutine color_init_from_array2

	pure subroutine color_init_from_array2g (col, c1, ghost)
	integer, dimension(:,:), intent(in) :: c1
	type(color_t), dimension(:), intent(out) :: col
	logical, intent(in), dimension(:) :: ghost
	call color_init_from_array2 (col, c1)
	col%ghost = ghost
	end subroutine color_init_from_array2g

	@ %def color_init_from_array
	@ Set the ghost property
	<<Colors: color: TBP>>=
	procedure :: set_ghost => color_set_ghost
	<<Colors: procedures>>=
	elemental subroutine color_set_ghost (col, ghost)
	class(color_t), intent(inout) :: col
	logical, intent(in) :: ghost
	col%ghost = ghost
	end subroutine color_set_ghost

	@ %def color_set_ghost
	@ Undefine the color state:
	<<Colors: color: TBP>>=
	procedure :: undefine => color_undefine
	<<Colors: procedures>>=
	elemental subroutine color_undefine (col, undefine_ghost)
	class(color_t), intent(inout) :: col
	logical, intent(in), optional :: undefine_ghost
	col%defined = .false.
	if (present (undefine_ghost)) then
	if (undefine_ghost) col%ghost = .false.
	else
	col%ghost = .false.
	end if
	end subroutine color_undefine

	@ %def color_undefine
	@ Output. As dense as possible, no linebreak. If color is undefined,
	no output.

	The separate version for a color array suggest two distinct interfaces.
	<<Colors: public>>=
	public :: color_write
	<<Colors: interfaces>>=
	interface color_write
	module procedure color_write_single
	module procedure color_write_array
	end interface color_write

	<<Colors: color: TBP>>=
	procedure :: write => color_write_single
	<<Colors: procedures>>=
	subroutine color_write_single (col, unit)
	class(color_t), intent(in) :: col
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (col%ghost) then
	write (u, "(A)", advance="no") "c*"
	else if (col%defined) then
	write (u, "(A)", advance="no") "c("
	if (col%c1(1) /= 0) write (u, "(I0)", advance="no") col%c1(1)
	if (any (col%c1 /= 0)) write (u, "(1x)", advance="no")
	if (col%c1(2) /= 0) write (u, "(I0)", advance="no") col%c1(2)
	if (.not. col%is_diagonal ()) then
	write (u, "(A)", advance="no") "\|"
	if (col%c2(1) /= 0) write (u, "(I0)", advance="no") col%c2(1)
	if (any (col%c2 /= 0)) write (u, "(1x)", advance="no")
	if (col%c2(2) /= 0) write (u, "(I0)", advance="no") col%c2(2)
	end if
	write (u, "(A)", advance="no") ")"
	end if
	end subroutine color_write_single

	subroutine color_write_array (col, unit)
	type(color_t), dimension(:), intent(in) :: col
	integer, intent(in), optional :: unit
	integer :: u
	integer :: i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)", advance="no") "["
	do i = 1, size (col)
	if (i > 1) write (u, "(1x)", advance="no")
	call color_write_single (col(i), u)
	end do
	write (u, "(A)", advance="no") "]"
	end subroutine color_write_array

	@ %def color_write
	@ Binary I/O. For allocatable colors, this would have to be modified.
	<<Colors: color: TBP>>=
	procedure :: write_raw => color_write_raw
	procedure :: read_raw => color_read_raw
	<<Colors: procedures>>=
	subroutine color_write_raw (col, u)
	class(color_t), intent(in) :: col
	integer, intent(in) :: u
	logical :: defined
	defined = col%is_defined () .or. col%is_ghost ()
	write (u) defined
	if (defined) then
	write (u) col%c1, col%c2
	write (u) col%ghost
	end if
	end subroutine color_write_raw

	subroutine color_read_raw (col, u, iostat)
	class(color_t), intent(inout) :: col
	integer, intent(in) :: u
	integer, intent(out), optional :: iostat
	logical :: defined
	read (u, iostat=iostat) col%defined
	if (col%defined) then
	read (u, iostat=iostat) col%c1, col%c2
	read (u, iostat=iostat) col%ghost
	end if
	end subroutine color_read_raw

	@ %def color_write_raw color_read_raw
	@
	\subsection{Predicates}
	Return the definition status. A color state may be defined but trivial.
	<<Colors: color: TBP>>=
	procedure :: is_defined => color_is_defined
	procedure :: is_nonzero => color_is_nonzero
	<<Colors: procedures>>=
	elemental function color_is_defined (col) result (defined)
	logical :: defined
	class(color_t), intent(in) :: col
	defined = col%defined
	end function color_is_defined

	elemental function color_is_nonzero (col) result (flag)
	logical :: flag
	class(color_t), intent(in) :: col
	flag = col%defined &
	.and. .not. col%ghost &
	.and. any (col%c1 /= 0 .or. col%c2 /= 0)
	end function color_is_nonzero

	@ %def color_is_defined
	@ %def color_is_nonzero
	@ Diagonal color objects have only one array allocated:
	<<Colors: color: TBP>>=
	procedure :: is_diagonal => color_is_diagonal
	<<Colors: procedures>>=
	elemental function color_is_diagonal (col) result (diagonal)
	logical :: diagonal
	class(color_t), intent(in) :: col
	if (col%defined) then
	diagonal = all (col%c1 == col%c2)
	else
	diagonal = .true.
	end if
	end function color_is_diagonal

	@ %def color_is_diagonal
	@ Return the ghost flag
	<<Colors: color: TBP>>=
	procedure :: is_ghost => color_is_ghost
	<<Colors: procedures>>=
	elemental function color_is_ghost (col) result (ghost)
	logical :: ghost
	class(color_t), intent(in) :: col
	ghost = col%ghost
	end function color_is_ghost

	@ %def color_is_ghost
	@ The ghost parity: true if the color-ghost flag is set. Again, no
	TBP since this is an array.
	<<Colors: procedures>>=
	pure function color_ghost_parity (col) result (parity)
	type(color_t), dimension(:), intent(in) :: col
	logical :: parity
	parity = mod (count (col%ghost), 2) == 1
	end function color_ghost_parity

	@ %def color_ghost_parity
	@ Determine the color representation, given a color object. We allow
	only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$).
	A color ghost must not have color assigned, but the color type is $8$. For
	non-diagonal color, representations must match. If the color type is
	undefined, return $0$. If it is invalid or unsupported, return $-1$.

	Assumption: nonzero entries precede nonzero ones.
	<<Colors: color: TBP>>=
	procedure :: get_type => color_get_type
	<<Colors: procedures>>=
	elemental function color_get_type (col) result (ctype)
	class(color_t), intent(in) :: col
	integer :: ctype
	if (col%defined) then
	ctype = -1
	if (col%ghost) then
	if (all (col%c1 == 0 .and. col%c2 == 0)) then
	ctype = 8
	end if
	else
	if (all ((col%c1 == 0 .and. col%c2 == 0) &
	& .or. (col%c1 > 0 .and. col%c2 > 0) &
	& .or. (col%c1 < 0 .and. col%c2 < 0))) then
	if (all (col%c1 == 0)) then
	ctype = 1
	else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then
	ctype = 3
	else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then
	ctype = -3
	else if ((col%c1(1) > 0 .and. col%c1(2) < 0) &
	.or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then
	ctype = 8
	end if
	end if
	end if
	else
	ctype = 0
	end if
	end function color_get_type

	@ %def color_get_type
	@
	\subsection{Accessing contents}
	Return the number of color indices. We assume that it is identical
	for both arrays.
	<<Colors: color: TBP>>=
	procedure, private :: get_number_of_indices => color_get_number_of_indices
	<<Colors: procedures>>=
	elemental function color_get_number_of_indices (col) result (n)
	integer :: n
	class(color_t), intent(in) :: col
	if (col%defined .and. .not. col%ghost) then
	n = count (col%c1 /= 0)
	else
	n = 0
	end if
	end function color_get_number_of_indices

	@ %def color_get_number_of_indices
	@ Return the (first) color/anticolor entry (assuming that color is
	diagonal). The result is a positive color index.
	<<Colors: color: TBP>>=
	procedure :: get_col => color_get_col
	procedure :: get_acl => color_get_acl
	<<Colors: procedures>>=
	elemental function color_get_col (col) result (c)
	integer :: c
	class(color_t), intent(in) :: col
	integer :: i
	if (col%defined .and. .not. col%ghost) then
	do i = 1, size (col%c1)
	if (col%c1(i) > 0) then
	c = col%c1(i)
	return
	end if
	end do
	end if
	c = 0
	end function color_get_col

	elemental function color_get_acl (col) result (c)
	integer :: c
	class(color_t), intent(in) :: col
	integer :: i
	if (col%defined .and. .not. col%ghost) then
	do i = 1, size (col%c1)
	if (col%c1(i) < 0) then
	c = - col%c1(i)
	return
	end if
	end do
	end if
	c = 0
	end function color_get_acl

	@ %def color_get_col color_get_acl
	@ Return the color index with highest absolute value
	<<Colors: public>>=
	public :: color_get_max_value
	<<Colors: interfaces>>=
	interface color_get_max_value
	module procedure color_get_max_value0
	module procedure color_get_max_value1
	module procedure color_get_max_value2
	end interface color_get_max_value

	<<Colors: procedures>>=
	elemental function color_get_max_value0 (col) result (cmax)
	integer :: cmax
	type(color_t), intent(in) :: col
	if (col%defined .and. .not. col%ghost) then
	cmax = maxval (abs (col%c1))
	else
	cmax = 0
	end if
	end function color_get_max_value0

	pure function color_get_max_value1 (col) result (cmax)
	integer :: cmax
	type(color_t), dimension(:), intent(in) :: col
	cmax = maxval (color_get_max_value0 (col))
	end function color_get_max_value1

	pure function color_get_max_value2 (col) result (cmax)
	integer :: cmax
	type(color_t), dimension(:,:), intent(in) :: col
	integer, dimension(size(col, 2)) :: cm
	integer :: i
	forall (i = 1:size(col, 2))
	cm(i) = color_get_max_value1 (col(:,i))
	end forall
	cmax = maxval (cm)
	end function color_get_max_value2

	@ %def color_get_max_value
	@
	\subsection{Comparisons}
	Similar to helicities, colors match if they are equal, or if either
	one is undefined.
	<<Colors: color: TBP>>=
	generic :: operator(.match.) => color_match
	generic :: operator(==) => color_eq
	generic :: operator(/=) => color_neq
	procedure, private :: color_match
	procedure, private :: color_eq
	procedure, private :: color_neq
	@ %def .match. == /=
	<<Colors: procedures>>=
	elemental function color_match (col1, col2) result (eq)
	logical :: eq
	class(color_t), intent(in) :: col1, col2
	if (col1%defined .and. col2%defined) then
	if (col1%ghost .and. col2%ghost) then
	eq = .true.
	else if (.not. col1%ghost .and. .not. col2%ghost) then
	eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
	else
	eq = .false.
	end if
	else
	eq = .true.
	end if
	end function color_match

	elemental function color_eq (col1, col2) result (eq)
	logical :: eq
	class(color_t), intent(in) :: col1, col2
	if (col1%defined .and. col2%defined) then
	if (col1%ghost .and. col2%ghost) then
	eq = .true.
	else if (.not. col1%ghost .and. .not. col2%ghost) then
	eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
	else
	eq = .false.
	end if
	else if (.not. col1%defined &
	.and. .not. col2%defined) then
	eq = col1%ghost .eqv. col2%ghost
	else
	eq = .false.
	end if
	end function color_eq

	@ %def color_eq
	<<Colors: procedures>>=
	elemental function color_neq (col1, col2) result (neq)
	logical :: neq
	class(color_t), intent(in) :: col1, col2
	if (col1%defined .and. col2%defined) then
	if (col1%ghost .and. col2%ghost) then
	neq = .false.
	else if (.not. col1%ghost .and. .not. col2%ghost) then
	neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2)
	else
	neq = .true.
	end if
	else if (.not. col1%defined &
	.and. .not. col2%defined) then
	neq = col1%ghost .neqv. col2%ghost
	else
	neq = .true.
	end if
	end function color_neq

	@ %def color_neq
	@
	\subsection{Tools}
	Shift color indices by a common offset.
	<<Colors: color: TBP>>=
	procedure :: add_offset => color_add_offset
	<<Colors: procedures>>=
	elemental subroutine color_add_offset (col, offset)
	class(color_t), intent(inout) :: col
	integer, intent(in) :: offset
	if (col%defined .and. .not. col%ghost) then
	where (col%c1 /= 0) col%c1 = col%c1 + sign (offset, col%c1)
	where (col%c2 /= 0) col%c2 = col%c2 + sign (offset, col%c2)
	end if
	end subroutine color_add_offset

	@ %def color_add_offset
	@ Reassign color indices for an array of colored particle in canonical
	order. The allocated size of the color map is such that two colors
	per particle can be accomodated.

	The algorithm works directly on the contents of the color objects, it
	<<Colors: public>>=
	public :: color_canonicalize
	<<Colors: procedures>>=
	subroutine color_canonicalize (col)
	type(color_t), dimension(:), intent(inout) :: col
	integer, dimension(2*size(col)) :: map
	integer :: n_col, i, j, k
	n_col = 0
	do i = 1, size (col)
	if (col(i)%defined .and. .not. col(i)%ghost) then
	do j = 1, size (col(i)%c1)
	if (col(i)%c1(j) /= 0) then
	k = find (abs (col(i)%c1(j)), map(:n_col))
	if (k == 0) then
	n_col = n_col + 1
	map(n_col) = abs (col(i)%c1(j))
	k = n_col
	end if
	col(i)%c1(j) = sign (k, col(i)%c1(j))
	end if
	if (col(i)%c2(j) /= 0) then
	k = find (abs (col(i)%c2(j)), map(:n_col))
	if (k == 0) then
	n_col = n_col + 1
	map(n_col) = abs (col(i)%c2(j))
	k = n_col
	end if
	col(i)%c2(j) = sign (k, col(i)%c2(j))
	end if
	end do
	end if
	end do
	contains
	function find (c, array) result (k)
	integer :: k
	integer, intent(in) :: c
	integer, dimension(:), intent(in) :: array
	integer :: i
	k = 0
	do i = 1, size (array)
	if (c == array (i)) then
	k = i
	return
	end if
	end do
	end function find
	end subroutine color_canonicalize

	@ %def color_canonicalize
	@ Return an array of different color indices from an array of colors.
	The last argument is a pseudo-color array, where the color entries
	correspond to the position of the corresponding index entry in the
	index array. The colors are assumed to be diagonal.

	The algorithm works directly on the contents of the color objects.
	<<Colors: procedures>>=
	subroutine extract_color_line_indices (col, c_index, col_pos)
	type(color_t), dimension(:), intent(in) :: col
	integer, dimension(:), intent(out), allocatable :: c_index
	type(color_t), dimension(size(col)), intent(out) :: col_pos
	integer, dimension(:), allocatable :: c_tmp
	integer :: i, j, k, n, c
	allocate (c_tmp (sum (col%get_number_of_indices ())), source=0)
	n = 0
	SCAN1: do i = 1, size (col)
	if (col(i)%defined .and. .not. col(i)%ghost) then
	SCAN2: do j = 1, 2
	c = abs (col(i)%c1(j))
	if (c /= 0) then
	do k = 1, n
	if (c_tmp(k) == c) then
	col_pos(i)%c1(j) = k
	cycle SCAN2
	end if
	end do
	n = n + 1
	c_tmp(n) = c
	col_pos(i)%c1(j) = n
	end if
	end do SCAN2
	end if
	end do SCAN1
	allocate (c_index (n))
	c_index = c_tmp(1:n)
	end subroutine extract_color_line_indices

	@ %def extract_color_line_indices
	@ Given a color array, pairwise contract the color lines in all
	possible ways and return the resulting array of arrays. The input
	color array must be diagonal, and each color should occur exactly
	twice, once as color and once as anticolor.

	Gluon entries with equal color and anticolor are explicitly excluded.

	This algorithm is generic, but for long arrays it is neither
	efficient, nor does it avoid duplicates. It is intended for small
	arrays, in particular for the state matrix of a structure-function
	pair.

	The algorithm works directly on the contents of the color objects, it
	thus depends on the implementation.
	<<Colors: public>>=
	public :: color_array_make_contractions
	<<Colors: procedures>>=
	subroutine color_array_make_contractions (col_in, col_out)
	type(color_t), dimension(:), intent(in) :: col_in
	type(color_t), dimension(:,:), intent(out), allocatable :: col_out
	type :: entry_t
	integer, dimension(:), allocatable :: map
	type(color_t), dimension(:), allocatable :: col
	type(entry_t), pointer :: next => null ()
	logical :: nlo_event = .false.
	end type entry_t
	type :: list_t
	integer :: n = 0
	type(entry_t), pointer :: first => null ()
	type(entry_t), pointer :: last => null ()
	end type list_t
	type(list_t) :: list
	type(entry_t), pointer :: entry
	integer, dimension(:), allocatable :: c_index
	type(color_t), dimension(size(col_in)) :: col_pos
	integer :: n_prt, n_c_index
	integer, dimension(:), allocatable :: map
	integer :: i, j, c
	n_prt = size (col_in)
	call extract_color_line_indices (col_in, c_index, col_pos)
	n_c_index = size (c_index)
	allocate (map (n_c_index))
	map = 0
	call list_append_if_valid (list, map)
	entry => list%first
	do while (associated (entry))
	do i = 1, n_c_index
	if (entry%map(i) == 0) then
	c = c_index(i)
	do j = i + 1, n_c_index
	if (entry%map(j) == 0) then
	map = entry%map
	map(i) = c
	map(j) = c
	call list_append_if_valid (list, map)
	end if
	end do
	end if
	end do
	entry => entry%next
	end do
	call list_to_array (list, col_out)
	contains
	subroutine list_append_if_valid (list, map)
	type(list_t), intent(inout) :: list
	integer, dimension(:), intent(in) :: map
	type(entry_t), pointer :: entry
	integer :: i, j, c, p
	entry => list%first
	do while (associated (entry))
	if (all (map == entry%map)) return
	entry => entry%next
	end do
	allocate (entry)
	allocate (entry%map (n_c_index))
	entry%map = map
	allocate (entry%col (n_prt))
	do i = 1, n_prt
	do j = 1, 2
	c = col_in(i)%c1(j)
	if (c /= 0) then
	p = col_pos(i)%c1(j)
	entry%col(i)%defined = .true.
	if (map(p) /= 0) then
	entry%col(i)%c1(j) = sign (map(p), c)
	else
	entry%col(i)%c1(j) = c
	endif
	entry%col(i)%c2(j) = entry%col(i)%c1(j)
	end if
	end do
	if (any (entry%col(i)%c1 /= 0) .and. &
	entry%col(i)%c1(1) == - entry%col(i)%c1(2)) return
	end do
	if (associated (list%last)) then
	list%last%next => entry
	else
	list%first => entry
	end if
	list%last => entry
	list%n = list%n + 1
	end subroutine list_append_if_valid
	subroutine list_to_array (list, col)
	type(list_t), intent(inout) :: list
	type(color_t), dimension(:,:), intent(out), allocatable :: col
	type(entry_t), pointer :: entry
	integer :: i
	allocate (col (n_prt, list%n - 1))
	do i = 0, list%n - 1
	entry => list%first
	list%first => list%first%next
	if (i /= 0) col(:,i) = entry%col
	deallocate (entry)
	end do
	list%last => null ()
	end subroutine list_to_array
	end subroutine color_array_make_contractions

	@ %def color_array_make_contractions
	@ Invert the color index, switching from particle to antiparticle.
	For gluons, we have to swap the order of color entries.
	<<Colors: color: TBP>>=
	procedure :: invert => color_invert
	<<Colors: procedures>>=
	elemental subroutine color_invert (col)
	class(color_t), intent(inout) :: col
	if (col%defined .and. .not. col%ghost) then
	col%c1 = - col%c1
	col%c2 = - col%c2
	if (col%c1(1) < 0 .and. col%c1(2) > 0) then
	col%c1 = col%c1(2:1:-1)
	col%c2 = col%c2(2:1:-1)
	end if
	end if
	end subroutine color_invert

	@ %def color_invert
	@ Make a color map for two matching color arrays. The result is an
	array of integer pairs.
	<<Colors: public>>=
	public :: make_color_map
	<<Colors: interfaces>>=
	interface make_color_map
	module procedure color_make_color_map
	end interface make_color_map

	<<Colors: procedures>>=
	subroutine color_make_color_map (map, col1, col2)
	integer, dimension(:,:), intent(out), allocatable :: map
	type(color_t), dimension(:), intent(in) :: col1, col2
	integer, dimension(:,:), allocatable :: map1
	integer :: i, j, k
	allocate (map1 (2, 2 * sum (col1%get_number_of_indices ())))
	k = 0
	do i = 1, size (col1)
	if (col1(i)%defined .and. .not. col1(i)%ghost) then
	do j = 1, size (col1(i)%c1)
	if (col1(i)%c1(j) /= 0 &
	.and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then
	k = k + 1
	map1(1,k) = abs (col1(i)%c1(j))
	map1(2,k) = abs (col2(i)%c1(j))
	end if
	if (col1(i)%c2(j) /= 0 &
	.and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then
	k = k + 1
	map1(1,k) = abs (col1(i)%c2(j))
	map1(2,k) = abs (col2(i)%c2(j))
	end if
	end do
	end if
	end do
	allocate (map (2, k))
	map(:,:) = map1(:,:k)
	end subroutine color_make_color_map

	@ %def make_color_map
	@ Translate colors which have a match in the translation table (an
	array of integer pairs). Color that do not match an entry are simply
	transferred; this is done by first transferring all components, then
	modifiying entries where appropriate.
	<<Colors: public>>=
	public :: color_translate
	<<Colors: interfaces>>=
	interface color_translate
	module procedure color_translate0
	module procedure color_translate0_offset
	module procedure color_translate1
	end interface color_translate

	<<Colors: procedures>>=
	subroutine color_translate0 (col, map)
	type(color_t), intent(inout) :: col
	integer, dimension(:,:), intent(in) :: map
	type(color_t) :: col_tmp
	integer :: i
	if (col%defined .and. .not. col%ghost) then
	col_tmp = col
	do i = 1, size (map,2)
	where (abs (col%c1) == map(1,i))
	col_tmp%c1 = sign (map(2,i), col%c1)
	end where
	where (abs (col%c2) == map(1,i))
	col_tmp%c2 = sign (map(2,i), col%c2)
	end where
	end do
	col = col_tmp
	end if
	end subroutine color_translate0

	subroutine color_translate0_offset (col, map, offset)
	type(color_t), intent(inout) :: col
	integer, dimension(:,:), intent(in) :: map
	integer, intent(in) :: offset
	logical, dimension(size(col%c1)) :: mask1, mask2
	type(color_t) :: col_tmp
	integer :: i
	if (col%defined .and. .not. col%ghost) then
	col_tmp = col
	mask1 = col%c1 /= 0
	mask2 = col%c2 /= 0
	do i = 1, size (map,2)
	where (abs (col%c1) == map(1,i))
	col_tmp%c1 = sign (map(2,i), col%c1)
	mask1 = .false.
	end where
	where (abs (col%c2) == map(1,i))
	col_tmp%c2 = sign (map(2,i), col%c2)
	mask2 = .false.
	end where
	end do
	col = col_tmp
	where (mask1) col%c1 = sign (abs (col%c1) + offset, col%c1)
	where (mask2) col%c2 = sign (abs (col%c2) + offset, col%c2)
	end if
	end subroutine color_translate0_offset

	subroutine color_translate1 (col, map, offset)
	type(color_t), dimension(:), intent(inout) :: col
	integer, dimension(:,:), intent(in) :: map
	integer, intent(in), optional :: offset
	integer :: i
	if (present (offset)) then
	do i = 1, size (col)
	call color_translate0_offset (col(i), map, offset)
	end do
	else
	do i = 1, size (col)
	call color_translate0 (col(i), map)
	end do
	end if
	end subroutine color_translate1

	@ %def color_translate
	@ Merge two color objects by taking the first entry from the first and
	the first entry from the second argument. Makes sense only if the
	input colors are defined (and diagonal). If either one is undefined,
	transfer the defined one.
	<<Colors: color: TBP>>=
	generic :: operator(.merge.) => merge_colors
	procedure, private :: merge_colors
	@ %def .merge.
	<<Colors: procedures>>=
	elemental function merge_colors (col1, col2) result (col)
	type(color_t) :: col
	class(color_t), intent(in) :: col1, col2
	if (color_is_defined (col1) .and. color_is_defined (col2)) then
	if (color_is_ghost (col1) .and. color_is_ghost (col2)) then
	call color_init_trivial_ghost (col, .true.)
	else
	call color_init_arrays (col, col1%c1, col2%c1)
	end if
	else if (color_is_defined (col1)) then
	call color_init_array (col, col1%c1)
	else if (color_is_defined (col2)) then
	call color_init_array (col, col2%c1)
	end if
	end function merge_colors

	@ %def merge_colors
	@ Merge up to two (diagonal!) color objects. The result inherits the unmatched
	color lines of the input colors. If one of the input colors is
	undefined, the output is undefined as well. It must be in a supported
	color representation.

	A color-ghost object should not actually occur in real-particle
	events, but for completeness we define its behavior. For simplicity,
	it is identified as a color-octet with zero color/anticolor. It can
	only couple to a triplet or antitriplet. A fusion of triplet with
	matching antitriplet will yield a singlet, not a ghost, however.

	If the fusion fails, the result is undefined.

	NOTE: The [[select type]] casting is required by gfortran 4.8. It may not be
	required by the standard.
	<<Colors: color: TBP>>=
	generic :: operator (.fuse.) => color_fusion
	procedure, private :: color_fusion
	<<Colors: procedures>>=
	function color_fusion (col1, col2) result (col)
	class(color_t), intent(in) :: col1, col2
	type(color_t) :: col
	integer, dimension(2) :: ctype
	if (col1%is_defined () .and. col2%is_defined ()) then
	if (col1%is_diagonal () .and. col2%is_diagonal ()) then
	select type (col1)
	type is (color_t)
	select type (col2)
	type is (color_t)
	ctype = [col1%get_type (), col2%get_type ()]
	select case (ctype(1))
	case (1)
	select case (ctype(2))
	case (1,3,-3,8)
	col = col2
	end select
	case (3)
	select case (ctype(2))
	case (1)
	col = col1
	case (-3)
	call t_a (col1%get_col (), col2%get_acl ())
	case (8)
	call t_o (col1%get_col (), col2%get_acl (), &
	& col2%get_col ())
	end select
	case (-3)
	select case (ctype(2))
	case (1)
	col = col1
	case (3)
	call t_a (col2%get_col (), col1%get_acl ())
	case (8)
	call a_o (col1%get_acl (), col2%get_col (), &
	& col2%get_acl ())
	end select
	case (8)
	select case (ctype(2))
	case (1)
	col = col1
	case (3)
	call t_o (col2%get_col (), col1%get_acl (), &
	& col1%get_col ())
	case (-3)
	call a_o (col2%get_acl (), col1%get_col (), &
	& col1%get_acl ())
	case (8)
	call o_o (col1%get_col (), col1%get_acl (), &
	& col2%get_col (), col2%get_acl ())
	end select
	end select
	end select
	end select
	end if
	end if
	contains
	subroutine t_a (c1, c2)
	integer, intent(in) :: c1, c2
	if (c1 == c2) then
	call col%init_col_acl (0, 0)
	else
	call col%init_col_acl (c1, c2)
	end if
	end subroutine t_a
	subroutine t_o (c1, c2, c3)
	integer, intent(in) :: c1, c2, c3
	if (c1 == c2) then
	call col%init_col_acl (c3, 0)
	else if (c2 == 0 .and. c3 == 0) then
	call col%init_col_acl (c1, 0)
	end if
	end subroutine t_o
	subroutine a_o (c1, c2, c3)
	integer, intent(in) :: c1, c2, c3
	if (c1 == c2) then
	call col%init_col_acl (0, c3)
	else if (c2 == 0 .and. c3 == 0) then
	call col%init_col_acl (0, c1)
	end if
	end subroutine a_o
	subroutine o_o (c1, c2, c3, c4)
	integer, intent(in) :: c1, c2, c3, c4
	if (all ([c1,c2,c3,c4] /= 0)) then
	if (c2 == c3 .and. c4 == c1) then
	call col%init_col_acl (0, 0)
	else if (c2 == c3) then
	call col%init_col_acl (c1, c4)
	else if (c4 == c1) then
	call col%init_col_acl (c3, c2)
	end if
	end if
	end subroutine o_o
	end function color_fusion

	@ %def color_fusion
	@ Compute the color factor, given two interfering color arrays.
	<<Colors: public>>=
	public :: compute_color_factor
	<<Colors: procedures>>=
	function compute_color_factor (col1, col2, nc) result (factor)
	real(default) :: factor
	type(color_t), dimension(:), intent(in) :: col1, col2
	integer, intent(in), optional :: nc
	type(color_t), dimension(size(col1)) :: col
	integer :: ncol, nloops, nghost
	ncol = 3; if (present (nc)) ncol = nc
	col = col1 .merge. col2
	nloops = count_color_loops (col)
	nghost = count (col%is_ghost ())
	factor = real (ncol, default) ** (nloops - nghost)
	if (color_ghost_parity (col)) factor = - factor
	end function compute_color_factor

	@ %def compute_color_factor
	@
	We have a pair of color index arrays which corresponds to a squared
	matrix element. We want to determine the number of color loops in
	this square matrix element. So we first copy the colors (stored in a
	single color array with a pair of color lists in each entry) to a
	temporary where the color indices are shifted by some offset. We then
	recursively follow each loop, starting at the first color that has the
	offset, resetting the first color index to the loop index and each
	further index to zero as we go. We check that (a) each color index
	occurs twice within the left (right) color array, (b) the loops are
	closed, so we always come back to a line which has the loop index.

	In order for the algorithm to work we have to conjugate the colors of
	initial state particles (one for decays, two for scatterings) into
	their corresponding anticolors of outgoing particles.
	<<Colors: public>>=
	public :: count_color_loops
	<<Colors: procedures>>=
	function count_color_loops (col) result (count)
	integer :: count
	type(color_t), dimension(:), intent(in) :: col
	type(color_t), dimension(size(col)) :: cc
	integer :: i, n, offset
	cc = col
	n = size (cc)
	offset = n
	call color_add_offset (cc, offset)
	count = 0
	SCAN_LOOPS: do
	do i = 1, n
	if (color_is_nonzero (cc(i))) then
	if (any (cc(i)%c1 > offset)) then
	count = count + 1
	call follow_line1 (pick_new_line (cc(i)%c1, count, 1))
	cycle SCAN_LOOPS
	end if
	end if
	end do
	exit SCAN_LOOPS
	end do SCAN_LOOPS
	contains
	function pick_new_line (c, reset_val, sgn) result (line)
	integer :: line
	integer, dimension(:), intent(inout) :: c
	integer, intent(in) :: reset_val
	integer, intent(in) :: sgn
	integer :: i
	if (any (c == count)) then
	line = count
	else
	do i = 1, size (c)
	if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then
	line = c(i)
	c(i) = reset_val
	return
	end if
	end do
	call color_mismatch
	end if
	end function pick_new_line

	subroutine reset_line (c, line)
	integer, dimension(:), intent(inout) :: c
	integer, intent(in) :: line
	integer :: i
	do i = 1, size (c)
	if (c(i) == line) then
	c(i) = 0
	return
	end if
	end do
	end subroutine reset_line

	recursive subroutine follow_line1 (line)
	integer, intent(in) :: line
	integer :: i
	if (line == count) return
	do i = 1, n
	if (any (cc(i)%c1 == -line)) then
	call reset_line (cc(i)%c1, -line)
	call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line)))
	return
	end if
	end do
	call color_mismatch ()
	end subroutine follow_line1

	recursive subroutine follow_line2 (line)
	integer, intent(in) :: line
	integer :: i
	do i = 1, n
	if (any (cc(i)%c2 == -line)) then
	call reset_line (cc(i)%c2, -line)
	call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line)))
	return
	end if
	end do
	call color_mismatch ()
	end subroutine follow_line2

	subroutine color_mismatch ()
	call color_write (col)
	print *
	call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", &
	[var_str ("the evaluation of color correlations. This can happen if there "), &
	var_str ("are different color structures in the initial or final state of "), &
	var_str ("the process definition. If so, please use separate processes for "), &
	var_str ("the different initial / final states. In a future WHIZARD version "), &
	var_str ("this will be fixed.")])
	end subroutine color_mismatch
	end function count_color_loops

	@ %def count_color_loops
	@
	\subsection{Unit tests}
	Test module, followed by the corresponding implementation module.
	<<[[colors_ut.f90]]>>=
	<<File header>>

	module colors_ut
	use unit_tests
	use colors_uti

	<<Standard module head>>

	<<Colors: public test>>

	contains

	<<Colors: test driver>>

	end module colors_ut
	@ %def colors_ut
	@
	<<[[colors_uti.f90]]>>=
	<<File header>>

	module colors_uti

	use colors

	<<Standard module head>>

	<<Colors: test declarations>>

	contains

	<<Colors: tests>>

	end module colors_uti
	@ %def colors_ut
	@ API: driver for the unit tests below.
	<<Colors: public test>>=
	public :: color_test
	<<Colors: test driver>>=
	subroutine color_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Colors: execute tests>>
	end subroutine color_test

	@ %def color_test
	@ This is a color counting test.
	<<Colors: execute tests>>=
	call test (color_1, "color_1", &
	"check color counting", &
	u, results)
	<<Colors: test declarations>>=
	public :: color_1
	<<Colors: tests>>=
	subroutine color_1 (u)
	integer, intent(in) :: u
	type(color_t), dimension(4) :: col1, col2, col
	type(color_t), dimension(:), allocatable :: col3
	type(color_t), dimension(:,:), allocatable :: col_array
	integer :: count, i
	call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2])
	col2 = col1
	call color_write (col1, u)
	write (u, "(A)")
	call color_write (col2, u)
	write (u, "(A)")
	col = col1 .merge. col2
	call color_write (col, u)
	write (u, "(A)")
	count = count_color_loops (col)
	write (u, "(A,I1)") "Number of color loops (3): ", count
	call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1])
	call color_write (col1, u)
	write (u, "(A)")
	call color_write (col2, u)
	write (u, "(A)")
	col = col1 .merge. col2
	call color_write (col, u)
	write (u, "(A)")
	count = count_color_loops (col)
	write (u, "(A,I1)") "Number of color loops (2): ", count
	write (u, "(A)")
	allocate (col3 (4))
	call color_init_from_array (col3, &
	reshape ([1, 0, 0, -1, 2, -3, 3, -2], &
	[2, 4]))
	call color_write (col3, u)
	write (u, "(A)")
	call color_array_make_contractions (col3, col_array)
	write (u, "(A)") "Contractions:"
	do i = 1, size (col_array, 2)
	call color_write (col_array(:,i), u)
	write (u, "(A)")
	end do
	deallocate (col3)
	write (u, "(A)")
	allocate (col3 (6))
	call color_init_from_array (col3, &
	reshape ([1, -2, 3, 0, 0, -1, 2, -4, -3, 0, 4, 0], &
	[2, 6]))
	call color_write (col3, u)
	write (u, "(A)")
	call color_array_make_contractions (col3, col_array)
	write (u, "(A)") "Contractions:"
	do i = 1, size (col_array, 2)
	call color_write (col_array(:,i), u)
	write (u, "(A)")
	end do
	end subroutine color_1

	@ %def color_1
	@ A color fusion test.
	<<Colors: execute tests>>=
	call test (color_2, "color_2", &
	"color fusion", &
	u, results)
	<<Colors: test declarations>>=
	public :: color_2
	<<Colors: tests>>=
	subroutine color_2 (u)
	integer, intent(in) :: u
	type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1

	write (u, "(A)") "* Test output: color_2"
	write (u, "(A)") "* Purpose: test all combinations for color-object fusion"
	write (u, "(A)")

	call s1%init_col_acl (0,0)
	call t1%init_col_acl (1,0)
	call t2%init_col_acl (2,0)
	call a1%init_col_acl (0,1)
	call a2%init_col_acl (0,2)
	call o1%init_col_acl (1,2)
	call o2%init_col_acl (1,3)
	call o3%init_col_acl (2,3)
	call o4%init_col_acl (2,1)
	call g1%init (ghost=.true.)

	call wrt ("s1", s1)
	call wrt ("t1", t1)
	call wrt ("t2", t2)
	call wrt ("a1", a1)
	call wrt ("a2", a2)
	call wrt ("o1", o1)
	call wrt ("o2", o2)
	call wrt ("o3", o3)
	call wrt ("o4", o4)
	call wrt ("g1", g1)

	write (u, *)

	call wrt ("s1 * s1", s1 .fuse. s1)

	write (u, *)

	call wrt ("s1 * t1", s1 .fuse. t1)
	call wrt ("s1 * a1", s1 .fuse. a1)
	call wrt ("s1 * o1", s1 .fuse. o1)

	write (u, *)

	call wrt ("t1 * s1", t1 .fuse. s1)
	call wrt ("a1 * s1", a1 .fuse. s1)
	call wrt ("o1 * s1", o1 .fuse. s1)

	write (u, *)

	call wrt ("t1 * t1", t1 .fuse. t1)

	write (u, *)

	call wrt ("t1 * t2", t1 .fuse. t2)
	call wrt ("t1 * a1", t1 .fuse. a1)
	call wrt ("t1 * a2", t1 .fuse. a2)
	call wrt ("t1 * o1", t1 .fuse. o1)
	call wrt ("t2 * o1", t2 .fuse. o1)

	write (u, *)

	call wrt ("t2 * t1", t2 .fuse. t1)
	call wrt ("a1 * t1", a1 .fuse. t1)
	call wrt ("a2 * t1", a2 .fuse. t1)
	call wrt ("o1 * t1", o1 .fuse. t1)
	call wrt ("o1 * t2", o1 .fuse. t2)

	write (u, *)

	call wrt ("a1 * a1", a1 .fuse. a1)

	write (u, *)

	call wrt ("a1 * a2", a1 .fuse. a2)
	call wrt ("a1 * o1", a1 .fuse. o1)
	call wrt ("a2 * o2", a2 .fuse. o2)

	write (u, *)

	call wrt ("a2 * a1", a2 .fuse. a1)
	call wrt ("o1 * a1", o1 .fuse. a1)
	call wrt ("o2 * a2", o2 .fuse. a2)

	write (u, *)

	call wrt ("o1 * o1", o1 .fuse. o1)

	write (u, *)

	call wrt ("o1 * o2", o1 .fuse. o2)
	call wrt ("o1 * o3", o1 .fuse. o3)
	call wrt ("o1 * o4", o1 .fuse. o4)

	write (u, *)

	call wrt ("o2 * o1", o2 .fuse. o1)
	call wrt ("o3 * o1", o3 .fuse. o1)
	call wrt ("o4 * o1", o4 .fuse. o1)

	write (u, *)

	call wrt ("g1 * g1", g1 .fuse. g1)

	write (u, *)

	call wrt ("g1 * s1", g1 .fuse. s1)
	call wrt ("g1 * t1", g1 .fuse. t1)
	call wrt ("g1 * a1", g1 .fuse. a1)
	call wrt ("g1 * o1", g1 .fuse. o1)

	write (u, *)

	call wrt ("s1 * g1", s1 .fuse. g1)
	call wrt ("t1 * g1", t1 .fuse. g1)
	call wrt ("a1 * g1", a1 .fuse. g1)
	call wrt ("o1 * g1", o1 .fuse. g1)

	write (u, "(A)")
	write (u, "(A)") "* Test output end: color_2"

	contains

	subroutine wrt (s, col)
	character(*), intent(in) :: s
	class(color_t), intent(in) :: col
	write (u, "(A,1x,'=',1x)", advance="no") s
	call col%write (u)
	write (u, *)
	end subroutine wrt

	end subroutine color_2

	@ %def color_2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsection{The Madgraph color model}
	This section describes the method for matrix element and color
	flow calculation within Madgraph.

	For each Feynman diagram, the colorless amplitude for a specified
	helicity and momentum configuration (in- and out- combined) is
	computed:
	\begin{equation}
	A_d(p,h)
	\end{equation}
	Inserting color, the squared matrix element for definite helicity and
	momentum is
	\begin{equation}
	M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h)
	\end{equation}
	where $C_{dd'}$ describes the color interference of the two diagrams
	$A_d$ and $A_d'$, which is independent of momentum and helicity and
	can be calculated for each Feynman diagram pair by reducing it to the
	corresponding color graph. Obviously, one could combine all diagrams
	with identical color structure, such that the index $d$ runs only over
	different color graphs. For colorless diagrams all elements of
	$C_{dd'}$ are equal to unity.

	The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such
	that it can be written in the form
	\begin{equation}
	C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*,
	\end{equation}
	where the eigenvectors $c_d$ are normalized,
	\begin{equation}
	\sum_d \|c_d^\lambda\|^2 = 1,
	\end{equation}
	and the $\lambda$ values are the corresponding eigenvalues. In the
	colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams
	($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero
	eigenvalue.

	Consequently, the squared matrix element for definite helicity and
	momentum can also be written as
	\begin{equation}
	M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^*
	\end{equation}
	with
	\begin{equation}
	A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h).
	\end{equation}
	For generic spin density matrices, this is easily generalized to
	\begin{equation}
	M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
	\end{equation}

	To determine the color flow probabilities of a given momentum-helicity
	configuration, the color flow amplitudes are calculated as
	\begin{equation}
	a_f(p,h) = \sum_d \beta^f_d A_d(p,h),
	\end{equation}
	where the coefficients $\beta^f_d$ describe the amplitude for a given
	Feynman diagram (or color graph) $d$ to correspond to a definite color
	flow~$f$. They are computed from $C_{dd'}$ by transforming this
	matrix into the color flow basis and neglecting all off-diagonal
	elements. Again, these coefficients do not depend on momentum or
	helicity and can therefore be calculated in advance. This gives the
	color flow transition matrix
	\begin{equation}
	F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h')
	\end{equation}
	which is assumed diagonal in color flow space and is separate from the
	color-summed transition matrix $M^2$. They are, however, equivalent
	(up to a factor) to leading order in $1/N_c$, and using the color flow
	transition matrix is appropriate for matching to hadronization.

	Note that the color flow transition matrix is not normalized at this
	stage. To make use of it, we have to fold it with the in-state
	density matrix to get a pseudo density matrix
	\begin{equation}
	\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})
	= \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\,
	\rho_{\rm in}(p,h_{\rm in},h'_{\rm in})
	\end{equation}
	which gets a meaning only after contracted with projections on the
	outgoing helicity states $k_{\rm out}$, given as linear combinations
	of helicity states with the unitary coefficient matrix $c(k_{\rm out},
	h_{\rm out})$. Then the probability of finding color flow $f$ when
	the helicity state $k_{\rm out}$ is measured is given by
	\begin{equation}
	P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out})
	\end{equation}
	where
	\begin{equation}
	Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}}
	c(k_{\rm out}, h_{\rm out})\,
	\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\,
	c^*(k_{\rm out}, h'_{\rm out})
	\end{equation}
	However, if we can assume that the out-state helicity basis is the
	canonical one, we can throw away the off diagonal elements in the
	color flow density matrix and normalize the ones on the diagonal to obtain
	\begin{equation}
	P^f(p, h_{\rm out}) =
	\hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) /
	\sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out})
	\end{equation}

	Finally, the color-summed out-state density matrix is computed by the
	scattering formula
	\begin{align}
	{\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})}
	&=
	\sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\,
	\rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\
	&= \sum_{h_{\rm in} h'_{\rm in} \lambda}
	A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
	\rho_{\rm in}(p,h_{\rm in},h'_{\rm in}),
	\end{align}
	The trace of $\rho_{\rm out}$ is the squared matrix element, summed
	over all internal degrees of freedom. To get the squared matrix
	element for a definite helicity $k_{\rm out}$ and color flow $f$, one
	has to project the density matrix onto the given helicity state and
	multiply with $P^f(p, k_{\rm out})$.

	For diagonal helicities the out-state density reduces to
	\begin{equation}
	\rho_{\rm out}(p,h_{\rm out})
	= \sum_{h_{\rm in}\lambda}
	\lambda\|A_\lambda(p,h)\|^2 \rho_{\rm in}(p,h_{\rm in}).
	\end{equation}
	Since no basis transformation is involved, we can use the normalized
	color flow probability $P^f(p, h_{\rm out})$ and express the result as
	\begin{align}
	\rho_{\rm out}^f(p,h_{\rm out})
	&= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\
	&= \sum_{h_{\rm in}\lambda}
	\frac{\|a^f(p,h)\|^2}{\sum_f\|a^f(p,h)\|^2}
	\lambda\|A_\lambda(p,h)\|^2 \rho_{\rm in}(p,h_{\rm in}).
	\end{align}

	From these considerations, the following calculation strategy can be
	derived:
	\begin{itemize}
	\item
	Before the first event is generated, the color interference matrix
	$C_{dd'}$ is computed and diagonalized, so the eigenvectors
	$c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients
	$\beta^f_d$ are obtained. In practice, these calculations are
	done when the matrix element code is generated, and the results are
	hardcoded in the matrix element subroutine as [[DATA]] statements.
	\item
	For each event, one loops over helicities once and stores the
	matrices $A_\lambda(p,h)$ and $a^f(p,h)$. The allowed color flows,
	helicity combinations and eigenvalues are each labeled by integer
	indices, so one has to store complex matrices of dimension
	$N_\lambda\times N_h$ and $N_f\times N_h$, respectively.
	\item
	The further strategy depends on the requested information.
	\begin{enumerate}
	\item
	If colorless diagonal helicity amplitudes are required, the
	eigenvalues $A_\lambda(p,h)$ are squared, summed with weight
	$\lambda$, and the result contracted with the in-state probability
	vector $\rho_{\rm in}(p, h_{\rm in})$. The result is a
	probability vector $\rho_{\rm out}(p, h_{\rm out})$.
	\item
	For colored diagonal helicity amplitudes, the color coefficients
	$a^f(p,h)$ are also squared and used as weights to obtain the color-flow
	probability vector $\rho_{\rm out}^f(p, h_{\rm out})$.
	\item
	For colorless non-diagonal helicity amplitudes, we contract the
	tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$,
	weighted with $\lambda$, with the correlated in-state density
	matrix, to obtain a correlated out-state density matrix.
	\item
	In the general (colored, non-diagonal) case, we do the same as
	in the colorless case, but return the un-normalized color flow
	density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$
	in addition. When the relevant helicity basis is known, the
	latter can be used by the caller program to determine flow
	probabilities. (In reality, we assume the canonical basis and
	reduce the correlated out-state density to its diagonal immediately.)
	\end{enumerate}
	\end{itemize}
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Flavors: Particle properties}
	This module contains a type for holding the flavor code, and all
	functions that depend on the model, i.e., that determine particle
	properties.

	The PDG code is packed in a special [[flavor]] type. (This prohibits
	meaningless operations, and it allows for a different implementation,
	e.g., some non-PDG scheme internally, if appropiate at some point.)

	There are lots of further particle properties that depend on the
	model. Implementing a flyweight pattern, the associated field data
	object is to be stored in a central area, the [[flavor]] object just
	receives a pointer to this, so all queries can be delegated.
	<<[[flavors.f90]]>>=
	<<File header>>

	module flavors

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use diagnostics
	use physics_defs, only: UNDEFINED
	use physics_defs, only: INVALID
	use physics_defs, only: HADRON_REMNANT
	use physics_defs, only: HADRON_REMNANT_SINGLET
	use physics_defs, only: HADRON_REMNANT_TRIPLET
	use physics_defs, only: HADRON_REMNANT_OCTET
	use model_data
	use colors, only: color_t

	<<Standard module head>>

	<<Flavors: public>>

	<<Flavors: types>>

	<<Flavors: interfaces>>

	contains

	<<Flavors: procedures>>

	end module flavors
	@ %def flavors
	@
	\subsection{The flavor type}
	The flavor type is an integer representing the PDG code, or
	undefined (zero). Negative codes represent antiflavors. They should
	be used only for particles which do have a distinct antiparticle.

	The [[hard_process]] flag can be set for particles that are participating in
	the hard interaction.

	The [[radiated]] flag can be set for particles that are the result of
	a beam-structure interaction (hadron beam remnant, ISR photon, etc.),
	not of the hard interaction itself.

	Further properties of the given flavor can be retrieved via the
	particle-data pointer, if it is associated.
	<<Flavors: public>>=
	public :: flavor_t
	<<Flavors: types>>=
	type :: flavor_t
	private
	integer :: f = UNDEFINED
	logical :: hard_process = .false.
	logical :: radiated = .false.
	type(field_data_t), pointer :: field_data => null ()
	contains
	<<Flavors: flavor: TBP>>
	end type flavor_t

	@ %def flavor_t
	@ Initializer form. If the model is assigned, the procedure is
	impure, therefore we have to define a separate array version.

	Note: The pure elemental subroutines can't have an intent(out) CLASS
	argument (because of the potential for an impure finalizer in a type
	extension), so we stick to intent(inout) and (re)set all components
	explicitly.
	<<Flavors: flavor: TBP>>=
	generic :: init => &
	flavor_init_empty, &
	flavor_init, &
	flavor_init_field_data, &
	flavor_init_model, &
	flavor_init_model_alt, &
	flavor_init_name_model
	procedure, private :: flavor_init_empty
	procedure, private :: flavor_init
	procedure, private :: flavor_init_field_data
	procedure, private :: flavor_init_model
	procedure, private :: flavor_init_model_alt
	procedure, private :: flavor_init_name_model
	<<Flavors: procedures>>=
	elemental subroutine flavor_init_empty (flv)
	class(flavor_t), intent(inout) :: flv
	flv%f = UNDEFINED
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => null ()
	end subroutine flavor_init_empty

	elemental subroutine flavor_init (flv, f)
	class(flavor_t), intent(inout) :: flv
	integer, intent(in) :: f
	flv%f = f
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => null ()
	end subroutine flavor_init

	impure elemental subroutine flavor_init_field_data (flv, field_data)
	class(flavor_t), intent(inout) :: flv
	type(field_data_t), intent(in), target :: field_data
	flv%f = field_data%get_pdg ()
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => field_data
	end subroutine flavor_init_field_data

	impure elemental subroutine flavor_init_model (flv, f, model)
	class(flavor_t), intent(inout) :: flv
	integer, intent(in) :: f
	class(model_data_t), intent(in), target :: model
	flv%f = f
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => model%get_field_ptr (f, check=.true.)
	end subroutine flavor_init_model

	impure elemental subroutine flavor_init_model_alt (flv, f, model, alt_model)
	class(flavor_t), intent(inout) :: flv
	integer, intent(in) :: f
	class(model_data_t), intent(in), target :: model, alt_model
	flv%f = f
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => model%get_field_ptr (f, check=.false.)
	if (.not. associated (flv%field_data)) then
	flv%field_data => alt_model%get_field_ptr (f, check=.false.)
	if (.not. associated (flv%field_data)) then
	write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") &
	"Particle with code", f, &
	"found neither in model", char (model%get_name ()), &
	"nor in model", char (alt_model%get_name ())
	call msg_fatal ()
	end if
	end if
	end subroutine flavor_init_model_alt

	impure elemental subroutine flavor_init_name_model (flv, name, model)
	class(flavor_t), intent(inout) :: flv
	type(string_t), intent(in) :: name
	class(model_data_t), intent(in), target :: model
	flv%f = model%get_pdg (name)
	flv%hard_process = .false.
	flv%radiated = .false.
	flv%field_data => model%get_field_ptr (name, check=.true.)
	end subroutine flavor_init_name_model

	@ %def flavor_init
	@ Set the [[radiated]] flag.
	<<Flavors: flavor: TBP>>=
	procedure :: tag_radiated => flavor_tag_radiated
	<<Flavors: procedures>>=
	elemental subroutine flavor_tag_radiated (flv)
	class(flavor_t), intent(inout) :: flv
	flv%radiated = .true.
	end subroutine flavor_tag_radiated

	@ %def flavor_tag_radiated
	@ Set the [[hard_process]] flag.
	<<Flavors: flavor: TBP>>=
	procedure :: tag_hard_process => flavor_tag_hard_process
	<<Flavors: procedures>>=
	elemental subroutine flavor_tag_hard_process (flv)
	class(flavor_t), intent(inout) :: flv
	flv%hard_process = .true.
	end subroutine flavor_tag_hard_process

	@ %def flavor_tag_hard_process
	@ Undefine the flavor state:
	<<Flavors: flavor: TBP>>=
	procedure :: undefine => flavor_undefine
	<<Flavors: procedures>>=
	elemental subroutine flavor_undefine (flv)
	class(flavor_t), intent(inout) :: flv
	flv%f = UNDEFINED
	flv%field_data => null ()
	end subroutine flavor_undefine

	@ %def flavor_undefine
	@ Output: dense, no linebreak
	<<Flavors: flavor: TBP>>=
	procedure :: write => flavor_write
	<<Flavors: procedures>>=
	subroutine flavor_write (flv, unit)
	class(flavor_t), intent(in) :: flv
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (associated (flv%field_data)) then
	write (u, "(A)", advance="no") "f("
	else
	write (u, "(A)", advance="no") "p("
	end if
	write (u, "(I0)", advance="no") flv%f
	if (flv%radiated) then
	write (u, "('*')", advance="no")
	end if
	write (u, "(A)", advance="no") ")"
	end subroutine flavor_write

	@ %def flavor_write
	@
	<<Flavors: public>>=
	public :: flavor_write_array
	<<Flavors: procedures>>=
	subroutine flavor_write_array (flv, unit)
	type(flavor_t), intent(in), dimension(:) :: flv
	integer, intent(in), optional :: unit
	integer :: u, i_flv
	u = given_output_unit (unit); if (u < 0) return
	do i_flv = 1, size (flv)
	call flv(i_flv)%write (u)
	if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / "
	end do
	write (u,"(A)")
	end subroutine flavor_write_array

	@ %def flavor_write_array
	@ Binary I/O. Currently, the model information is not written/read,
	so after reading the particle-data pointer is empty.
	<<Flavors: flavor: TBP>>=
	procedure :: write_raw => flavor_write_raw
	procedure :: read_raw => flavor_read_raw
	<<Flavors: procedures>>=
	subroutine flavor_write_raw (flv, u)
	class(flavor_t), intent(in) :: flv
	integer, intent(in) :: u
	write (u) flv%f
	write (u) flv%radiated
	end subroutine flavor_write_raw

	subroutine flavor_read_raw (flv, u, iostat)
	class(flavor_t), intent(out) :: flv
	integer, intent(in) :: u
	integer, intent(out), optional :: iostat
	read (u, iostat=iostat) flv%f
	if (present (iostat)) then
	if (iostat /= 0) return
	end if
	read (u, iostat=iostat) flv%radiated
	end subroutine flavor_read_raw

	@ %def flavor_write_raw flavor_read_raw
	@
	\subsubsection{Assignment}
	Default assignment of flavor objects is possible, but cannot be used
	in pure procedures, because a pointer assignment is involved.

	Assign the particle pointer separately. This cannot be elemental, so
	we define a scalar and an array version explicitly. We refer to an
	array of flavors, not an array of models.
	<<Flavors: flavor: TBP>>=
	procedure :: set_model => flavor_set_model_single
	<<Flavors: procedures>>=
	impure elemental subroutine flavor_set_model_single (flv, model)
	class(flavor_t), intent(inout) :: flv
	class(model_data_t), intent(in), target :: model
	if (flv%f /= UNDEFINED) &
	flv%field_data => model%get_field_ptr (flv%f)
	end subroutine flavor_set_model_single

	@ %def flavor_set_model
	@
	\subsubsection{Predicates}
	Return the definition status. By definition, the flavor object is
	defined if the flavor PDG code is nonzero.
	<<Flavors: flavor: TBP>>=
	procedure :: is_defined => flavor_is_defined
	<<Flavors: procedures>>=
	elemental function flavor_is_defined (flv) result (defined)
	class(flavor_t), intent(in) :: flv
	logical :: defined
	defined = flv%f /= UNDEFINED
	end function flavor_is_defined

	@ %def flavor_is_defined
	@ Check for valid flavor (including undefined). This is distinct from
	the [[is_defined]] status. Invalid flavor is actually a specific PDG
	code.
	<<Flavors: flavor: TBP>>=
	procedure :: is_valid => flavor_is_valid
	<<Flavors: procedures>>=
	elemental function flavor_is_valid (flv) result (valid)
	class(flavor_t), intent(in) :: flv
	logical :: valid
	valid = flv%f /= INVALID
	end function flavor_is_valid

	@ %def flavor_is_valid
	@ Return true if the particle-data pointer is associated. (Debugging aid)
	<<Flavors: flavor: TBP>>=
	procedure :: is_associated => flavor_is_associated
	<<Flavors: procedures>>=
	elemental function flavor_is_associated (flv) result (flag)
	class(flavor_t), intent(in) :: flv
	logical :: flag
	flag = associated (flv%field_data)
	end function flavor_is_associated

	@ %def flavor_is_associated
	@ Check the [[radiated]] flag. A radiated particle has a definite PDG
	flavor status, but it is actually a pseudoparticle (a beam remnant)
	which may be subject to fragmentation.
	<<Flavors: flavor: TBP>>=
	procedure :: is_radiated => flavor_is_radiated
	<<Flavors: procedures>>=
	elemental function flavor_is_radiated (flv) result (flag)
	class(flavor_t), intent(in) :: flv
	logical :: flag
	flag = flv%radiated
	end function flavor_is_radiated

	@ %def flavor_is_radiated
	@ Check the [[hard_process]] flag. A particle is tagged with this flag if
	it participates in the hard interaction and is not a beam remnant.
	<<Flavors: flavor: TBP>>=
	procedure :: is_hard_process => flavor_is_hard_process
	<<Flavors: procedures>>=
	elemental function flavor_is_hard_process (flv) result (flag)
	class(flavor_t), intent(in) :: flv
	logical :: flag
	flag = flv%hard_process
	end function flavor_is_hard_process

	@ %def flavor_is_hard_process
	@
	\subsubsection{Accessing contents}
	With the exception of the PDG code, all particle property enquiries are
	delegated to the [[field_data]] pointer. If this is unassigned, some
	access function will crash.

	Return the flavor as an integer
	<<Flavors: flavor: TBP>>=
	procedure :: get_pdg => flavor_get_pdg
	<<Flavors: procedures>>=
	elemental function flavor_get_pdg (flv) result (f)
	integer :: f
	class(flavor_t), intent(in) :: flv
	f = flv%f
	end function flavor_get_pdg

	@ %def flavor_get_pdg
	@ Return the flavor of the antiparticle
	<<Flavors: flavor: TBP>>=
	procedure :: get_pdg_anti => flavor_get_pdg_anti
	<<Flavors: procedures>>=
	elemental function flavor_get_pdg_anti (flv) result (f)
	integer :: f
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	if (flv%field_data%has_antiparticle ()) then
	f = -flv%f
	else
	f = flv%f
	end if
	else
	f = 0
	end if
	end function flavor_get_pdg_anti

	@ %def flavor_get_pdg_anti
	@
	Absolute value:
	<<Flavors: flavor: TBP>>=
	procedure :: get_pdg_abs => flavor_get_pdg_abs
	<<Flavors: procedures>>=
	elemental function flavor_get_pdg_abs (flv) result (f)
	integer :: f
	class(flavor_t), intent(in) :: flv
	f = abs (flv%f)
	end function flavor_get_pdg_abs

	@ %def flavor_get_pdg_abs
	@
	Generic properties
	<<Flavors: flavor: TBP>>=
	procedure :: is_visible => flavor_is_visible
	procedure :: is_parton => flavor_is_parton
	procedure :: is_beam_remnant => flavor_is_beam_remnant
	procedure :: is_gauge => flavor_is_gauge
	procedure :: is_left_handed => flavor_is_left_handed
	procedure :: is_right_handed => flavor_is_right_handed
	procedure :: is_antiparticle => flavor_is_antiparticle
	procedure :: has_antiparticle => flavor_has_antiparticle
	procedure :: is_stable => flavor_is_stable
	procedure :: get_decays => flavor_get_decays
	procedure :: decays_isotropically => flavor_decays_isotropically
	procedure :: decays_diagonal => flavor_decays_diagonal
	procedure :: has_decay_helicity => flavor_has_decay_helicity
	procedure :: get_decay_helicity => flavor_get_decay_helicity
	procedure :: is_polarized => flavor_is_polarized
	<<Flavors: procedures>>=
	elemental function flavor_is_visible (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%is_visible ()
	else
	flag = .false.
	end if
	end function flavor_is_visible

	elemental function flavor_is_parton (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%is_parton ()
	else
	flag = .false.
	end if
	end function flavor_is_parton

	elemental function flavor_is_beam_remnant (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	select case (abs (flv%f))
	case (HADRON_REMNANT, &
	HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET)
	flag = .true.
	case default
	flag = .false.
	end select
	end function flavor_is_beam_remnant

	elemental function flavor_is_gauge (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%is_gauge ()
	else
	flag = .false.
	end if
	end function flavor_is_gauge

	elemental function flavor_is_left_handed (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	if (flv%f > 0) then
	flag = flv%field_data%is_left_handed ()
	else
	flag = flv%field_data%is_right_handed ()
	end if
	else
	flag = .false.
	end if
	end function flavor_is_left_handed

	elemental function flavor_is_right_handed (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	if (flv%f > 0) then
	flag = flv%field_data%is_right_handed ()
	else
	flag = flv%field_data%is_left_handed ()
	end if
	else
	flag = .false.
	end if
	end function flavor_is_right_handed

	elemental function flavor_is_antiparticle (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	flag = flv%f < 0
	end function flavor_is_antiparticle

	elemental function flavor_has_antiparticle (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%has_antiparticle ()
	else
	flag = .false.
	end if
	end function flavor_has_antiparticle

	elemental function flavor_is_stable (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%is_stable (anti = flv%f < 0)
	else
	flag = .true.
	end if
	end function flavor_is_stable

	subroutine flavor_get_decays (flv, decay)
	class(flavor_t), intent(in) :: flv
	type(string_t), dimension(:), intent(out), allocatable :: decay
	logical :: anti
	anti = flv%f < 0
	if (.not. flv%field_data%is_stable (anti)) then
	call flv%field_data%get_decays (decay, anti)
	end if
	end subroutine flavor_get_decays

	elemental function flavor_decays_isotropically (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%decays_isotropically (anti = flv%f < 0)
	else
	flag = .true.
	end if
	end function flavor_decays_isotropically

	elemental function flavor_decays_diagonal (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%decays_diagonal (anti = flv%f < 0)
	else
	flag = .true.
	end if
	end function flavor_decays_diagonal

	elemental function flavor_has_decay_helicity (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%has_decay_helicity (anti = flv%f < 0)
	else
	flag = .false.
	end if
	end function flavor_has_decay_helicity

	elemental function flavor_get_decay_helicity (flv) result (hel)
	integer :: hel
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	hel = flv%field_data%decay_helicity (anti = flv%f < 0)
	else
	hel = 0
	end if
	end function flavor_get_decay_helicity

	elemental function flavor_is_polarized (flv) result (flag)
	logical :: flag
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	flag = flv%field_data%is_polarized (anti = flv%f < 0)
	else
	flag = .false.
	end if
	end function flavor_is_polarized

	@ %def flavor_is_visible
	@ %def flavor_is_parton
	@ %def flavor_is_beam_remnant
	@ %def flavor_is_gauge
	@ %def flavor_is_left_handed
	@ %def flavor_is_right_handed
	@ %def flavor_is_antiparticle
	@ %def flavor_has_antiparticle
	@ %def flavor_is_stable
	@ %def flavor_get_decays
	@ %def flavor_decays_isotropically
	@ %def flavor_decays_diagonal
	@ %def flavor_has_decays_helicity
	@ %def flavor_get_decay_helicity
	@ %def flavor_is_polarized
	@ Names:
	<<Flavors: flavor: TBP>>=
	procedure :: get_name => flavor_get_name
	procedure :: get_tex_name => flavor_get_tex_name
	<<Flavors: procedures>>=
	elemental function flavor_get_name (flv) result (name)
	type(string_t) :: name
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	name = flv%field_data%get_name (flv%f < 0)
	else
	name = "?"
	end if
	end function flavor_get_name

	elemental function flavor_get_tex_name (flv) result (name)
	type(string_t) :: name
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	name = flv%field_data%get_tex_name (flv%f < 0)
	else
	name = "?"
	end if
	end function flavor_get_tex_name

	@ %def flavor_get_name flavor_get_tex_name
	<<Flavors: flavor: TBP>>=
	procedure :: get_spin_type => flavor_get_spin_type
	procedure :: get_multiplicity => flavor_get_multiplicity
	procedure :: get_isospin_type => flavor_get_isospin_type
	procedure :: get_charge_type => flavor_get_charge_type
	procedure :: get_color_type => flavor_get_color_type
	<<Flavors: procedures>>=
	elemental function flavor_get_spin_type (flv) result (type)
	integer :: type
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	type = flv%field_data%get_spin_type ()
	else
	type = 1
	end if
	end function flavor_get_spin_type

	elemental function flavor_get_multiplicity (flv) result (type)
	integer :: type
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	type = flv%field_data%get_multiplicity ()
	else
	type = 1
	end if
	end function flavor_get_multiplicity

	elemental function flavor_get_isospin_type (flv) result (type)
	integer :: type
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	type = flv%field_data%get_isospin_type ()
	else
	type = 1
	end if
	end function flavor_get_isospin_type

	elemental function flavor_get_charge_type (flv) result (type)
	integer :: type
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	type = flv%field_data%get_charge_type ()
	else
	type = 1
	end if
	end function flavor_get_charge_type

	elemental function flavor_get_color_type (flv) result (type)
	integer :: type
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	if (flavor_is_antiparticle (flv)) then
	type = - flv%field_data%get_color_type ()
	else
	type = flv%field_data%get_color_type ()
	end if
	select case (type)
	case (-1,-8); type = abs (type)
	end select
	else
	type = 1
	end if
	end function flavor_get_color_type

	@ %def flavor_get_spin_type
	@ %def flavor_get_multiplicity
	@ %def flavor_get_isospin_type
	@ %def flavor_get_charge_type
	@ %def flavor_get_color_type
	@ These functions return real values:
	<<Flavors: flavor: TBP>>=
	procedure :: get_charge => flavor_get_charge
	procedure :: get_mass => flavor_get_mass
	procedure :: get_width => flavor_get_width
	procedure :: get_isospin => flavor_get_isospin
	<<Flavors: procedures>>=
	elemental function flavor_get_charge (flv) result (charge)
	real(default) :: charge
	class(flavor_t), intent(in) :: flv
	integer :: charge_type
	if (associated (flv%field_data)) then
	charge_type = flv%get_charge_type ()
	if (charge_type == 0 .or. charge_type == 1) then
	charge = 0
	else
	if (flavor_is_antiparticle (flv)) then
	charge = - flv%field_data%get_charge ()
	else
	charge = flv%field_data%get_charge ()
	end if
	end if
	else
	charge = 0
	end if
	end function flavor_get_charge

	elemental function flavor_get_mass (flv) result (mass)
	real(default) :: mass
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	mass = flv%field_data%get_mass ()
	else
	mass = 0
	end if
	end function flavor_get_mass

	elemental function flavor_get_width (flv) result (width)
	real(default) :: width
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	width = flv%field_data%get_width ()
	else
	width = 0
	end if
	end function flavor_get_width

	elemental function flavor_get_isospin (flv) result (isospin)
	real(default) :: isospin
	class(flavor_t), intent(in) :: flv
	if (associated (flv%field_data)) then
	if (flavor_is_antiparticle (flv)) then
	isospin = - flv%field_data%get_isospin ()
	else
	isospin = flv%field_data%get_isospin ()
	end if
	else
	isospin = 0
	end if
	end function flavor_get_isospin

	@ %def flavor_get_charge flavor_get_mass flavor_get_width
	@ %def flavor_get_isospin
	@
	\subsubsection{Comparisons}
	If one of the flavors is undefined, the other defined, they match.
	<<Flavors: flavor: TBP>>=
	generic :: operator(.match.) => flavor_match
	generic :: operator(==) => flavor_eq
	generic :: operator(/=) => flavor_neq
	procedure, private :: flavor_match
	procedure, private :: flavor_eq
	procedure, private :: flavor_neq
	@ %def .match. == /=
	<<Flavors: procedures>>=
	elemental function flavor_match (flv1, flv2) result (eq)
	logical :: eq
	class(flavor_t), intent(in) :: flv1, flv2
	if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
	eq = flv1%f == flv2%f
	else
	eq = .true.
	end if
	end function flavor_match

	elemental function flavor_eq (flv1, flv2) result (eq)
	logical :: eq
	class(flavor_t), intent(in) :: flv1, flv2
	if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
	eq = flv1%f == flv2%f
	else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
	eq = .true.
	else
	eq = .false.
	end if
	end function flavor_eq

	@ %def flavor_match flavor_eq
	<<Flavors: procedures>>=
	elemental function flavor_neq (flv1, flv2) result (neq)
	logical :: neq
	class(flavor_t), intent(in) :: flv1, flv2
	if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
	neq = flv1%f /= flv2%f
	else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
	neq = .false.
	else
	neq = .true.
	end if
	end function flavor_neq

	@ %def flavor_neq
	@
	\subsubsection{Tools}
	Merge two flavor indices. This works only if both are equal or either
	one is undefined, because we have no off-diagonal flavor entries.
	Otherwise, generate an invalid flavor.

	We cannot use elemental procedures because of the pointer component.
	<<Flavors: public>>=
	public :: operator(.merge.)
	<<Flavors: interfaces>>=
	interface operator(.merge.)
	module procedure merge_flavors0
	module procedure merge_flavors1
	end interface

	@ %def .merge.
	<<Flavors: procedures>>=
	function merge_flavors0 (flv1, flv2) result (flv)
	type(flavor_t) :: flv
	type(flavor_t), intent(in) :: flv1, flv2
	if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then
	if (flv1 == flv2) then
	flv = flv1
	else
	flv%f = INVALID
	end if
	else if (flavor_is_defined (flv1)) then
	flv = flv1
	else if (flavor_is_defined (flv2)) then
	flv = flv2
	end if
	end function merge_flavors0

	function merge_flavors1 (flv1, flv2) result (flv)
	type(flavor_t), dimension(:), intent(in) :: flv1, flv2
	type(flavor_t), dimension(size(flv1)) :: flv
	integer :: i
	do i = 1, size (flv1)
	flv(i) = flv1(i) .merge. flv2(i)
	end do
	end function merge_flavors1

	@ %def merge_flavors
	@ Generate consecutive color indices for a given flavor. The indices
	are counted starting with the stored value of c, so new indices are
	created each time this (impure) function is called. The counter can
	be reset by the optional argument [[c_seed]] if desired. The optional
	flag [[reverse]] is used only for octets. If set, the color and
	anticolor entries of the octet particle are exchanged.
	<<Flavors: public>>=
	public :: color_from_flavor
	<<Flavors: interfaces>>=
	interface color_from_flavor
	module procedure color_from_flavor0
	module procedure color_from_flavor1
	end interface
	<<Flavors: procedures>>=
	function color_from_flavor0 (flv, c_seed, reverse) result (col)
	type(color_t) :: col
	type(flavor_t), intent(in) :: flv
	integer, intent(in), optional :: c_seed
	logical, intent(in), optional :: reverse
	integer, save :: c = 1
	logical :: rev
	if (present (c_seed)) c = c_seed
	rev = .false.; if (present (reverse)) rev = reverse
	select case (flavor_get_color_type (flv))
	case (1)
	call col%init ()
	case (3)
	call col%init ([c]); c = c + 1
	case (-3)
	call col%init ([-c]); c = c + 1
	case (8)
	if (rev) then
	call col%init ([c+1, -c]); c = c + 2
	else
	call col%init ([c, -(c+1)]); c = c + 2
	end if
	end select
	end function color_from_flavor0

	function color_from_flavor1 (flv, c_seed, reverse) result (col)
	type(flavor_t), dimension(:), intent(in) :: flv
	integer, intent(in), optional :: c_seed
	logical, intent(in), optional :: reverse
	type(color_t), dimension(size(flv)) :: col
	integer :: i
	col(1) = color_from_flavor0 (flv(1), c_seed, reverse)
	do i = 2, size (flv)
	col(i) = color_from_flavor0 (flv(i), reverse=reverse)
	end do
	end function color_from_flavor1

	@ %def color_from_flavor
	@ This procedure returns the flavor object for the antiparticle. The
	antiparticle code may either be the same code or its negative.
	<<Flavors: flavor: TBP>>=
	procedure :: anti => flavor_anti
	<<Flavors: procedures>>=
	function flavor_anti (flv) result (aflv)
	type(flavor_t) :: aflv
	class(flavor_t), intent(in) :: flv
	if (flavor_has_antiparticle (flv)) then
	aflv%f = - flv%f
	else
	aflv%f = flv%f
	end if
	aflv%field_data => flv%field_data
	end function flavor_anti

	@ %def flavor_anti
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Quantum numbers}
	This module collects helicity, color, and flavor in a single type and
	defines procedures
	<<[[quantum_numbers.f90]]>>=
	<<File header>>

	module quantum_numbers

	use io_units
	use model_data
	use helicities
	use colors
	use flavors

	<<Standard module head>>

	<<Quantum numbers: public>>

	<<Quantum numbers: types>>

	<<Quantum numbers: interfaces>>

	contains

	<<Quantum numbers: procedures>>

	end module quantum_numbers
	@ %def quantum_numbers
	@
	\subsection{The quantum number type}
	<<Quantum numbers: public>>=
	public :: quantum_numbers_t
	<<Quantum numbers: types>>=
	type :: quantum_numbers_t
	private
	type(flavor_t) :: f
	type(color_t) :: c
	type(helicity_t) :: h
	integer :: sub = 0
	contains
	<<Quantum numbers: quantum numbers: TBP>>
	end type quantum_numbers_t

	@ %def quantum_number_t
	@ Define quantum numbers: Initializer form. All arguments may be
	present or absent.

	Some elemental initializers are impure because they set the [[flv]]
	component. This implies transfer of a pointer behind the scenes.
	<<Quantum numbers: quantum numbers: TBP>>=
	generic :: init => &
	quantum_numbers_init_f, &
	quantum_numbers_init_c, &
	quantum_numbers_init_h, &
	quantum_numbers_init_fc, &
	quantum_numbers_init_fh, &
	quantum_numbers_init_ch, &
	quantum_numbers_init_fch, &
	quantum_numbers_init_fs, &
	quantum_numbers_init_fhs, &
	quantum_numbers_init_fcs, &
	quantum_numbers_init_fhcs
	procedure, private :: quantum_numbers_init_f
	procedure, private :: quantum_numbers_init_c
	procedure, private :: quantum_numbers_init_h
	procedure, private :: quantum_numbers_init_fc
	procedure, private :: quantum_numbers_init_fh
	procedure, private :: quantum_numbers_init_ch
	procedure, private :: quantum_numbers_init_fch
	procedure, private :: quantum_numbers_init_fs
	procedure, private :: quantum_numbers_init_fhs
	procedure, private :: quantum_numbers_init_fcs
	procedure, private :: quantum_numbers_init_fhcs
	<<Quantum numbers: procedures>>=
	impure elemental subroutine quantum_numbers_init_f (qn, flv)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	qn%f = flv
	call qn%c%undefine ()
	call qn%h%undefine ()
	qn%sub = 0
	end subroutine quantum_numbers_init_f

	impure elemental subroutine quantum_numbers_init_c (qn, col)
	class(quantum_numbers_t), intent(out) :: qn
	type(color_t), intent(in) :: col
	call qn%f%undefine ()
	qn%c = col
	call qn%h%undefine ()
	qn%sub = 0
	end subroutine quantum_numbers_init_c

	impure elemental subroutine quantum_numbers_init_h (qn, hel)
	class(quantum_numbers_t), intent(out) :: qn
	type(helicity_t), intent(in) :: hel
	call qn%f%undefine ()
	call qn%c%undefine ()
	qn%h = hel
	qn%sub = 0
	end subroutine quantum_numbers_init_h

	impure elemental subroutine quantum_numbers_init_fc (qn, flv, col)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(color_t), intent(in) :: col
	qn%f = flv
	qn%c = col
	call qn%h%undefine ()
	qn%sub = 0
	end subroutine quantum_numbers_init_fc

	impure elemental subroutine quantum_numbers_init_fh (qn, flv, hel)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(helicity_t), intent(in) :: hel
	qn%f = flv
	call qn%c%undefine ()
	qn%h = hel
	qn%sub = 0
	end subroutine quantum_numbers_init_fh

	impure elemental subroutine quantum_numbers_init_ch (qn, col, hel)
	class(quantum_numbers_t), intent(out) :: qn
	type(color_t), intent(in) :: col
	type(helicity_t), intent(in) :: hel
	call qn%f%undefine ()
	qn%c = col
	qn%h = hel
	qn%sub = 0
	end subroutine quantum_numbers_init_ch

	impure elemental subroutine quantum_numbers_init_fch (qn, flv, col, hel)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(color_t), intent(in) :: col
	type(helicity_t), intent(in) :: hel
	qn%f = flv
	qn%c = col
	qn%h = hel
	qn%sub = 0
	end subroutine quantum_numbers_init_fch

	impure elemental subroutine quantum_numbers_init_fs (qn, flv, sub)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	integer, intent(in) :: sub
	qn%f = flv; qn%sub = sub
	end subroutine quantum_numbers_init_fs

	impure elemental subroutine quantum_numbers_init_fhs (qn, flv, hel, sub)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(helicity_t), intent(in) :: hel
	integer, intent(in) :: sub
	qn%f = flv; qn%h = hel; qn%sub = sub
	end subroutine quantum_numbers_init_fhs

	impure elemental subroutine quantum_numbers_init_fcs (qn, flv, col, sub)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(color_t), intent(in) :: col
	integer, intent(in) :: sub
	qn%f = flv; qn%c = col; qn%sub = sub
	end subroutine quantum_numbers_init_fcs

	impure elemental subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub)
	class(quantum_numbers_t), intent(out) :: qn
	type(flavor_t), intent(in) :: flv
	type(helicity_t), intent(in) :: hel
	type(color_t), intent(in) :: col
	integer, intent(in) :: sub
	qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub
	end subroutine quantum_numbers_init_fhcs

	@ %def quantum_numbers_init
	@
	\subsection{I/O}
	Write the quantum numbers in condensed form, enclosed by square
	brackets. Color is written only if nontrivial. For convenience,
	introduce also an array version.

	If the [[col_verbose]] option is set, show the quantum number color also
	if it is zero, but defined. Otherwise, suppress zero color.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_write
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: write => quantum_numbers_write_single
	<<Quantum numbers: interfaces>>=
	interface quantum_numbers_write
	module procedure quantum_numbers_write_single
	module procedure quantum_numbers_write_array
	end interface
	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_write_single (qn, unit, col_verbose)
	class(quantum_numbers_t), intent(in) :: qn
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: col_verbose
	integer :: u
	logical :: col_verb
	u = given_output_unit (unit); if (u < 0) return
	col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose
	write (u, "(A)", advance = "no") "["
	if (qn%f%is_defined ()) then
	call qn%f%write (u)
	if (qn%c%is_nonzero () .or. qn%h%is_defined ()) &
	write (u, "(1x)", advance = "no")
	end if
	if (col_verb) then
	if (qn%c%is_defined () .or. qn%c%is_ghost ()) then
	call color_write (qn%c, u)
	if (qn%h%is_defined ()) write (u, "(1x)", advance = "no")
	end if
	else
	if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then
	call color_write (qn%c, u)
	if (qn%h%is_defined ()) write (u, "(1x)", advance = "no")
	end if
	end if
	if (qn%h%is_defined ()) then
	call qn%h%write (u)
	end if
	if (qn%sub > 0) &
	write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub
	write (u, "(A)", advance="no") "]"
	end subroutine quantum_numbers_write_single

	subroutine quantum_numbers_write_array (qn, unit, col_verbose)
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: col_verbose
	integer :: i
	integer :: u
	logical :: col_verb
	u = given_output_unit (unit); if (u < 0) return
	col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose
	write (u, "(A)", advance="no") "["
	do i = 1, size (qn)
	if (i > 1) write (u, "(A)", advance="no") " / "
	if (qn(i)%f%is_defined ()) then
	call qn(i)%f%write (u)
	if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) &
	write (u, "(1x)", advance="no")
	end if
	if (col_verb) then
	if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then
	call color_write (qn(i)%c, u)
	if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no")
	end if
	else
	if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then
	call color_write (qn(i)%c, u)
	if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no")
	end if
	end if
	if (qn(i)%h%is_defined ()) then
	call qn(i)%h%write (u)
	end if
	if (qn(i)%sub > 0) &
	write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub
	end do
	write (u, "(A)", advance = "no") "]"
	end subroutine quantum_numbers_write_array

	@ %def quantum_numbers_write
	@ Binary I/O.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: write_raw => quantum_numbers_write_raw
	procedure :: read_raw => quantum_numbers_read_raw
	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_write_raw (qn, u)
	class(quantum_numbers_t), intent(in) :: qn
	integer, intent(in) :: u
	call qn%f%write_raw (u)
	call qn%c%write_raw (u)
	call qn%h%write_raw (u)
	end subroutine quantum_numbers_write_raw

	subroutine quantum_numbers_read_raw (qn, u, iostat)
	class(quantum_numbers_t), intent(out) :: qn
	integer, intent(in) :: u
	integer, intent(out), optional :: iostat
	call qn%f%read_raw (u, iostat=iostat)
	call qn%c%read_raw (u, iostat=iostat)
	call qn%h%read_raw (u, iostat=iostat)
	end subroutine quantum_numbers_read_raw

	@ %def quantum_numbers_write_raw quantum_numbers_read_raw
	@
	\subsection{Accessing contents}
	Color and helicity can be done by elemental functions. Flavor needs
	impure elemental. We export also the functions directly, this allows
	us to avoid temporaries in some places.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_get_flavor
	public :: quantum_numbers_get_color
	public :: quantum_numbers_get_helicity
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: get_flavor => quantum_numbers_get_flavor
	procedure :: get_color => quantum_numbers_get_color
	procedure :: get_helicity => quantum_numbers_get_helicity
	procedure :: get_sub => quantum_numbers_get_sub
	<<Quantum numbers: procedures>>=
	impure elemental function quantum_numbers_get_flavor (qn) result (flv)
	type(flavor_t) :: flv
	class(quantum_numbers_t), intent(in) :: qn
	flv = qn%f
	end function quantum_numbers_get_flavor

	elemental function quantum_numbers_get_color (qn) result (col)
	type(color_t) :: col
	class(quantum_numbers_t), intent(in) :: qn
	col = qn%c
	end function quantum_numbers_get_color

	elemental function quantum_numbers_get_helicity (qn) result (hel)
	type(helicity_t) :: hel
	class(quantum_numbers_t), intent(in) :: qn
	hel = qn%h
	end function quantum_numbers_get_helicity

	elemental function quantum_numbers_get_sub (qn) result (sub)
	integer :: sub
	class(quantum_numbers_t), intent(in) :: qn
	sub = qn%sub
	end function quantum_numbers_get_sub

	@ %def quantum_numbers_get_flavor
	@ %def quantum_numbers_get_color
	@ %def quantum_numbers_get_helicity
	@ %def quantum_numbers_get_sub
	@ This just resets the ghost property of the color part:
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: set_color_ghost => quantum_numbers_set_color_ghost
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_set_color_ghost (qn, ghost)
	class(quantum_numbers_t), intent(inout) :: qn
	logical, intent(in) :: ghost
	call qn%c%set_ghost (ghost)
	end subroutine quantum_numbers_set_color_ghost

	@ %def quantum_numbers_set_color_ghost
	@ Assign a model to the flavor part of quantum numbers.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: set_model => quantum_numbers_set_model
	<<Quantum numbers: procedures>>=
	impure elemental subroutine quantum_numbers_set_model (qn, model)
	class(quantum_numbers_t), intent(inout) :: qn
	class(model_data_t), intent(in), target :: model
	call qn%f%set_model (model)
	end subroutine quantum_numbers_set_model

	@ %def quantum_numbers_set_model
	@ Set the [[radiated]] flag for the flavor component.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: tag_radiated => quantum_numbers_tag_radiated
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_tag_radiated (qn)
	class(quantum_numbers_t), intent(inout) :: qn
	call qn%f%tag_radiated ()
	end subroutine quantum_numbers_tag_radiated

	@ %def quantum_numbers_tag_radiated
	@ Set the [[hard_process]] flag for the flavor component.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: tag_hard_process => quantum_numbers_tag_hard_process
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_tag_hard_process (qn)
	class(quantum_numbers_t), intent(inout) :: qn
	call qn%f%tag_hard_process ()
	end subroutine quantum_numbers_tag_hard_process

	@ %def quantum_numbers_tag_hard_process
	@
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: set_subtraction_index => quantum_numbers_set_subtraction_index
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_set_subtraction_index (qn, i)
	class(quantum_numbers_t), intent(inout) :: qn
	integer, intent(in) :: i
	qn%sub = i
	end subroutine quantum_numbers_set_subtraction_index

	@ %def quantum_numbers_set_subtraction_index
	@
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: get_subtraction_index => quantum_numbers_get_subtraction_index
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_get_subtraction_index (qn) result (sub)
	integer :: sub
	class(quantum_numbers_t), intent(in) :: qn
	sub = qn%sub
	end function quantum_numbers_get_subtraction_index

	@ %def quantum_numbers_get_subtraction_index
	@ This is a convenience function: return the color type for the flavor
	(array).

	Note: keep the public version temporarily, this will be used in a
	complicated expression which triggers a compiler bug (nagfor 5.3) in
	the TBP version.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_get_color_type
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: get_color_type => quantum_numbers_get_color_type
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_get_color_type (qn) result (color_type)
	integer :: color_type
	class(quantum_numbers_t), intent(in) :: qn
	color_type = qn%f%get_color_type ()
	end function quantum_numbers_get_color_type

	@ %def quantum_numbers_get_color_type
	@
	\subsection{Predicates}
	Check if the flavor index is valid (including UNDEFINED).
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: are_valid => quantum_numbers_are_valid
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_valid (qn) result (valid)
	logical :: valid
	class(quantum_numbers_t), intent(in) :: qn
	valid = qn%f%is_valid ()
	end function quantum_numbers_are_valid

	@ %def quantum_numbers_are_valid
	@ Check if the flavor part has its particle-data pointer associated
	(debugging aid).
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: are_associated => quantum_numbers_are_associated
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_associated (qn) result (flag)
	logical :: flag
	class(quantum_numbers_t), intent(in) :: qn
	flag = qn%f%is_associated ()
	end function quantum_numbers_are_associated

	@ %def quantum_numbers_are_associated
	@ Check if the helicity and color quantum numbers are
	diagonal. (Unpolarized/colorless also counts as diagonal.) Flavor is
	diagonal by definition.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: are_diagonal => quantum_numbers_are_diagonal
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_diagonal (qn) result (diagonal)
	logical :: diagonal
	class(quantum_numbers_t), intent(in) :: qn
	diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal ()
	end function quantum_numbers_are_diagonal

	@ %def quantum_numbers_are_diagonal
	@ Check if the color part has the ghost property.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: is_color_ghost => quantum_numbers_is_color_ghost
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_is_color_ghost (qn) result (ghost)
	logical :: ghost
	class(quantum_numbers_t), intent(in) :: qn
	ghost = qn%c%is_ghost ()
	end function quantum_numbers_is_color_ghost

	@ %def quantum_numbers_is_color_ghost
	@ Check if the flavor participates in the hard interaction.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: are_hard_process => quantum_numbers_are_hard_process
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_hard_process (qn) result (hard_process)
	logical :: hard_process
	class(quantum_numbers_t), intent(in) :: qn
	hard_process = qn%f%is_hard_process ()
	end function quantum_numbers_are_hard_process

	@ %def quantum_numbers_are_hard_process
	@
	\subsection{Comparisons}
	Matching and equality is derived from the individual quantum numbers.
	The variant [[fhmatch]] matches only flavor and helicity. The variant
	[[dhmatch]] matches only diagonal helicity, if the matching helicity is
	undefined.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_eq_wo_sub
	<<Quantum numbers: quantum numbers: TBP>>=
	generic :: operator(.match.) => quantum_numbers_match
	generic :: operator(.fmatch.) => quantum_numbers_match_f
	generic :: operator(.hmatch.) => quantum_numbers_match_h
	generic :: operator(.fhmatch.) => quantum_numbers_match_fh
	generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag
	generic :: operator(==) => quantum_numbers_eq
	generic :: operator(/=) => quantum_numbers_neq
	procedure, private :: quantum_numbers_match
	procedure, private :: quantum_numbers_match_f
	procedure, private :: quantum_numbers_match_h
	procedure, private :: quantum_numbers_match_fh
	procedure, private :: quantum_numbers_match_hel_diag
	procedure, private :: quantum_numbers_eq
	procedure, private :: quantum_numbers_neq
	@ %def .match. == /=
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_match (qn1, qn2) result (match)
	logical :: match
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	match = (qn1%f .match. qn2%f) .and. &
	(qn1%c .match. qn2%c) .and. &
	(qn1%h .match. qn2%h)
	end function quantum_numbers_match

	elemental function quantum_numbers_match_f (qn1, qn2) result (match)
	logical :: match
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	match = (qn1%f .match. qn2%f)
	end function quantum_numbers_match_f

	elemental function quantum_numbers_match_h (qn1, qn2) result (match)
	logical :: match
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	match = (qn1%h .match. qn2%h)
	end function quantum_numbers_match_h

	elemental function quantum_numbers_match_fh (qn1, qn2) result (match)
	logical :: match
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	match = (qn1%f .match. qn2%f) .and. &
	(qn1%h .match. qn2%h)
	end function quantum_numbers_match_fh

	elemental function quantum_numbers_match_hel_diag (qn1, qn2) result (match)
	logical :: match
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	match = (qn1%f .match. qn2%f) .and. &
	(qn1%c .match. qn2%c) .and. &
	(qn1%h .dmatch. qn2%h)
	end function quantum_numbers_match_hel_diag

	elemental function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq)
	logical :: eq
	type(quantum_numbers_t), intent(in) :: qn1, qn2
	eq = (qn1%f == qn2%f) .and. &
	(qn1%c == qn2%c) .and. &
	(qn1%h == qn2%h)
	end function quantum_numbers_eq_wo_sub

	elemental function quantum_numbers_eq (qn1, qn2) result (eq)
	logical :: eq
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	eq = (qn1%f == qn2%f) .and. &
	(qn1%c == qn2%c) .and. &
	(qn1%h == qn2%h) .and. &
	(qn1%sub == qn2%sub)
	end function quantum_numbers_eq

	elemental function quantum_numbers_neq (qn1, qn2) result (neq)
	logical :: neq
	class(quantum_numbers_t), intent(in) :: qn1, qn2
	neq = (qn1%f /= qn2%f) .or. &
	(qn1%c /= qn2%c) .or. &
	(qn1%h /= qn2%h) .or. &
	(qn1%sub /= qn2%sub)
	end function quantum_numbers_neq

	@ %def quantum_numbers_match
	@ %def quantum_numbers_eq
	@ %def quantum_numbers_neq
	<<Quantum numbers: public>>=
	public :: assignment(=)
	<<Quantum numbers: interfaces>>=
	interface assignment(=)
	module procedure quantum_numbers_assign
	end interface

	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_assign (qn_out, qn_in)
	type(quantum_numbers_t), intent(out) :: qn_out
	type(quantum_numbers_t), intent(in) :: qn_in
	qn_out%f = qn_in%f
	qn_out%c = qn_in%c
	qn_out%h = qn_in%h
	qn_out%sub = qn_in%sub
	end subroutine quantum_numbers_assign

	@ %def quantum_numbers_assign
	@ Two sets of quantum numbers are compatible if the individual quantum numbers
	are compatible, depending on the mask. Flavor has to match, regardless of the
	flavor mask.

	If the color flag is set, color is compatible if the ghost property is
	identical. If the color flag is unset, color has to be identical. I.e., if
	the flag is set, the color amplitudes can interfere. If it is not set, they
	must be identical, and there must be no ghost. The latter property is used
	for expanding physical color flows.

	Helicity is compatible if the mask is unset, otherwise it has to match. This
	determines if two amplitudes can be multiplied (no mask) or traced (mask).
	<<Quantum numbers: public>>=
	public :: quantum_numbers_are_compatible
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_compatible (qn1, qn2, mask) &
	result (flag)
	logical :: flag
	type(quantum_numbers_t), intent(in) :: qn1, qn2
	type(quantum_numbers_mask_t), intent(in) :: mask
	if (mask%h .or. mask%hd) then
	flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h)
	else
	flag = (qn1%f .match. qn2%f)
	end if
	if (mask%c) then
	flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ())
	else
	flag = flag .and. &
	.not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. &
	(qn1%c == qn2%c)
	end if
	end function quantum_numbers_are_compatible

	@ %def quantum_numbers_are_compatible
	@ This is the analog for a single quantum-number set. We just check for color
	ghosts; they are excluded if the color mask is unset (color-flow expansion).
	<<Quantum numbers: public>>=
	public :: quantum_numbers_are_physical
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_physical (qn, mask) result (flag)
	logical :: flag
	type(quantum_numbers_t), intent(in) :: qn
	type(quantum_numbers_mask_t), intent(in) :: mask
	if (mask%c) then
	flag = .true.
	else
	flag = .not. qn%c%is_ghost ()
	end if
	end function quantum_numbers_are_physical

	@ %def quantum_numbers_are_physical
	@
	\subsection{Operations}
	Inherited from the color component: reassign color indices in
	canonical order.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_canonicalize_color
	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_canonicalize_color (qn)
	type(quantum_numbers_t), dimension(:), intent(inout) :: qn
	call color_canonicalize (qn%c)
	end subroutine quantum_numbers_canonicalize_color

	@ %def quantum_numbers_canonicalize_color
	@ Inherited from the color component: make a color map for two matching
	quantum-number arrays.
	<<Quantum numbers: public>>=
	public :: make_color_map
	<<Quantum numbers: interfaces>>=
	interface make_color_map
	module procedure quantum_numbers_make_color_map
	end interface make_color_map

	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_make_color_map (map, qn1, qn2)
	integer, dimension(:,:), intent(out), allocatable :: map
	type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
	call make_color_map (map, qn1%c, qn2%c)
	end subroutine quantum_numbers_make_color_map

	@ %def make_color_map
	@ Inherited from the color component: translate the color part using a
	color-map array
	<<Quantum numbers: public>>=
	public :: quantum_numbers_translate_color
	<<Quantum numbers: interfaces>>=
	interface quantum_numbers_translate_color
	module procedure quantum_numbers_translate_color0
	module procedure quantum_numbers_translate_color1
	end interface

	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_translate_color0 (qn, map, offset)
	type(quantum_numbers_t), intent(inout) :: qn
	integer, dimension(:,:), intent(in) :: map
	integer, intent(in), optional :: offset
	call color_translate (qn%c, map, offset)
	end subroutine quantum_numbers_translate_color0

	subroutine quantum_numbers_translate_color1 (qn, map, offset)
	type(quantum_numbers_t), dimension(:), intent(inout) :: qn
	integer, dimension(:,:), intent(in) :: map
	integer, intent(in), optional :: offset
	call color_translate (qn%c, map, offset)
	end subroutine quantum_numbers_translate_color1

	@ %def quantum_numbers_translate_color
	@ Inherited from the color component: return the color index with
	highest absolute value.

	Since the algorithm is not elemental, we keep the separate
	procedures for different array rank.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_get_max_color_value
	<<Quantum numbers: interfaces>>=
	interface quantum_numbers_get_max_color_value
	module procedure quantum_numbers_get_max_color_value0
	module procedure quantum_numbers_get_max_color_value1
	module procedure quantum_numbers_get_max_color_value2
	end interface

	<<Quantum numbers: procedures>>=
	pure function quantum_numbers_get_max_color_value0 (qn) result (cmax)
	integer :: cmax
	type(quantum_numbers_t), intent(in) :: qn
	cmax = color_get_max_value (qn%c)
	end function quantum_numbers_get_max_color_value0

	pure function quantum_numbers_get_max_color_value1 (qn) result (cmax)
	integer :: cmax
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	cmax = color_get_max_value (qn%c)
	end function quantum_numbers_get_max_color_value1

	pure function quantum_numbers_get_max_color_value2 (qn) result (cmax)
	integer :: cmax
	type(quantum_numbers_t), dimension(:,:), intent(in) :: qn
	cmax = color_get_max_value (qn%c)
	end function quantum_numbers_get_max_color_value2

	@ Inherited from the color component: add an offset to the indices of
	the color part
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: add_color_offset => quantum_numbers_add_color_offset
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_add_color_offset (qn, offset)
	class(quantum_numbers_t), intent(inout) :: qn
	integer, intent(in) :: offset
	call qn%c%add_offset (offset)
	end subroutine quantum_numbers_add_color_offset

	@ %def quantum_numbers_add_color_offset
	@ Given a quantum number array, return all possible color
	contractions, leaving the other quantum numbers intact.
	<<Quantum numbers: public>>=
	public :: quantum_number_array_make_color_contractions
	<<Quantum numbers: procedures>>=
	subroutine quantum_number_array_make_color_contractions (qn_in, qn_out)
	type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
	type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out
	type(color_t), dimension(:,:), allocatable :: col
	integer :: i
	call color_array_make_contractions (qn_in%c, col)
	allocate (qn_out (size (col, 1), size (col, 2)))
	do i = 1, size (qn_out, 2)
	qn_out(:,i)%f = qn_in%f
	qn_out(:,i)%c = col(:,i)
	qn_out(:,i)%h = qn_in%h
	end do
	end subroutine quantum_number_array_make_color_contractions

	@ %def quantum_number_array_make_color_contractions
	@ Inherited from the color component: invert the color, switching
	particle/antiparticle.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: invert_color => quantum_numbers_invert_color
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_invert_color (qn)
	class(quantum_numbers_t), intent(inout) :: qn
	call qn%c%invert ()
	end subroutine quantum_numbers_invert_color

	@ %def quantum_numbers_invert_color
	@ Flip helicity.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: flip_helicity => quantum_numbers_flip_helicity
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_flip_helicity (qn)
	class(quantum_numbers_t), intent(inout) :: qn
	call qn%h%flip ()
	end subroutine quantum_numbers_flip_helicity

	@ %def quantum_numbers_flip_helicity
	@
	Merge two quantum number sets: for each entry, if both are defined,
	combine them to an off-diagonal entry (meaningful only if the input
	was diagonal). If either entry is undefined, take the defined
	one.

	For flavor, off-diagonal entries are invalid, so both
	flavors must be equal, otherwise an invalid flavor is inserted.
	<<Quantum numbers: public>>=
	public :: operator(.merge.)
	<<Quantum numbers: interfaces>>=
	interface operator(.merge.)
	module procedure merge_quantum_numbers0
	module procedure merge_quantum_numbers1
	end interface

	<<Quantum numbers: procedures>>=
	function merge_quantum_numbers0 (qn1, qn2) result (qn3)
	type(quantum_numbers_t) :: qn3
	type(quantum_numbers_t), intent(in) :: qn1, qn2
	qn3%f = qn1%f .merge. qn2%f
	qn3%c = qn1%c .merge. qn2%c
	qn3%h = qn1%h .merge. qn2%h
	qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
	end function merge_quantum_numbers0

	function merge_quantum_numbers1 (qn1, qn2) result (qn3)
	type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
	type(quantum_numbers_t), dimension(size(qn1)) :: qn3
	qn3%f = qn1%f .merge. qn2%f
	qn3%c = qn1%c .merge. qn2%c
	qn3%h = qn1%h .merge. qn2%h
	qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
	end function merge_quantum_numbers1

	@ %def merge_quantum_numbers
	@
	<<Quantum numbers: procedures>>=
	elemental function merge_subtraction_index (sub1, sub2) result (sub3)
	integer :: sub3
	integer, intent(in) :: sub1, sub2
	if (sub1 > 0 .and. sub2 > 0) then
	if (sub1 == sub2) then
	sub3 = sub1
	else
	sub3 = 0
	end if
	else if (sub1 > 0) then
	sub3 = sub1
	else if (sub2 > 0) then
	sub3 = sub2
	else
	sub3 = 0
	end if
	end function merge_subtraction_index

	@ %def merge_subtraction_index
	@
	\subsection{The quantum number mask}
	The quantum numbers mask is true for quantum numbers that should be
	ignored or summed over. The three mandatory entries correspond to
	flavor, color, and helicity, respectively.

	There is an additional entry [[cg]]: If false, the color-ghosts
	property should be kept even if color is ignored. This is relevant
	only if [[c]] is set, otherwise it is always false.

	The flag [[hd]] tells that only diagonal entries in helicity should be
	kept. If [[h]] is set, [[hd]] is irrelevant and will be kept
	[[.false.]]
	<<Quantum numbers: public>>=
	public :: quantum_numbers_mask_t
	<<Quantum numbers: types>>=
	type :: quantum_numbers_mask_t
	private
	logical :: f = .false.
	logical :: c = .false.
	logical :: cg = .false.
	logical :: h = .false.
	logical :: hd = .false.
	integer :: sub = 0
	contains
	<<Quantum numbers: quantum numbers mask: TBP>>
	end type quantum_numbers_mask_t

	@ %def quantum_number_t
	@ Define a quantum number mask: Constructor form
	<<Quantum numbers: public>>=
	public :: quantum_numbers_mask
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_mask &
	(mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask)
	type(quantum_numbers_mask_t) :: mask
	logical, intent(in) :: mask_f, mask_c, mask_h
	logical, intent(in), optional :: mask_cg
	logical, intent(in), optional :: mask_hd
	call quantum_numbers_mask_init &
	(mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
	end function quantum_numbers_mask

	@ %def new_quantum_numbers_mask
	@ Define quantum numbers: Initializer form
	<<Quantum numbers: quantum numbers mask: TBP>>=
	procedure :: init => quantum_numbers_mask_init
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_mask_init &
	(mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	logical, intent(in) :: mask_f, mask_c, mask_h
	logical, intent(in), optional :: mask_cg, mask_hd
	mask%f = mask_f
	mask%c = mask_c
	mask%h = mask_h
	mask%cg = .false.
	if (present (mask_cg)) then
	if (mask%c) mask%cg = mask_cg
	else
	mask%cg = mask_c
	end if
	mask%hd = .false.
	if (present (mask_hd)) then
	if (.not. mask%h) mask%hd = mask_hd
	end if
	end subroutine quantum_numbers_mask_init

	@ %def quantum_numbers_mask_init
	@ Write a quantum numbers mask. We need the stand-alone subroutine for the
	array case.
	<<Quantum numbers: public>>=
	public :: quantum_numbers_mask_write
	<<Quantum numbers: interfaces>>=
	interface quantum_numbers_mask_write
	module procedure quantum_numbers_mask_write_single
	module procedure quantum_numbers_mask_write_array
	end interface
	<<Quantum numbers: quantum numbers mask: TBP>>=
	procedure :: write => quantum_numbers_mask_write_single
	<<Quantum numbers: procedures>>=
	subroutine quantum_numbers_mask_write_single (mask, unit)
	class(quantum_numbers_mask_t), intent(in) :: mask
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)", advance="no") "["
	write (u, "(L1)", advance="no") mask%f
	write (u, "(L1)", advance="no") mask%c
	if (.not.mask%cg) write (u, "('g')", advance="no")
	write (u, "(L1)", advance="no") mask%h
	if (mask%hd) write (u, "('d')", advance="no")
	write (u, "(A)", advance="no") "]"
	end subroutine quantum_numbers_mask_write_single

	subroutine quantum_numbers_mask_write_array (mask, unit)
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)", advance="no") "["
	do i = 1, size (mask)
	if (i > 1) write (u, "(A)", advance="no") "/"
	write (u, "(L1)", advance="no") mask(i)%f
	write (u, "(L1)", advance="no") mask(i)%c
	if (.not.mask(i)%cg) write (u, "('g')", advance="no")
	write (u, "(L1)", advance="no") mask(i)%h
	if (mask(i)%hd) write (u, "('d')", advance="no")
	end do
	write (u, "(A)", advance="no") "]"
	end subroutine quantum_numbers_mask_write_array

	@ %def quantum_numbers_mask_write
	@
	\subsection{Setting mask components}
	<<Quantum numbers: quantum numbers mask: TBP>>=
	procedure :: set_flavor => quantum_numbers_mask_set_flavor
	procedure :: set_color => quantum_numbers_mask_set_color
	procedure :: set_helicity => quantum_numbers_mask_set_helicity
	procedure :: set_sub => quantum_numbers_mask_set_sub
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_mask_set_flavor (mask, mask_f)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	logical, intent(in) :: mask_f
	mask%f = mask_f
	end subroutine quantum_numbers_mask_set_flavor

	elemental subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	logical, intent(in) :: mask_c
	logical, intent(in), optional :: mask_cg
	mask%c = mask_c
	if (present (mask_cg)) then
	if (mask%c) mask%cg = mask_cg
	else
	mask%cg = mask_c
	end if
	end subroutine quantum_numbers_mask_set_color

	elemental subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	logical, intent(in) :: mask_h
	logical, intent(in), optional :: mask_hd
	mask%h = mask_h
	if (present (mask_hd)) then
	if (.not. mask%h) mask%hd = mask_hd
	end if
	end subroutine quantum_numbers_mask_set_helicity

	elemental subroutine quantum_numbers_mask_set_sub (mask, sub)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	integer, intent(in) :: sub
	mask%sub = sub
	end subroutine quantum_numbers_mask_set_sub

	@ %def quantum_numbers_mask_set_flavor
	@ %def quantum_numbers_mask_set_color
	@ %def quantum_numbers_mask_set_helicity
	@ %def quantum_numbers_mask_set_sub
	@ The following routines assign part of a mask, depending on the flags given.
	<<Quantum numbers: quantum numbers mask: TBP>>=
	procedure :: assign => quantum_numbers_mask_assign
	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_mask_assign &
	(mask, mask_in, flavor, color, helicity)
	class(quantum_numbers_mask_t), intent(inout) :: mask
	class(quantum_numbers_mask_t), intent(in) :: mask_in
	logical, intent(in), optional :: flavor, color, helicity
	if (present (flavor)) then
	if (flavor) then
	mask%f = mask_in%f
	end if
	end if
	if (present (color)) then
	if (color) then
	mask%c = mask_in%c
	mask%cg = mask_in%cg
	end if
	end if
	if (present (helicity)) then
	if (helicity) then
	mask%h = mask_in%h
	mask%hd = mask_in%hd
	end if
	end if
	end subroutine quantum_numbers_mask_assign

	@ %def quantum_numbers_mask_assign
	@
	\subsection{Mask predicates}
	Return true if either one of the entries is set:
	<<Quantum numbers: public>>=
	public :: any
	<<Quantum numbers: interfaces>>=
	interface any
	module procedure quantum_numbers_mask_any
	end interface
	<<Quantum numbers: procedures>>=
	function quantum_numbers_mask_any (mask) result (match)
	logical :: match
	type(quantum_numbers_mask_t), intent(in) :: mask
	match = mask%f .or. mask%c .or. mask%h .or. mask%hd
	end function quantum_numbers_mask_any

	@ %def any
	@
	\subsection{Operators}
	The OR operation is applied to all components.
	<<Quantum numbers: quantum numbers mask: TBP>>=
	generic :: operator(.or.) => quantum_numbers_mask_or
	procedure, private :: quantum_numbers_mask_or
	@ %def .or.
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_mask_or (mask1, mask2) result (mask)
	type(quantum_numbers_mask_t) :: mask
	class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
	mask%f = mask1%f .or. mask2%f
	mask%c = mask1%c .or. mask2%c
	if (mask%c) mask%cg = mask1%cg .or. mask2%cg
	mask%h = mask1%h .or. mask2%h
	if (.not. mask%h) mask%hd = mask1%hd .or. mask2%hd
	end function quantum_numbers_mask_or

	@ %def quantum_numbers_mask_or
	@
	\subsection{Mask comparisons}
	Return true if the two masks are equivalent / differ:
	<<Quantum numbers: quantum numbers mask: TBP>>=
	generic :: operator(.eqv.) => quantum_numbers_mask_eqv
	generic :: operator(.neqv.) => quantum_numbers_mask_neqv
	procedure, private :: quantum_numbers_mask_eqv
	procedure, private :: quantum_numbers_mask_neqv
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_mask_eqv (mask1, mask2) result (eqv)
	logical :: eqv
	class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
	eqv = (mask1%f .eqv. mask2%f) .and. &
	(mask1%c .eqv. mask2%c) .and. &
	(mask1%cg .eqv. mask2%cg) .and. &
	(mask1%h .eqv. mask2%h) .and. &
	(mask1%hd .eqv. mask2%hd)
	end function quantum_numbers_mask_eqv

	elemental function quantum_numbers_mask_neqv (mask1, mask2) result (neqv)
	logical :: neqv
	class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
	neqv = (mask1%f .neqv. mask2%f) .or. &
	(mask1%c .neqv. mask2%c) .or. &
	(mask1%cg .neqv. mask2%cg) .or. &
	(mask1%h .neqv. mask2%h) .or. &
	(mask1%hd .neqv. mask2%hd)
	end function quantum_numbers_mask_neqv

	@ %def .eqv. .neqv.
	@
	\subsection{Apply a mask}
	Applying a mask to the quantum number object means undefining those
	entries where the mask is set. The others remain unaffected.

	The [[hd]] mask has the special property that it ``diagonalizes''
	helicity, i.e., the second helicity entry is dropped and the result is
	a diagonal helicity quantum number.
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: undefine => quantum_numbers_undefine
	procedure :: undefined => quantum_numbers_undefined0
	<<Quantum numbers: public>>=
	public :: quantum_numbers_undefined
	<<Quantum numbers: interfaces>>=
	interface quantum_numbers_undefined
	module procedure quantum_numbers_undefined0
	module procedure quantum_numbers_undefined1
	module procedure quantum_numbers_undefined11
	end interface

	<<Quantum numbers: procedures>>=
	elemental subroutine quantum_numbers_undefine (qn, mask)
	class(quantum_numbers_t), intent(inout) :: qn
	type(quantum_numbers_mask_t), intent(in) :: mask
	if (mask%f) call qn%f%undefine ()
	if (mask%c) call qn%c%undefine (undefine_ghost = mask%cg)
	if (mask%h) then
	call qn%h%undefine ()
	else if (mask%hd) then
	if (.not. qn%h%is_diagonal ()) then
	call qn%h%diagonalize ()
	end if
	end if
	if (mask%sub > 0) qn%sub = 0
	end subroutine quantum_numbers_undefine

	function quantum_numbers_undefined0 (qn, mask) result (qn_new)
	class(quantum_numbers_t), intent(in) :: qn
	type(quantum_numbers_mask_t), intent(in) :: mask
	type(quantum_numbers_t) :: qn_new
	select type (qn)
	type is (quantum_numbers_t); qn_new = qn
	end select
	call quantum_numbers_undefine (qn_new, mask)
	end function quantum_numbers_undefined0

	function quantum_numbers_undefined1 (qn, mask) result (qn_new)
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	type(quantum_numbers_mask_t), intent(in) :: mask
	type(quantum_numbers_t), dimension(size(qn)) :: qn_new
	qn_new = qn
	call quantum_numbers_undefine (qn_new, mask)
	end function quantum_numbers_undefined1

	function quantum_numbers_undefined11 (qn, mask) result (qn_new)
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	type(quantum_numbers_t), dimension(size(qn)) :: qn_new
	qn_new = qn
	call quantum_numbers_undefine (qn_new, mask)
	end function quantum_numbers_undefined11

	@ %def quantum_numbers_undefine
	@ %def quantum_numbers_undefined
	@ Return true if the input quantum number set has entries that would
	be removed by the applied mask, e.g., if polarization is defined but
	[[mask%h]] is set:
	<<Quantum numbers: quantum numbers: TBP>>=
	procedure :: are_redundant => quantum_numbers_are_redundant
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_are_redundant (qn, mask) &
	result (redundant)
	logical :: redundant
	class(quantum_numbers_t), intent(in) :: qn
	type(quantum_numbers_mask_t), intent(in) :: mask
	redundant = .false.
	if (mask%f) then
	redundant = qn%f%is_defined ()
	end if
	if (mask%c) then
	redundant = qn%c%is_defined ()
	end if
	if (mask%h) then
	redundant = qn%h%is_defined ()
	else if (mask%hd) then
	redundant = .not. qn%h%is_diagonal ()
	end if
	if (mask%sub > 0) redundant = qn%sub >= mask%sub
	end function quantum_numbers_are_redundant

	@ %def quantum_numbers_are_redundant
	@ Return true if the helicity flag is set or the diagonal-helicity flag is
	set.
	<<Quantum numbers: quantum numbers mask: TBP>>=
	procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity
	<<Quantum numbers: procedures>>=
	elemental function quantum_numbers_mask_diagonal_helicity (mask) &
	result (flag)
	logical :: flag
	class(quantum_numbers_mask_t), intent(in) :: mask
	flag = mask%h .or. mask%hd
	end function quantum_numbers_mask_diagonal_helicity

	@ %def quantum_numbers_mask_diagonal_helicity
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Transition Matrices and Evaluation}

	The modules in this chapter implement transition matrices and calculations.
	The functionality is broken down in three modules
	\begin{description}
	\item[state\_matrices]
	represent state and transition density matrices built from particle quantum
	numbers (helicity, color, flavor)
	\item[interactions]
	extend state matrices with the record of particle momenta. They also
	distinguish in- and out-particles and store parent-child relations.
	\item[evaluators]
	These objects extend interaction objects by the information how to calculate
	matrix elements from products and squares of other interactions. They
	implement the methods to actually compute those matrix elements.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{State matrices}
	This module deals with the internal state of a particle system, i.e.,
	with its density matrix in flavor, color, and helicity space.
	<<[[state_matrices.f90]]>>=
	<<File header>>

	module state_matrices

	<<Use kinds>>
	use io_units
	use format_utils, only: pac_fmt
	use format_defs, only: FMT_17, FMT_19
	use diagnostics
	use sorting
	use model_data
	use flavors
	use colors
	use helicities
	use quantum_numbers

	<<Standard module head>>

	<<State matrices: public>>

	<<State matrices: parameters>>

	<<State matrices: types>>

	<<State matrices: interfaces>>

	contains

	<<State matrices: procedures>>

	end module state_matrices
	@ %def state_matrices
	@
	\subsection{Nodes of the quantum state trie}
	A quantum state object represents an unnormalized density matrix,
	i.e., an array of possibilities for flavor, color, and helicity
	indices with associated complex values. Physically, the trace of this
	matrix is the summed squared matrix element for an interaction, and
	the matrix elements divided by this value correspond to the
	flavor-color-helicity density matrix. (Flavor and color are
	diagonal.)

	We store density matrices as tries, that is, as trees where each
	branching represents the possible quantum numbers of a particle. The
	first branching is the first particle in the system. A leaf (the node
	corresponding to the last particle) contains the value of the matrix
	element.

	Each node contains a flavor, color, and helicity entry. Note that
	each of those entries may be actually undefined, so we can also represent,
	e.g., unpolarized particles.

	The value is meaningful only for leaves, which have no child nodes.
	There is a pointer to the parent node which allows for following the
	trie downwards from a leaf, it is null for a root node. The child
	nodes are implemented as a list, so there is a pointer to the first
	and last child, and each node also has a [[next]] pointer to the next
	sibling.

	The root node does not correspond to a particle, only its children do.
	The quantum numbers of the root node are irrelevant and will not be
	set. However, we use a common type for the three classes (root,
	branch, leaf); they may easily be distinguished by the association
	status of parent and child.

	\subsubsection{Node type}
	The node is linked in all directions: the parent, the first and last
	in the list of children, and the previous and next sibling. This allows
	us for adding and removing nodes and whole branches anywhere in the
	trie. (Circular links are not allowed, however.). The node holds its
	associated set of quantum numbers. The integer index, which is set
	only for leaf nodes, is the index of the corresponding matrix element
	value within the state matrix.

	Temporarily, matrix-element values may be stored within a leaf node.
	This is used during state-matrix factorization. When the state matrix
	is [[freeze]]d, these values are transferred to the matrix-element
	array within the host state matrix.
	<<State matrices: types>>=
	type :: node_t
	private
	type(quantum_numbers_t) :: qn
	type(node_t), pointer :: parent => null ()
	type(node_t), pointer :: child_first => null ()
	type(node_t), pointer :: child_last => null ()
	type(node_t), pointer :: next => null ()
	type(node_t), pointer :: previous => null ()
	integer :: me_index = 0
	integer, dimension(:), allocatable :: me_count
	complex(default) :: me = 0
	end type node_t

	@ %def node_t
	@
	\subsubsection{Operations on nodes}
	Recursively deallocate all children of the current
	node. This includes any values associated with the children.
	<<State matrices: procedures>>=
	pure recursive subroutine node_delete_offspring (node)
	type(node_t), pointer :: node
	type(node_t), pointer :: child
	child => node%child_first
	do while (associated (child))
	node%child_first => node%child_first%next
	call node_delete_offspring (child)
	deallocate (child)
	child => node%child_first
	end do
	node%child_last => null ()
	end subroutine node_delete_offspring

	@ %def node_delete_offspring
	@ Remove a node including its offspring. Adjust the pointers of
	parent and siblings, if necessary.
	<<State matrices: procedures>>=
	pure subroutine node_delete (node)
	type(node_t), pointer :: node
	call node_delete_offspring (node)
	if (associated (node%previous)) then
	node%previous%next => node%next
	else if (associated (node%parent)) then
	node%parent%child_first => node%next
	end if
	if (associated (node%next)) then
	node%next%previous => node%previous
	else if (associated (node%parent)) then
	node%parent%child_last => node%previous
	end if
	deallocate (node)
	end subroutine node_delete

	@ %def node_delete
	@ Append a child node
	<<State matrices: procedures>>=
	subroutine node_append_child (node, child)
	type(node_t), target, intent(inout) :: node
	type(node_t), pointer :: child
	allocate (child)
	if (associated (node%child_last)) then
	node%child_last%next => child
	child%previous => node%child_last
	else
	node%child_first => child
	end if
	node%child_last => child
	child%parent => node
	end subroutine node_append_child

	@ %def node_append_child
	@
	\subsubsection{I/O}
	Output of a single node, no recursion. We print the quantum numbers
	in square brackets, then the value (if any).
	<<State matrices: procedures>>=
	subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag)
	type(node_t), intent(in) :: node
	complex(default), dimension(:), intent(in), optional :: me_array
	logical, intent(in), optional :: verbose, col_verbose, testflag
	integer, intent(in), optional :: unit
	logical :: verb
	integer :: u
	character(len=7) :: fmt
	call pac_fmt (fmt, FMT_19, FMT_17, testflag)
	verb = .false.; if (present (verbose)) verb = verbose
	u = given_output_unit (unit); if (u < 0) return
	call node%qn%write (u, col_verbose)
	if (node%me_index /= 0) then
	write (u, "(A,I0,A)", advance="no") " => ME(", node%me_index, ")"
	if (present (me_array)) then
	write (u, "(A)", advance="no") " = "
	write (u, "('('," // fmt // ",','," // fmt // ",')')", &
	advance="no") pacify_complex (me_array(node%me_index))
	end if
	end if
	write (u, *)
	if (verb) then
	call ptr_write ("parent ", node%parent)
	call ptr_write ("child_first", node%child_first)
	call ptr_write ("child_last ", node%child_last)
	call ptr_write ("next ", node%next)
	call ptr_write ("previous ", node%previous)
	end if
	contains
	subroutine ptr_write (label, node)
	character(*), intent(in) :: label
	type(node_t), pointer :: node
	if (associated (node)) then
	write (u, "(10x,A,1x,'->',1x)", advance="no") label
	call node%qn%write (u, col_verbose)
	write (u, *)
	end if
	end subroutine ptr_write
	end subroutine node_write

	@ %def node_write
	@ Recursive output of a node:
	<<State matrices: procedures>>=
	recursive subroutine node_write_rec (node, me_array, verbose, &
	indent, unit, col_verbose, testflag)
	type(node_t), intent(in), target :: node
	complex(default), dimension(:), intent(in), optional :: me_array
	logical, intent(in), optional :: verbose, col_verbose, testflag
	integer, intent(in), optional :: indent
	integer, intent(in), optional :: unit
	type(node_t), pointer :: current
	logical :: verb
	integer :: i, u
	verb = .false.; if (present (verbose)) verb = verbose
	i = 0; if (present (indent)) i = indent
	u = given_output_unit (unit); if (u < 0) return
	current => node%child_first
	do while (associated (current))
	write (u, "(A)", advance="no") repeat (" ", i)
	call node_write (current, me_array, verbose = verb, &
	unit = u, col_verbose = col_verbose, testflag = testflag)
	call node_write_rec (current, me_array, verbose = verb, &
	indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag)
	current => current%next
	end do
	end subroutine node_write_rec

	@ %def node_write_rec
	@ Binary I/O. Matrix elements are written only for leaf nodes.
	<<State matrices: procedures>>=
	recursive subroutine node_write_raw_rec (node, u)
	type(node_t), intent(in), target :: node
	integer, intent(in) :: u
	logical :: associated_child_first, associated_next
	call node%qn%write_raw (u)
	associated_child_first = associated (node%child_first)
	write (u) associated_child_first
	associated_next = associated (node%next)
	write (u) associated_next
	if (associated_child_first) then
	call node_write_raw_rec (node%child_first, u)
	else
	write (u) node%me_index
	write (u) node%me
	end if
	if (associated_next) then
	call node_write_raw_rec (node%next, u)
	end if
	end subroutine node_write_raw_rec

	recursive subroutine node_read_raw_rec (node, u, parent, iostat)
	type(node_t), intent(out), target :: node
	integer, intent(in) :: u
	type(node_t), intent(in), optional, target :: parent
	integer, intent(out), optional :: iostat
	logical :: associated_child_first, associated_next
	type(node_t), pointer :: child
	call node%qn%read_raw (u, iostat=iostat)
	read (u, iostat=iostat) associated_child_first
	read (u, iostat=iostat) associated_next
	if (present (parent)) node%parent => parent
	if (associated_child_first) then
	allocate (child)
	node%child_first => child
	node%child_last => null ()
	call node_read_raw_rec (child, u, node, iostat=iostat)
	do while (associated (child))
	child%previous => node%child_last
	node%child_last => child
	child => child%next
	end do
	else
	read (u, iostat=iostat) node%me_index
	read (u, iostat=iostat) node%me
	end if
	if (associated_next) then
	allocate (node%next)
	call node_read_raw_rec (node%next, u, parent, iostat=iostat)
	end if
	end subroutine node_read_raw_rec

	@ %def node_write_raw
	@
	\subsection{State matrix}
	\subsubsection{Definition}
	The quantum state object is a container that keeps and hides the root
	node. For direct accessibility of values, they are stored
	in a separate array. The leaf nodes of the quantum-number tree point to those
	values, once the state matrix is finalized.

	The [[norm]] component is redefined if a common factor is extracted from all
	nodes.
	<<State matrices: public>>=
	public :: state_matrix_t
	<<State matrices: types>>=
	type :: state_matrix_t
	private
	type(node_t), pointer :: root => null ()
	integer :: depth = 0
	integer :: n_matrix_elements = 0
	logical :: leaf_nodes_store_values = .false.
	integer :: n_counters = 0
	complex(default), dimension(:), allocatable :: me
	real(default) :: norm = 1
	integer :: n_sub = -1
	contains
	<<State matrices: state matrix: TBP>>
	end type state_matrix_t

	@ %def state_matrix_t
	@ This initializer allocates the root node but does not fill
	anything. We declare whether values are stored within the nodes
	during state-matrix construction, and how many counters should be
	maintained (default: none).
	<<State matrices: state matrix: TBP>>=
	procedure :: init => state_matrix_init
	<<State matrices: procedures>>=
	subroutine state_matrix_init (state, store_values, n_counters)
	class(state_matrix_t), intent(out) :: state
	logical, intent(in), optional :: store_values
	integer, intent(in), optional :: n_counters
	allocate (state%root)
	if (present (store_values)) &
	state%leaf_nodes_store_values = store_values
	if (present (n_counters)) state%n_counters = n_counters
	end subroutine state_matrix_init

	@ %def state_matrix_init
	@ This recursively deletes all children of the root node, restoring
	the initial state. The matrix element array is not finalized, since
	it does not contain physical entries, just pointers.
	<<State matrices: state matrix: TBP>>=
	procedure :: final => state_matrix_final
	<<State matrices: procedures>>=
	subroutine state_matrix_final (state)
	class(state_matrix_t), intent(inout) :: state
	if (allocated (state%me)) deallocate (state%me)
	if (associated (state%root)) call node_delete (state%root)
	state%depth = 0
	state%n_matrix_elements = 0
	end subroutine state_matrix_final

	@ %def state_matrix_final
	@ Output: Present the tree as a nested list with appropriate
	indentation.
	<<State matrices: state matrix: TBP>>=
	procedure :: write => state_matrix_write
	<<State matrices: procedures>>=
	subroutine state_matrix_write (state, unit, write_value_list, &
	verbose, col_verbose, testflag)
	class(state_matrix_t), intent(in) :: state
	logical, intent(in), optional :: write_value_list, verbose, col_verbose
	logical, intent(in), optional :: testflag
	integer, intent(in), optional :: unit
	complex(default) :: me_dum
	character(len=7) :: fmt
	integer :: u
	integer :: i
	call pac_fmt (fmt, FMT_19, FMT_17, testflag)
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A," // fmt // ")") "State matrix: norm = ", state%norm
	if (associated (state%root)) then
	if (allocated (state%me)) then
	call node_write_rec (state%root, state%me, verbose = verbose, &
	indent = 1, unit = u, col_verbose = col_verbose, &
	testflag = testflag)
	else
	call node_write_rec (state%root, verbose = verbose, indent = 1, &
	unit = u, col_verbose = col_verbose, testflag = testflag)
	end if
	end if
	if (present (write_value_list)) then
	if (write_value_list .and. allocated (state%me)) then
	do i = 1, size (state%me)
	write (u, "(1x,I0,A)", advance="no") i, ":"
	me_dum = state%me(i)
	if (real(state%me(i)) == -real(state%me(i))) then
	me_dum = &
	cmplx (0._default, aimag(me_dum), kind=default)
	end if
	if (aimag(me_dum) == -aimag(me_dum)) then
	me_dum = &
	cmplx (real(me_dum), 0._default, kind=default)
	end if
	write (u, "('('," // fmt // ",','," // fmt // &
	",')')") me_dum
	end do
	end if
	end if
	end subroutine state_matrix_write

	@ %def state_matrix_write
	@ Binary I/O. The auxiliary matrix-element array is not written, but
	reconstructed after reading the tree.

	Note: To be checked. Might be broken, don't use (unless trivial).
	<<State matrices: state matrix: TBP>>=
	procedure :: write_raw => state_matrix_write_raw
	procedure :: read_raw => state_matrix_read_raw
	<<State matrices: procedures>>=
	subroutine state_matrix_write_raw (state, u)
	class(state_matrix_t), intent(in), target :: state
	integer, intent(in) :: u
	logical :: is_defined
	integer :: depth, j
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	is_defined = state%is_defined ()
	write (u) is_defined
	if (is_defined) then
	write (u) state%get_norm ()
	write (u) state%get_n_leaves ()
	depth = state%get_depth ()
	write (u) depth
	allocate (qn (depth))
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	do j = 1, depth
	call qn(j)%write_raw (u)
	end do
	write (u) it%get_me_index ()
	write (u) it%get_matrix_element ()
	call it%advance ()
	end do
	end if
	end subroutine state_matrix_write_raw

	subroutine state_matrix_read_raw (state, u, iostat)
	class(state_matrix_t), intent(out) :: state
	integer, intent(in) :: u
	integer, intent(out) :: iostat
	logical :: is_defined
	real(default) :: norm
	integer :: n_leaves, depth, i, j
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: me_index
	complex(default) :: me
	read (u, iostat=iostat) is_defined
	if (iostat /= 0) goto 1
	if (is_defined) then
	call state%init (store_values = .true.)
	read (u, iostat=iostat) norm
	if (iostat /= 0) goto 1
	call state_matrix_set_norm (state, norm)
	read (u) n_leaves
	if (iostat /= 0) goto 1
	read (u) depth
	if (iostat /= 0) goto 1
	allocate (qn (depth))
	do i = 1, n_leaves
	do j = 1, depth
	call qn(j)%read_raw (u, iostat=iostat)
	if (iostat /= 0) goto 1
	end do
	read (u, iostat=iostat) me_index
	if (iostat /= 0) goto 1
	read (u, iostat=iostat) me
	if (iostat /= 0) goto 1
	call state%add_state (qn, index = me_index, value = me)
	end do
	call state_matrix_freeze (state)
	end if
	return

	! Clean up on error
	1 continue
	call state%final ()
	end subroutine state_matrix_read_raw

	@ %def state_matrix_write_raw state_matrix_read_raw
	@ Assign a model pointer to all flavor entries. This will become
	necessary when we have read a state matrix from file.
	<<State matrices: state matrix: TBP>>=
	procedure :: set_model => state_matrix_set_model
	<<State matrices: procedures>>=
	subroutine state_matrix_set_model (state, model)
	class(state_matrix_t), intent(inout), target :: state
	class(model_data_t), intent(in), target :: model
	type(state_iterator_t) :: it
	call it%init (state)
	do while (it%is_valid ())
	call it%set_model (model)
	call it%advance ()
	end do
	end subroutine state_matrix_set_model

	@ %def state_matrix_set_model
	@ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag
	all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction.
	Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as
	part of the hard process.
	<<State matrices: state matrix: TBP>>=
	procedure :: tag_hard_process => state_matrix_tag_hard_process
	<<State matrices: procedures>>=
	subroutine state_matrix_tag_hard_process (state, tagged_state, tag)
	class(state_matrix_t), intent(in), target :: state
	type(state_matrix_t), intent(out) :: tagged_state
	integer, dimension(:), intent(in), optional :: tag
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	complex(default) :: value
	integer :: i
	call tagged_state%init (store_values = .true.)
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	value = it%get_matrix_element ()
	if (present (tag)) then
	do i = 1, size (tag)
	call qn(tag(i))%tag_hard_process ()
	end do
	else
	call qn%tag_hard_process ()
	end if
	call tagged_state%add_state (qn, index = it%get_me_index (), value = value)
	call it%advance ()
	end do
	call tagged_state%freeze ()
	end subroutine state_matrix_tag_hard_process

	@ %def state_matrix_tag_hard_process
	\subsubsection{Properties of the quantum state}
	A state is defined if its root is allocated:
	<<State matrices: state matrix: TBP>>=
	procedure :: is_defined => state_matrix_is_defined
	<<State matrices: procedures>>=
	elemental function state_matrix_is_defined (state) result (defined)
	logical :: defined
	class(state_matrix_t), intent(in) :: state
	defined = associated (state%root)
	end function state_matrix_is_defined

	@ %def state_matrix_is_defined
	@ A state is empty if its depth is zero:
	<<State matrices: state matrix: TBP>>=
	procedure :: is_empty => state_matrix_is_empty
	<<State matrices: procedures>>=
	elemental function state_matrix_is_empty (state) result (flag)
	logical :: flag
	class(state_matrix_t), intent(in) :: state
	flag = state%depth == 0
	end function state_matrix_is_empty

	@ %def state_matrix_is_empty
	@ Return the number of matrix-element values.
	<<State matrices: state matrix: TBP>>=
	generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask
	procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all
	procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask
	<<State matrices: procedures>>=
	pure function state_matrix_get_n_matrix_elements_all (state) result (n)
	integer :: n
	class(state_matrix_t), intent(in) :: state
	n = state%n_matrix_elements
	end function state_matrix_get_n_matrix_elements_all

	@ %def state_matrix_get_n_matrix_elements_all
	@
	<<State matrices: procedures>>=
	function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n)
	integer :: n
	class(state_matrix_t), intent(in) :: state
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(size(qn_mask)) :: qn
	type(state_matrix_t) :: state_tmp
	call state_tmp%init ()
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	call qn%undefine (qn_mask)
	call state_tmp%add_state (qn)
	call it%advance ()
	end do
	n = state_tmp%n_matrix_elements
	call state_tmp%final ()
	end function state_matrix_get_n_matrix_elements_mask

	@ %def state_matrix_get_n_matrix_elments_mask
	@ Return the size of the [[me]]-array for debugging purposes.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_me_size => state_matrix_get_me_size
	<<State matrices: procedures>>=
	pure function state_matrix_get_me_size (state) result (n)
	integer :: n
	class(state_matrix_t), intent(in) :: state
	if (allocated (state%me)) then
	n = size (state%me)
	else
	n = 0
	end if
	end function state_matrix_get_me_size

	@ %def state_matrix_get_me_size
	@
	<<State matrices: state matrix: TBP>>=
	procedure :: compute_n_sub => state_matrix_compute_n_sub
	<<State matrices: procedures>>=
	function state_matrix_compute_n_sub (state) result (n_sub)
	integer :: n_sub
	class(state_matrix_t), intent(in) :: state
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(state%depth) :: qn
	integer :: sub, sub_pos
	n_sub = 0
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	sub = 0
	sub_pos = qn_array_sub_pos ()
	if (sub_pos > 0) sub = qn(sub_pos)%get_sub ()
	if (sub > n_sub) n_sub = sub
	call it%advance ()
	end do
	contains
	function qn_array_sub_pos () result (pos)
	integer :: pos
	integer :: i
	pos = 0
	do i = 1, state%depth
	if (qn(i)%get_sub () > 0) then
	pos = i
	exit
	end if
	end do
	end function qn_array_sub_pos
	end function state_matrix_compute_n_sub

	@ %def state_matrix_compute_n_sub
	@
	<<State matrices: state matrix: TBP>>=
	procedure :: set_n_sub => state_matrix_set_n_sub
	<<State matrices: procedures>>=
	subroutine state_matrix_set_n_sub (state)
	class(state_matrix_t), intent(inout) :: state
	state%n_sub = state%compute_n_sub ()
	end subroutine state_matrix_set_n_sub

	@ %def state_matrix_set_n_sub
	@ Return number of subtractions.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_n_sub => state_matrix_get_n_sub
	<<State matrices: procedures>>=
	function state_matrix_get_n_sub (state) result (n_sub)
	integer :: n_sub
	class(state_matrix_t), intent(in) :: state
	if (state%n_sub < 0) then
	call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.")
	end if
	n_sub = state%n_sub
	end function state_matrix_get_n_sub

	@ %def state_matrix_get_n_sub
	@ Return the number of leaves. This can be larger than the number of
	independent matrix elements.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_n_leaves => state_matrix_get_n_leaves
	<<State matrices: procedures>>=
	function state_matrix_get_n_leaves (state) result (n)
	integer :: n
	class(state_matrix_t), intent(in) :: state
	type(state_iterator_t) :: it
	n = 0
	call it%init (state)
	do while (it%is_valid ())
	n = n + 1
	call it%advance ()
	end do
	end function state_matrix_get_n_leaves

	@ %def state_matrix_get_n_leaves
	@ Return the depth:
	<<State matrices: state matrix: TBP>>=
	procedure :: get_depth => state_matrix_get_depth
	<<State matrices: procedures>>=
	pure function state_matrix_get_depth (state) result (depth)
	integer :: depth
	class(state_matrix_t), intent(in) :: state
	depth = state%depth
	end function state_matrix_get_depth

	@ %def state_matrix_get_depth
	@ Return the norm:
	<<State matrices: state matrix: TBP>>=
	procedure :: get_norm => state_matrix_get_norm
	<<State matrices: procedures>>=
	pure function state_matrix_get_norm (state) result (norm)
	real(default) :: norm
	class(state_matrix_t), intent(in) :: state
	norm = state%norm
	end function state_matrix_get_norm

	@ %def state_matrix_get_norm
	@
	\subsubsection{Retrieving contents}
	Return the quantum number array, using an index. We have to scan the
	state matrix since there is no shortcut.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_quantum_number => &
	state_matrix_get_quantum_number
	<<State matrices: procedures>>=
	function state_matrix_get_quantum_number (state, i, by_me_index) result (qn)
	class(state_matrix_t), intent(in), target :: state
	integer, intent(in) :: i
	logical, intent(in), optional :: by_me_index
	logical :: opt_by_me_index
	type(quantum_numbers_t), dimension(state%depth) :: qn
	type(state_iterator_t) :: it
	integer :: k
	opt_by_me_index = .false.
	if (present (by_me_index)) opt_by_me_index = by_me_index
	k = 0
	call it%init (state)
	do while (it%is_valid ())
	if (opt_by_me_index) then
	k = it%get_me_index ()
	else
	k = k + 1
	end if
	if (k == i) then
	qn = it%get_quantum_numbers ()
	exit
	end if
	call it%advance ()
	end do
	end function state_matrix_get_quantum_number

	@ %def state_matrix_get_quantum_number
	<<State matrices: state matrix: TBP>>=
	generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask
	procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all
	procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask
	<<State matrices: procedures>>=
	subroutine state_matrix_get_quantum_numbers_all (state, qn)
	class(state_matrix_t), intent(in), target :: state
	type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
	integer :: i
	allocate (qn (state%get_n_matrix_elements (), &
	state%get_depth()))
	do i = 1, state%get_n_matrix_elements ()
	qn (i, :) = state%get_quantum_number (i)
	end do
	end subroutine state_matrix_get_quantum_numbers_all

	@ %def state_matrix_get_quantum_numbers_all
	@
	<<State matrices: procedures>>=
	subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn)
	class(state_matrix_t), intent(in), target :: state
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
	type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
	type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp
	type(state_matrix_t) :: state_tmp
	type(state_iterator_t) :: it
	integer :: i, n
	n = state%get_n_matrix_elements (qn_mask)
	allocate (qn (n, state%get_depth ()))
	allocate (qn_tmp (state%get_depth ()))
	call it%init (state)
	call state_tmp%init ()
	do while (it%is_valid ())
	qn_tmp = it%get_quantum_numbers ()
	call qn_tmp%undefine (qn_mask)
	call state_tmp%add_state (qn_tmp)
	call it%advance ()
	end do
	do i = 1, n
	qn (i, :) = state_tmp%get_quantum_number (i)
	end do
	call state_tmp%final ()
	end subroutine state_matrix_get_quantum_numbers_mask

	@ %def state_matrix_get_quantum_numbers_mask
	@
	<<State matrices: state matrix: TBP>>=
	procedure :: get_flavors => state_matrix_get_flavors
	<<State matrices: procedures>>=
	subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv)
	class(state_matrix_t), intent(in), target :: state
	logical, intent(in) :: only_elementary
	type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
	integer, intent(out), dimension(:,:), allocatable :: flv
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	integer :: i_flv, n_partons
	type(flavor_t), dimension(:), allocatable :: flv_flv
	if (present (qn_mask)) then
	call state%get_quantum_numbers (qn_mask, qn)
	else
	call state%get_quantum_numbers (qn)
	end if
	allocate (flv_flv (size (qn, dim=2)))
	if (only_elementary) then
	flv_flv = qn(1, :)%get_flavor ()
	n_partons = count (is_elementary (flv_flv%get_pdg ()))
	end if
	allocate (flv (n_partons, size (qn, dim=1)))
	associate (n_flv => size (qn, dim=1))
	do i_flv = 1, size (qn, dim=1)
	flv_flv = qn(i_flv, :)%get_flavor ()
	flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg()))
	end do
	end associate
	contains
	elemental function is_elementary (pdg)
	logical :: is_elementary
	integer, intent(in) :: pdg
	is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93
	end function is_elementary
	end subroutine state_matrix_get_flavors

	@ %def state_matrix_get_flavors
	@ Return a single matrix element using its index. Works only if the
	shortcut array is allocated.
	<<State matrices: state matrix: TBP>>=
	generic :: get_matrix_element => get_matrix_element_single
	generic :: get_matrix_element => get_matrix_element_array
	procedure :: get_matrix_element_single => &
	state_matrix_get_matrix_element_single
	procedure :: get_matrix_element_array => &
	state_matrix_get_matrix_element_array
	<<State matrices: procedures>>=
	elemental function state_matrix_get_matrix_element_single (state, i) result (me)
	complex(default) :: me
	class(state_matrix_t), intent(in) :: state
	integer, intent(in) :: i
	if (allocated (state%me)) then
	me = state%me(i)
	else
	me = 0
	end if
	end function state_matrix_get_matrix_element_single

	@ %def state_matrix_get_matrix_element_single
	@
	<<State matrices: procedures>>=
	function state_matrix_get_matrix_element_array (state) result (me)
	complex(default), dimension(:), allocatable :: me
	class(state_matrix_t), intent(in) :: state
	if (allocated (state%me)) then
	allocate (me (size (state%me)))
	me = state%me
	else
	me = 0
	end if
	end function state_matrix_get_matrix_element_array

	@ %def state_matrix_get_matrix_element_array
	@ Return the color index with maximum absolute value that is present within
	the state matrix.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_max_color_value => state_matrix_get_max_color_value
	<<State matrices: procedures>>=
	function state_matrix_get_max_color_value (state) result (cmax)
	integer :: cmax
	class(state_matrix_t), intent(in) :: state
	if (associated (state%root)) then
	cmax = node_get_max_color_value (state%root)
	else
	cmax = 0
	end if
	contains
	recursive function node_get_max_color_value (node) result (cmax)
	integer :: cmax
	type(node_t), intent(in), target :: node
	type(node_t), pointer :: current
	cmax = quantum_numbers_get_max_color_value (node%qn)
	current => node%child_first
	do while (associated (current))
	cmax = max (cmax, node_get_max_color_value (current))
	current => current%next
	end do
	end function node_get_max_color_value
	end function state_matrix_get_max_color_value

	@ %def state_matrix_get_max_color_value
	@
	\subsubsection{Building the quantum state}
	The procedure generates a branch associated to the input array of
	quantum numbers. If the branch exists already, it is used.

	Optionally, we set the matrix-element index, a value (which may be
	added to the previous one), and increment one of the possible
	counters. We may also return the matrix element index of the current
	node.
	<<State matrices: state matrix: TBP>>=
	procedure :: add_state => state_matrix_add_state
	<<State matrices: procedures>>=
	subroutine state_matrix_add_state (state, qn, index, value, &
	sum_values, counter_index, ignore_sub, me_index)
	class(state_matrix_t), intent(inout) :: state
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer, intent(in), optional :: index
	complex(default), intent(in), optional :: value
	logical, intent(in), optional :: sum_values
	integer, intent(in), optional :: counter_index
	logical, intent(in), optional :: ignore_sub
	integer, intent(out), optional :: me_index
	logical :: set_index, get_index, add
	set_index = present (index)
	get_index = present (me_index)
	add = .false.; if (present (sum_values)) add = sum_values
	if (state%depth == 0) then
	state%depth = size (qn)
	else if (state%depth /= size (qn)) then
	call state%write ()
	call msg_bug ("State matrix: depth mismatch")
	end if
	if (size (qn) > 0) call node_make_branch (state%root, qn)
	contains
	recursive subroutine node_make_branch (parent, qn)
	type(node_t), pointer :: parent
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	type(node_t), pointer :: child
	logical :: match
	match = .false.
	child => parent%child_first
	SCAN_CHILDREN: do while (associated (child))
	if (present (ignore_sub)) then
	if (ignore_sub) then
	match = quantum_numbers_eq_wo_sub (child%qn, qn(1))
	else
	match = child%qn == qn(1)
	end if
	else
	match = child%qn == qn(1)
	end if
	if (match) exit SCAN_CHILDREN
	child => child%next
	end do SCAN_CHILDREN
	if (.not. match) then
	call node_append_child (parent, child)
	child%qn = qn(1)
	end if
	select case (size (qn))
	case (1)
	if (.not. match) then
	state%n_matrix_elements = state%n_matrix_elements + 1
	child%me_index = state%n_matrix_elements
	end if
	if (set_index) then
	child%me_index = index
	end if
	if (get_index) then
	me_index = child%me_index
	end if
	if (present (counter_index)) then
	if (.not. allocated (child%me_count)) then
	allocate (child%me_count (state%n_counters))
	child%me_count = 0
	end if
	child%me_count(counter_index) = child%me_count(counter_index) + 1
	end if
	if (present (value)) then
	if (add) then
	child%me = child%me + value
	else
	child%me = value
	end if
	end if
	case (2:)
	call node_make_branch (child, qn(2:))
	end select
	end subroutine node_make_branch
	end subroutine state_matrix_add_state

	@ %def state_matrix_add_state
	@ Remove irrelevant flavor/color/helicity labels and the corresponding
	branchings. The masks indicate which particles are affected; the
	masks length should coincide with the depth of the trie (without the
	root node). Recursively scan the whole tree, starting from the leaf
	nodes and working up to the root node. If a mask entry is set for the
	current tree level, scan the children there. For each child within
	that level make a new empty branch where the masked quantum number is
	undefined. Then recursively combine all following children with
	matching quantum number into this new node and move on.
	<<State matrices: state matrix: TBP>>=
	procedure :: collapse => state_matrix_collapse
	<<State matrices: procedures>>=
	subroutine state_matrix_collapse (state, mask)
	class(state_matrix_t), intent(inout) :: state
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	type(state_matrix_t) :: red_state
	if (state%is_defined ()) then
	call state%reduce (mask, red_state)
	call state%final ()
	state = red_state
	end if
	end subroutine state_matrix_collapse

	@ %def state_matrix_collapse
	@ Transform the given state matrix into a reduced state matrix where
	some quantum numbers are removed, as indicated by the mask. The
	procedure creates a new state matrix, so the old one can be deleted
	after this if it is no longer used.

	It is said that the matrix element ordering is lost afterwards. We allow to keep
	the original matrix element index in the new state matrix. If the matrix
	element indices are kept, we do not freeze the state matrix. After reordering
	the matrix element indices by [[state_matrix_reorder_me]], the state matrix can
	be frozen.
	<<State matrices: state matrix: TBP>>=
	procedure :: reduce => state_matrix_reduce
	<<State matrices: procedures>>=
	subroutine state_matrix_reduce (state, mask, red_state, keep_me_index)
	class(state_matrix_t), intent(in), target :: state
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	type(state_matrix_t), intent(out) :: red_state
	logical, optional, intent(in) :: keep_me_index
	logical :: opt_keep_me_index
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(size(mask)) :: qn
	opt_keep_me_index = .false.
	if (present (keep_me_index)) opt_keep_me_index = keep_me_index
	call red_state%init ()
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	call qn%undefine (mask)
	if (opt_keep_me_index) then
	call red_state%add_state (qn, index = it%get_me_index ())
	else
	call red_state%add_state (qn)
	end if
	call it%advance ()
	end do
	if (.not. opt_keep_me_index) then
	call red_state%freeze ()
	end if
	end subroutine state_matrix_reduce

	@ %def state_matrix_reduce
	@ Reorder the matrix elements -- not the tree itself. The procedure is necessary
	in case the matrix element indices were kept when reducing over quantum numbers
	and one wants to reintroduce the previous order of the matrix elements.
	<<State matrices: state matrix: TBP>>=
	procedure :: reorder_me => state_matrix_reorder_me
	<<State matrices: procedures>>=
	subroutine state_matrix_reorder_me (state, ordered_state)
	class(state_matrix_t), intent(in), target :: state
	type(state_matrix_t), intent(out) :: ordered_state
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(state%depth) :: qn
	integer, dimension(:), allocatable :: me_index
	integer :: i
	call ordered_state%init ()
	call get_me_index_sorted (state, me_index)
	i = 1; call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	call ordered_state%add_state (qn, index = me_index(i))
	i = i + 1; call it%advance ()
	end do
	call ordered_state%freeze ()
	contains
	subroutine get_me_index_sorted (state, me_index)
	class(state_matrix_t), intent(in), target :: state
	integer, dimension(:), allocatable, intent(out) :: me_index
	type(state_iterator_t) :: it
	integer :: i, j
	integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted
	associate (n_matrix_elements => state%get_n_matrix_elements ())
	allocate (me_index(n_matrix_elements), source = 0)
	allocate (me_index_sorted(n_matrix_elements), source = 0)
	allocate (me_index_unsorted(n_matrix_elements), source = 0)
	i = 1; call it%init (state)
	do while (it%is_valid ())
	me_index_unsorted(i) = it%get_me_index ()
	i = i + 1
	call it%advance ()
	end do
	me_index_sorted = sort (me_index_unsorted)
	! We do not care about efficiency at this point.
	UNSORTED: do i = 1, n_matrix_elements
	SORTED: do j = 1, n_matrix_elements
	if (me_index_unsorted(i) == me_index_sorted(j)) then
	me_index(i) = j
	cycle UNSORTED
	end if
	end do SORTED
	end do UNSORTED
	end associate
	end subroutine get_me_index_sorted
	end subroutine state_matrix_reorder_me

	@ %def state_matrix_order_by_flavors
	@ This subroutine sets up the matrix-element array. The leaf nodes
	aquire the index values that point to the appropriate matrix-element
	entry.

	We recursively scan the trie. Once we arrive at a leaf node, the
	index is increased and associated to that node. Finally, we allocate
	the matrix-element array with the appropriate size.

	If matrix element values are temporarily stored within the leaf nodes,
	we scan the state again and transfer them to the matrix-element array.
	<<State matrices: state matrix: TBP>>=
	procedure :: freeze => state_matrix_freeze
	<<State matrices: procedures>>=
	subroutine state_matrix_freeze (state)
	class(state_matrix_t), intent(inout), target :: state
	type(state_iterator_t) :: it
	if (associated (state%root)) then
	if (allocated (state%me)) deallocate (state%me)
	allocate (state%me (state%n_matrix_elements))
	state%me = 0
	call state%set_n_sub ()
	end if
	if (state%leaf_nodes_store_values) then
	call it%init (state)
	do while (it%is_valid ())
	state%me(it%get_me_index ()) = it%get_matrix_element ()
	call it%advance ()
	end do
	state%leaf_nodes_store_values = .false.
	end if
	end subroutine state_matrix_freeze

	@ %def state_matrix_freeze
	@
	\subsubsection{Direct access to the value array}
	Several methods for setting a value directly are summarized in this
	generic:
	<<State matrices: state matrix: TBP>>=
	generic :: set_matrix_element => set_matrix_element_qn
	generic :: set_matrix_element => set_matrix_element_all
	generic :: set_matrix_element => set_matrix_element_array
	generic :: set_matrix_element => set_matrix_element_single
	generic :: set_matrix_element => set_matrix_element_clone
	procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn
	procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all
	procedure :: set_matrix_element_array => &
	state_matrix_set_matrix_element_array
	procedure :: set_matrix_element_single => &
	state_matrix_set_matrix_element_single
	procedure :: set_matrix_element_clone => &
	state_matrix_set_matrix_element_clone
	@ %def state_matrix_set_matrix_element
	@ Set a value that corresponds to a quantum number array:
	<<State matrices: procedures>>=
	subroutine state_matrix_set_matrix_element_qn (state, qn, value)
	class(state_matrix_t), intent(inout), target :: state
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	complex(default), intent(in) :: value
	type(state_iterator_t) :: it
	if (.not. allocated (state%me)) then
	allocate (state%me (size(qn)))
	end if
	call it%init (state)
	call it%go_to_qn (qn)
	call it%set_matrix_element (value)
	end subroutine state_matrix_set_matrix_element_qn

	@ %def state_matrix_set_matrix_element_qn
	@ Set all matrix elements to a single value
	<<State matrices: procedures>>=
	subroutine state_matrix_set_matrix_element_all (state, value)
	class(state_matrix_t), intent(inout) :: state
	complex(default), intent(in) :: value
	if (.not. allocated (state%me)) then
	allocate (state%me (state%n_matrix_elements))
	end if
	state%me = value
	end subroutine state_matrix_set_matrix_element_all

	@ %def state_matrix_set_matrix_element_all
	@ Set the matrix-element array directly.
	<<State matrices: procedures>>=
	subroutine state_matrix_set_matrix_element_array (state, value, range)
	class(state_matrix_t), intent(inout) :: state
	complex(default), intent(in), dimension(:) :: value
	integer, intent(in), dimension(:), optional :: range
	integer :: i, n_me, n_val, i_first, i_last
	if (present (range)) then
	state%me(range) = value
	else
	if (.not. allocated (state%me)) &
	allocate (state%me (size (value)))
	state%me(:) = value
	end if
	end subroutine state_matrix_set_matrix_element_array

	pure subroutine state_matrix_set_matrix_element_single (state, i, value)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	complex(default), intent(in) :: value
	if (.not. allocated (state%me)) then
	allocate (state%me (state%n_matrix_elements))
	end if
	state%me(i) = value
	end subroutine state_matrix_set_matrix_element_single

	@ %def state_matrix_set_matrix_element_array
	@ %def state_matrix_set_matrix_element_single
	@ Clone the matrix elements from another (matching) state matrix.
	<<State matrices: procedures>>=
	subroutine state_matrix_set_matrix_element_clone (state, state1)
	class(state_matrix_t), intent(inout) :: state
	type(state_matrix_t), intent(in) :: state1
	if (.not. allocated (state1%me)) return
	if (.not. allocated (state%me)) allocate (state%me (size (state1%me)))
	state%me = state1%me
	end subroutine state_matrix_set_matrix_element_clone

	@ %def state_matrix_set_matrix_element_clone
	@ Add a value to a matrix element
	<<State matrices: state matrix: TBP>>=
	procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element
	<<State matrices: procedures>>=
	subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor)
	class(state_matrix_t), intent(inout), target :: state
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	complex(default), intent(in) :: value
	logical, intent(in), optional :: match_only_flavor
	type(state_iterator_t) :: it
	call it%init (state)
	call it%go_to_qn (qn, match_only_flavor)
	if (it%is_valid ()) then
	call it%add_to_matrix_element (value)
	else
	call msg_fatal ("Cannot add to matrix element - it%node not allocated")
	end if
	end subroutine state_matrix_add_to_matrix_element

	@ %def state_matrix_add_to_matrix_element
	@
	\subsection{State iterators}
	Accessing the quantum state from outside is best done using a
	specialized iterator, i.e., a pointer to a particular branch of the
	quantum state trie. Technically, the iterator contains a pointer to a
	leaf node, but via parent pointers it allows to access the whole
	branch where the leaf is attached. For quick access, we also keep the
	branch depth (which is assumed to be universal for a quantum state).
	<<State matrices: public>>=
	public :: state_iterator_t
	<<State matrices: types>>=
	type :: state_iterator_t
	private
	integer :: depth = 0
	type(state_matrix_t), pointer :: state => null ()
	type(node_t), pointer :: node => null ()
	contains
	<<State matrices: state iterator: TBP>>
	end type state_iterator_t

	@ %def state_iterator
	@ The initializer: Point at the first branch. Note that this cannot
	be pure, thus not be elemental, because the iterator can be used to
	manipulate data in the state matrix.
	<<State matrices: state iterator: TBP>>=
	procedure :: init => state_iterator_init
	<<State matrices: procedures>>=
	subroutine state_iterator_init (it, state)
	class(state_iterator_t), intent(out) :: it
	type(state_matrix_t), intent(in), target :: state
	it%state => state
	it%depth = state%depth
	if (state%is_defined ()) then
	it%node => state%root
	do while (associated (it%node%child_first))
	it%node => it%node%child_first
	end do
	else
	it%node => null ()
	end if
	end subroutine state_iterator_init

	@ %def state_iterator_init
	@ Go forward. Recursively programmed: if the next node does not
	exist, go back to the parent node and look at its successor (if
	present), etc.

	There is a possible pitfall in the implementation: If the dummy
	pointer argument to the [[find_next]] routine is used directly, we
	still get the correct result for the iterator, but calling the
	recursion on [[node%parent]] means that we manipulate a parent pointer
	in the original state in addition to the iterator. Making a local
	copy of the pointer avoids this. Using pointer intent would be
	helpful, but we do not yet rely on this F2003 feature.
	<<State matrices: state iterator: TBP>>=
	procedure :: advance => state_iterator_advance
	<<State matrices: procedures>>=
	subroutine state_iterator_advance (it)
	class(state_iterator_t), intent(inout) :: it
	call find_next (it%node)
	contains
	recursive subroutine find_next (node_in)
	type(node_t), intent(in), target :: node_in
	type(node_t), pointer :: node
	node => node_in
	if (associated (node%next)) then
	node => node%next
	do while (associated (node%child_first))
	node => node%child_first
	end do
	it%node => node
	else if (associated (node%parent)) then
	call find_next (node%parent)
	else
	it%node => null ()
	end if
	end subroutine find_next
	end subroutine state_iterator_advance

	@ %def state_iterator_advance
	@ If all has been scanned, the iterator is at an undefined state.
	Check for this:
	<<State matrices: state iterator: TBP>>=
	procedure :: is_valid => state_iterator_is_valid
	<<State matrices: procedures>>=
	function state_iterator_is_valid (it) result (defined)
	logical :: defined
	class(state_iterator_t), intent(in) :: it
	defined = associated (it%node)
	end function state_iterator_is_valid

	@ %def state_iterator_is_valid
	@ Return the matrix-element index that corresponds to the current node
	<<State matrices: state iterator: TBP>>=
	procedure :: get_me_index => state_iterator_get_me_index
	<<State matrices: procedures>>=
	function state_iterator_get_me_index (it) result (n)
	integer :: n
	class(state_iterator_t), intent(in) :: it
	n = it%node%me_index
	end function state_iterator_get_me_index

	@ %def state_iterator_get_me_index
	@ Return the number of times this quantum-number state has been added
	(noting that it is physically inserted only the first time). Note
	that for each state, there is an array of counters.
	<<State matrices: state iterator: TBP>>=
	procedure :: get_me_count => state_iterator_get_me_count
	<<State matrices: procedures>>=
	function state_iterator_get_me_count (it) result (n)
	integer, dimension(:), allocatable :: n
	class(state_iterator_t), intent(in) :: it
	if (allocated (it%node%me_count)) then
	allocate (n (size (it%node%me_count)))
	n = it%node%me_count
	else
	allocate (n (0))
	end if
	end function state_iterator_get_me_count

	@ %def state_iterator_get_me_count
	@
	<<State matrices: state iterator: TBP>>=
	procedure :: get_depth => state_iterator_get_depth
	<<State matrices: procedures>>=
	pure function state_iterator_get_depth (state_iterator) result (depth)
	integer :: depth
	class(state_iterator_t), intent(in) :: state_iterator
	depth = state_iterator%depth
	end function state_iterator_get_depth

	@ %def state_iterator_get_depth
	@ Proceed to the state associated with the quantum numbers [[qn]].
	<<State matrices: state iterator: TBP>>=
	procedure :: go_to_qn => state_iterator_go_to_qn
	<<State matrices: procedures>>=
	subroutine state_iterator_go_to_qn (it, qn, match_only_flavor)
	class(state_iterator_t), intent(inout) :: it
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	logical, intent(in), optional :: match_only_flavor
	logical :: match_flv
	match_flv = .false.; if (present (match_only_flavor)) match_flv = .true.
	do while (it%is_valid ())
	if (match_flv) then
	if (all (qn .fmatch. it%get_quantum_numbers ())) then
	return
	else
	call it%advance ()
	end if
	else
	if (all (qn == it%get_quantum_numbers ())) then
	return
	else
	call it%advance ()
	end if
	end if
	end do
	end subroutine state_iterator_go_to_qn

	@ %def state_iterator_go_to_qn
	@ Use the iterator to retrieve quantum-number information:
	<<State matrices: state iterator: TBP>>=
	generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, &
	get_qn_range, get_qn_single
	generic :: get_flavor => get_flv_multi, get_flv_slice, &
	get_flv_range, get_flv_single
	generic :: get_color => get_col_multi, get_col_slice, &
	get_col_range, get_col_single
	generic :: get_helicity => get_hel_multi, get_hel_slice, &
	get_hel_range, get_hel_single
	<<State matrices: state iterator: TBP>>=
	procedure :: get_qn_multi => state_iterator_get_qn_multi
	procedure :: get_qn_slice => state_iterator_get_qn_slice
	procedure :: get_qn_range => state_iterator_get_qn_range
	procedure :: get_qn_single => state_iterator_get_qn_single
	procedure :: get_flv_multi => state_iterator_get_flv_multi
	procedure :: get_flv_slice => state_iterator_get_flv_slice
	procedure :: get_flv_range => state_iterator_get_flv_range
	procedure :: get_flv_single => state_iterator_get_flv_single
	procedure :: get_col_multi => state_iterator_get_col_multi
	procedure :: get_col_slice => state_iterator_get_col_slice
	procedure :: get_col_range => state_iterator_get_col_range
	procedure :: get_col_single => state_iterator_get_col_single
	procedure :: get_hel_multi => state_iterator_get_hel_multi
	procedure :: get_hel_slice => state_iterator_get_hel_slice
	procedure :: get_hel_range => state_iterator_get_hel_range
	procedure :: get_hel_single => state_iterator_get_hel_single
	@ These versions return the whole quantum number array
	<<State matrices: procedures>>=
	function state_iterator_get_qn_multi (it) result (qn)
	class(state_iterator_t), intent(in) :: it
	type(quantum_numbers_t), dimension(it%depth) :: qn
	type(node_t), pointer :: node
	integer :: i
	node => it%node
	do i = it%depth, 1, -1
	qn(i) = node%qn
	node => node%parent
	end do
	end function state_iterator_get_qn_multi

	function state_iterator_get_flv_multi (it) result (flv)
	class(state_iterator_t), intent(in) :: it
	type(flavor_t), dimension(it%depth) :: flv
	flv = quantum_numbers_get_flavor &
	(it%get_quantum_numbers ())
	end function state_iterator_get_flv_multi

	function state_iterator_get_col_multi (it) result (col)
	class(state_iterator_t), intent(in) :: it
	type(color_t), dimension(it%depth) :: col
	col = quantum_numbers_get_color &
	(it%get_quantum_numbers ())
	end function state_iterator_get_col_multi

	function state_iterator_get_hel_multi (it) result (hel)
	class(state_iterator_t), intent(in) :: it
	type(helicity_t), dimension(it%depth) :: hel
	hel = quantum_numbers_get_helicity &
	(it%get_quantum_numbers ())
	end function state_iterator_get_hel_multi

	@ An array slice (derived from the above).
	<<State matrices: procedures>>=
	function state_iterator_get_qn_slice (it, index) result (qn)
	class(state_iterator_t), intent(in) :: it
	integer, dimension(:), intent(in) :: index
	type(quantum_numbers_t), dimension(size(index)) :: qn
	type(quantum_numbers_t), dimension(it%depth) :: qn_tmp
	qn_tmp = state_iterator_get_qn_multi (it)
	qn = qn_tmp(index)
	end function state_iterator_get_qn_slice

	function state_iterator_get_flv_slice (it, index) result (flv)
	class(state_iterator_t), intent(in) :: it
	integer, dimension(:), intent(in) :: index
	type(flavor_t), dimension(size(index)) :: flv
	flv = quantum_numbers_get_flavor &
	(it%get_quantum_numbers (index))
	end function state_iterator_get_flv_slice

	function state_iterator_get_col_slice (it, index) result (col)
	class(state_iterator_t), intent(in) :: it
	integer, dimension(:), intent(in) :: index
	type(color_t), dimension(size(index)) :: col
	col = quantum_numbers_get_color &
	(it%get_quantum_numbers (index))
	end function state_iterator_get_col_slice

	function state_iterator_get_hel_slice (it, index) result (hel)
	class(state_iterator_t), intent(in) :: it
	integer, dimension(:), intent(in) :: index
	type(helicity_t), dimension(size(index)) :: hel
	hel = quantum_numbers_get_helicity &
	(it%get_quantum_numbers (index))
	end function state_iterator_get_hel_slice

	@ An array range (implemented directly).
	<<State matrices: procedures>>=
	function state_iterator_get_qn_range (it, k1, k2) result (qn)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k1, k2
	type(quantum_numbers_t), dimension(k2-k1+1) :: qn
	type(node_t), pointer :: node
	integer :: i
	node => it%node
	SCAN: do i = it%depth, 1, -1
	if (k1 <= i .and. i <= k2) then
	qn(i-k1+1) = node%qn
	else
	node => node%parent
	end if
	end do SCAN
	end function state_iterator_get_qn_range

	function state_iterator_get_flv_range (it, k1, k2) result (flv)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k1, k2
	type(flavor_t), dimension(k2-k1+1) :: flv
	flv = quantum_numbers_get_flavor &
	(it%get_quantum_numbers (k1, k2))
	end function state_iterator_get_flv_range

	function state_iterator_get_col_range (it, k1, k2) result (col)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k1, k2
	type(color_t), dimension(k2-k1+1) :: col
	col = quantum_numbers_get_color &
	(it%get_quantum_numbers (k1, k2))
	end function state_iterator_get_col_range

	function state_iterator_get_hel_range (it, k1, k2) result (hel)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k1, k2
	type(helicity_t), dimension(k2-k1+1) :: hel
	hel = quantum_numbers_get_helicity &
	(it%get_quantum_numbers (k1, k2))
	end function state_iterator_get_hel_range

	@ Just a specific single element
	<<State matrices: procedures>>=
	function state_iterator_get_qn_single (it, k) result (qn)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k
	type(quantum_numbers_t) :: qn
	type(node_t), pointer :: node
	integer :: i
	node => it%node
	SCAN: do i = it%depth, 1, -1
	if (i == k) then
	qn = node%qn
	exit SCAN
	else
	node => node%parent
	end if
	end do SCAN
	end function state_iterator_get_qn_single

	function state_iterator_get_flv_single (it, k) result (flv)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k
	type(flavor_t) :: flv
	flv = quantum_numbers_get_flavor &
	(it%get_quantum_numbers (k))
	end function state_iterator_get_flv_single

	function state_iterator_get_col_single (it, k) result (col)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k
	type(color_t) :: col
	col = quantum_numbers_get_color &
	(it%get_quantum_numbers (k))
	end function state_iterator_get_col_single

	function state_iterator_get_hel_single (it, k) result (hel)
	class(state_iterator_t), intent(in) :: it
	integer, intent(in) :: k
	type(helicity_t) :: hel
	hel = quantum_numbers_get_helicity &
	(it%get_quantum_numbers (k))
	end function state_iterator_get_hel_single

	@ %def state_iterator_get_quantum_numbers
	@ %def state_iterator_get_flavor
	@ %def state_iterator_get_color
	@ %def state_iterator_get_helicity
	@ Assign a model pointer to the current flavor entries.
	<<State matrices: state iterator: TBP>>=
	procedure :: set_model => state_iterator_set_model
	<<State matrices: procedures>>=
	subroutine state_iterator_set_model (it, model)
	class(state_iterator_t), intent(inout) :: it
	class(model_data_t), intent(in), target :: model
	type(node_t), pointer :: node
	integer :: i
	node => it%node
	do i = it%depth, 1, -1
	call node%qn%set_model (model)
	node => node%parent
	end do
	end subroutine state_iterator_set_model

	@ %def state_iterator_set_model
	@ Retrieve the matrix element value associated with the current node.
	<<State matrices: state iterator: TBP>>=
	procedure :: get_matrix_element => state_iterator_get_matrix_element
	<<State matrices: procedures>>=
	function state_iterator_get_matrix_element (it) result (me)
	complex(default) :: me
	class(state_iterator_t), intent(in) :: it
	if (it%state%leaf_nodes_store_values) then
	me = it%node%me
	else if (it%node%me_index /= 0) then
	me = it%state%me(it%node%me_index)
	else
	me = 0
	end if
	end function state_iterator_get_matrix_element

	@ %def state_iterator_get_matrix_element
	@ Set the matrix element value using the state iterator.
	<<State matrices: state iterator: TBP>>=
	procedure :: set_matrix_element => state_iterator_set_matrix_element
	<<State matrices: procedures>>=
	subroutine state_iterator_set_matrix_element (it, value)
	class(state_iterator_t), intent(inout) :: it
	complex(default), intent(in) :: value
	if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value
	end subroutine state_iterator_set_matrix_element

	@ %def state_iterator_set_matrix_element
	@
	<<State matrices: state iterator: TBP>>=
	procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element
	<<State matrices: procedures>>=
	subroutine state_iterator_add_to_matrix_element (it, value)
	class(state_iterator_t), intent(inout) :: it
	complex(default), intent(in) :: value
	if (it%node%me_index /= 0) &
	it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value
	end subroutine state_iterator_add_to_matrix_element

	@ %def state_iterator_add_to_matrix_element
	@
	\subsection{Operations on quantum states}
	Return a deep copy of a state matrix.
	<<State matrices: public>>=
	public :: assignment(=)
	<<State matrices: interfaces>>=
	interface assignment(=)
	module procedure state_matrix_assign
	end interface

	<<State matrices: procedures>>=
	subroutine state_matrix_assign (state_out, state_in)
	type(state_matrix_t), intent(out) :: state_out
	type(state_matrix_t), intent(in), target :: state_in
	type(state_iterator_t) :: it
	if (.not. state_in%is_defined ()) return
	call state_out%init ()
	call it%init (state_in)
	do while (it%is_valid ())
	call state_out%add_state (it%get_quantum_numbers (), &
	it%get_me_index ())
	call it%advance ()
	end do
	if (allocated (state_in%me)) then
	allocate (state_out%me (size (state_in%me)))
	state_out%me = state_in%me
	end if
	state_out%n_sub = state_in%n_sub
	end subroutine state_matrix_assign

	@ %def state_matrix_assign
	@ Determine the indices of all diagonal matrix elements.
	<<State matrices: state matrix: TBP>>=
	procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries
	<<State matrices: procedures>>=
	subroutine state_matrix_get_diagonal_entries (state, i)
	class(state_matrix_t), intent(in) :: state
	integer, dimension(:), allocatable, intent(out) :: i
	integer, dimension(state%n_matrix_elements) :: tmp
	integer :: n
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	n = 0
	call it%init (state)
	allocate (qn (it%depth))
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	if (all (qn%are_diagonal ())) then
	n = n + 1
	tmp(n) = it%get_me_index ()
	end if
	call it%advance ()
	end do
	allocate (i(n))
	if (n > 0) i = tmp(:n)
	end subroutine state_matrix_get_diagonal_entries

	@ %def state_matrices_get_diagonal_entries
	@ Normalize all matrix elements, i.e., multiply by a common factor.
	Assuming that the factor is nonzero, of course.
	<<State matrices: state matrix: TBP>>=
	procedure :: renormalize => state_matrix_renormalize
	<<State matrices: procedures>>=
	subroutine state_matrix_renormalize (state, factor)
	class(state_matrix_t), intent(inout) :: state
	complex(default), intent(in) :: factor
	state%me = state%me * factor
	end subroutine state_matrix_renormalize

	@ %def state_matrix_renormalize
	@ Renormalize the state matrix by its trace, if nonzero. The renormalization
	is reflected in the state-matrix norm.
	<<State matrices: state matrix: TBP>>=
	procedure :: normalize_by_trace => state_matrix_normalize_by_trace
	<<State matrices: procedures>>=
	subroutine state_matrix_normalize_by_trace (state)
	class(state_matrix_t), intent(inout) :: state
	real(default) :: trace
	trace = state%trace ()
	if (trace /= 0) then
	state%me = state%me / trace
	state%norm = state%norm * trace
	end if
	end subroutine state_matrix_normalize_by_trace

	@ %def state_matrix_renormalize_by_trace
	@ Analogous, but renormalize by maximal (absolute) value.
	<<State matrices: state matrix: TBP>>=
	procedure :: normalize_by_max => state_matrix_normalize_by_max
	<<State matrices: procedures>>=
	subroutine state_matrix_normalize_by_max (state)
	class(state_matrix_t), intent(inout) :: state
	real(default) :: m
	m = maxval (abs (state%me))
	if (m /= 0) then
	state%me = state%me / m
	state%norm = state%norm * m
	end if
	end subroutine state_matrix_normalize_by_max

	@ %def state_matrix_renormalize_by_max
	@ Explicitly set the norm of a state matrix.
	<<State matrices: state matrix: TBP>>=
	procedure :: set_norm => state_matrix_set_norm
	<<State matrices: procedures>>=
	subroutine state_matrix_set_norm (state, norm)
	class(state_matrix_t), intent(inout) :: state
	real(default), intent(in) :: norm
	state%norm = norm
	end subroutine state_matrix_set_norm

	@ %def state_matrix_set_norm
	@ Return the sum of all matrix element values.
	<<State matrices: state matrix: TBP>>=
	procedure :: sum => state_matrix_sum
	<<State matrices: procedures>>=
	pure function state_matrix_sum (state) result (value)
	complex(default) :: value
	class(state_matrix_t), intent(in) :: state
	value = sum (state%me)
	end function state_matrix_sum

	@ %def state_matrix_sum
	@ Return the trace of a state matrix, i.e., the sum over all diagonal
	values.

	If [[qn_in]] is provided, only branches that match this
	quantum-numbers array in flavor and helicity are considered. (This mode is
	used for selecting a color state.)
	<<State matrices: state matrix: TBP>>=
	procedure :: trace => state_matrix_trace
	<<State matrices: procedures>>=
	function state_matrix_trace (state, qn_in) result (trace)
	complex(default) :: trace
	class(state_matrix_t), intent(in), target :: state
	type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	type(state_iterator_t) :: it
	allocate (qn (state%get_depth ()))
	trace = 0
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	if (present (qn_in)) then
	if (.not. all (qn .fhmatch. qn_in)) then
	call it%advance (); cycle
	end if
	end if
	if (all (qn%are_diagonal ())) then
	trace = trace + it%get_matrix_element ()
	end if
	call it%advance ()
	end do
	end function state_matrix_trace

	@ %def state_matrix_trace
	@ Append new states which are color-contracted versions of the
	existing states. The matrix element index of each color contraction
	coincides with the index of its origin, so no new matrix elements are
	generated. After this operation, no [[freeze]] must be performed
	anymore.
	<<State matrices: state matrix: TBP>>=
	procedure :: add_color_contractions => state_matrix_add_color_contractions
	<<State matrices: procedures>>=
	subroutine state_matrix_add_color_contractions (state)
	class(state_matrix_t), intent(inout), target :: state
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con
	integer, dimension(:), allocatable :: me_index
	integer :: depth, n_me, i, j
	depth = state%get_depth ()
	n_me = state%get_n_matrix_elements ()
	allocate (qn (depth, n_me))
	allocate (me_index (n_me))
	i = 0
	call it%init (state)
	do while (it%is_valid ())
	i = i + 1
	qn(:,i) = it%get_quantum_numbers ()
	me_index(i) = it%get_me_index ()
	call it%advance ()
	end do
	do i = 1, n_me
	call quantum_number_array_make_color_contractions (qn(:,i), qn_con)
	do j = 1, size (qn_con, 2)
	call state%add_state (qn_con(:,j), index = me_index(i))
	end do
	end do
	end subroutine state_matrix_add_color_contractions

	@ %def state_matrix_add_color_contractions
	@ This procedure merges two state matrices of equal depth. For each
	quantum number (flavor, color, helicity), we take the entry from the
	first argument where defined, otherwise the second one. (If both are
	defined, we get an off-diagonal matrix.) The resulting
	trie combines the information of the input tries in all possible ways.
	Note that values are ignored, all values in the result are zero.
	<<State matrices: public>>=
	public :: merge_state_matrices
	<<State matrices: procedures>>=
	subroutine merge_state_matrices (state1, state2, state3)
	type(state_matrix_t), intent(in), target :: state1, state2
	type(state_matrix_t), intent(out) :: state3
	type(state_iterator_t) :: it1, it2
	type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2
	if (state1%depth /= state2%depth) then
	call state1%write ()
	call state2%write ()
	call msg_bug ("State matrices merge impossible: incompatible depths")
	end if
	call state3%init ()
	call it1%init (state1)
	do while (it1%is_valid ())
	qn1 = it1%get_quantum_numbers ()
	call it2%init (state2)
	do while (it2%is_valid ())
	qn2 = it2%get_quantum_numbers ()
	call state3%add_state (qn1 .merge. qn2)
	call it2%advance ()
	end do
	call it1%advance ()
	end do
	call state3%freeze ()
	end subroutine merge_state_matrices

	@ %def merge_state_matrices
	@ Multiply matrix elements from two state matrices. Choose the elements
	as given by the integer index arrays, multiply them and store the sum
	of products in the indicated matrix element. The suffixes mean:
	c=conjugate first factor; f=include weighting factor.

	Note that the [[dot_product]] intrinsic function conjugates its first
	complex argument. This is intended for the [[c]] suffix case, but
	must be reverted for the plain-product case.

	We provide analogous subroutines for just summing over state matrix
	entries. The [[evaluate_sum]] variant includes the state-matrix norm
	in the evaluation, the [[evaluate_me_sum]] takes into account just the
	matrix elements proper.
	<<State matrices: state matrix: TBP>>=
	procedure :: evaluate_product => state_matrix_evaluate_product
	procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf
	procedure :: evaluate_square_c => state_matrix_evaluate_square_c
	procedure :: evaluate_sum => state_matrix_evaluate_sum
	procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum
	<<State matrices: procedures>>=
	pure subroutine state_matrix_evaluate_product &
	(state, i, state1, state2, index1, index2)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	type(state_matrix_t), intent(in) :: state1, state2
	integer, dimension(:), intent(in) :: index1, index2
	state%me(i) = &
	dot_product (conjg (state1%me(index1)), state2%me(index2))
	state%norm = state1%norm * state2%norm
	end subroutine state_matrix_evaluate_product

	pure subroutine state_matrix_evaluate_product_cf &
	(state, i, state1, state2, index1, index2, factor)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	type(state_matrix_t), intent(in) :: state1, state2
	integer, dimension(:), intent(in) :: index1, index2
	complex(default), dimension(:), intent(in) :: factor
	state%me(i) = &
	dot_product (state1%me(index1), factor * state2%me(index2))
	state%norm = state1%norm * state2%norm
	end subroutine state_matrix_evaluate_product_cf

	pure subroutine state_matrix_evaluate_square_c (state, i, state1, index1)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	type(state_matrix_t), intent(in) :: state1
	integer, dimension(:), intent(in) :: index1
	state%me(i) = &
	dot_product (state1%me(index1), state1%me(index1))
	state%norm = abs (state1%norm) ** 2
	end subroutine state_matrix_evaluate_square_c

	pure subroutine state_matrix_evaluate_sum (state, i, state1, index1)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	type(state_matrix_t), intent(in) :: state1
	integer, dimension(:), intent(in) :: index1
	state%me(i) = &
	sum (state1%me(index1)) * state1%norm
	end subroutine state_matrix_evaluate_sum

	pure subroutine state_matrix_evaluate_me_sum (state, i, state1, index1)
	class(state_matrix_t), intent(inout) :: state
	integer, intent(in) :: i
	type(state_matrix_t), intent(in) :: state1
	integer, dimension(:), intent(in) :: index1
	state%me(i) = sum (state1%me(index1))
	end subroutine state_matrix_evaluate_me_sum

	@ %def state_matrix_evaluate_product
	@ %def state_matrix_evaluate_product_cf
	@ %def state_matrix_evaluate_square_c
	@ %def state_matrix_evaluate_sum
	@ %def state_matrix_evaluate_me_sum
	@ Outer product (of states and matrix elements):
	<<State matrices: public>>=
	public :: outer_multiply
	<<State matrices: interfaces>>=
	interface outer_multiply
	module procedure outer_multiply_pair
	module procedure outer_multiply_array
	end interface

	@ %def outer_multiply
	@ This procedure constructs the outer product of two state matrices.
	<<State matrices: procedures>>=
	subroutine outer_multiply_pair (state1, state2, state3)
	type(state_matrix_t), intent(in), target :: state1, state2
	type(state_matrix_t), intent(out) :: state3
	type(state_iterator_t) :: it1, it2
	type(quantum_numbers_t), dimension(state1%depth) :: qn1
	type(quantum_numbers_t), dimension(state2%depth) :: qn2
	type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3
	complex(default) :: val1, val2
	call state3%init (store_values = .true.)
	call it1%init (state1)
	do while (it1%is_valid ())
	qn1 = it1%get_quantum_numbers ()
	val1 = it1%get_matrix_element ()
	call it2%init (state2)
	do while (it2%is_valid ())
	qn2 = it2%get_quantum_numbers ()
	val2 = it2%get_matrix_element ()
	qn3(:state1%depth) = qn1
	qn3(state1%depth+1:) = qn2
	call state3%add_state (qn3, value=val1 * val2)
	call it2%advance ()
	end do
	call it1%advance ()
	end do
	call state3%freeze ()
	end subroutine outer_multiply_pair

	@ %def outer_multiply_state_pair
	@ This executes the above routine iteratively for an arbitrary number
	of state matrices.
	<<State matrices: procedures>>=
	subroutine outer_multiply_array (state_in, state_out)
	type(state_matrix_t), dimension(:), intent(in), target :: state_in
	type(state_matrix_t), intent(out) :: state_out
	type(state_matrix_t), dimension(:), allocatable, target :: state_tmp
	integer :: i, n
	n = size (state_in)
	select case (n)
	case (0)
	call state_out%init ()
	case (1)
	state_out = state_in(1)
	case (2)
	call outer_multiply_pair (state_in(1), state_in(2), state_out)
	case default
	allocate (state_tmp (n-2))
	call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1))
	do i = 2, n - 2
	call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i))
	end do
	call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out)
	do i = 1, size(state_tmp)
	call state_tmp(i)%final ()
	end do
	end select
	end subroutine outer_multiply_array

	@ %def outer_multiply_pair
	@ %def outer_multiply_array
	@
	\subsection{Factorization}
	In physical events, the state matrix is factorized into
	single-particle state matrices. This is essentially a measurement.

	In a simulation, we select one particular branch of the state matrix
	with a probability that is determined by the matrix elements at the
	leaves. (This makes sense only if the state matrix represents a
	squared amplitude.) The selection is based on a (random) value [[x]]
	between 0 and one that is provided as the third argument.

	For flavor and color, we select a unique value for each particle. For
	polarization, we have three options (modes). Option 1 is to drop
	helicity information altogether and sum over all diagonal helicities.
	Option 2 is to select a unique diagonal helicity in the same way as
	flavor and color. Option 3 is, for each particle, to trace over all
	remaining helicities in order to obtain an array of independent
	single-particle helicity matrices.

	Only branches that match the given quantum-number array [[qn_in]], if
	present, are considered. For this array, color is ignored.

	If the optional [[correlated_state]] is provided, it is assigned the
	correlated density matrix for the selected flavor-color branch, so
	multi-particle spin correlations remain available even if they are
	dropped in the single-particle density matrices. This should be
	done by the caller for the choice [[FM_CORRELATED_HELICITY]], which otherwise
	is handled as [[FM_IGNORE_HELICITY]].

	The algorithm is as follows: First, we determine the normalization by
	summing over all diagonal matrix elements. In a second scan, we
	select one of the diagonal matrix elements by a cumulative comparison
	with the normalized random number. In the corresponding quantum
	number array, we undefine the helicity entries. Then, we scan the
	third time. For each branch that matches the selected quantum number
	array (i.e., definite flavor and color, arbitrary helicity), we
	determine its contribution to any of the single-particle state
	matrices. The matrix-element value is added if all other quantum
	numbers are diagonal, while the helicity of the chosen particle may be
	arbitrary; this helicity determines the branch in the single-particle
	state.

	As a result, flavor and color quantum numbers are selected with the
	correct probability. Within this subset of states, each
	single-particle state matrix results from tracing over all other
	particles. Note that the single-particle state matrices are not
	normalized.

	The flag [[ok]] is set to false if the matrix element sum is zero, so
	factorization is not possible. This can happen if an event did not pass
	cuts.
	<<State matrices: parameters>>=
	integer, parameter, public :: FM_IGNORE_HELICITY = 1
	integer, parameter, public :: FM_SELECT_HELICITY = 2
	integer, parameter, public :: FM_FACTOR_HELICITY = 3
	integer, parameter, public :: FM_CORRELATED_HELICITY = 4

	@ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY
	@ %def FM_CORRELATED_HELICITY
	<<State matrices: state matrix: TBP>>=
	procedure :: factorize => state_matrix_factorize
	<<State matrices: procedures>>=
	subroutine state_matrix_factorize &
	(state, mode, x, ok, single_state, correlated_state, qn_in)
	class(state_matrix_t), intent(in), target :: state
	integer, intent(in) :: mode
	real(default), intent(in) :: x
	logical, intent(out) :: ok
	type(state_matrix_t), &
	dimension(:), allocatable, intent(out) :: single_state
	type(state_matrix_t), intent(out), optional :: correlated_state
	type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
	type(state_iterator_t) :: it
	real(default) :: s, xt
	complex(default) :: value
	integer :: i, depth
	type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	logical, dimension(:), allocatable :: diagonal
	logical, dimension(:,:), allocatable :: mask
	ok = .true.
	if (x /= 0) then
	xt = x * abs (state%trace (qn_in))
	else
	xt = 0
	end if
	s = 0
	depth = state%get_depth ()
	allocate (qn (depth), qn1 (depth), diagonal (depth))
	call it%init (state)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	if (present (qn_in)) then
	if (.not. all (qn .fhmatch. qn_in)) then
	call it%advance (); cycle
	end if
	end if
	if (all (qn%are_diagonal ())) then
	value = abs (it%get_matrix_element ())
	s = s + value
	if (s > xt) exit
	end if
	call it%advance ()
	end do
	if (.not. it%is_valid ()) then
	if (s == 0) ok = .false.
	call it%init (state)
	end if
	allocate (single_state (depth))
	do i = 1, depth
	call single_state(i)%init (store_values = .true.)
	end do
	if (present (correlated_state)) &
	call correlated_state%init (store_values = .true.)
	qn = it%get_quantum_numbers ()
	select case (mode)
	case (FM_SELECT_HELICITY) ! single branch selected; shortcut
	do i = 1, depth
	call single_state(i)%add_state ([qn(i)], value=value)
	end do
	if (.not. present (correlated_state)) then
	do i = 1, size(single_state)
	call single_state(i)%freeze ()
	end do
	return
	end if
	end select
	allocate (qn_mask (depth))
	call qn_mask%init (.false., .false., .false., .true.)
	call qn%undefine (qn_mask)
	select case (mode)
	case (FM_FACTOR_HELICITY)
	allocate (mask (depth, depth))
	mask = .false.
	forall (i = 1:depth) mask(i,i) = .true.
	end select
	call it%init (state)
	do while (it%is_valid ())
	qn1 = it%get_quantum_numbers ()
	if (all (qn .match. qn1)) then
	diagonal = qn1%are_diagonal ()
	value = it%get_matrix_element ()
	select case (mode)
	case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY)
	!!! trace over diagonal states that match qn
	if (all (diagonal)) then
	do i = 1, depth
	call single_state(i)%add_state &
	([qn(i)], value=value, sum_values=.true.)
	end do
	end if
	case (FM_FACTOR_HELICITY) !!! trace over all other particles
	do i = 1, depth
	if (all (diagonal .or. mask(:,i))) then
	call single_state(i)%add_state &
	([qn1(i)], value=value, sum_values=.true.)
	end if
	end do
	end select
	if (present (correlated_state)) &
	call correlated_state%add_state (qn1, value=value)
	end if
	call it%advance ()
	end do
	do i = 1, depth
	call single_state(i)%freeze ()
	end do
	if (present (correlated_state)) &
	call correlated_state%freeze ()
	end subroutine state_matrix_factorize

	@ %def state_matrix_factorize
	@
	\subsubsection{Auxiliary functions}
	<<State matrices: state matrix: TBP>>=
	procedure :: get_polarization_density_matrix &
	=> state_matrix_get_polarization_density_matrix
	<<State matrices: procedures>>=
	function state_matrix_get_polarization_density_matrix (state) result (pol_matrix)
	real(default), dimension(:,:), allocatable :: pol_matrix
	class(state_matrix_t), intent(in) :: state
	type(node_t), pointer :: current => null ()
	!!! What's the generic way to allocate the matrix?
	allocate (pol_matrix (4,4)); pol_matrix = 0
	if (associated (state%root%child_first)) then
	current => state%root%child_first
	do while (associated (current))
	call current%qn%write ()
	current => current%next
	end do
	else
	call msg_fatal ("Polarization state not allocated!")
	end if
	end function state_matrix_get_polarization_density_matrix

	@ %def state_matrix_get_polarization_density_matrix
	@
	\subsubsection{Quantum-number matching}
	This feature allows us to check whether a given string of PDG values
	matches, in any ordering, any of the flavor combinations that the
	state matrix provides. We will also request the permutation of the
	successful match.

	This type provides an account of the state's flavor content. We store
	all flavor combinations, as [[pdg]] values, in an array, assuming that
	the length is uniform.

	We check only the entries selected by [[mask_match]]. Among those,
	only the entries selected by [[mask_sort]] are sorted and thus matched
	without respecting array element order. The entries that correspond to
	a true value in the associated [[mask]] are sorted. The mapping from
	the original state to the sorted state is given by the index array
	[[map]].
	<<State matrices: public>>=
	public :: state_flv_content_t
	<<State matrices: types>>=
	type :: state_flv_content_t
	private
	integer, dimension(:,:), allocatable :: pdg
	integer, dimension(:,:), allocatable :: map
	logical, dimension(:), allocatable :: mask
	contains
	<<State matrices: state flv content: TBP>>
	end type state_flv_content_t

	@ %def state_matrix_flavor_content
	@ Output (debugging aid).
	<<State matrices: state flv content: TBP>>=
	procedure :: write => state_flv_content_write
	<<State matrices: procedures>>=
	subroutine state_flv_content_write (state_flv, unit)
	class(state_flv_content_t), intent(in), target :: state_flv
	integer, intent(in), optional :: unit
	integer :: u, n, d, i, j
	u = given_output_unit (unit)
	d = size (state_flv%pdg, 1)
	n = size (state_flv%pdg, 2)
	do i = 1, n
	write (u, "(2x,'PDG =')", advance="no")
	do j = 1, d
	write (u, "(1x,I0)", advance="no") state_flv%pdg(j,i)
	end do
	write (u, "(' :: map = (')", advance="no")
	do j = 1, d
	write (u, "(1x,I0)", advance="no") state_flv%map(j,i)
	end do
	write (u, "(' )')")
	end do
	end subroutine state_flv_content_write

	@ %def state_flv_content_write
	@ Initialize with table length and mask. Each row of the [[map]]
	array, of length $d$, is initialized with $(0,1,\ldots,d)$.
	<<State matrices: state flv content: TBP>>=
	procedure :: init => state_flv_content_init
	<<State matrices: procedures>>=
	subroutine state_flv_content_init (state_flv, n, mask)
	class(state_flv_content_t), intent(out) :: state_flv
	integer, intent(in) :: n
	logical, dimension(:), intent(in) :: mask
	integer :: d, i
	d = size (mask)
	allocate (state_flv%pdg (d, n), source = 0)
	allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n))
	allocate (state_flv%mask (d), source = mask)
	end subroutine state_flv_content_init

	@ %def state_flv_content_init
	@ Manually fill the entries, one flavor set and mapping at a time.
	<<State matrices: state flv content: TBP>>=
	procedure :: set_entry => state_flv_content_set_entry
	<<State matrices: procedures>>=
	subroutine state_flv_content_set_entry (state_flv, i, pdg, map)
	class(state_flv_content_t), intent(inout) :: state_flv
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: pdg, map
	state_flv%pdg(:,i) = pdg
	where (map /= 0)
	state_flv%map(:,i) = map
	end where
	end subroutine state_flv_content_set_entry

	@ %def state_flv_content_set_entry
	@ Given a state matrix, determine the flavor content. That is, scan
	the state matrix and extract flavor only, build a new state matrix
	from that.
	<<State matrices: state flv content: TBP>>=
	procedure :: fill => state_flv_content_fill
	<<State matrices: procedures>>=
	subroutine state_flv_content_fill &
	(state_flv, state_full, mask)
	class(state_flv_content_t), intent(out) :: state_flv
	type(state_matrix_t), intent(in), target :: state_full
	logical, dimension(:), intent(in) :: mask
	type(state_matrix_t), target :: state_tmp
	type(state_iterator_t) :: it
	type(flavor_t), dimension(:), allocatable :: flv
	integer, dimension(:), allocatable :: pdg, pdg_subset
	integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: n, d, c, i, j
	call state_tmp%init ()
	d = state_full%get_depth ()
	allocate (flv (d), qn (d), pdg (d), idx (d), map (d))
	idx = [(i, i = 1, d)]
	c = count (mask)
	allocate (pdg_subset (c), map_subset (c), idx_subset (c))
	call it%init (state_full)
	do while (it%is_valid ())
	flv = it%get_flavor ()
	call qn%init (flv)
	call state_tmp%add_state (qn)
	call it%advance ()
	end do
	n = state_tmp%get_n_leaves ()
	call state_flv%init (n, mask)
	i = 0
	call it%init (state_tmp)
	do while (it%is_valid ())
	i = i + 1
	flv = it%get_flavor ()
	pdg = flv%get_pdg ()
	idx_subset = pack (idx, mask)
	pdg_subset = pack (pdg, mask)
	map_subset = order_abs (pdg_subset)
	map = unpack (idx_subset (map_subset), mask, idx)
	call state_flv%set_entry (i, &
	unpack (pdg_subset(map_subset), mask, pdg), &
	order (map))
	call it%advance ()
	end do
	call state_tmp%final ()
	end subroutine state_flv_content_fill

	@ %def state_flv_content_fill
	@ Match a given flavor string against the flavor content. We sort the
	input string and check whether it matches any of the stored strings.
	If yes, return the mapping.

	Only PDG entries under the preset mask are sorted before matching. The
	other entries must match exactly (i.e., without reordering). A zero
	entry matches anything. In any case, the length of the PDG string
	must be equal to the length $d$ of the individual flavor-state entries.
	<<State matrices: state flv content: TBP>>=
	procedure :: match => state_flv_content_match
	<<State matrices: procedures>>=
	subroutine state_flv_content_match (state_flv, pdg, success, map)
	class(state_flv_content_t), intent(in) :: state_flv
	integer, dimension(:), intent(in) :: pdg
	logical, intent(out) :: success
	integer, dimension(:), intent(out) :: map
	integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2
	integer, dimension(:), allocatable :: idx, map_subset, idx_subset
	integer :: i, n, c, d
	c = count (state_flv%mask)
	d = size (state_flv%pdg, 1)
	n = size (state_flv%pdg, 2)
	allocate (idx (d), source = [(i, i = 1, d)])
	allocate (idx_subset (c), pdg_subset (c), map_subset (c))
	allocate (pdg_sorted (d), map1 (d), map2 (d))
	idx_subset = pack (idx, state_flv%mask)
	pdg_subset = pack (pdg, state_flv%mask)
	map_subset = order_abs (pdg_subset)
	pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg)
	success = .false.
	do i = 1, n
	if (all (pdg_sorted == state_flv%pdg(:,i) &
	.or. pdg_sorted == 0)) then
	success = .true.
	exit
	end if
	end do
	if (success) then
	map1 = state_flv%map(:,i)
	map2 = unpack (idx_subset(map_subset), state_flv%mask, idx)
	map = map2(map1)
	where (pdg == 0) map = 0
	end if
	end subroutine state_flv_content_match

	@ %def state_flv_content_match
	@
	<<State matrices: procedures>>=
	elemental function pacify_complex (c_in) result (c_pac)
	complex(default), intent(in) :: c_in
	complex(default) :: c_pac
	c_pac = c_in
	if (real(c_pac) == -real(c_pac)) then
	c_pac = &
	cmplx (0._default, aimag(c_pac), kind=default)
	end if
	if (aimag(c_pac) == -aimag(c_pac)) then
	c_pac = &
	cmplx (real(c_pac), 0._default, kind=default)
	end if
	end function pacify_complex

	@ %def pacify_complex
	@
	\subsection{Unit tests}
	Test module, followed by the corresponding implementation module.
	<<[[state_matrices_ut.f90]]>>=
	<<File header>>

	module state_matrices_ut
	use unit_tests
	use state_matrices_uti

	<<Standard module head>>

	<<State matrices: public test>>

	contains

	<<State matrices: test driver>>

	end module state_matrices_ut
	@ %def state_matrices_ut
	@
	<<[[state_matrices_uti.f90]]>>=
	<<File header>>

	module state_matrices_uti

	<<Use kinds>>
	use io_units
	use format_defs, only: FMT_19
	use flavors
	use colors
	use helicities
	use quantum_numbers

	use state_matrices

	<<Standard module head>>

	<<State matrices: test declarations>>

	contains

	<<State matrices: tests>>

	end module state_matrices_uti
	@ %def state_matrices_ut
	@ API: driver for the unit tests below.
	<<State matrices: public test>>=
	public :: state_matrix_test
	<<State matrices: test driver>>=
	subroutine state_matrix_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<State matrices: execute tests>>
	end subroutine state_matrix_test

	@ %def state_matrix_test
	@ Create two quantum states of equal depth and merge them.
	<<State matrices: execute tests>>=
	call test (state_matrix_1, "state_matrix_1", &
	"check merge of quantum states of equal depth", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_1
	<<State matrices: tests>>=
	subroutine state_matrix_1 (u)
	integer, intent(in) :: u
	type(state_matrix_t) :: state1, state2, state3
	type(flavor_t), dimension(3) :: flv
	type(color_t), dimension(3) :: col
	type(quantum_numbers_t), dimension(3) :: qn

	write (u, "(A)") "* Test output: state_matrix_1"
	write (u, "(A)") "* Purpose: create and merge two quantum states"
	write (u, "(A)")

	write (u, "(A)") "* Initialization"
	write (u, "(A)")

	write (u, "(A)") "* State matrix 1"
	write (u, "(A)")

	call state1%init ()
	call flv%init ([1, 2, 11])
	call qn%init (flv, helicity ([ 1, 1, 1]))
	call state1%add_state (qn)
	call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1]))
	call state1%add_state (qn)
	call state1%freeze ()
	call state1%write (u)

	write (u, "(A)")
	write (u, "(A)") "* State matrix 2"
	write (u, "(A)")

	call state2%init ()
	call col(1)%init ([501])
	call col(2)%init ([-501])
	call col(3)%init ([0])
	call qn%init (col, helicity ([-1, -1, 0]))
	call state2%add_state (qn)
	call col(3)%init ([99])
	call qn%init (col, helicity ([-1, -1, 0]))
	call state2%add_state (qn)
	call state2%freeze ()
	call state2%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Merge the state matrices"
	write (u, "(A)")

	call merge_state_matrices (state1, state2, state3)
	call state3%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Collapse the state matrix"
	write (u, "(A)")

	call state3%collapse (quantum_numbers_mask (.false., .false., &
	[.true.,.false.,.false.]))
	call state3%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"
	write (u, "(A)")

	call state1%final ()
	call state2%final ()
	call state3%final ()

	write (u, "(A)")
	write (u, "(A)") "* Test output end: state_matrix_1"
	write (u, "(A)")

	end subroutine state_matrix_1

	@ %def state_matrix_1
	@ Create a correlated three-particle state matrix and factorize it.
	<<State matrices: execute tests>>=
	call test (state_matrix_2, "state_matrix_2", &
	"check factorizing 3-particle state matrix", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_2
	<<State matrices: tests>>=
	subroutine state_matrix_2 (u)
	integer, intent(in) :: u
	type(state_matrix_t) :: state
	type(state_matrix_t), dimension(:), allocatable :: single_state
	type(state_matrix_t) :: correlated_state
	integer :: f, h11, h12, h21, h22, i, mode
	type(flavor_t), dimension(2) :: flv
	type(color_t), dimension(2) :: col
	type(helicity_t), dimension(2) :: hel
	type(quantum_numbers_t), dimension(2) :: qn
	logical :: ok

	write (u, "(A)")
	write (u, "(A)") "* Test output: state_matrix_2"
	write (u, "(A)") "* Purpose: factorize correlated 3-particle state"
	write (u, "(A)")

	write (u, "(A)") "* Initialization"
	write (u, "(A)")

	call state%init ()
	do f = 1, 2
	do h11 = -1, 1, 2
	do h12 = -1, 1, 2
	do h21 = -1, 1, 2
	do h22 = -1, 1, 2
	call flv%init ([f, -f])
	call col(1)%init ([1])
	call col(2)%init ([-1])
	call hel%init ([h11,h12], [h21, h22])
	call qn%init (flv, col, hel)
	call state%add_state (qn)
	end do
	end do
	end do
	end do
	end do
	call state%freeze ()
	call state%write (u)

	write (u, "(A)")
	write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
	"* Trace = ", state%trace ()
	write (u, "(A)")

	do mode = 1, 3
	write (u, "(A)")
	write (u, "(A,I1)") "* Mode = ", mode
	call state%factorize &
	(mode, 0.15_default, ok, single_state, correlated_state)
	do i = 1, size (single_state)
	write (u, "(A)")
	call single_state(i)%write (u)
	write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
	"Trace = ", single_state(i)%trace ()
	end do
	write (u, "(A)")
	call correlated_state%write (u)
	write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
	"Trace = ", correlated_state%trace ()
	do i = 1, size(single_state)
	call single_state(i)%final ()
	end do
	call correlated_state%final ()
	end do

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	call state%final ()

	write (u, "(A)")
	write (u, "(A)") "* Test output end: state_matrix_2"

	end subroutine state_matrix_2

	@ %def state_matrix_2
	@ Create a colored state matrix and add color contractions.
	<<State matrices: execute tests>>=
	call test (state_matrix_3, "state_matrix_3", &
	"check factorizing 3-particle state matrix", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_3
	<<State matrices: tests>>=
	subroutine state_matrix_3 (u)
	use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET
	integer, intent(in) :: u
	type(state_matrix_t) :: state
	type(flavor_t), dimension(4) :: flv
	type(color_t), dimension(4) :: col
	type(quantum_numbers_t), dimension(4) :: qn

	write (u, "(A)") "* Test output: state_matrix_3"
	write (u, "(A)") "* Purpose: add color connections to colored state"
	write (u, "(A)")

	write (u, "(A)") "* Initialization"
	write (u, "(A)")

	call state%init ()
	call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ])
	call col(1)%init ([17])
	call col(2)%init ([-17])
	call col(3)%init ([-19])
	call col(4)%init ([19])
	call qn%init (flv, col)
	call state%add_state (qn)
	call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ])
	call col(1)%init ([17])
	call col(2)%init ([-17])
	call col(3)%init ([3, -5])
	call col(4)%init ([5, -3])
	call qn%init (flv, col)
	call state%add_state (qn)
	call state%freeze ()

	write (u, "(A)") "* State:"
	write (u, "(A)")

	call state%write (u)
	call state%add_color_contractions ()

	write (u, "(A)") "* State with contractions:"
	write (u, "(A)")

	call state%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	call state%final ()

	write (u, "(A)")
	write (u, "(A)") "* Test output end: state_matrx_3"

	end subroutine state_matrix_3

	@ %def state_matrix_3
	@ Create a correlated three-particle state matrix, write it to file
	and read again.
	<<State matrices: execute tests>>=
	call test (state_matrix_4, "state_matrix_4", &
	"check raw I/O", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_4
	<<State matrices: tests>>=
	subroutine state_matrix_4 (u)
	integer, intent(in) :: u
	type(state_matrix_t), allocatable :: state
	integer :: f, h11, h12, h21, h22, i
	type(flavor_t), dimension(2) :: flv
	type(color_t), dimension(2) :: col
	type(helicity_t), dimension(2) :: hel
	type(quantum_numbers_t), dimension(2) :: qn
	integer :: unit, iostat

	write (u, "(A)")
	write (u, "(A)") "* Test output: state_matrix_4"
	write (u, "(A)") "* Purpose: raw I/O for correlated 3-particle state"
	write (u, "(A)")

	write (u, "(A)") "* Initialization"
	write (u, "(A)")

	allocate (state)

	call state%init ()
	do f = 1, 2
	do h11 = -1, 1, 2
	do h12 = -1, 1, 2
	do h21 = -1, 1, 2
	do h22 = -1, 1, 2
	call flv%init ([f, -f])
	call col(1)%init ([1])
	call col(2)%init ([-1])
	call hel%init ([h11, h12], [h21, h22])
	call qn%init (flv, col, hel)
	call state%add_state (qn)
	end do
	end do
	end do
	end do
	end do
	call state%freeze ()

	call state%set_norm (3._default)
	do i = 1, state%get_n_leaves ()
	call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default))
	end do

	call state%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write to file and read again "
	write (u, "(A)")

	unit = free_unit ()
	open (unit, action="readwrite", form="unformatted", status="scratch")
	call state%write_raw (unit)
	call state%final ()
	deallocate (state)

	allocate(state)
	rewind (unit)
	call state%read_raw (unit, iostat=iostat)
	close (unit)

	call state%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	call state%final ()
	deallocate (state)

	write (u, "(A)")
	write (u, "(A)") "* Test output end: state_matrix_4"

	end subroutine state_matrix_4

	@ %def state_matrix_4
	@
	Create a flavor-content object for a given state matrix and match it
	against trial flavor (i.e., PDG) strings.
	<<State matrices: execute tests>>=
	call test (state_matrix_5, "state_matrix_5", &
	"check flavor content", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_5
	<<State matrices: tests>>=
	subroutine state_matrix_5 (u)
	integer, intent(in) :: u
	type(state_matrix_t), allocatable, target :: state
	type(state_iterator_t) :: it
	type(state_flv_content_t), allocatable :: state_flv
	type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4
	type(color_t), dimension(4) :: col1, col2
	type(helicity_t), dimension(4) :: hel1, hel2, hel3
	type(quantum_numbers_t), dimension(4) :: qn
	logical, dimension(4) :: mask

	write (u, "(A)") "* Test output: state_matrix_5"
	write (u, "(A)") "* Purpose: check flavor-content state"
	write (u, "(A)")

	write (u, "(A)") "* Set up arbitrary state matrix"
	write (u, "(A)")

	call flv1%init ([1, 4, 2, 7])
	call flv2%init ([1, 3,-3, 8])
	call flv3%init ([5, 6, 3, 7])
	call flv4%init ([6, 3, 5, 8])
	call hel1%init ([0, 1, -1, 0])
	call hel2%init ([0, 1, 1, 1])
	call hel3%init ([1, 0, 0, 0])
	call col1(1)%init ([0])
	call col1(2)%init ([0])
	call col1(3)%init ([0])
	call col1(4)%init ([0])
	call col2(1)%init ([5, -6])
	call col2(2)%init ([0])
	call col2(3)%init ([6, -5])
	call col2(4)%init ([0])

	allocate (state)
	call state%init ()
	call qn%init (flv1, col1, hel1)
	call state%add_state (qn)
	call qn%init (flv1, col1, hel2)
	call state%add_state (qn)
	call qn%init (flv3, col1, hel3)
	call state%add_state (qn)
	call qn%init (flv4, col1, hel3)
	call state%add_state (qn)
	call qn%init (flv1, col2, hel3)
	call state%add_state (qn)
	call qn%init (flv2, col2, hel2)
	call state%add_state (qn)
	call qn%init (flv2, col2, hel1)
	call state%add_state (qn)
	call qn%init (flv2, col1, hel1)
	call state%add_state (qn)
	call qn%init (flv3, col1, hel1)
	call state%add_state (qn)
	call qn%init (flv3, col2, hel3)
	call state%add_state (qn)
	call qn%init (flv1, col1, hel1)
	call state%add_state (qn)

	write (u, "(A)") "* Quantum number content"
	write (u, "(A)")

	call it%init (state)
	do while (it%is_valid ())
	call quantum_numbers_write (it%get_quantum_numbers (), u)
	write (u, *)
	call it%advance ()
	end do

	write (u, "(A)")
	write (u, "(A)") "* Extract the flavor content"
	write (u, "(A)")

	mask = [.true., .true., .true., .false.]

	allocate (state_flv)
	call state_flv%fill (state, mask)
	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Match trial sets"
	write (u, "(A)")

	call check ([1, 2, 3, 0])
	call check ([1, 4, 2, 0])
	call check ([4, 2, 1, 0])
	call check ([1, 3, -3, 0])
	call check ([1, -3, 3, 0])
	call check ([6, 3, 5, 0])

	write (u, "(A)")
	write (u, "(A)") "* Determine the flavor content with mask"
	write (u, "(A)")

	mask = [.false., .true., .true., .false.]

	call state_flv%fill (state, mask)
	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Match trial sets"
	write (u, "(A)")

	call check ([1, 2, 3, 0])
	call check ([1, 4, 2, 0])
	call check ([4, 2, 1, 0])
	call check ([1, 3, -3, 0])
	call check ([1, -3, 3, 0])
	call check ([6, 3, 5, 0])

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	deallocate (state_flv)

	call state%final ()
	deallocate (state)

	write (u, "(A)")
	write (u, "(A)") "* Test output end: state_matrix_5"

	contains

	subroutine check (pdg)
	integer, dimension(4), intent(in) :: pdg
	integer, dimension(4) :: map
	logical :: success
	call state_flv%match (pdg, success, map)
	write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no") pdg, success
	if (success) then
	write (u, "(2x,'map = (',4(1x,I0),' )')") map
	else
	write (u, *)
	end if
	end subroutine check

	end subroutine state_matrix_5

	@ %def state_matrix_5
	@
	Create a state matrix with full flavor, color and helicity information.
	Afterwards, reduce such that it is only differential in flavor and
	initial-state helicities. This is used when preparing states for beam-
	polarized computations with external matrix element providers.
	<<State matrices: execute tests>>=
	call test (state_matrix_6, "state_matrix_6", &
	"check state matrix reduction", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_6
	<<State matrices: tests>>=
	subroutine state_matrix_6 (u)
	integer, intent(in) :: u
	type(state_matrix_t), allocatable :: state_orig, state_reduced
	type(flavor_t), dimension(4) :: flv
	type(helicity_t), dimension(4) :: hel
	type(color_t), dimension(4) :: col
	type(quantum_numbers_t), dimension(4) :: qn
	type(quantum_numbers_mask_t), dimension(4) :: qn_mask
	integer :: h1, h2, h3 , h4
	integer :: n_states = 0

	write (u, "(A)") "* Test output: state_matrix_6"
	write (u, "(A)") "* Purpose: Check state matrix reduction"
	write (u, "(A)")

	write (u, "(A)") "* Set up helicity-diagonal state matrix"
	write (u, "(A)")

	allocate (state_orig)
	call state_orig%init ()

	call flv%init ([11, -11, 1, -1])
	call col(3)%init ([1])
	call col(4)%init ([-1])
	do h1 = -1, 1, 2
	do h2 = -1, 1, 2
	do h3 = -1, 1, 2
	do h4 = -1, 1, 2
	n_states = n_states + 1
	call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
	call qn%init (flv, col, hel)
	call state_orig%add_state (qn)
	end do
	end do
	end do
	end do
	call state_orig%freeze ()

	write (u, "(A)") "* Original state: "
	write (u, "(A)")
	call state_orig%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Setup quantum mask: "

	call qn_mask%init ([.false., .false., .false., .false.], &
	[.true., .true., .true., .true.], &
	[.false., .false., .true., .true.])
	call quantum_numbers_mask_write (qn_mask, u)
	write (u, "(A)")
	write (u, "(A)") "* Reducing the state matrix using above mask"
	write (u, "(A)")
	allocate (state_reduced)
	call state_orig%reduce (qn_mask, state_reduced)

	write (u, "(A)") "* Reduced state matrix: "
	call state_reduced%write (u)

	write (u, "(A)") "* Test output end: state_matrix_6"
	end subroutine state_matrix_6

	@ %def state_matrix_6
	@
	Create a state matrix with full flavor, color and helicity information.
	Afterwards, reduce such that it is only differential in flavor and
	initial-state helicities, and keeping old indices. Afterwards reorder the
	reduced state matrix in accordance to the original state matrix.
	<<State matrices: execute tests>>=
	call test (state_matrix_7, "state_matrix_7", &
	"check ordered state matrix reduction", &
	u, results)
	<<State matrices: test declarations>>=
	public :: state_matrix_7
	<<State matrices: tests>>=
	subroutine state_matrix_7 (u)
	integer, intent(in) :: u
	type(state_matrix_t), allocatable :: state_orig, state_reduced, &
	state_ordered
	type(flavor_t), dimension(4) :: flv
	type(helicity_t), dimension(4) :: hel
	type(color_t), dimension(4) :: col
	type(quantum_numbers_t), dimension(4) :: qn
	type(quantum_numbers_mask_t), dimension(4) :: qn_mask
	integer :: h1, h2, h3 , h4
	integer :: n_states = 0

	write (u, "(A)") "* Test output: state_matrix_7"
	write (u, "(A)") "* Purpose: Check ordered state matrix reduction"
	write (u, "(A)")

	write (u, "(A)") "* Set up helicity-diagonal state matrix"
	write (u, "(A)")

	allocate (state_orig)
	call state_orig%init ()

	call flv%init ([11, -11, 1, -1])
	call col(3)%init ([1])
	call col(4)%init ([-1])
	do h1 = -1, 1, 2
	do h2 = -1, 1, 2
	do h3 = -1, 1, 2
	do h4 = -1, 1, 2
	n_states = n_states + 1
	call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
	call qn%init (flv, col, hel)
	call state_orig%add_state (qn)
	end do
	end do
	end do
	end do
	call state_orig%freeze ()

	write (u, "(A)") "* Original state: "
	write (u, "(A)")
	call state_orig%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Setup quantum mask: "

	call qn_mask%init ([.false., .false., .false., .false.], &
	[.true., .true., .true., .true.], &
	[.false., .false., .true., .true.])
	call quantum_numbers_mask_write (qn_mask, u)
	write (u, "(A)")
	write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:"
	write (u, "(A)")
	allocate (state_reduced)
	call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.)

	write (u, "(A)") "* Reduced state matrix with kept indices: "
	call state_reduced%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Reordering reduced state matrix:"
	write (u, "(A)")
	allocate (state_ordered)
	call state_reduced%reorder_me (state_ordered)

	write (u, "(A)") "* Reduced and ordered state matrix:"
	call state_ordered%write (u)

	write (u, "(A)") "* Test output end: state_matrix_6"
	end subroutine state_matrix_7

	@ %def state_matrix_7
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Interactions}
	This module defines the [[interaction_t]] type. It is an extension of
	the [[state_matrix_t]] type.

	The state matrix is a representation of a multi-particle density
	matrix. It implements all possible flavor, color, and quantum-number
	assignments of the entries in a generic density matrix, and it can
	hold a complex matrix element for each entry. (Note that this matrix
	can hold non-diagonal entries in color and helicity space.) The
	[[interaction_t]] object associates this with a list of momenta, such
	that the whole object represents a multi-particle state.

	The [[interaction_t]] holds information about which particles are
	incoming, virtual (i.e., kept for the records), or outgoing. Each
	particle can be associated to a source within another interaction.
	This allows us to automatically fill those interaction momenta which
	have been computed or defined elsewhere. It also contains internal
	parent-child relations and flags for (virtual) particles which are to
	be treated as resonances.

	A quantum-number mask array summarizes, for each particle within the
	interaction, the treatment of flavor, color, or helicity (expose or
	ignore). A list of locks states which particles are bound to have an
	identical quantum-number mask. This is useful when the mask is
	changed at one place.
	<<[[interactions.f90]]>>=
	<<File header>>

	module interactions

	<<Use kinds>>
	use io_units
	use diagnostics
	- use pdg_arrays, only: is_elementary
	use sorting
	use lorentz
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices

	<<Standard module head>>

	<<Interactions: public>>

	<<Interactions: types>>

	<<Interactions: interfaces>>

	contains

	<<Interactions: procedures>>

	end module interactions
	@ %def interactions
	@ Given a ordered list of quantum numbers (without any subtraction index) map
	these list to a state matrix, such that each list index corresponds to index of a set of
	quantum numbers in the state matrix, hence, the matrix element.

	The (unphysical) subtraction index is not a genuine quantum number and as
	such handled specially.
	<<Interactions: public>>=
	public :: qn_index_map_t
	<<Interactions: types>>=
	type :: qn_index_map_t
	private
	type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv
	type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
	logical :: flip_hel = .false.
	integer :: n_flv = 0, n_hel = 0, n_sub = 0
	integer, dimension(:, :, :), allocatable :: index
	contains
	<<Interactions: qn index map: TBP>>
	end type qn_index_map_t

	@ %def qn_index_map_t
	@ Construct a mapping from interaction to an array of (sorted) quantum numbers.

	We strip all non-elementary particles (like beam) from the quantum numbers which
	we retrieve from the interaction.

	We consider helicity matrix elements only, when [[qn_hel]] is allocated.
	Else the helicity index is handled trivially as [[1]].
	<<Interactions: qn index map: TBP>>=
	generic :: init => qn_index_map_init
	procedure, private :: qn_index_map_init
	<<Interactions: procedures>>=
	subroutine qn_index_map_init (self, int, qn_flv, n_sub, qn_hel)
	class(qn_index_map_t), intent(out) :: self
	class(interaction_t), intent(in) :: int
	type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
	integer, intent(in) :: n_sub
	type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
	type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int
	integer :: i, i_flv, i_hel, i_sub
	self%qn_flv = qn_flv
	self%n_flv = size (qn_flv, dim=2)
	self%n_sub = n_sub
	if (present (qn_hel)) then
	if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then
	call msg_bug ("[qn_index_map_init] number of particles does not match.")
	end if
	self%qn_hel = qn_hel
	self%n_hel = size (qn_hel, dim=2)
	else
	self%n_hel = 1
	end if
	allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0)
	associate (n_me => int%get_n_matrix_elements ())
	do i = 1, n_me
	qn_int = int%get_quantum_numbers (i, by_me_index = .true.)
	qn = pack (qn_int, qn_int%are_hard_process ())
	i_flv = find_flv_index (self, qn)
	i_hel = 1; if (allocated (self%qn_hel)) &
	i_hel = find_hel_index (self, qn)
	i_sub = find_sub_index (self, qn)
	self%index(i_flv, i_hel, i_sub) = i
	end do
	end associate
	contains
	integer function find_flv_index (self, qn) result (i_flv)
	type(qn_index_map_t), intent(in) :: self
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer :: j
	i_flv = 0
	do j = 1, self%n_flv
	if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle
	i_flv = j
	exit
	end do
	if (i_flv < 1) then
	call msg_message ("QN:")
	call quantum_numbers_write (qn)
	call msg_message ("")
	call msg_message ("QN_FLV:")
	do j = 1, self%n_flv
	call quantum_numbers_write (self%qn_flv(:, j))
	call msg_message ("")
	end do
	call msg_bug ("[find_flv_index] could not find flv in qn_flv.")
	end if
	end function find_flv_index

	integer function find_hel_index (self, qn) result (i_hel)
	type(qn_index_map_t), intent(in) :: self
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer :: j
	i_hel = 0
	do j = 1, self%n_hel
	if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle
	i_hel = j
	exit
	end do
	if (i_hel < 1) then
	call msg_message ("QN:")
	call quantum_numbers_write (qn)
	call msg_message ("")
	call msg_message ("QN_HEL:")
	do j = 1, self%n_hel
	call quantum_numbers_write (self%qn_hel(:, j))
	call msg_message ("")
	end do
	call msg_bug ("[find_hel_index] could not find hel in qn_hel.")
	end if
	end function find_hel_index

	integer function find_sub_index (self, qn) result (i_sub)
	type(qn_index_map_t), intent(in) :: self
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer :: s
	i_sub = -1
	do s = 0, self%n_sub
	if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) &
	.or. (all (qn%get_sub () == 0) .and. s == 0)) then
	i_sub = s
	exit
	end if
	end do
	if (i_sub < 0) then
	call msg_message ("QN:")
	call quantum_numbers_write (qn)
	call msg_bug ("[find_sub_index] could not find sub in qn.")
	end if
	end function find_sub_index
	end subroutine qn_index_map_init

	@ %def qn_index_map_init
	@ Construct a trivial mapping.
	<<Interactions: qn index map: TBP>>=
	generic :: init => qn_index_map_init_trivial
	procedure, private :: qn_index_map_init_trivial
	<<Interactions: procedures>>=
	subroutine qn_index_map_init_trivial (self, int)
	class(qn_index_map_t), intent(out) :: self
	class(interaction_t), intent(in) :: int
	integer :: qn
	self%n_flv = int%get_n_matrix_elements ()
	self%n_hel = 1
	self%n_sub = 0
	allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0)
	do qn = 1, self%n_flv
	self%index(qn, 1, 0) = qn
	end do
	end subroutine qn_index_map_init_trivial

	@ %def qn_index_map_init_trivial
	@ Write the index map to unit.
	<<Interactions: qn index map: TBP>>=
	procedure :: write => qn_index_map_write
	<<Interactions: procedures>>=
	subroutine qn_index_map_write (self, unit)
	class(qn_index_map_t), intent(in) :: self
	integer, intent(in), optional :: unit
	integer :: u, i_flv, i_hel, i_sub
	u = given_output_unit (unit); if (u < 0) return
	write (u, *) "flip_hel: ", self%flip_hel
	do i_flv = 1, self%n_flv
	if (allocated (self%qn_flv)) &
	call quantum_numbers_write (self%qn_flv(:, i_flv))
	write (u, *)
	do i_hel = 1, self%n_hel
	if (allocated (self%qn_hel)) then
	call quantum_numbers_write (self%qn_hel(:, i_hel))
	write (u, *)
	end if
	do i_sub = 0, self%n_sub
	write (u, *) &
	"(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub)
	end do
	end do
	end do
	end subroutine qn_index_map_write

	@ %def qn_index_map_write
	@ Set helicity convention. If [[flip]], then we flip the helicities of anti-particles
	and we remap the indices accordingly.
	<<Interactions: qn index map: TBP>>=
	procedure :: set_helicity_flip => qn_index_map_set_helicity_flip
	<<Interactions: procedures>>=
	subroutine qn_index_map_set_helicity_flip (self, yorn)
	class(qn_index_map_t), intent(inout) :: self
	logical, intent(in) :: yorn
	integer :: i, i_flv, i_hel, i_hel_new
	type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip
	integer, dimension(:, :, :), allocatable :: index
	if (.not. allocated (self%qn_hel)) then
	call msg_bug ("[qn_index_map_set_helicity_flip] &
	&cannot flip not-given helicity.")
	end if
	! Workaround for ifort (allocate-on-assignmet)
	allocate (qn_hel_flip (size (self%qn_hel, dim=1),&
	size (self%qn_hel, dim=2)))
	allocate (index (self%n_flv, self%n_hel, 0:self%n_sub),&
	source=self%index)
	self%flip_hel = yorn
	if (self%flip_hel) then
	do i_flv = 1, self%n_flv
	qn_hel_flip = self%qn_hel
	do i_hel = 1, self%n_hel
	do i = 1, size (self%qn_flv, dim=1)
	if (is_anti_particle (self%qn_flv(i, i_flv))) then
	call qn_hel_flip(i, i_hel)%flip_helicity ()
	end if
	end do
	end do
	do i_hel = 1, self%n_hel
	i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel))
	self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :)
	end do
	end do
	end if
	contains
	logical function is_anti_particle (qn) result (yorn)
	type(quantum_numbers_t), intent(in) :: qn
	type(flavor_t) :: flv
	flv = qn%get_flavor ()
	yorn = flv%get_pdg () < 0
	end function is_anti_particle

	integer function find_hel_index (qn_sort, qn) result (i_hel)
	type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer :: j
	do j = 1, size(qn_sort, dim=2)
	if (.not. all (qn .hmatch. qn_sort(:, j))) cycle
	i_hel = j
	exit
	end do
	end function find_hel_index
	end subroutine qn_index_map_set_helicity_flip

	@ %def qn_index_map_set_helicity_flip
	@ Map from the previously given quantum number and subtraction
	index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element.
	<<Interactions: qn index map: TBP>>=
	procedure :: get_index => qn_index_map_get_index
	<<Interactions: procedures>>=
	integer function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index)
	class(qn_index_map_t), intent(in) :: self
	integer, intent(in) :: i_flv
	integer, intent(in), optional :: i_hel
	integer, intent(in), optional :: i_sub
	integer :: i_sub_opt, i_hel_opt
	i_sub_opt = 0; if (present (i_sub)) &
	i_sub_opt = i_sub
	i_hel_opt = 1; if (present (i_hel)) &
	i_hel_opt = i_hel
	index = 0
	if (.not. allocated (self%index)) then
	call msg_bug ("[qn_index_map_get_index] The index map is not allocated.")
	end if
	index = self%index(i_flv, i_hel_opt, i_sub_opt)
	if (index <= 0) then
	call self%write ()
	call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.")
	end if
	end function qn_index_map_get_index

	@ %def qn_index_map_get_i_flv
	@ Get [[n_flv]].
	<<Interactions: qn index map: TBP>>=
	procedure :: get_n_flv => qn_index_map_get_n_flv
	<<Interactions: procedures>>=
	integer function qn_index_map_get_n_flv (self) result (n_flv)
	class(qn_index_map_t), intent(in) :: self
	n_flv = self%n_flv
	end function qn_index_map_get_n_flv

	@ %def qn_index_map_get_n_flv
	@ Get [[n_hel]].
	<<Interactions: qn index map: TBP>>=
	procedure :: get_n_hel => qn_index_map_get_n_hel
	<<Interactions: procedures>>=
	integer function qn_index_map_get_n_hel (self) result (n_hel)
	class(qn_index_map_t), intent(in) :: self
	n_hel = self%n_hel
	end function qn_index_map_get_n_hel

	@ %def qn_index_map_get_n_flv
	@ Get [[n_sub]].
	<<Interactions: qn index map: TBP>>=
	procedure :: get_n_sub => qn_index_map_get_n_sub
	<<Interactions: procedures>>=
	integer function qn_index_map_get_n_sub (self) result (n_sub)
	class(qn_index_map_t), intent(in) :: self
	n_sub = self%n_sub
	end function qn_index_map_get_n_sub

	@ %def qn_index_map_get_n_sub
	@
	\subsection{External interaction links}
	Each particle in an interaction can have a link to a corresponding
	particle in another interaction. This allows to fetch the momenta of
	incoming or virtual particles from the interaction where they are
	defined. The link object consists of a pointer to the interaction and
	an index.
	<<Interactions: types>>=
	type :: external_link_t
	private
	type(interaction_t), pointer :: int => null ()
	integer :: i
	end type external_link_t

	@ %def external_link_t
	@ Set an external link.
	<<Interactions: procedures>>=
	subroutine external_link_set (link, int, i)
	type(external_link_t), intent(out) :: link
	type(interaction_t), target, intent(in) :: int
	integer, intent(in) :: i
	if (i /= 0) then
	link%int => int
	link%i = i
	end if
	end subroutine external_link_set

	@ %def external_link_set
	@ Reassign an external link to a new interaction (which should be an
	image of the original target).
	<<Interactions: procedures>>=
	subroutine external_link_reassign (link, int_src, int_target)
	type(external_link_t), intent(inout) :: link
	type(interaction_t), intent(in) :: int_src
	type(interaction_t), intent(in), target :: int_target
	if (associated (link%int)) then
	if (link%int%tag == int_src%tag) link%int => int_target
	end if
	end subroutine external_link_reassign

	@ %def external_link_reassign
	@ Return true if the link is set
	<<Interactions: procedures>>=
	function external_link_is_set (link) result (flag)
	logical :: flag
	type(external_link_t), intent(in) :: link
	flag = associated (link%int)
	end function external_link_is_set

	@ %def external_link_is_set
	@ Return the interaction pointer.
	<<Interactions: public>>=
	public :: external_link_get_ptr
	<<Interactions: procedures>>=
	function external_link_get_ptr (link) result (int)
	type(interaction_t), pointer :: int
	type(external_link_t), intent(in) :: link
	int => link%int
	end function external_link_get_ptr

	@ %def external_link_get_ptr
	@ Return the index within that interaction
	<<Interactions: public>>=
	public :: external_link_get_index
	<<Interactions: procedures>>=
	function external_link_get_index (link) result (i)
	integer :: i
	type(external_link_t), intent(in) :: link
	i = link%i
	end function external_link_get_index

	@ %def external_link_get_index
	@ Return a pointer to the momentum of the corresponding particle. If
	there is no association, return a null pointer.
	<<Interactions: procedures>>=
	function external_link_get_momentum_ptr (link) result (p)
	type(vector4_t), pointer :: p
	type(external_link_t), intent(in) :: link
	if (associated (link%int)) then
	p => link%int%p(link%i)
	else
	p => null ()
	end if
	end function external_link_get_momentum_ptr

	@ %def external_link_get_momentum_ptr
	@
	\subsection{Internal relations}
	In addition to the external links, particles within the interaction
	have parent-child relations. Here, more than one link is possible,
	and we set up an array.
	<<Interactions: types>>=
	type :: internal_link_list_t
	private
	integer :: length = 0
	integer, dimension(:), allocatable :: link
	contains
	<<Interactions: internal link list: TBP>>
	end type internal_link_list_t

	@ %def internal_link_t internal_link_list_t
	@ Output, non-advancing.
	<<Interactions: internal link list: TBP>>=
	procedure :: write => internal_link_list_write
	<<Interactions: procedures>>=
	subroutine internal_link_list_write (object, unit)
	class(internal_link_list_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	do i = 1, object%length
	write (u, "(1x,I0)", advance="no") object%link(i)
	end do
	end subroutine internal_link_list_write

	@ %def internal_link_list_write
	@ Append an item. Start with an array size of 2 and double the size
	if necessary.

	Make sure that the indices are stored in ascending order. To this
	end, shift the existing entries right, starting from the end, as long
	as they are larger than the new entry.
	<<Interactions: internal link list: TBP>>=
	procedure :: append => internal_link_list_append
	<<Interactions: procedures>>=
	subroutine internal_link_list_append (link_list, link)
	class(internal_link_list_t), intent(inout) :: link_list
	integer, intent(in) :: link
	integer :: l, j
	integer, dimension(:), allocatable :: tmp
	l = link_list%length
	if (allocated (link_list%link)) then
	if (l == size (link_list%link)) then
	allocate (tmp (2 * l))
	tmp(:l) = link_list%link
	call move_alloc (from = tmp, to = link_list%link)
	end if
	else
	allocate (link_list%link (2))
	end if
	link_list%link(l+1) = link
	SHIFT_LINK_IN_PLACE: do j = l, 1, -1
	if (link >= link_list%link(j)) then
	exit SHIFT_LINK_IN_PLACE
	else
	link_list%link(j+1) = link_list%link(j)
	link_list%link(j) = link
	end if
	end do SHIFT_LINK_IN_PLACE
	link_list%length = l + 1
	end subroutine internal_link_list_append

	@ %def internal_link_list_append
	@ Return true if the link list is nonempty:
	<<Interactions: internal link list: TBP>>=
	procedure :: has_entries => internal_link_list_has_entries
	<<Interactions: procedures>>=
	function internal_link_list_has_entries (link_list) result (flag)
	class(internal_link_list_t), intent(in) :: link_list
	logical :: flag
	flag = link_list%length > 0
	end function internal_link_list_has_entries

	@ %def internal_link_list_has_entries
	@ Return the list length
	<<Interactions: internal link list: TBP>>=
	procedure :: get_length => internal_link_list_get_length
	<<Interactions: procedures>>=
	function internal_link_list_get_length (link_list) result (length)
	class(internal_link_list_t), intent(in) :: link_list
	integer :: length
	length = link_list%length
	end function internal_link_list_get_length

	@ %def internal_link_list_get_length
	@ Return an entry.
	<<Interactions: internal link list: TBP>>=
	procedure :: get_link => internal_link_list_get_link
	<<Interactions: procedures>>=
	function internal_link_list_get_link (link_list, i) result (link)
	class(internal_link_list_t), intent(in) :: link_list
	integer, intent(in) :: i
	integer :: link
	if (i <= link_list%length) then
	link = link_list%link(i)
	else
	call msg_bug ("Internal link list: out of bounds")
	end if
	end function internal_link_list_get_link

	@ %def internal_link_list_get_link
	@
	\subsection{The interaction type}
	An interaction is an entangled system of particles. Thus, the
	interaction object consists of two parts: the subevent, and the
	quantum state which technically is a trie. The subnode levels beyond
	the trie root node are in correspondence to the subevent, so
	both should be traversed in parallel.

	The subevent is implemented as an allocatable array of
	four-momenta. The first [[n_in]] particles are incoming, [[n_vir]]
	particles in-between can be kept for bookkeeping, and the last
	[[n_out]] particles are outgoing.

	Distinct interactions are linked by their particles: for each
	particle, we have the possibility of links to corresponding particles
	in other interactions. Furthermore, for bookkeeping purposes we have
	a self-link array [[relations]] where the parent-child relations are
	kept, and a flag array [[resonant]] which is set for an intermediate
	resonance.

	Each momentum is associated with masks for flavor, color, and
	helicity. If a mask entry is set, the associated quantum number is to
	be ignored for that particle. If any mask has changed, the flag
	[[update]] is set.

	We can have particle pairs locked together. If this is the case, the
	corresponding mask entries are bound to be equal. This is useful for
	particles that go through the interaction.

	The interaction tag serves bookkeeping purposes. In particular, it
	identifies links in printout.
	<<Interactions: public>>=
	public :: interaction_t
	<<Interactions: types>>=
	type :: interaction_t
	private
	integer :: tag = 0
	type(state_matrix_t) :: state_matrix
	integer :: n_in = 0
	integer :: n_vir = 0
	integer :: n_out = 0
	integer :: n_tot = 0
	logical, dimension(:), allocatable :: p_is_known
	type(vector4_t), dimension(:), allocatable :: p
	type(external_link_t), dimension(:), allocatable :: source
	type(internal_link_list_t), dimension(:), allocatable :: parents
	type(internal_link_list_t), dimension(:), allocatable :: children
	logical, dimension(:), allocatable :: resonant
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	integer, dimension(:), allocatable :: hel_lock
	logical :: update_state_matrix = .false.
	logical :: update_values = .false.
	contains
	<<Interactions: interaction: TBP>>
	end type interaction_t

	@ %def interaction_particle_p interaction_t
	@ Initialize the particle array with a fixed size. The first [[n_in]]
	particles are incoming, the rest outgoing. Masks are optional. There
	is also an optional tag. The interaction still needs fixing the
	values, but that is to be done after all branches have been added.

	Interaction tags are assigned consecutively, using a [[save]]d
	variable local to this procedure. If desired, we can provide a seed
	for the interaction tags. Such a seed should be positive. The
	default seed is one. [[tag=0]] indicates an empty interaction.

	If [[set_relations]] is set and true, we establish parent-child
	relations for all incoming and outgoing particles. Virtual particles
	are skipped; this option is normally used only for interations without
	virtual particles.
	<<Interactions: interaction: TBP>>=
	procedure :: basic_init => interaction_init
	<<Interactions: procedures>>=
	subroutine interaction_init &
	(int, n_in, n_vir, n_out, &
	tag, resonant, mask, hel_lock, set_relations, store_values)
	class(interaction_t), intent(out) :: int
	integer, intent(in) :: n_in, n_vir, n_out
	integer, intent(in), optional :: tag
	logical, dimension(:), intent(in), optional :: resonant
	type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask
	integer, dimension(:), intent(in), optional :: hel_lock
	logical, intent(in), optional :: set_relations, store_values
	logical :: set_rel
	integer :: i, j
	set_rel = .false.; if (present (set_relations)) set_rel = set_relations
	call interaction_set_tag (int, tag)
	call int%state_matrix%init (store_values)
	int%n_in = n_in
	int%n_vir = n_vir
	int%n_out = n_out
	int%n_tot = n_in + n_vir + n_out
	allocate (int%p_is_known (int%n_tot))
	int%p_is_known = .false.
	allocate (int%p (int%n_tot))
	allocate (int%source (int%n_tot))
	allocate (int%parents (int%n_tot))
	allocate (int%children (int%n_tot))
	allocate (int%resonant (int%n_tot))
	if (present (resonant)) then
	int%resonant = resonant
	else
	int%resonant = .false.
	end if
	allocate (int%mask (int%n_tot))
	allocate (int%hel_lock (int%n_tot))
	if (present (mask)) then
	int%mask = mask
	end if
	if (present (hel_lock)) then
	int%hel_lock = hel_lock
	else
	int%hel_lock = 0
	end if
	int%update_state_matrix = .false.
	int%update_values = .true.
	if (set_rel) then
	do i = 1, n_in
	do j = 1, n_out
	call int%relate (i, n_in + j)
	end do
	end do
	end if
	end subroutine interaction_init

	@ %def interaction_init
	@ Set or create a unique tag for the interaction. Without
	interaction, reset the tag counter.
	<<Interactions: procedures>>=
	subroutine interaction_set_tag (int, tag)
	type(interaction_t), intent(inout), optional :: int
	integer, intent(in), optional :: tag
	integer, save :: stored_tag = 1
	if (present (int)) then
	if (present (tag)) then
	int%tag = tag
	else
	int%tag = stored_tag
	stored_tag = stored_tag + 1
	end if
	else if (present (tag)) then
	stored_tag = tag
	else
	stored_tag = 1
	end if
	end subroutine interaction_set_tag

	@ %def interaction_set_tag
	@ The public interface for the previous procedure only covers the
	reset functionality.
	<<Interactions: public>>=
	public :: reset_interaction_counter
	<<Interactions: procedures>>=
	subroutine reset_interaction_counter (tag)
	integer, intent(in), optional :: tag
	call interaction_set_tag (tag=tag)
	end subroutine reset_interaction_counter

	@ %def reset_interaction_counter
	@ Finalizer: The state-matrix object contains pointers.
	<<Interactions: interaction: TBP>>=
	procedure :: final => interaction_final
	<<Interactions: procedures>>=
	subroutine interaction_final (object)
	class(interaction_t), intent(inout) :: object
	call object%state_matrix%final ()
	end subroutine interaction_final

	@ %def interaction_final
	@ Output. The [[verbose]] option refers to the state matrix output.
	<<Interactions: interaction: TBP>>=
	procedure :: basic_write => interaction_write
	<<Interactions: procedures>>=
	subroutine interaction_write &
	(int, unit, verbose, show_momentum_sum, show_mass, show_state, &
	col_verbose, testflag)
	class(interaction_t), intent(in) :: int
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: show_state, col_verbose, testflag
	integer :: u
	integer :: i, index_link
	type(interaction_t), pointer :: int_link
	logical :: show_st
	u = given_output_unit (unit); if (u < 0) return
	show_st = .true.; if (present (show_state)) show_st = show_state
	if (int%tag /= 0) then
	write (u, "(1x,A,I0)") "Interaction: ", int%tag
	do i = 1, int%n_tot
	if (i == 1 .and. int%n_in > 0) then
	write (u, "(1x,A)") "Incoming:"
	else if (i == int%n_in + 1 .and. int%n_vir > 0) then
	write (u, "(1x,A)") "Virtual:"
	else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then
	write (u, "(1x,A)") "Outgoing:"
	end if
	write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
	if (allocated (int%resonant)) then
	if (int%resonant(i)) then
	write (u, "(A)") "[r]"
	else
	write (u, *)
	end if
	else
	write (u, *)
	end if
	if (allocated (int%p)) then
	if (int%p_is_known(i)) then
	call vector4_write (int%p(i), u, show_mass, testflag)
	else
	write (u, "(A)") " [momentum undefined]"
	end if
	else
	write (u, "(A)") " [momentum not allocated]"
	end if
	if (allocated (int%mask)) then
	write (u, "(1x,A)", advance="no") "mask [fch] = "
	call int%mask(i)%write (u)
	write (u, *)
	end if
	if (int%parents(i)%has_entries () &
	.or. int%children(i)%has_entries ()) then
	write (u, "(1x,A)", advance="no") "internal links:"
	call int%parents(i)%write (u)
	if (int%parents(i)%has_entries ()) &
	write (u, "(1x,A)", advance="no") "=>"
	write (u, "(1x,A)", advance="no") "X"
	if (int%children(i)%has_entries ()) &
	write (u, "(1x,A)", advance="no") "=>"
	call int%children(i)%write (u)
	write (u, *)
	end if
	if (allocated (int%hel_lock)) then
	if (int%hel_lock(i) /= 0) then
	write (u, "(1x,A,1x,I0)") "helicity lock:", int%hel_lock(i)
	end if
	end if
	if (external_link_is_set (int%source(i))) then
	write (u, "(1x,A)", advance="no") "source:"
	int_link => external_link_get_ptr (int%source(i))
	index_link = external_link_get_index (int%source(i))
	write (u, "(1x,'(',I0,')',I0)", advance="no") &
	int_link%tag, index_link
	write (u, *)
	end if
	end do
	if (present (show_momentum_sum)) then
	if (allocated (int%p) .and. show_momentum_sum) then
	write (u, "(1x,A)") "Incoming particles (sum):"
	call vector4_write &
	(sum (int%p(1 : int%n_in)), u, show_mass = show_mass)
	write (u, "(1x,A)") "Outgoing particles (sum):"
	call vector4_write &
	(sum (int%p(int%n_in + int%n_vir + 1 : )), &
	u, show_mass = show_mass)
	write (u, *)
	end if
	end if
	if (show_st) then
	call int%write_state_matrix (write_value_list = verbose, &
	verbose = verbose, unit = unit, col_verbose = col_verbose, &
	testflag = testflag)
	end if
	else
	write (u, "(1x,A)") "Interaction: [empty]"
	end if
	end subroutine interaction_write

	@ %def interaction_write
	@
	<<Interactions: interaction: TBP>>=
	procedure :: write_state_matrix => interaction_write_state_matrix
	<<Interactions: procedures>>=
	subroutine interaction_write_state_matrix (int, unit, write_value_list, &
	verbose, col_verbose, testflag)
	class(interaction_t), intent(in) :: int
	logical, intent(in), optional :: write_value_list, verbose, col_verbose
	logical, intent(in), optional :: testflag
	integer, intent(in), optional :: unit
	call int%state_matrix%write (write_value_list = verbose, &
	verbose = verbose, unit = unit, col_verbose = col_verbose, &
	testflag = testflag)
	end subroutine interaction_write_state_matrix

	@ %def interaction_write_state_matrix
	@ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure
	the iterator does not conserve the order of the matrix element respective their
	quantum numbers. Setting the [[keep_order]] results in a reorder state matrix
	with reintroduced matrix element indices.
	<<Interactions: interaction: TBP>>=
	procedure :: reduce_state_matrix => interaction_reduce_state_matrix
	<<Interactions: procedures>>=
	subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order)
	class(interaction_t), intent(inout) :: int
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
	logical, optional, intent(in) :: keep_order
	type(state_matrix_t) :: state
	logical :: opt_keep_order
	opt_keep_order = .false.
	if (present (keep_order)) opt_keep_order = keep_order
	call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order)
	int%state_matrix = state
	if (opt_keep_order) then
	call int%state_matrix%reorder_me (state)
	int%state_matrix = state
	end if
	end subroutine interaction_reduce_state_matrix

	@ %def interaction_reduce_state_matrix
	@ Assignment: We implement this as a deep copy. This applies, in
	particular, to the state-matrix and internal-link components.
	Furthermore, the new interaction acquires a new tag.
	<<Interactions: public>>=
	public :: assignment(=)
	<<Interactions: interfaces>>=
	interface assignment(=)
	module procedure interaction_assign
	end interface

	<<Interactions: procedures>>=
	subroutine interaction_assign (int_out, int_in)
	type(interaction_t), intent(out) :: int_out
	type(interaction_t), intent(in), target :: int_in
	call interaction_set_tag (int_out)
	int_out%state_matrix = int_in%state_matrix
	int_out%n_in = int_in%n_in
	int_out%n_out = int_in%n_out
	int_out%n_vir = int_in%n_vir
	int_out%n_tot = int_in%n_tot
	if (allocated (int_in%p_is_known)) then
	allocate (int_out%p_is_known (size (int_in%p_is_known)))
	int_out%p_is_known = int_in%p_is_known
	end if
	if (allocated (int_in%p)) then
	allocate (int_out%p (size (int_in%p)))
	int_out%p = int_in%p
	end if
	if (allocated (int_in%source)) then
	allocate (int_out%source (size (int_in%source)))
	int_out%source = int_in%source
	end if
	if (allocated (int_in%parents)) then
	allocate (int_out%parents (size (int_in%parents)))
	int_out%parents = int_in%parents
	end if
	if (allocated (int_in%children)) then
	allocate (int_out%children (size (int_in%children)))
	int_out%children = int_in%children
	end if
	if (allocated (int_in%resonant)) then
	allocate (int_out%resonant (size (int_in%resonant)))
	int_out%resonant = int_in%resonant
	end if
	if (allocated (int_in%mask)) then
	allocate (int_out%mask (size (int_in%mask)))
	int_out%mask = int_in%mask
	end if
	if (allocated (int_in%hel_lock)) then
	allocate (int_out%hel_lock (size (int_in%hel_lock)))
	int_out%hel_lock = int_in%hel_lock
	end if
	int_out%update_state_matrix = int_in%update_state_matrix
	int_out%update_values = int_in%update_values
	end subroutine interaction_assign

	@ %def interaction_assign
	@
	\subsection{Methods inherited from the state matrix member}
	Until F2003 is standard, we cannot implement inheritance directly.
	Therefore, we need wrappers for ``inherited'' methods.

	Make a new branch in the state matrix if it does not yet exist. This
	is not just a wrapper but it introduces the interaction mask: where a
	quantum number is masked, it is not transferred but set undefined.
	After this, the value array has to be updated.
	<<Interactions: interaction: TBP>>=
	procedure :: add_state => interaction_add_state
	<<Interactions: procedures>>=
	subroutine interaction_add_state &
	(int, qn, index, value, sum_values, counter_index, ignore_sub, me_index)
	class(interaction_t), intent(inout) :: int
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	integer, intent(in), optional :: index
	complex(default), intent(in), optional :: value
	logical, intent(in), optional :: sum_values
	integer, intent(in), optional :: counter_index
	logical, intent(in), optional :: ignore_sub
	integer, intent(out), optional :: me_index
	type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp
	qn_tmp = qn
	call qn_tmp%undefine (int%mask)
	call int%state_matrix%add_state (qn_tmp, index, value, sum_values, &
	counter_index, ignore_sub, me_index)
	int%update_values = .true.
	end subroutine interaction_add_state

	@ %def interaction_add_state
	@ Freeze the quantum state: First collapse the quantum state, i.e.,
	remove quantum numbers if any mask has changed, then fix the array of
	value pointers.
	<<Interactions: interaction: TBP>>=
	procedure :: freeze => interaction_freeze
	<<Interactions: procedures>>=
	subroutine interaction_freeze (int)
	class(interaction_t), intent(inout) :: int
	if (int%update_state_matrix) then
	call int%state_matrix%collapse (int%mask)
	int%update_state_matrix = .false.
	int%update_values = .true.
	end if
	if (int%update_values) then
	call int%state_matrix%freeze ()
	int%update_values = .false.
	end if
	end subroutine interaction_freeze

	@ %def interaction_freeze
	@ Return true if the state matrix is empty.
	<<Interactions: interaction: TBP>>=
	procedure :: is_empty => interaction_is_empty
	<<Interactions: procedures>>=
	pure function interaction_is_empty (int) result (flag)
	logical :: flag
	class(interaction_t), intent(in) :: int
	flag = int%state_matrix%is_empty ()
	end function interaction_is_empty

	@ %def interaction_is_empty
	@ Get the number of values stored in the state matrix:
	<<Interactions: interaction: TBP>>=
	procedure :: get_n_matrix_elements => &
	interaction_get_n_matrix_elements
	<<Interactions: procedures>>=
	pure function interaction_get_n_matrix_elements (int) result (n)
	integer :: n
	class(interaction_t), intent(in) :: int
	n = int%state_matrix%get_n_matrix_elements ()
	end function interaction_get_n_matrix_elements

	@ %def interaction_get_n_matrix_elements
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_state_depth => interaction_get_state_depth
	<<Interactions: procedures>>=
	function interaction_get_state_depth (int) result (n)
	integer :: n
	class(interaction_t), intent(in) :: int
	n = int%state_matrix%get_depth ()
	end function interaction_get_state_depth

	@ %def interaction_get_state_depth
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_n_in_helicities => interaction_get_n_in_helicities
	<<Interactions: procedures>>=
	function interaction_get_n_in_helicities (int) result (n_hel)
	integer :: n_hel
	class(interaction_t), intent(in) :: int
	type(interaction_t) :: int_copy
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	integer :: i
	allocate (qn_mask (int%n_tot))
	do i = 1, int%n_tot
	if (i <= int%n_in) then
	call qn_mask(i)%init (.true., .true., .false.)
	else
	call qn_mask(i)%init (.true., .true., .true.)
	end if
	end do
	int_copy = int
	call int_copy%set_mask (qn_mask)
	call int_copy%freeze ()
	allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), &
	int_copy%state_matrix%get_depth ()))
	qn = int_copy%get_quantum_numbers ()
	n_hel = 0
	do i = 1, size (qn, dim=1)
	if (all (qn(i,:)%get_subtraction_index () == 0)) n_hel = n_hel + 1
	end do
	call int_copy%final ()
	deallocate (qn_mask)
	deallocate (qn)
	end function interaction_get_n_in_helicities

	@ %def interaction_get_n_in_helicities
	@ Get the size of the [[me]]-array of the associated state matrix
	for debugging purposes
	<<Interactions: interaction: TBP>>=
	procedure :: get_me_size => interaction_get_me_size
	<<Interactions: procedures>>=
	pure function interaction_get_me_size (int) result (n)
	integer :: n
	class(interaction_t), intent(in) :: int
	n = int%state_matrix%get_me_size ()
	end function interaction_get_me_size

	@ %def interaction_get_me_size
	@ Get the norm of the state matrix (if the norm has been taken out, otherwise
	this would be unity).
	<<Interactions: interaction: TBP>>=
	procedure :: get_norm => interaction_get_norm
	<<Interactions: procedures>>=
	pure function interaction_get_norm (int) result (norm)
	real(default) :: norm
	class(interaction_t), intent(in) :: int
	norm = int%state_matrix%get_norm ()
	end function interaction_get_norm

	@ %def interaction_get_norm
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_n_sub => interaction_get_n_sub
	<<Interactions: procedures>>=
	function interaction_get_n_sub (int) result (n_sub)
	integer :: n_sub
	class(interaction_t), intent(in) :: int
	n_sub = int%state_matrix%get_n_sub ()
	end function interaction_get_n_sub

	@ %def interaction_get_n_sub
	@ Get the quantum number array that corresponds to a given index.
	<<Interactions: interaction: TBP>>=
	generic :: get_quantum_numbers => get_quantum_numbers_single, &
	get_quantum_numbers_all, &
	get_quantum_numbers_all_qn_mask
	procedure :: get_quantum_numbers_single => &
	interaction_get_quantum_numbers_single
	procedure :: get_quantum_numbers_all => &
	interaction_get_quantum_numbers_all
	procedure :: get_quantum_numbers_all_qn_mask => &
	interaction_get_quantum_numbers_all_qn_mask
	<<Interactions: procedures>>=
	function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn)
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	class(interaction_t), intent(in), target :: int
	integer, intent(in) :: i
	logical, intent(in), optional :: by_me_index
	allocate (qn (int%state_matrix%get_depth ()))
	qn = int%state_matrix%get_quantum_number (i, by_me_index)
	end function interaction_get_quantum_numbers_single

	function interaction_get_quantum_numbers_all (int) result (qn)
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	class(interaction_t), intent(in), target :: int
	integer :: i
	<<Interactions: get quantum numbers all>>
	<<Interactions: get quantum numbers all>>=
	allocate (qn (int%state_matrix%get_n_matrix_elements (), &
	int%state_matrix%get_depth()))
	do i = 1, int%state_matrix%get_n_matrix_elements ()
	qn (i, :) = int%state_matrix%get_quantum_number (i)
	end do
	<<Interactions: procedures>>=
	end function interaction_get_quantum_numbers_all

	function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) &
	result (qn)
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	class(interaction_t), intent(in) :: int
	type(quantum_numbers_mask_t), intent(in) :: qn_mask
	integer :: n_redundant, n_all, n_me
	integer :: i
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
	<<Interactions: get quantum numbers all qn mask>>
	<<Interactions: get quantum numbers all qn mask>>=
	call int%state_matrix%get_quantum_numbers (qn_all)
	n_redundant = count (qn_all%are_redundant (qn_mask))
	n_all = size (qn_all)
	!!! Number of matrix elements = survivors / n_particles
	n_me = (n_all - n_redundant) / int%state_matrix%get_depth ()
	allocate (qn (n_me, int%state_matrix%get_depth()))
	do i = 1, n_me
	if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) &
	qn (i, :) = qn_all (i, :)
	end do
	<<Interactions: procedures>>=
	end function interaction_get_quantum_numbers_all_qn_mask

	@ %def interaction_get_quantum_numbers_single
	@ %def interaction_get_quantum_numbers_all
	@ %def interaction_get_quantum_numbers_all_qn_mask
	@
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub
	<<Interactions: procedures>>=
	subroutine interaction_get_quantum_numbers_all_sub (int, qn)
	class(interaction_t), intent(in) :: int
	type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
	integer :: i
	<<Interactions: get quantum numbers all>>
	end subroutine interaction_get_quantum_numbers_all_sub

	@ %def interaction_get_quantum_numbers_all
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_flavors => interaction_get_flavors
	<<Interactions: procedures>>=
	subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv)
	class(interaction_t), intent(in), target :: int
	logical, intent(in) :: only_elementary
	type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
	integer, intent(out), dimension(:,:), allocatable :: flv
	call int%state_matrix%get_flavors (only_elementary, qn_mask, flv)
	end subroutine interaction_get_flavors

	@ %def interaction_get_flavors
	@
	<<Interactions: interaction: TBP>>=
	procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask
	<<Interactions: procedures>>=
	subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn)
	class(interaction_t), intent(in) :: int
	type(quantum_numbers_mask_t), intent(in) :: qn_mask
	type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
	integer :: n_redundant, n_all, n_me
	integer :: i
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
	<<Interactions: get quantum numbers all qn mask>>
	end subroutine interaction_get_quantum_numbers_mask

	@ %def interaction_get_quantum_numbers_mask
	@ Get the matrix element that corresponds to a set of quantum
	numbers, a given index, or return the whole array.
	<<Interactions: interaction: TBP>>=
	generic :: get_matrix_element => get_matrix_element_single
	generic :: get_matrix_element => get_matrix_element_array
	procedure :: get_matrix_element_single => &
	interaction_get_matrix_element_single
	procedure :: get_matrix_element_array => &
	interaction_get_matrix_element_array
	<<Interactions: procedures>>=
	elemental function interaction_get_matrix_element_single (int, i) result (me)
	complex(default) :: me
	class(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	me = int%state_matrix%get_matrix_element (i)
	end function interaction_get_matrix_element_single

	@ %def interaction_get_matrix_element_single
	<<Interactions: procedures>>=
	function interaction_get_matrix_element_array (int) result (me)
	complex(default), dimension(:), allocatable :: me
	class(interaction_t), intent(in) :: int
	allocate (me (int%get_n_matrix_elements ()))
	me = int%state_matrix%get_matrix_element ()
	end function interaction_get_matrix_element_array

	@ %def interaction_get_matrix_element_array
	@ Set the complex value(s) stored in the quantum state.
	<<Interactions: interaction: TBP>>=
	generic :: set_matrix_element => interaction_set_matrix_element_qn, &
	interaction_set_matrix_element_all, &
	interaction_set_matrix_element_array, &
	interaction_set_matrix_element_single, &
	interaction_set_matrix_element_clone
	procedure :: interaction_set_matrix_element_qn
	procedure :: interaction_set_matrix_element_all
	procedure :: interaction_set_matrix_element_array
	procedure :: interaction_set_matrix_element_single
	procedure :: interaction_set_matrix_element_clone
	@ %def interaction_set_matrix_element
	@ Indirect access via the quantum number array:
	<<Interactions: procedures>>=
	subroutine interaction_set_matrix_element_qn (int, qn, val)
	class(interaction_t), intent(inout) :: int
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	complex(default), intent(in) :: val
	call int%state_matrix%set_matrix_element (qn, val)
	end subroutine interaction_set_matrix_element_qn

	@ %def interaction_set_matrix_element
	@ Set all entries of the matrix-element array to a given value.
	<<Interactions: procedures>>=
	subroutine interaction_set_matrix_element_all (int, value)
	class(interaction_t), intent(inout) :: int
	complex(default), intent(in) :: value
	call int%state_matrix%set_matrix_element (value)
	end subroutine interaction_set_matrix_element_all

	@ %def interaction_set_matrix_element_all
	@ Set the matrix-element array directly.
	<<Interactions: procedures>>=
	subroutine interaction_set_matrix_element_array (int, value, range)
	class(interaction_t), intent(inout) :: int
	complex(default), intent(in), dimension(:) :: value
	integer, intent(in), dimension(:), optional :: range
	call int%state_matrix%set_matrix_element (value, range)
	end subroutine interaction_set_matrix_element_array

	pure subroutine interaction_set_matrix_element_single (int, i, value)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	complex(default), intent(in) :: value
	call int%state_matrix%set_matrix_element (i, value)
	end subroutine interaction_set_matrix_element_single

	@ %def interaction_set_matrix_element_array
	@ %def interaction_set_matrix_element_single
	@ Clone from another (matching) interaction.
	<<Interactions: procedures>>=
	subroutine interaction_set_matrix_element_clone (int, int1)
	class(interaction_t), intent(inout) :: int
	class(interaction_t), intent(in) :: int1
	call int%state_matrix%set_matrix_element (int1%state_matrix)
	end subroutine interaction_set_matrix_element_clone

	@ %def interaction_set_matrix_element_clone
	@
	<<Interactions: interaction: TBP>>=
	procedure :: set_only_matrix_element => interaction_set_only_matrix_element
	<<Interactions: procedures>>=
	subroutine interaction_set_only_matrix_element (int, i, value)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	complex(default), intent(in) :: value
	call int%set_matrix_element (cmplx (0, 0, default))
	call int%set_matrix_element (i, value)
	end subroutine interaction_set_only_matrix_element

	@ %def interaction_set_only_matrix_element
	@
	<<Interactions: interaction: TBP>>=
	procedure :: add_to_matrix_element => interaction_add_to_matrix_element
	<<Interactions: procedures>>=
	subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor)
	class(interaction_t), intent(inout) :: int
	type(quantum_numbers_t), dimension(:), intent(in) :: qn
	complex(default), intent(in) :: value
	logical, intent(in), optional :: match_only_flavor
	call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor)
	end subroutine interaction_add_to_matrix_element

	@ %def interaction_add_to_matrix_element
	@ Get the indices of any diagonal matrix elements.
	<<Interactions: interaction: TBP>>=
	procedure :: get_diagonal_entries => interaction_get_diagonal_entries
	<<Interactions: procedures>>=
	subroutine interaction_get_diagonal_entries (int, i)
	class(interaction_t), intent(in) :: int
	integer, dimension(:), allocatable, intent(out) :: i
	call int%state_matrix%get_diagonal_entries (i)
	end subroutine interaction_get_diagonal_entries

	@ %def interaction_get_diagonal_entries
	@ Renormalize the state matrix by its trace, if nonzero. The renormalization
	is reflected in the state-matrix norm.
	<<Interactions: interaction: TBP>>=
	procedure :: normalize_by_trace => interaction_normalize_by_trace
	<<Interactions: procedures>>=
	subroutine interaction_normalize_by_trace (int)
	class(interaction_t), intent(inout) :: int
	call int%state_matrix%normalize_by_trace ()
	end subroutine interaction_normalize_by_trace

	@ %def interaction_normalize_by_trace
	@ Analogous, but renormalize by maximal (absolute) value.
	<<Interactions: interaction: TBP>>=
	procedure :: normalize_by_max => interaction_normalize_by_max
	<<Interactions: procedures>>=
	subroutine interaction_normalize_by_max (int)
	class(interaction_t), intent(inout) :: int
	call int%state_matrix%normalize_by_max ()
	end subroutine interaction_normalize_by_max

	@ %def interaction_normalize_by_max
	@ Explicitly set the norm value (of the state matrix).
	<<Interactions: interaction: TBP>>=
	procedure :: set_norm => interaction_set_norm
	<<Interactions: procedures>>=
	subroutine interaction_set_norm (int, norm)
	class(interaction_t), intent(inout) :: int
	real(default), intent(in) :: norm
	call int%state_matrix%set_norm (norm)
	end subroutine interaction_set_norm

	@ %def interaction_set_norm
	@
	<<Interactions: interaction: TBP>>=
	procedure :: set_state_matrix => interaction_set_state_matrix
	<<Interactions: procedures>>=
	subroutine interaction_set_state_matrix (int, state)
	class(interaction_t), intent(inout) :: int
	type(state_matrix_t), intent(in) :: state
	int%state_matrix = state
	end subroutine interaction_set_state_matrix

	@ %def interaction_set_state_matrix
	@ Return the maximum absolute value of color indices.
	<<Interactions: interaction: TBP>>=
	procedure :: get_max_color_value => &
	interaction_get_max_color_value
	<<Interactions: procedures>>=
	function interaction_get_max_color_value (int) result (cmax)
	class(interaction_t), intent(in) :: int
	integer :: cmax
	cmax = int%state_matrix%get_max_color_value ()
	end function interaction_get_max_color_value

	@ %def interaction_get_max_color_value
	@ Factorize the state matrix into single-particle state matrices, the
	branch selection depending on a (random) value between 0 and 1;
	optionally also return a correlated state matrix.
	<<Interactions: interaction: TBP>>=
	procedure :: factorize => interaction_factorize
	<<Interactions: procedures>>=
	subroutine interaction_factorize &
	(int, mode, x, ok, single_state, correlated_state, qn_in)
	class(interaction_t), intent(in), target :: int
	integer, intent(in) :: mode
	real(default), intent(in) :: x
	logical, intent(out) :: ok
	type(state_matrix_t), &
	dimension(:), allocatable, intent(out) :: single_state
	type(state_matrix_t), intent(out), optional :: correlated_state
	type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
	call int%state_matrix%factorize &
	(mode, x, ok, single_state, correlated_state, qn_in)
	end subroutine interaction_factorize

	@ %def interaction_factorize
	@ Sum all matrix element values
	<<Interactions: interaction: TBP>>=
	procedure :: sum => interaction_sum
	<<Interactions: procedures>>=
	function interaction_sum (int) result (value)
	class(interaction_t), intent(in) :: int
	complex(default) :: value
	value = int%state_matrix%sum ()
	end function interaction_sum

	@ %def interaction_sum
	@ Append new states which are color-contracted versions of the
	existing states. The matrix element index of each color contraction
	coincides with the index of its origin, so no new matrix elements are
	generated. After this operation, no [[freeze]] must be performed
	anymore.
	<<Interactions: interaction: TBP>>=
	procedure :: add_color_contractions => &
	interaction_add_color_contractions
	<<Interactions: procedures>>=
	subroutine interaction_add_color_contractions (int)
	class(interaction_t), intent(inout) :: int
	call int%state_matrix%add_color_contractions ()
	end subroutine interaction_add_color_contractions

	@ %def interaction_add_color_contractions
	@ Multiply matrix elements from two interactions. Choose the elements
	as given by the integer index arrays, multiply them and store the sum
	of products in the indicated matrix element. The suffixes mean:
	c=conjugate first factor; f=include weighting factor.
	<<Interactions: interaction: TBP>>=
	procedure :: evaluate_product => interaction_evaluate_product
	procedure :: evaluate_product_cf => interaction_evaluate_product_cf
	procedure :: evaluate_square_c => interaction_evaluate_square_c
	procedure :: evaluate_sum => interaction_evaluate_sum
	procedure :: evaluate_me_sum => interaction_evaluate_me_sum
	<<Interactions: procedures>>=
	pure subroutine interaction_evaluate_product &
	(int, i, int1, int2, index1, index2)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(in) :: int1, int2
	integer, dimension(:), intent(in) :: index1, index2
	call int%state_matrix%evaluate_product &
	(i, int1%state_matrix, int2%state_matrix, &
	index1, index2)
	end subroutine interaction_evaluate_product

	pure subroutine interaction_evaluate_product_cf &
	(int, i, int1, int2, index1, index2, factor)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(in) :: int1, int2
	integer, dimension(:), intent(in) :: index1, index2
	complex(default), dimension(:), intent(in) :: factor
	call int%state_matrix%evaluate_product_cf &
	(i, int1%state_matrix, int2%state_matrix, &
	index1, index2, factor)
	end subroutine interaction_evaluate_product_cf

	pure subroutine interaction_evaluate_square_c (int, i, int1, index1)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(in) :: int1
	integer, dimension(:), intent(in) :: index1
	call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1)
	end subroutine interaction_evaluate_square_c

	pure subroutine interaction_evaluate_sum (int, i, int1, index1)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(in) :: int1
	integer, dimension(:), intent(in) :: index1
	call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1)
	end subroutine interaction_evaluate_sum

	pure subroutine interaction_evaluate_me_sum (int, i, int1, index1)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(in) :: int1
	integer, dimension(:), intent(in) :: index1
	call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1)
	end subroutine interaction_evaluate_me_sum

	@ %def interaction_evaluate_product
	@ %def interaction_evaluate_product_cf
	@ %def interaction_evaluate_square_c
	@ %def interaction_evaluate_sum
	@ %def interaction_evaluate_me_sum
	@ Tag quantum numbers of the state matrix als part of the hard process, according
	to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are
	tagged as part of the hard process.
	<<Interactions: interaction: TBP>>=
	procedure :: tag_hard_process => interaction_tag_hard_process
	<<Interactions: procedures>>=
	subroutine interaction_tag_hard_process (int, tag)
	class(interaction_t), intent(inout) :: int
	integer, dimension(:), intent(in), optional :: tag
	type(state_matrix_t) :: state
	call int%state_matrix%tag_hard_process (state, tag)
	call int%state_matrix%final ()
	int%state_matrix = state
	end subroutine interaction_tag_hard_process

	@ %def interaction_tag_hard_process
	\subsection{Accessing contents}
	Return the integer tag.
	<<Interactions: interaction: TBP>>=
	procedure :: get_tag => interaction_get_tag
	<<Interactions: procedures>>=
	function interaction_get_tag (int) result (tag)
	class(interaction_t), intent(in) :: int
	integer :: tag
	tag = int%tag
	end function interaction_get_tag

	@ %def interaction_get_tag
	@ Return the number of particles.
	<<Interactions: interaction: TBP>>=
	procedure :: get_n_tot => interaction_get_n_tot
	procedure :: get_n_in => interaction_get_n_in
	procedure :: get_n_vir => interaction_get_n_vir
	procedure :: get_n_out => interaction_get_n_out
	<<Interactions: procedures>>=
	pure function interaction_get_n_tot (object) result (n_tot)
	class(interaction_t), intent(in) :: object
	integer :: n_tot
	n_tot = object%n_tot
	end function interaction_get_n_tot

	pure function interaction_get_n_in (object) result (n_in)
	class(interaction_t), intent(in) :: object
	integer :: n_in
	n_in = object%n_in
	end function interaction_get_n_in

	pure function interaction_get_n_vir (object) result (n_vir)
	class(interaction_t), intent(in) :: object
	integer :: n_vir
	n_vir = object%n_vir
	end function interaction_get_n_vir

	pure function interaction_get_n_out (object) result (n_out)
	class(interaction_t), intent(in) :: object
	integer :: n_out
	n_out = object%n_out
	end function interaction_get_n_out

	@ %def interaction_get_n_tot
	@ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out
	@ Return a momentum index. The flags specify whether to keep/drop
	incoming, virtual, or outgoing momenta. Check for illegal values.
	<<Interactions: procedures>>=
	function idx (int, i, outgoing)
	integer :: idx
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	logical, intent(in), optional :: outgoing
	logical :: in, vir, out
	if (present (outgoing)) then
	in = .not. outgoing
	vir = .false.
	out = outgoing
	else
	in = .true.
	vir = .true.
	out = .true.
	end if
	idx = 0
	if (in) then
	if (vir) then
	if (out) then
	if (i <= int%n_tot) idx = i
	else
	if (i <= int%n_in + int%n_vir) idx = i
	end if
	else if (out) then
	if (i <= int%n_in) then
	idx = i
	else if (i <= int%n_in + int%n_out) then
	idx = int%n_vir + i
	end if
	else
	if (i <= int%n_in) idx = i
	end if
	else if (vir) then
	if (out) then
	if (i <= int%n_vir + int%n_out) idx = int%n_in + i
	else
	if (i <= int%n_vir) idx = int%n_in + i
	end if
	else if (out) then
	if (i <= int%n_out) idx = int%n_in + int%n_vir + i
	end if
	if (idx == 0) then
	call int%basic_write ()
	print *, i, in, vir, out
	call msg_bug (" Momentum index is out of range for this interaction")
	end if
	end function idx

	@ %def idx
	@ Return all or just a specific four-momentum.
	<<Interactions: interaction: TBP>>=
	generic :: get_momenta => get_momenta_all, get_momenta_idx
	procedure :: get_momentum => interaction_get_momentum
	procedure :: get_momenta_all => interaction_get_momenta_all
	procedure :: get_momenta_idx => interaction_get_momenta_idx
	<<Interactions: procedures>>=
	function interaction_get_momenta_all (int, outgoing) result (p)
	class(interaction_t), intent(in) :: int
	type(vector4_t), dimension(:), allocatable :: p
	logical, intent(in), optional :: outgoing
	integer :: i
	if (present (outgoing)) then
	if (outgoing) then
	allocate (p (int%n_out))
	else
	allocate (p (int%n_in))
	end if
	else
	allocate (p (int%n_tot))
	end if
	do i = 1, size (p)
	p(i) = int%p(idx (int, i, outgoing))
	end do
	end function interaction_get_momenta_all

	function interaction_get_momenta_idx (int, jj) result (p)
	class(interaction_t), intent(in) :: int
	type(vector4_t), dimension(:), allocatable :: p
	integer, dimension(:), intent(in) :: jj
	allocate (p (size (jj)))
	p = int%p(jj)
	end function interaction_get_momenta_idx

	function interaction_get_momentum (int, i, outgoing) result (p)
	class(interaction_t), intent(in) :: int
	type(vector4_t) :: p
	integer, intent(in) :: i
	logical, intent(in), optional :: outgoing
	p = int%p(idx (int, i, outgoing))
	end function interaction_get_momentum

	@ %def interaction_get_momenta interaction_get_momentum
	@ This is a variant as a subroutine. Redundant, but the function
	above fails at times for gfortran 4.5.0 (double allocation, compiler
	bug).
	<<Interactions: interaction: TBP>>=
	procedure :: get_momenta_sub => interaction_get_momenta_sub
	<<Interactions: procedures>>=
	subroutine interaction_get_momenta_sub (int, p, outgoing)
	class(interaction_t), intent(in) :: int
	type(vector4_t), dimension(:), intent(out) :: p
	logical, intent(in), optional :: outgoing
	integer :: i
	do i = 1, size (p)
	p(i) = int%p(idx (int, i, outgoing))
	end do
	end subroutine interaction_get_momenta_sub

	@ %def interaction_get_momenta_sub
	@ Return a shallow copy of the state matrix:
	<<Interactions: interaction: TBP>>=
	procedure :: get_state_matrix_ptr => &
	interaction_get_state_matrix_ptr
	<<Interactions: procedures>>=
	function interaction_get_state_matrix_ptr (int) result (state)
	class(interaction_t), intent(in), target :: int
	type(state_matrix_t), pointer :: state
	state => int%state_matrix
	end function interaction_get_state_matrix_ptr

	@ %def interaction_get_state_matrix_ptr
	@ Return the array of resonance flags
	<<Interactions: interaction: TBP>>=
	procedure :: get_resonance_flags => interaction_get_resonance_flags
	<<Interactions: procedures>>=
	function interaction_get_resonance_flags (int) result (resonant)
	class(interaction_t), intent(in) :: int
	logical, dimension(size(int%resonant)) :: resonant
	resonant = int%resonant
	end function interaction_get_resonance_flags

	@ %def interaction_get_resonance_flags
	@ Return the quantum-numbers mask (or part of it)
	<<Interactions: interaction: TBP>>=
	generic :: get_mask => get_mask_all, get_mask_slice
	procedure :: get_mask_all => interaction_get_mask_all
	procedure :: get_mask_slice => interaction_get_mask_slice
	<<Interactions: procedures>>=
	function interaction_get_mask_all (int) result (mask)
	class(interaction_t), intent(in) :: int
	type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask
	mask = int%mask
	end function interaction_get_mask_all

	function interaction_get_mask_slice (int, index) result (mask)
	class(interaction_t), intent(in) :: int
	integer, dimension(:), intent(in) :: index
	type(quantum_numbers_mask_t), dimension(size(index)) :: mask
	mask = int%mask(index)
	end function interaction_get_mask_slice

	@ %def interaction_get_mask
	@ Compute the invariant mass squared of the incoming particles (if any,
	otherwise outgoing).
	<<Interactions: public>>=
	public :: interaction_get_s
	<<Interactions: procedures>>=
	function interaction_get_s (int) result (s)
	real(default) :: s
	type(interaction_t), intent(in) :: int
	if (int%n_in /= 0) then
	s = sum (int%p(:int%n_in)) ** 2
	else
	s = sum (int%p(int%n_vir + 1 : )) ** 2
	end if
	end function interaction_get_s

	@ %def interaction_get_s
	@ Compute the Lorentz transformation that transforms the incoming
	particles from the center-of-mass frame to the lab frame where they
	are given. If the c.m. mass squared is negative or zero, return the
	identity.
	<<Interactions: public>>=
	public :: interaction_get_cm_transformation
	<<Interactions: procedures>>=
	function interaction_get_cm_transformation (int) result (lt)
	type(lorentz_transformation_t) :: lt
	type(interaction_t), intent(in) :: int
	type(vector4_t) :: p_cm
	real(default) :: s
	if (int%n_in /= 0) then
	p_cm = sum (int%p(:int%n_in))
	else
	p_cm = sum (int%p(int%n_vir+1:))
	end if
	s = p_cm ** 2
	if (s > 0) then
	lt = boost (p_cm, sqrt (s))
	else
	lt = identity
	end if
	end function interaction_get_cm_transformation

	@ %def interaction_get_cm_transformation
	@ Return flavor, momentum, and position of the first outgoing
	unstable particle present in the interaction. Note that we need not
	iterate through the state matrix; if there is an unstable particle, it
	will be present in all state-matrix entries.
	<<Interactions: public>>=
	public :: interaction_get_unstable_particle
	<<Interactions: procedures>>=
	subroutine interaction_get_unstable_particle (int, flv, p, i)
	type(interaction_t), intent(in), target :: int
	type(flavor_t), intent(out) :: flv
	type(vector4_t), intent(out) :: p
	integer, intent(out) :: i
	type(state_iterator_t) :: it
	type(flavor_t), dimension(int%n_tot) :: flv_array
	call it%init (int%state_matrix)
	flv_array = it%get_flavor ()
	do i = int%n_in + int%n_vir + 1, int%n_tot
	if (.not. flv_array(i)%is_stable ()) then
	flv = flv_array(i)
	p = int%p(i)
	return
	end if
	end do
	end subroutine interaction_get_unstable_particle

	@ %def interaction_get_unstable_particle
	@ Return the complete set of \emph{outgoing} flavors, assuming that
	the flavor quantum number is not suppressed.
	<<Interactions: public>>=
	public :: interaction_get_flv_out
	<<Interactions: procedures>>=
	subroutine interaction_get_flv_out (int, flv)
	type(interaction_t), intent(in), target :: int
	type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
	type(state_iterator_t) :: it
	type(flavor_t), dimension(:), allocatable :: flv_state
	integer :: n_in, n_vir, n_out, n_tot, n_state, i
	n_in = int%get_n_in ()
	n_vir = int%get_n_vir ()
	n_out = int%get_n_out ()
	n_tot = int%get_n_tot ()
	n_state = int%get_n_matrix_elements ()
	allocate (flv (n_out, n_state))
	allocate (flv_state (n_tot))
	i = 1
	call it%init (int%get_state_matrix_ptr ())
	do while (it%is_valid ())
	flv_state = it%get_flavor ()
	flv(:,i) = flv_state(n_in + n_vir + 1 : )
	i = i + 1
	call it%advance ()
	end do
	end subroutine interaction_get_flv_out

	@ %def interaction_get_flv_out
	@ Determine the flavor content of the interaction. We analyze the
	state matrix for this, and we select the outgoing particles of the
	hard process only for the required mask, which indicates the particles
	that can appear in any order in a matching event record.

	We have to assume that any radiated particles (beam remnants) appear
	at the beginning of the particles marked as outgoing.
	<<Interactions: public>>=
	public :: interaction_get_flv_content
	<<Interactions: procedures>>=
	subroutine interaction_get_flv_content (int, state_flv, n_out_hard)
	type(interaction_t), intent(in), target :: int
	type(state_flv_content_t), intent(out) :: state_flv
	integer, intent(in) :: n_out_hard
	logical, dimension(:), allocatable :: mask
	integer :: n_tot
	n_tot = int%get_n_tot ()
	allocate (mask (n_tot), source = .false.)
	mask(n_tot-n_out_hard + 1 : ) = .true.
	call state_flv%fill (int%get_state_matrix_ptr (), mask)
	end subroutine interaction_get_flv_content

	@ %def interaction_get_flv_content
	@
	\subsection{Modifying contents}
	Set the quantum numbers mask.
	<<Interactions: interaction: TBP>>=
	procedure :: set_mask => interaction_set_mask
	<<Interactions: procedures>>=
	subroutine interaction_set_mask (int, mask)
	class(interaction_t), intent(inout) :: int
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	if (size (int%mask) /= size (mask)) &
	call msg_fatal ("Attempting to set mask with unfitting size!")
	int%mask = mask
	int%update_state_matrix = .true.
	end subroutine interaction_set_mask

	@ %def interaction_set_mask
	@ Merge a particular mask entry, respecting a possible helicity lock for this
	entry. We apply an OR relation, which means that quantum numbers are
	summed over if either of the two masks requires it.
	<<Interactions: procedures>>=
	subroutine interaction_merge_mask_entry (int, i, mask)
	type(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	type(quantum_numbers_mask_t), intent(in) :: mask
	type(quantum_numbers_mask_t) :: mask_tmp
	integer :: ii
	ii = idx (int, i)
	if (int%mask(ii) .neqv. mask) then
	int%mask(ii) = int%mask(ii) .or. mask
	if (int%hel_lock(ii) /= 0) then
	call mask_tmp%assign (mask, helicity=.true.)
	int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp
	end if
	end if
	int%update_state_matrix = .true.
	end subroutine interaction_merge_mask_entry

	@ %def interaction_merge_mask_entry
	@ Fill the momenta array, do not care about the quantum numbers of
	particles.
	<<Interactions: interaction: TBP>>=
	procedure :: reset_momenta => interaction_reset_momenta
	procedure :: set_momenta => interaction_set_momenta
	procedure :: set_momentum => interaction_set_momentum
	<<Interactions: procedures>>=
	subroutine interaction_reset_momenta (int)
	class(interaction_t), intent(inout) :: int
	int%p = vector4_null
	int%p_is_known = .true.
	end subroutine interaction_reset_momenta

	subroutine interaction_set_momenta (int, p, outgoing)
	class(interaction_t), intent(inout) :: int
	type(vector4_t), dimension(:), intent(in) :: p
	logical, intent(in), optional :: outgoing
	integer :: i, index
	do i = 1, size (p)
	index = idx (int, i, outgoing)
	int%p(index) = p(i)
	int%p_is_known(index) = .true.
	end do
	end subroutine interaction_set_momenta

	subroutine interaction_set_momentum (int, p, i, outgoing)
	class(interaction_t), intent(inout) :: int
	type(vector4_t), intent(in) :: p
	integer, intent(in) :: i
	logical, intent(in), optional :: outgoing
	integer :: index
	index = idx (int, i, outgoing)
	int%p(index) = p
	int%p_is_known(index) = .true.
	end subroutine interaction_set_momentum

	@ %def interaction_reset_momenta
	@ %def interaction_set_momenta interaction_set_momentum
	@ This more sophisticated version of setting values is used for
	structure functions, in particular if nontrivial flavor, color, and
	helicity may be present: set values selectively for the given flavors.
	If there is more than one flavor, scan the interaction and check for a
	matching flavor at the specified particle location. If it matches,
	insert the value that corresponds to this flavor.
	<<Interactions: public>>=
	public :: interaction_set_flavored_values
	<<Interactions: procedures>>=
	subroutine interaction_set_flavored_values (int, value, flv_in, pos)
	type(interaction_t), intent(inout) :: int
	complex(default), dimension(:), intent(in) :: value
	type(flavor_t), dimension(:), intent(in) :: flv_in
	integer, intent(in) :: pos
	type(state_iterator_t) :: it
	type(flavor_t) :: flv
	integer :: i
	if (size (value) == 1) then
	call int%set_matrix_element (value(1))
	else
	call it%init (int%state_matrix)
	do while (it%is_valid ())
	flv = it%get_flavor (pos)
	SCAN_FLV: do i = 1, size (value)
	if (flv == flv_in(i)) then
	call it%set_matrix_element (value(i))
	exit SCAN_FLV
	end if
	end do SCAN_FLV
	call it%advance ()
	end do
	end if
	end subroutine interaction_set_flavored_values

	@ %def interaction_set_flavored_values
	@
	\subsection{Handling Linked interactions}
	Store relations between corresponding particles within one
	interaction. The first particle is the parent, the second one the
	child. Links are established in both directions.

	These relations have no effect on the propagation of momenta etc.,
	they are rather used for mother-daughter relations in event output.
	<<Interactions: interaction: TBP>>=
	procedure :: relate => interaction_relate
	<<Interactions: procedures>>=
	subroutine interaction_relate (int, i1, i2)
	class(interaction_t), intent(inout), target :: int
	integer, intent(in) :: i1, i2
	if (i1 /= 0 .and. i2 /= 0) then
	call int%children(i1)%append (i2)
	call int%parents(i2)%append (i1)
	end if
	end subroutine interaction_relate

	@ %def interaction_relate
	@ Transfer internal parent-child relations defined within interaction
	[[int1]] to a new interaction [[int]] where the particle indices are
	mapped to. Some particles in [[int1]] may have no image in [[int]].
	In that case, a child entry maps to zero, and we skip this relation.

	Also transfer resonance flags.
	<<Interactions: interaction: TBP>>=
	procedure :: transfer_relations => interaction_transfer_relations
	<<Interactions: procedures>>=
	subroutine interaction_transfer_relations (int1, int2, map)
	class(interaction_t), intent(in) :: int1
	class(interaction_t), intent(inout), target :: int2
	integer, dimension(:), intent(in) :: map
	integer :: i, j, k
	do i = 1, size (map)
	do j = 1, int1%parents(i)%get_length ()
	k = int1%parents(i)%get_link (j)
	call int2%relate (map(k), map(i))
	end do
	if (map(i) /= 0) then
	int2%resonant(map(i)) = int1%resonant(i)
	end if
	end do
	end subroutine interaction_transfer_relations

	@ %def interaction_transfer_relations
	@ Make up internal parent-child relations for the particle(s) that are
	connected to a new interaction [[int]].

	If [[resonant]] is defined and true, the connections are marked as
	resonant in the result interaction
	<<Interactions: interaction: TBP>>=
	procedure :: relate_connections => interaction_relate_connections
	<<Interactions: procedures>>=
	subroutine interaction_relate_connections &
	(int, int_in, connection_index, &
	map, map_connections, resonant)
	class(interaction_t), intent(inout), target :: int
	class(interaction_t), intent(in) :: int_in
	integer, dimension(:), intent(in) :: connection_index
	integer, dimension(:), intent(in) :: map, map_connections
	logical, intent(in), optional :: resonant
	logical :: reson
	integer :: i, j, i2, k2
	reson = .false.; if (present (resonant)) reson = resonant
	do i = 1, size (map_connections)
	k2 = connection_index(i)
	do j = 1, int_in%children(k2)%get_length ()
	i2 = int_in%children(k2)%get_link (j)
	call int%relate (map_connections(i), map(i2))
	end do
	int%resonant(map_connections(i)) = reson
	end do
	end subroutine interaction_relate_connections

	@ %def interaction_relate_connections.
	@ Return the number of source/target links of the internal connections of
	particle [[i]].
	<<Interactions: public>>=
	public :: interaction_get_n_children
	public :: interaction_get_n_parents
	<<Interactions: procedures>>=
	function interaction_get_n_children (int, i) result (n)
	integer :: n
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	n = int%children(i)%get_length ()
	end function interaction_get_n_children

	function interaction_get_n_parents (int, i) result (n)
	integer :: n
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	n = int%parents(i)%get_length ()
	end function interaction_get_n_parents

	@ %def interaction_get_n_children interaction_get_n_parents
	@ Return the source/target links of the internal connections of
	particle [[i]] as an array.
	<<Interactions: public>>=
	public :: interaction_get_children
	public :: interaction_get_parents
	<<Interactions: procedures>>=
	function interaction_get_children (int, i) result (idx)
	integer, dimension(:), allocatable :: idx
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	integer :: k, l
	l = int%children(i)%get_length ()
	allocate (idx (l))
	do k = 1, l
	idx(k) = int%children(i)%get_link (k)
	end do
	end function interaction_get_children

	function interaction_get_parents (int, i) result (idx)
	integer, dimension(:), allocatable :: idx
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	integer :: k, l
	l = int%parents(i)%get_length ()
	allocate (idx (l))
	do k = 1, l
	idx(k) = int%parents(i)%get_link (k)
	end do
	end function interaction_get_parents

	@ %def interaction_get_children interaction_get_parents
	@ Add a source link from an interaction to a corresponding particle
	within another interaction. These links affect the propagation of
	particles: the two linked particles are considered as the same
	particle, outgoing and incoming.
	<<Interactions: interaction: TBP>>=
	procedure :: set_source_link => interaction_set_source_link
	<<Interactions: procedures>>=
	subroutine interaction_set_source_link (int, i, int1, i1)
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: i
	class(interaction_t), intent(in), target :: int1
	integer, intent(in) :: i1
	if (i /= 0) call external_link_set (int%source(i), int1, i1)
	end subroutine interaction_set_source_link

	@ %def interaction_set_source_link
	@ Reassign links to a new interaction (which is an image of the
	current interaction).
	<<Interactions: public>>=
	public :: interaction_reassign_links
	<<Interactions: procedures>>=
	subroutine interaction_reassign_links (int, int_src, int_target)
	type(interaction_t), intent(inout) :: int
	type(interaction_t), intent(in) :: int_src
	type(interaction_t), intent(in), target :: int_target
	integer :: i
	if (allocated (int%source)) then
	do i = 1, size (int%source)
	call external_link_reassign (int%source(i), int_src, int_target)
	end do
	end if
	end subroutine interaction_reassign_links

	@ %def interaction_reassign_links
	@ Since links are one-directional, if we want to follow them backwards
	we have to scan all possibilities. This procedure returns the index
	of the particle within [[int]] which points to the particle [[i1]]
	within interaction [[int1]]. If unsuccessful, return zero.
	<<Interactions: public>>=
	public :: interaction_find_link
	<<Interactions: procedures>>=
	function interaction_find_link (int, int1, i1) result (i)
	integer :: i
	type(interaction_t), intent(in) :: int, int1
	integer, intent(in) :: i1
	type(interaction_t), pointer :: int_tmp
	do i = 1, int%n_tot
	int_tmp => external_link_get_ptr (int%source(i))
	if (int_tmp%tag == int1%tag) then
	if (external_link_get_index (int%source(i)) == i1) return
	end if
	end do
	i = 0
	end function interaction_find_link

	@ %def interaction_find_link
	@ The inverse: return interaction pointer and index for the ultimate source of
	[[i]] within [[int]].
	<<Interactions: interaction: TBP>>=
	procedure :: find_source => interaction_find_source
	<<Interactions: procedures>>=
	subroutine interaction_find_source (int, i, int1, i1)
	class(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	type(interaction_t), intent(out), pointer :: int1
	integer, intent(out) :: i1
	type(external_link_t) :: link
	link = interaction_get_ultimate_source (int, i)
	int1 => external_link_get_ptr (link)
	i1 = external_link_get_index (link)
	end subroutine interaction_find_source

	@ %def interaction_find_source
	@ Follow source links recursively to return the ultimate source of a particle.
	<<Interactions: procedures>>=
	function interaction_get_ultimate_source (int, i) result (link)
	type(external_link_t) :: link
	type(interaction_t), intent(in) :: int
	integer, intent(in) :: i
	type(interaction_t), pointer :: int_src
	integer :: i_src
	link = int%source(i)
	if (external_link_is_set (link)) then
	do
	int_src => external_link_get_ptr (link)
	i_src = external_link_get_index (link)
	if (external_link_is_set (int_src%source(i_src))) then
	link = int_src%source(i_src)
	else
	exit
	end if
	end do
	end if
	end function interaction_get_ultimate_source

	@ %def interaction_get_ultimate_source
	@ Update mask entries by merging them with corresponding masks in
	interactions linked to the current one. The mask determines quantum
	numbers which are summed over.

	Note that both the mask of the current interaction and the mask of the
	linked interaction are updated (side effect!). This ensures that both
	agree for the linked particle.
	<<Interactions: public>>=
	public :: interaction_exchange_mask
	<<Interactions: procedures>>=
	subroutine interaction_exchange_mask (int)
	type(interaction_t), intent(inout) :: int
	integer :: i, index_link
	type(interaction_t), pointer :: int_link
	do i = 1, int%n_tot
	if (external_link_is_set (int%source(i))) then
	int_link => external_link_get_ptr (int%source(i))
	index_link = external_link_get_index (int%source(i))
	call interaction_merge_mask_entry &
	(int, i, int_link%mask(index_link))
	call interaction_merge_mask_entry &
	(int_link, index_link, int%mask(i))
	end if
	end do
	call int%freeze ()
	end subroutine interaction_exchange_mask

	@ %def interaction_exchange_mask
	@ Copy momenta from interactions linked to the current one.
	<<Interactions: interaction: TBP>>=
	procedure :: receive_momenta => interaction_receive_momenta
	<<Interactions: procedures>>=
	subroutine interaction_receive_momenta (int)
	class(interaction_t), intent(inout) :: int
	integer :: i, index_link
	type(interaction_t), pointer :: int_link
	do i = 1, int%n_tot
	if (external_link_is_set (int%source(i))) then
	int_link => external_link_get_ptr (int%source(i))
	index_link = external_link_get_index (int%source(i))
	call int%set_momentum (int_link%p(index_link), i)
	end if
	end do
	end subroutine interaction_receive_momenta

	@ %def interaction_receive_momenta
	@ The inverse operation: Copy momenta back to the interactions linked
	to the current one.
	<<Interactions: public>>=
	public :: interaction_send_momenta
	<<Interactions: procedures>>=
	subroutine interaction_send_momenta (int)
	type(interaction_t), intent(in) :: int
	integer :: i, index_link
	type(interaction_t), pointer :: int_link
	do i = 1, int%n_tot
	if (external_link_is_set (int%source(i))) then
	int_link => external_link_get_ptr (int%source(i))
	index_link = external_link_get_index (int%source(i))
	call int_link%set_momentum (int%p(i), index_link)
	end if
	end do
	end subroutine interaction_send_momenta

	@ %def interaction_send_momenta
	@ For numerical comparisons: pacify all momenta in an interaction.
	<<Interactions: public>>=
	public :: interaction_pacify_momenta
	<<Interactions: procedures>>=
	subroutine interaction_pacify_momenta (int, acc)
	type(interaction_t), intent(inout) :: int
	real(default), intent(in) :: acc
	integer :: i
	do i = 1, int%n_tot
	call pacify (int%p(i), acc)
	end do
	end subroutine interaction_pacify_momenta

	@ %def interaction_pacify_momenta
	@ For each subtraction entry starting from [[SUB = 0]], we duplicate the original state matrix entries as is.
	<<Interactions: interaction: TBP>>=
	procedure :: declare_subtraction => interaction_declare_subtraction
	<<Interactions: procedures>>=
	subroutine interaction_declare_subtraction (int, n_sub)
	class(interaction_t), intent(inout), target :: int
	integer, intent(in) :: n_sub
	integer :: i_sub
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	type(state_matrix_t) :: state_matrix
	call state_matrix%init (store_values = .true.)
	allocate (qn (int%get_state_depth ()))
	do i_sub = 0, n_sub
	call it%init (int%state_matrix)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	call qn%set_subtraction_index (i_sub)
	call state_matrix%add_state (qn, value = it%get_matrix_element ())
	call it%advance ()
	end do
	end do
	call state_matrix%freeze ()
	call state_matrix%set_n_sub ()
	call int%state_matrix%final ()
	int%state_matrix = state_matrix
	end subroutine interaction_declare_subtraction

	@ %def interaction_declare_subtraction
	@
	\subsection{Recovering connections}
	When creating an evaluator for two interactions, we have to know by
	which particles they are connected. The connection indices can be
	determined if we have two linked interactions. We assume that
	[[int1]] is the source and [[int2]] the target, so the connections of
	interest are stored within [[int2]]. A connection is found if either the
	source is [[int1]], or the (ultimate)
	source of a particle within [[int2]] coincides with the (ultimate) source of a
	aparticle within [[int1]]. The result is an array of
	index pairs.

	To make things simple, we scan the interaction twice,
	once for counting hits, then allocate the array, then scan again and
	store the connections.

	The connections are scanned for [[int2]], which has sources in [[int1]]. It
	may happen that the order of connections is interchanged (crossed). We
	require the indices in [[int1]] to be sorted, so we reorder both index arrays
	correspondingly before returning them. (After this, the indices in [[int2]]
	may be out of order.)
	<<Interactions: public>>=
	public :: find_connections
	<<Interactions: procedures>>=
	subroutine find_connections (int1, int2, n, connection_index)
	class(interaction_t), intent(in) :: int1, int2
	integer, intent(out) :: n
	integer, dimension(:,:), intent(out), allocatable :: connection_index
	integer, dimension(:,:), allocatable :: conn_index_tmp
	integer, dimension(:), allocatable :: ordering
	integer :: i, j, k
	type(external_link_t) :: link1, link2
	type(interaction_t), pointer :: int_link1, int_link2
	n = 0
	do i = 1, size (int2%source)
	link2 = interaction_get_ultimate_source (int2, i)
	if (external_link_is_set (link2)) then
	int_link2 => external_link_get_ptr (link2)
	if (int_link2%tag == int1%tag) then
	n = n + 1
	else
	k = external_link_get_index (link2)
	do j = 1, size (int1%source)
	link1 = interaction_get_ultimate_source (int1, j)
	if (external_link_is_set (link1)) then
	int_link1 => external_link_get_ptr (link1)
	if (int_link1%tag == int_link2%tag) then
	if (external_link_get_index (link1) == k) &
	n = n + 1
	end if
	end if
	end do
	end if
	end if
	end do
	allocate (conn_index_tmp (n, 2))
	n = 0
	do i = 1, size (int2%source)
	link2 = interaction_get_ultimate_source (int2, i)
	if (external_link_is_set (link2)) then
	int_link2 => external_link_get_ptr (link2)
	if (int_link2%tag == int1%tag) then
	n = n + 1
	conn_index_tmp(n,1) = external_link_get_index (int2%source(i))
	conn_index_tmp(n,2) = i
	else
	k = external_link_get_index (link2)
	do j = 1, size (int1%source)
	link1 = interaction_get_ultimate_source (int1, j)
	if (external_link_is_set (link1)) then
	int_link1 => external_link_get_ptr (link1)
	if (int_link1%tag == int_link2%tag) then
	if (external_link_get_index (link1) == k) then
	n = n + 1
	conn_index_tmp(n,1) = j
	conn_index_tmp(n,2) = i
	end if
	end if
	end if
	end do
	end if
	end if
	end do
	allocate (connection_index (n, 2))
	if (n > 1) then
	allocate (ordering (n))
	ordering = order (conn_index_tmp(:,1))
	connection_index = conn_index_tmp(ordering,:)
	else
	connection_index = conn_index_tmp
	end if
	end subroutine find_connections

	@ %def find_connections
	@
	\subsection{Unit tests}
	Test module, followed by the corresponding implementation module.
	<<[[interactions_ut.f90]]>>=
	<<File header>>

	module interactions_ut
	use unit_tests
	use interactions_uti

	<<Standard module head>>

	<<Interactions: public test>>

	contains

	<<Interactions: test driver>>

	end module interactions_ut
	@ %def interactions_ut
	@
	<<[[interactions_uti.f90]]>>=
	<<File header>>

	module interactions_uti

	<<Use kinds>>
	use lorentz
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices

	use interactions

	<<Standard module head>>

	<<Interactions: test declarations>>

	contains

	<<Interactions: tests>>

	end module interactions_uti
	@ %def interactions_ut
	@ API: driver for the unit tests below.
	<<Interactions: public test>>=
	public :: interaction_test
	<<Interactions: test driver>>=
	subroutine interaction_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Interactions: execute tests>>
	end subroutine interaction_test

	@ %def interaction_test
	@ Generate an interaction of a polarized virtual photon and a colored
	quark which may be either up or down. Remove the quark polarization.
	Generate another interaction for the quark radiating a photon and link
	this to the first interation. The radiation ignores polarization;
	transfer this information to the first interaction to simplify it.
	Then, transfer the momentum to the radiating quark and perform a
	splitting.
	<<Interactions: execute tests>>=
	call test (interaction_1, "interaction_1", &
	"check interaction setup", &
	u, results)
	<<Interactions: test declarations>>=
	public :: interaction_1
	<<Interactions: tests>>=
	subroutine interaction_1 (u)
	integer, intent(in) :: u
	type(interaction_t), target :: int, rad
	type(vector4_t), dimension(3) :: p
	type(quantum_numbers_mask_t), dimension(3) :: mask
	p(2) = vector4_moving (500._default, 500._default, 1)
	p(3) = vector4_moving (500._default,-500._default, 1)
	p(1) = p(2) + p(3)

	write (u, "(A)") "* Test output: interaction"
	write (u, "(A)") "* Purpose: check routines for interactions"
	write (u, "(A)")

	call int%basic_init (1, 0, 2, set_relations=.true., &
	store_values = .true. )
	call int_set (int, 1, -1, 1, 1, &
	cmplx (0.3_default, 0.1_default, kind=default))
	call int_set (int, 1, -1,-1, 1, &
	cmplx (0.5_default,-0.7_default, kind=default))
	call int_set (int, 1, 1, 1, 1, &
	cmplx (0.1_default, 0._default, kind=default))
	call int_set (int, -1, 1, -1, 2, &
	cmplx (0.4_default, -0.1_default, kind=default))
	call int_set (int, 1, 1, 1, 2, &
	cmplx (0.2_default, 0._default, kind=default))
	call int%freeze ()
	call int%set_momenta (p)
	mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.])
	call rad%basic_init (1, 0, 2, &
	mask=mask, set_relations=.true., store_values = .true.)
	call rad_set (1)
	call rad_set (2)
	call rad%set_source_link (1, int, 2)
	call interaction_exchange_mask (rad)
	call rad%receive_momenta ()
	p(1) = rad%get_momentum (1)
	p(2) = 0.4_default * p(1)
	p(3) = p(1) - p(2)
	call rad%set_momenta (p(2:3), outgoing=.true.)
	call int%freeze ()
	call rad%freeze ()
	call rad%set_matrix_element &
	(cmplx (0._default, 0._default, kind=default))
	call int%basic_write (u)
	write (u, "(A)")
	call rad%basic_write (u)
	write (u, "(A)")
	write (u, "(A)") "* Cleanup"
	call int%final ()
	call rad%final ()
	write (u, "(A)")
	write (u, "(A)") "* Test interaction_1: successful."
	contains
	subroutine int_set (int, h1, h2, hq, q, val)
	type(interaction_t), target, intent(inout) :: int
	integer, intent(in) :: h1, h2, hq, q
	type(flavor_t), dimension(3) :: flv
	type(color_t), dimension(3) :: col
	type(helicity_t), dimension(3) :: hel
	type(quantum_numbers_t), dimension(3) :: qn
	complex(default), intent(in) :: val
	call flv%init ([21, q, -q])
	call col(2)%init_col_acl (5, 0)
	call col(3)%init_col_acl (0, 5)
	call hel%init ([h1, hq, -hq], [h2, hq, -hq])
	call qn%init (flv, col, hel)
	call int%add_state (qn)
	call int%set_matrix_element (val)
	end subroutine int_set
	subroutine rad_set (q)
	integer, intent(in) :: q
	type(flavor_t), dimension(3) :: flv
	type(quantum_numbers_t), dimension(3) :: qn
	call flv%init ([ q, q, 21 ])
	call qn%init (flv)
	call rad%add_state (qn)
	end subroutine rad_set
	end subroutine interaction_1

	@ %def interaction_1
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Matrix element evaluation}

	The [[evaluator_t]] type is an extension of the [[interaction_t]]
	type. It represents either a density matrix as the square of a
	transition matrix element, or the product of two density matrices.
	Usually, some quantum numbers are summed over in the result.

	The [[interaction_t]] subobject represents a multi-particle
	interaction with incoming, virtual, and outgoing particles and the
	associated (not necessarily diagonal) density matrix of quantum
	state. When the evaluator is initialized, this interaction is
	constructed from the input interaction(s).

	In addition, the initialization process sets up a multiplication
	table. For each matrix element of the result, it states which matrix
	elements are to be taken from the input interaction(s), multiplied
	(optionally, with an additional weight factor) and summed over.

	Eventually, to a processes we associate a chain of evaluators which
	are to be evaluated sequentially. The physical event and its matrix
	element value(s) can be extracted from the last evaluator in such a
	chain.

	Evaluators are constructed only once (as long as this is possible)
	during an initialization step. Then, for each event, momenta
	are computed and transferred among evaluators using the links within
	the interaction subobject. The multiplication tables enable fast
	evaluation of the result without looking at quantum numbers anymore.
	<<[[evaluators.f90]]>>=
	<<File header>>

	module evaluators

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_19
	use physics_defs, only: n_beam_structure_int
	use diagnostics
	use lorentz
	- use model_data
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices
	use interactions

	<<Standard module head>>

	<<Evaluators: public>>

	<<Evaluators: parameters>>

	<<Evaluators: types>>

	<<Evaluators: interfaces>>

	contains

	<<Evaluators: procedures>>

	end module evaluators
	@ %def evaluators
	@
	\subsection{Array of pairings}
	The evaluator contains an array of [[pairing_array]] objects. This
	makes up the multiplication table.

	Each pairing array contains two list of matrix element indices and a
	list of numerical factors. The matrix element indices correspond to
	the input interactions. The corresponding matrix elements are to be
	multiplied and optionally multiplied by a factor. The results are
	summed over to yield one specific matrix element of the result
	evaluator.
	<<Evaluators: types>>=
	type :: pairing_array_t
	integer, dimension(:), allocatable :: i1, i2
	complex(default), dimension(:), allocatable :: factor
	end type pairing_array_t

	@ %def pairing_array_t
	<<Evaluators: procedures>>=
	elemental subroutine pairing_array_init (pa, n, has_i2, has_factor)
	type(pairing_array_t), intent(out) :: pa
	integer, intent(in) :: n
	logical, intent(in) :: has_i2, has_factor
	allocate (pa%i1 (n))
	if (has_i2) allocate (pa%i2 (n))
	if (has_factor) allocate (pa%factor (n))
	end subroutine pairing_array_init

	@ %def pairing_array_init
	@
	<<Evaluators: public>>=
	public :: pairing_array_write
	<<Evaluators: procedures>>=
	subroutine pairing_array_write (pa, unit)
	type(pairing_array_t), intent(in) :: pa
	integer, intent(in), optional :: unit
	integer :: i, u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)", advance = "no") "["
	if (allocated (pa%i1)) then
	write (u, "(I0,A)", advance = "no") pa%i1, ","
	else
	write (u, "(A)", advance = "no") "x,"
	end if
	if (allocated (pa%i2)) then
	write (u, "(I0,A)", advance = "no") pa%i1, ","
	else
	write (u, "(A)", advance = "no") "x,"
	end if
	write (u, "(A)", advance = "no") "]"
	if (allocated (pa%factor)) then
	write (u, "(A,F5.4,A,F5.4,A)") ";(", &
	real(pa%factor), ",", aimag(pa%factor), ")]"
	else
	write (u, "(A)") ""
	end if
	end subroutine pairing_array_write

	@ %def pairing_array_write
	@
	\subsection{The evaluator type}
	Possible variants of evaluators:
	<<Evaluators: parameters>>=
	integer, parameter :: &
	EVAL_UNDEFINED = 0, &
	EVAL_PRODUCT = 1, &
	EVAL_SQUARED_FLOWS = 2, &
	EVAL_SQUARE_WITH_COLOR_FACTORS = 3, &
	EVAL_COLOR_CONTRACTION = 4, &
	EVAL_IDENTITY = 5, &
	EVAL_QN_SUM = 6
	@ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS
	@ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM
	@ The evaluator type contains the result interaction and an array of
	pairing lists, one for each matrix element in the result interaction.
	<<Evaluators: public>>=
	public :: evaluator_t
	<<Evaluators: types>>=
	type, extends (interaction_t) :: evaluator_t
	private
	integer :: type = EVAL_UNDEFINED
	class(interaction_t), pointer :: int_in1 => null ()
	class(interaction_t), pointer :: int_in2 => null ()
	type(pairing_array_t), dimension(:), allocatable :: pairing_array
	contains
	<<Evaluators: evaluator: TBP>>
	end type evaluator_t

	@ %def evaluator_t
	@ Output.
	<<Evaluators: evaluator: TBP>>=
	procedure :: write => evaluator_write
	<<Evaluators: procedures>>=
	subroutine evaluator_write (eval, unit, &
	verbose, show_momentum_sum, show_mass, show_state, show_table, &
	col_verbose, testflag)
	class(evaluator_t), intent(in) :: eval
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: show_state, show_table, col_verbose
	logical, intent(in), optional :: testflag
	logical :: conjugate, square, show_tab
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	show_tab = .true.; if (present (show_table)) show_tab = .false.
	call eval%basic_write &
	(unit, verbose, show_momentum_sum, show_mass, &
	show_state, col_verbose, testflag)
	if (show_tab) then
	write (u, "(1x,A)") "Matrix-element multiplication"
	write (u, "(2x,A)", advance="no") "Input interaction 1:"
	if (associated (eval%int_in1)) then
	write (u, "(1x,I0)") eval%int_in1%get_tag ()
	else
	write (u, "(A)") " [undefined]"
	end if
	write (u, "(2x,A)", advance="no") "Input interaction 2:"
	if (associated (eval%int_in2)) then
	write (u, "(1x,I0)") eval%int_in2%get_tag ()
	else
	write (u, "(A)") " [undefined]"
	end if
	select case (eval%type)
	case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS)
	conjugate = .true.
	square = .true.
	case (EVAL_IDENTITY)
	write (u, "(1X,A)") "Identity evaluator, pairing array unused"
	return
	case default
	conjugate = .false.
	square = .false.
	end select
	call eval%write_pairing_array (conjugate, square, u)
	end if
	end subroutine evaluator_write

	@ %def evaluator_write
	@
	<<Evaluators: evaluator: TBP>>=
	procedure :: write_pairing_array => evaluator_write_pairing_array
	<<Evaluators: procedures>>=
	subroutine evaluator_write_pairing_array (eval, conjugate, square, unit)
	class(evaluator_t), intent(in) :: eval
	logical, intent(in) :: conjugate, square
	integer, intent(in), optional :: unit
	integer :: u, i, j
	u = given_output_unit (unit); if (u < 0) return
	if (allocated (eval%pairing_array)) then
	do i = 1, size (eval%pairing_array)
	write (u, "(2x,A,I0,A)") "ME(", i, ") = "
	do j = 1, size (eval%pairing_array(i)%i1)
	write (u, "(4x,A)", advance="no") "+"
	if (allocated (eval%pairing_array(i)%i2)) then
	write (u, "(1x,A,I0,A)", advance="no") &
	"ME1(", eval%pairing_array(i)%i1(j), ")"
	if (conjugate) then
	write (u, "(A)", advance="no") "* x"
	else
	write (u, "(A)", advance="no") " x"
	end if
	write (u, "(1x,A,I0,A)", advance="no") &
	"ME2(", eval%pairing_array(i)%i2(j), ")"
	else if (square) then
	write (u, "(1x,A)", advance="no") "\|"
	write (u, "(A,I0,A)", advance="no") &
	"ME1(", eval%pairing_array(i)%i1(j), ")"
	write (u, "(A)", advance="no") "\|^2"
	else
	write (u, "(1x,A,I0,A)", advance="no") &
	"ME1(", eval%pairing_array(i)%i1(j), ")"
	end if
	if (allocated (eval%pairing_array(i)%factor)) then
	write (u, "(1x,A)", advance="no") "x"
	write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // &
	",')')") eval%pairing_array(i)%factor(j)
	else
	write (u, *)
	end if
	end do
	end do
	end if
	end subroutine evaluator_write_pairing_array

	@ %def evaluator_write_pairing_array
	@ Assignment: Deep copy of the interaction component.
	<<Evaluators: public>>=
	public :: assignment(=)
	<<Evaluators: interfaces>>=
	interface assignment(=)
	module procedure evaluator_assign
	end interface

	<<Evaluators: procedures>>=
	subroutine evaluator_assign (eval_out, eval_in)
	type(evaluator_t), intent(out) :: eval_out
	type(evaluator_t), intent(in) :: eval_in
	eval_out%type = eval_in%type
	eval_out%int_in1 => eval_in%int_in1
	eval_out%int_in2 => eval_in%int_in2
	eval_out%interaction_t = eval_in%interaction_t
	if (allocated (eval_in%pairing_array)) then
	allocate (eval_out%pairing_array (size (eval_in%pairing_array)))
	eval_out%pairing_array = eval_in%pairing_array
	end if
	end subroutine evaluator_assign

	@ %def evaluator_assign
	@
	\subsection{Auxiliary structures for evaluator creation}
	Creating an evaluator that properly handles all quantum numbers requires some
	bookkeeping. In this section, we define several auxiliary types and methods
	that organize and simplify this task. More structures are defined within the
	specific initializers (as local types and internal subroutines).

	These types are currently implemented in a partial object-oriented way: We
	define some basic methods for initialization etc.\ here, but the evaluator
	routines below do access their internals as well. This simplifies some things
	such as index addressing using array slices, at the expense of losing some
	clarity.

	\subsubsection{Index mapping}
	Index mapping are abundant when constructing an evaluator. To have arrays of
	index mappings, we define this:
	<<Evaluators: types>>=
	type :: index_map_t
	integer, dimension(:), allocatable :: entry
	end type index_map_t

	@ %def index_map_t
	<<Evaluators: procedures>>=
	elemental subroutine index_map_init (map, n)
	type(index_map_t), intent(out) :: map
	integer, intent(in) :: n
	allocate (map%entry (n))
	map%entry = 0
	end subroutine index_map_init

	@ %def index_map_init
	<<Evaluators: procedures>>=
	function index_map_exists (map) result (flag)
	logical :: flag
	type(index_map_t), intent(in) :: map
	flag = allocated (map%entry)
	end function index_map_exists

	@ %def index_map_exists
	<<Evaluators: interfaces>>=
	interface size
	module procedure index_map_size
	end interface

	@ %def size
	<<Evaluators: procedures>>=
	function index_map_size (map) result (s)
	integer :: s
	type(index_map_t), intent(in) :: map
	if (allocated (map%entry)) then
	s = size (map%entry)
	else
	s = 0
	end if
	end function index_map_size

	@ %def index_map_size
	<<Evaluators: interfaces>>=
	interface assignment(=)
	module procedure index_map_assign_int
	module procedure index_map_assign_array
	end interface

	@ %def =
	<<Evaluators: procedures>>=
	elemental subroutine index_map_assign_int (map, ival)
	type(index_map_t), intent(inout) :: map
	integer, intent(in) :: ival
	map%entry = ival
	end subroutine index_map_assign_int

	subroutine index_map_assign_array (map, array)
	type(index_map_t), intent(inout) :: map
	integer, dimension(:), intent(in) :: array
	map%entry = array
	end subroutine index_map_assign_array

	@ %def index_map_assign_int index_map_assign_array
	<<Evaluators: procedures>>=
	elemental subroutine index_map_set_entry (map, i, ival)
	type(index_map_t), intent(inout) :: map
	integer, intent(in) :: i
	integer, intent(in) :: ival
	map%entry(i) = ival
	end subroutine index_map_set_entry

	@ %def index_map_set_entry
	<<Evaluators: procedures>>=
	elemental function index_map_get_entry (map, i) result (ival)
	integer :: ival
	type(index_map_t), intent(in) :: map
	integer, intent(in) :: i
	ival = map%entry(i)
	end function index_map_get_entry

	@ %def index_map_get_entry
	@
	\subsubsection{Index mapping (two-dimensional)}
	This is a variant with a square matrix instead of an array.
	<<Evaluators: types>>=
	type :: index_map2_t
	integer :: s = 0
	integer, dimension(:,:), allocatable :: entry
	end type index_map2_t

	@ %def index_map2_t
	<<Evaluators: procedures>>=
	elemental subroutine index_map2_init (map, n)
	type(index_map2_t), intent(out) :: map
	integer, intent(in) :: n
	map%s = n
	allocate (map%entry (n, n))
	end subroutine index_map2_init

	@ %def index_map2_init
	<<Evaluators: procedures>>=
	function index_map2_exists (map) result (flag)
	logical :: flag
	type(index_map2_t), intent(in) :: map
	flag = allocated (map%entry)
	end function index_map2_exists

	@ %def index_map2_exists
	<<Evaluators: interfaces>>=
	interface size
	module procedure index_map2_size
	end interface

	@ %def size
	<<Evaluators: procedures>>=
	function index_map2_size (map) result (s)
	integer :: s
	type(index_map2_t), intent(in) :: map
	s = map%s
	end function index_map2_size

	@ %def index_map2_size
	<<Evaluators: interfaces>>=
	interface assignment(=)
	module procedure index_map2_assign_int
	end interface

	@ %def =
	<<Evaluators: procedures>>=
	elemental subroutine index_map2_assign_int (map, ival)
	type(index_map2_t), intent(inout) :: map
	integer, intent(in) :: ival
	map%entry = ival
	end subroutine index_map2_assign_int

	@ %def index_map2_assign_int
	<<Evaluators: procedures>>=
	elemental subroutine index_map2_set_entry (map, i, j, ival)
	type(index_map2_t), intent(inout) :: map
	integer, intent(in) :: i, j
	integer, intent(in) :: ival
	map%entry(i,j) = ival
	end subroutine index_map2_set_entry

	@ %def index_map2_set_entry
	<<Evaluators: procedures>>=
	elemental function index_map2_get_entry (map, i, j) result (ival)
	integer :: ival
	type(index_map2_t), intent(in) :: map
	integer, intent(in) :: i, j
	ival = map%entry(i,j)
	end function index_map2_get_entry

	@ %def index_map2_get_entry
	@
	\subsubsection{Auxiliary structures: particle mask}
	This is a simple container of a logical array.
	<<Evaluators: types>>=
	type :: prt_mask_t
	logical, dimension(:), allocatable :: entry
	end type prt_mask_t

	@ %def prt_mask_t
	<<Evaluators: procedures>>=
	subroutine prt_mask_init (mask, n)
	type(prt_mask_t), intent(out) :: mask
	integer, intent(in) :: n
	allocate (mask%entry (n))
	end subroutine prt_mask_init

	@ %def prt_mask_init
	<<Evaluators: interfaces>>=
	interface size
	module procedure prt_mask_size
	end interface

	@ %def size
	<<Evaluators: procedures>>=
	function prt_mask_size (mask) result (s)
	integer :: s
	type(prt_mask_t), intent(in) :: mask
	s = size (mask%entry)
	end function prt_mask_size

	@ %def prt_mask_size
	@
	\subsubsection{Quantum number containers}
	Trivial transparent containers:
	<<Evaluators: types>>=
	type :: qn_list_t
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	end type qn_list_t

	type :: qn_mask_array_t
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	end type qn_mask_array_t

	@ %def qn_list_t qn_mask_array_t
	@
	\subsubsection{Auxiliary structures: connection entries}
	This type is used as intermediate storage when computing the product of two
	evaluators or the square of an evaluator. The quantum-number array [[qn]]
	corresponds to the particles common to both interactions, but irrelevant
	quantum numbers (color) masked out. The index arrays [[index_in]] determine
	the entries in the input interactions that contribute to this connection.
	[[n_index]] is the size of these arrays, and [[count]] is used while filling
	the entries. Finally, the quantum-number arrays [[qn_in_list]] are the actual
	entries in the input interaction that contribute. In the product case, they
	exclude the connected quantum numbers.

	Each evaluator has its own [[connection_table]] which contains an array of
	[[connection_entry]] objects, but also has stuff that specifically applies to
	the evaluator type. Hence, we do not generalize the [[connection_table_t]]
	type.

	The filling procedure [[connection_entry_add_state]] is specific to the
	various evaluator types.
	<<Evaluators: types>>=
	type :: connection_entry_t
	type(quantum_numbers_t), dimension(:), allocatable :: qn_conn
	integer, dimension(:), allocatable :: n_index
	integer, dimension(:), allocatable :: count
	type(index_map_t), dimension(:), allocatable :: index_in
	type(qn_list_t), dimension(:), allocatable :: qn_in_list
	end type connection_entry_t

	@ %def connection_entry_t
	<<Evaluators: procedures>>=
	subroutine connection_entry_init &
	(entry, n_count, n_map, qn_conn, count, n_rest)
	type(connection_entry_t), intent(out) :: entry
	integer, intent(in) :: n_count, n_map
	type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn
	integer, dimension(n_count), intent(in) :: count
	integer, dimension(n_count), intent(in) :: n_rest
	integer :: i
	allocate (entry%qn_conn (size (qn_conn)))
	allocate (entry%n_index (n_count))
	allocate (entry%count (n_count))
	allocate (entry%index_in (n_map))
	allocate (entry%qn_in_list (n_count))
	entry%qn_conn = qn_conn
	entry%n_index = count
	entry%count = 0
	if (size (entry%index_in) == size (count)) then
	call index_map_init (entry%index_in, count)
	else
	call index_map_init (entry%index_in, count(1))
	end if
	do i = 1, n_count
	allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i)))
	end do
	end subroutine connection_entry_init

	@ %def connection_entry_init
	<<Evaluators: procedures>>=
	subroutine connection_entry_write (entry, unit)
	type(connection_entry_t), intent(in) :: entry
	integer, intent(in), optional :: unit
	integer :: i, j
	integer :: u
	u = given_output_unit (unit)
	call quantum_numbers_write (entry%qn_conn, unit)
	write (u, *)
	do i = 1, size (entry%n_index)
	write (u, *) "Input interaction", i
	do j = 1, entry%n_index(i)
	if (size (entry%n_index) == size (entry%index_in)) then
	write (u, "(2x,I0,4x,I0,2x)", advance = "no") &
	j, index_map_get_entry (entry%index_in(i), j)
	else
	write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") &
	j, index_map_get_entry (entry%index_in(1), j), &
	index_map_get_entry (entry%index_in(2), j)
	end if
	call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit)
	write (u, *)
	end do
	end do
	end subroutine connection_entry_write

	@ %def connection_entry_write
	@
	\subsubsection{Color handling}
	For managing color-factor computation, we introduce this local type. The
	[[index]] is the index in the color table that corresponds to a given matrix
	element index in the input interaction. The [[col]] array stores the color
	assignments in rows. The [[factor]] array associates a complex number with
	each pair of arrays in the color table. The [[factor_is_known]] array reveals
	whether a given factor is known already or still has to be computed.
	<<Evaluators: types>>=
	type :: color_table_t
	integer, dimension(:), allocatable :: index
	type(color_t), dimension(:,:), allocatable :: col
	logical, dimension(:,:), allocatable :: factor_is_known
	complex(default), dimension(:,:), allocatable :: factor
	end type color_table_t

	@ %def color_table_t
	@ This is the initializer. We extract the color states from the given state
	matrices, establish index mappings between the two states (implemented by the
	array [[me_index]]), make an array of color states, and initialize the
	color-factor table. The latter is two-dimensional (includes interference) and
	not yet filled.
	<<Evaluators: procedures>>=
	subroutine color_table_init (color_table, state, n_tot)
	type(color_table_t), intent(out) :: color_table
	type(state_matrix_t), intent(in) :: state
	integer, intent(in) :: n_tot
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	type(state_matrix_t) :: state_col
	integer :: index, n_col_state
	allocate (color_table%index (state%get_n_matrix_elements ()))
	color_table%index = 0
	allocate (qn (n_tot))
	call state_col%init ()
	call it%init (state)
	do while (it%is_valid ())
	index = it%get_me_index ()
	call qn%init (col = it%get_color ())
	call state_col%add_state (qn, me_index = color_table%index(index))
	call it%advance ()
	end do
	n_col_state = state_col%get_n_matrix_elements ()
	allocate (color_table%col (n_tot, n_col_state))
	call it%init (state_col)
	do while (it%is_valid ())
	index = it%get_me_index ()
	color_table%col(:,index) = it%get_color ()
	call it%advance ()
	end do
	call state_col%final ()
	allocate (color_table%factor_is_known (n_col_state, n_col_state))
	allocate (color_table%factor (n_col_state, n_col_state))
	color_table%factor_is_known = .false.
	end subroutine color_table_init

	@ %def color_table_init
	@ Output (debugging use):
	<<Evaluators: procedures>>=
	subroutine color_table_write (color_table, unit)
	type(color_table_t), intent(in) :: color_table
	integer, intent(in), optional :: unit
	integer :: i, j
	integer :: u
	u = given_output_unit (unit)
	write (u, *) "Color table:"
	if (allocated (color_table%index)) then
	write (u, *) " Index mapping state => color table:"
	do i = 1, size (color_table%index)
	write (u, "(3x,I0,2x,I0,2x)") i, color_table%index(i)
	end do
	write (u, *) " Color table:"
	do i = 1, size (color_table%col, 2)
	write (u, "(3x,I0,2x)", advance = "no") i
	call color_write (color_table%col(:,i), unit)
	write (u, *)
	end do
	write (u, *) " Defined color factors:"
	do i = 1, size (color_table%factor, 1)
	do j = 1, size (color_table%factor, 2)
	if (color_table%factor_is_known(i,j)) then
	write (u, *) i, j, color_table%factor(i,j)
	end if
	end do
	end do
	end if
	end subroutine color_table_write

	@ %def color_table_write
	@ This subroutine sets color factors, based on information from the hard
	matrix element: the list of pairs of color-flow indices (in the basis of the
	matrix element code), the list of corresponding factors, and the list of
	mappings from the matrix element index in the input interaction to the
	color-flow index in the hard matrix element object.

	We first determine the mapping of color-flow indices from the hard matrix
	element code to the current color table. The mapping could be nontrivial
	because the latter is derived from iterating over a state matrix, which may
	return states in non-canonical order. The translation table can be determined
	because we have, for the complete state matrix, both the mapping to the hard
	interaction (the input [[col_index_hi]]) and the mapping to the current
	color table (the component [[color_table%index]]).

	Once this mapping is known, we scan the list of index pairs
	[[color_flow_index]] and translate them to valid color-table index pairs. For
	this pair, the color factor is set using the corresponding entry in the list
	[[col_factor]].
	<<Evaluators: procedures>>=
	subroutine color_table_set_color_factors (color_table, &
	col_flow_index, col_factor, col_index_hi)
	type(color_table_t), intent(inout) :: color_table
	integer, dimension(:,:), intent(in) :: col_flow_index
	complex(default), dimension(:), intent(in) :: col_factor
	integer, dimension(:), intent(in) :: col_index_hi
	integer, dimension(:), allocatable :: hi_to_ct
	integer :: n_cflow
	integer :: hi_index, me_index, ct_index, cf_index
	integer, dimension(2) :: hi_index_pair, ct_index_pair
	n_cflow = size (col_index_hi)
	if (size (color_table%index) /= n_cflow) &
	call msg_bug ("Mismatch between hard matrix element and color table")
	allocate (hi_to_ct (n_cflow))
	do me_index = 1, size (color_table%index)
	ct_index = color_table%index(me_index)
	hi_index = col_index_hi(me_index)
	hi_to_ct(hi_index) = ct_index
	end do
	do cf_index = 1, size (col_flow_index, 2)
	hi_index_pair = col_flow_index(:,cf_index)
	ct_index_pair = hi_to_ct(hi_index_pair)
	color_table%factor(ct_index_pair(1), ct_index_pair(2)) = &
	col_factor(cf_index)
	color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true.
	end do
	end subroutine color_table_set_color_factors

	@ %def color_table_set_color_factors
	@ This function returns a color factor, given two indices which point to the
	matrix elements of the initial state matrix. Internally, we can map them to
	the corresponding indices in the color table. As a side effect, we store the
	color factor in the color table for later lookup. (I.e., this function is
	impure.)
	<<Evaluators: procedures>>=
	function color_table_get_color_factor (color_table, index1, index2, nc) &
	result (factor)
	real(default) :: factor
	type(color_table_t), intent(inout) :: color_table
	integer, intent(in) :: index1, index2
	integer, intent(in), optional :: nc
	integer :: i1, i2
	i1 = color_table%index(index1)
	i2 = color_table%index(index2)
	if (color_table%factor_is_known(i1,i2)) then
	factor = real(color_table%factor(i1,i2), kind=default)
	else
	factor = compute_color_factor &
	(color_table%col(:,i1), color_table%col(:,i2), nc)
	color_table%factor(i1,i2) = factor
	color_table%factor_is_known(i1,i2) = .true.
	end if
	end function color_table_get_color_factor

	@ %def color_table_get_color_factor
	@
	\subsection{Creating an evaluator: Matrix multiplication}
	The evaluator for matrix multiplication is the most complicated
	variant.

	The initializer takes two input interactions and constructs the result
	evaluator, which consists of the interaction and the multiplication
	table for the product (or convolution) of the two. Normally, the
	input interactions are connected by one or more common particles
	(e.g., decay, structure function convolution).

	In the result interaction, quantum numbers of the connections can be
	summed over. This is determined by the [[qn_mask_conn]] argument.
	The [[qn_mask_rest]] argument is its analog for the other particles
	within the result interaction. (E.g., for the trace of the state
	matrix, all quantum numbers are summed over.) Finally, the
	[[connections_are_resonant]] argument tells whether the connecting
	particles should be marked as resonant in the final event record.
	This is useful for decays.

	The algorithm consists of the following steps:
	\begin{enumerate}
	\item
	[[find_connections]]: Find the particles which are connected, i.e.,
	common to both input interactions. Either they are directly linked,
	or both are linked to a common source.
	\item
	[[compute_index_bounds_and_mappings]]: Compute the mappings of
	particle indices from the input interactions to the result
	interaction. There is a separate mapping for the connected
	particles.
	\item
	[[accumulate_connected_states]]: Create an auxiliary state matrix
	which lists the possible quantum numbers for the connected
	particles. When building this matrix, count the number of times
	each assignment is contained in any of the input states and, for
	each of the input states, record the index of the matrix element
	within the new state matrix. For the connected particles, reassign
	color indices such that no color state is present twice in different
	color-index assignment. Note that helicity assignments of the
	connected state can be (and will be) off-diagonal, so no spin
	correlations are lost in decays.

	Do this for both input interactions.
	\item
	[[allocate_connection_entries]]: Allocate a table of connections.
	Each table row corresponds to one state in the auxiliary matrix, and
	to multiple states of the input interactions. It collects all
	states of the unconnected particles in the two input interactions
	that are associated with the particular state (quantum-number
	assignment) of the connected particles.
	\item
	[[fill_connection_table]]: Fill the table of connections by scanning
	both input interactions. When copying states, reassign color
	indices for the unconnected particles such that they match between
	all involved particle sets (interaction 1, interaction 2, and
	connected particles).
	\item
	[[make_product_interaction]]: Scan the table of connections we have
	just built. For each entry, construct all possible pairs of states
	of the unconnected particles and combine them with the specific
	connected-particle state. This is a possible quantum-number
	assignment of the result interaction. Now mask all quantum numbers
	that should be summed over, and append this to the result state
	matrix. Record the matrix element index of the result. We now have
	the result interaction.
	\item
	[[make_pairing_array]]: First allocate the pairing array with the
	number of entries of the result interaction. Then scan the table of
	connections again. For each entry, record the indices of the matrix
	elements which have to be multiplied and summed over in order to
	compute this particular matrix element. This makes up the
	multiplication table.
	\item
	[[record_links]]: Transfer all source pointers from the input
	interactions to the result interaction. Do the same for the
	internal parent-child relations and resonance assignments. For the
	connected particles, make up appropriate additional parent-child
	relations. This allows for fetching momenta from other interactions
	when a new event is filled, and to reconstruct the event history
	when the event is analyzed.
	\end{enumerate}

	After all this is done, for each event, we just have to evaluate the
	pairing arrays (multiplication tables) in order to compute the result
	matrix elements in their proper positions. The quantum-number
	assignments remain fixed from now on.
	<<Evaluators: evaluator: TBP>>=
	procedure :: init_product => evaluator_init_product
	<<Evaluators: procedures>>=
	subroutine evaluator_init_product &
	(eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, &
	connections_are_resonant, ignore_sub)

	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), intent(in), target :: int_in1, int_in2
	type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
	type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
	type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
	logical, intent(in), optional :: connections_are_resonant
	logical, intent(in), optional :: ignore_sub

	type(qn_mask_array_t), dimension(2) :: qn_mask_in
	type(state_matrix_t), pointer :: state_in1, state_in2

	type :: connection_table_t
	integer :: n_conn = 0
	integer, dimension(2) :: n_rest = 0
	integer :: n_tot = 0
	integer :: n_me_conn = 0
	type(state_matrix_t) :: state
	type(index_map_t), dimension(:), allocatable :: index_conn
	type(connection_entry_t), dimension(:), allocatable :: entry
	type(index_map_t) :: index_result
	end type connection_table_t
	type(connection_table_t) :: connection_table

	integer :: n_in, n_vir, n_out, n_tot
	integer, dimension(2) :: n_rest
	integer :: n_conn

	integer, dimension(:,:), allocatable :: connection_index
	type(index_map_t), dimension(2) :: prt_map_in
	type(index_map_t) :: prt_map_conn
	type(prt_mask_t), dimension(2) :: prt_is_connected
	type(quantum_numbers_mask_t), dimension(:), allocatable :: &
	qn_mask_conn_initial, int_in1_mask, int_in2_mask

	integer :: i

	eval%type = EVAL_PRODUCT
	eval%int_in1 => int_in1
	eval%int_in2 => int_in2

	state_in1 => int_in1%get_state_matrix_ptr ()
	state_in2 => int_in2%get_state_matrix_ptr ()

	call find_connections (int_in1, int_in2, n_conn, connection_index)
	if (n_conn == 0) then
	call msg_message ("First interaction:")
	call int_in1%basic_write (col_verbose=.true.)
	call msg_message ("Second interaction:")
	call int_in2%basic_write (col_verbose=.true.)
	call msg_fatal ("Evaluator product: no connections found between factors")
	end if
	call compute_index_bounds_and_mappings &
	(int_in1, int_in2, n_conn, &
	n_in, n_vir, n_out, n_tot, &
	n_rest, prt_map_in, prt_map_conn)

	call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ())
	call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ())
	do i = 1, 2
	prt_is_connected(i)%entry = .true.
	prt_is_connected(i)%entry(connection_index(:,i)) = .false.
	end do
	allocate (qn_mask_conn_initial (n_conn), &
	int_in1_mask (n_conn), int_in2_mask (n_conn))
	int_in1_mask = int_in1%get_mask (connection_index(:,1))
	int_in2_mask = int_in2%get_mask (connection_index(:,2))
	do i = 1, n_conn
	qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i)
	end do
	allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ()))
	allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ()))
	qn_mask_in(1)%mask = int_in1%get_mask ()
	qn_mask_in(2)%mask = int_in2%get_mask ()

	call connection_table_init (connection_table, &
	state_in1, state_in2, &
	qn_mask_conn_initial, &
	n_conn, connection_index, n_rest, &
	qn_filter_conn, ignore_sub)
	call connection_table_fill (connection_table, &
	state_in1, state_in2, &
	connection_index, prt_is_connected)
	call make_product_interaction (eval%interaction_t, &
	n_in, n_vir, n_out, &
	connection_table, &
	prt_map_in, prt_is_connected, &
	qn_mask_in, qn_mask_conn_initial, &
	qn_mask_conn, qn_filter_conn, qn_mask_rest)
	call make_pairing_array (eval%pairing_array, &
	eval%get_n_matrix_elements (), &
	connection_table)
	call record_links (eval%interaction_t, &
	int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
	prt_is_connected, connections_are_resonant)
	call connection_table_final (connection_table)


	if (eval%get_n_matrix_elements () == 0) then
	print *, "Evaluator product"
	print *, "First interaction"
	call int_in1%basic_write (col_verbose=.true.)
	print *
	print *, "Second interaction"
	call int_in2%basic_write (col_verbose=.true.)
	print *
	call msg_fatal ("Product of density matrices is empty", &
	[var_str (" --------------------------------------------"), &
	var_str ("This happens when two density matrices are convoluted "), &
	var_str ("but the processes they belong to (e.g., production "), &
	var_str ("and decay) do not match. This could happen if the "), &
	var_str ("beam specification does not match the hard "), &
	var_str ("process. Or it may indicate a WHIZARD bug.")])
	end if

	contains

	subroutine compute_index_bounds_and_mappings &
	(int1, int2, n_conn, &
	n_in, n_vir, n_out, n_tot, &
	n_rest, prt_map_in, prt_map_conn)
	class(interaction_t), intent(in) :: int1, int2
	integer, intent(in) :: n_conn
	integer, intent(out) :: n_in, n_vir, n_out, n_tot
	integer, dimension(2), intent(out) :: n_rest
	type(index_map_t), dimension(2), intent(out) :: prt_map_in
	type(index_map_t), intent(out) :: prt_map_conn
	integer, dimension(:), allocatable :: index
	integer :: n_in1, n_vir1, n_out1
	integer :: n_in2, n_vir2, n_out2
	integer :: k
	n_in1 = int1%get_n_in ()
	n_vir1 = int1%get_n_vir ()
	n_out1 = int1%get_n_out () - n_conn
	n_rest(1) = n_in1 + n_vir1 + n_out1
	n_in2 = int2%get_n_in () - n_conn
	n_vir2 = int2%get_n_vir ()
	n_out2 = int2%get_n_out ()
	n_rest(2) = n_in2 + n_vir2 + n_out2
	n_in = n_in1 + n_in2
	n_vir = n_vir1 + n_vir2 + n_conn
	n_out = n_out1 + n_out2
	n_tot = n_in + n_vir + n_out
	call index_map_init (prt_map_in, n_rest)
	call index_map_init (prt_map_conn, n_conn)
	allocate (index (n_tot))
	index = [ (i, i = 1, n_tot) ]
	prt_map_in(1)%entry(1 : n_in1) = index( 1 : n_in1)
	k = n_in1
	prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2)
	k = k + n_in2
	prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1)
	k = k + n_vir1
	prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2)
	k = k + n_vir2
	prt_map_conn%entry = index(k + 1 : k + n_conn)
	k = k + n_conn
	prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1)
	k = k + n_out1
	prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2)
	end subroutine compute_index_bounds_and_mappings

	subroutine connection_table_init &
	(connection_table, state_in1, state_in2, qn_mask_conn, &
	n_conn, connection_index, n_rest, &
	qn_filter_conn, is_real_sub)
	type(connection_table_t), intent(out) :: connection_table
	type(state_matrix_t), intent(in), target :: state_in1, state_in2
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn
	integer, intent(in) :: n_conn
	integer, dimension(:,:), intent(in) :: connection_index
	integer, dimension(2), intent(in) :: n_rest
	type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
	logical, intent(in), optional :: is_real_sub
	integer, dimension(2) :: n_me_in
	type(state_iterator_t) :: it
	type(quantum_numbers_t), dimension(n_conn) :: qn
	integer :: i, me_index_in, me_index_conn, n_me_conn
	integer, dimension(2) :: me_count
	logical :: is_sub, has_sub_qn
	integer :: i_beam_sub
	connection_table%n_conn = n_conn
	connection_table%n_rest = n_rest
	n_me_in(1) = state_in1%get_n_matrix_elements ()
	n_me_in(2) = state_in2%get_n_matrix_elements ()
	allocate (connection_table%index_conn (2))
	call index_map_init (connection_table%index_conn, n_me_in)
	connection_table%index_conn = 0
	call connection_table%state%init (n_counters = 2)
	do i = 1, 2
	select case (i)
	case (1); call it%init (state_in1)
	case (2); call it%init (state_in2)
	end select
	do while (it%is_valid ())
	qn = it%get_quantum_numbers (connection_index(:,i))
	call qn%undefine (qn_mask_conn)
	if (present (qn_filter_conn)) then
	if (.not. all (qn .match. qn_filter_conn)) then
	call it%advance (); cycle
	end if
	end if
	call quantum_numbers_canonicalize_color (qn)
	me_index_in = it%get_me_index ()
	is_sub = .false.; if (present (is_real_sub)) is_sub = is_real_sub
	has_sub_qn = .false.
	do i_beam_sub = 1, n_beam_structure_int
	has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub)
	end do
	call connection_table%state%add_state (qn, &
	counter_index = i, &
	ignore_sub = .not. (is_sub .and. has_sub_qn), &
	me_index = me_index_conn)
	call index_map_set_entry (connection_table%index_conn(i), &
	me_index_in, me_index_conn)
	call it%advance ()
	end do
	end do
	n_me_conn = connection_table%state%get_n_matrix_elements ()
	connection_table%n_me_conn = n_me_conn
	allocate (connection_table%entry (n_me_conn))
	call it%init (connection_table%state)
	do while (it%is_valid ())
	i = it%get_me_index ()
	me_count = it%get_me_count ()
	call connection_entry_init (connection_table%entry(i), 2, 2, &
	it%get_quantum_numbers (), me_count, n_rest)
	call it%advance ()
	end do
	end subroutine connection_table_init

	subroutine connection_table_final (connection_table)
	type(connection_table_t), intent(inout) :: connection_table
	call connection_table%state%final ()
	end subroutine connection_table_final

	subroutine connection_table_write (connection_table, unit)
	type(connection_table_t), intent(in) :: connection_table
	integer, intent(in), optional :: unit
	integer :: i, j
	integer :: u
	u = given_output_unit (unit)
	write (u, *) "Connection table:"
	call connection_table%state%write (unit)
	if (allocated (connection_table%index_conn)) then
	write (u, *) " Index mapping input => connection table:"
	do i = 1, size (connection_table%index_conn)
	write (u, *) " Input state", i
	do j = 1, size (connection_table%index_conn(i))
	write (u, *) j, &
	index_map_get_entry (connection_table%index_conn(i), j)
	end do
	end do
	end if
	if (allocated (connection_table%entry)) then
	write (u, *) " Connection table contents:"
	do i = 1, size (connection_table%entry)
	call connection_entry_write (connection_table%entry(i), unit)
	end do
	end if
	if (index_map_exists (connection_table%index_result)) then
	write (u, *) " Index mapping connection table => output:"
	do i = 1, size (connection_table%index_result)
	write (u, *) i, &
	index_map_get_entry (connection_table%index_result, i)
	end do
	end if
	end subroutine connection_table_write

	subroutine connection_table_fill &
	(connection_table, state_in1, state_in2, &
	connection_index, prt_is_connected)
	type(connection_table_t), intent(inout) :: connection_table
	type(state_matrix_t), intent(in), target :: state_in1, state_in2
	integer, dimension(:,:), intent(in) :: connection_index
	type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
	type(state_iterator_t) :: it
	integer :: index_in, index_conn
	integer :: color_offset
	integer :: n_result_entries
	integer :: i, k
	color_offset = connection_table%state%get_max_color_value ()
	do i = 1, 2
	select case (i)
	case (1); call it%init (state_in1)
	case (2); call it%init (state_in2)
	end select
	do while (it%is_valid ())
	index_in = it%get_me_index ()
	index_conn = index_map_get_entry &
	(connection_table%index_conn(i), index_in)
	if (index_conn /= 0) then
	call connection_entry_add_state &
	(connection_table%entry(index_conn), i, &
	index_in, it%get_quantum_numbers (), &
	connection_index(:,i), prt_is_connected(i), &
	color_offset)
	end if
	call it%advance ()
	end do
	color_offset = color_offset + state_in1%get_max_color_value ()
	end do
	n_result_entries = 0
	do k = 1, size (connection_table%entry)
	n_result_entries = &
	n_result_entries + product (connection_table%entry(k)%n_index)
	end do
	call index_map_init (connection_table%index_result, n_result_entries)
	end subroutine connection_table_fill

	subroutine connection_entry_add_state &
	(entry, i, index_in, qn_in, connection_index, prt_is_connected, &
	color_offset)
	type(connection_entry_t), intent(inout) :: entry
	integer, intent(in) :: i
	integer, intent(in) :: index_in
	type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
	integer, dimension(:), intent(in) :: connection_index
	type(prt_mask_t), intent(in) :: prt_is_connected
	integer, intent(in) :: color_offset
	integer :: c
	integer, dimension(:,:), allocatable :: color_map
	entry%count(i) = entry%count(i) + 1
	c = entry%count(i)
	call make_color_map (color_map, &
	qn_in(connection_index), entry%qn_conn)
	call index_map_set_entry (entry%index_in(i), c, index_in)
	entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry)
	call quantum_numbers_translate_color &
	(entry%qn_in_list(i)%qn(:,c), color_map, color_offset)
	end subroutine connection_entry_add_state

	subroutine make_product_interaction (int, &
	n_in, n_vir, n_out, &
	connection_table, &
	prt_map_in, prt_is_connected, &
	qn_mask_in, qn_mask_conn_initial, &
	qn_mask_conn, qn_filter_conn, qn_mask_rest)
	type(interaction_t), intent(out), target :: int
	integer, intent(in) :: n_in, n_vir, n_out
	type(connection_table_t), intent(inout), target :: connection_table
	type(index_map_t), dimension(2), intent(in) :: prt_map_in
	type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
	type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: &
	qn_mask_conn_initial
	type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
	type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
	type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
	type(index_map_t), dimension(2) :: prt_index_in
	type(index_map_t) :: prt_index_conn
	integer :: n_tot, n_conn
	integer, dimension(2) :: n_rest
	integer :: i, j, k, m
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(connection_entry_t), pointer :: entry
	integer :: result_index
	n_conn = connection_table%n_conn
	n_rest = connection_table%n_rest
	n_tot = sum (n_rest) + n_conn
	allocate (qn (n_tot), qn_mask (n_tot))
	do i = 1, 2
	call index_map_init (prt_index_in(i), n_rest(i))
	prt_index_in(i) = &
	prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ])
	end do
	call index_map_init (prt_index_conn, n_conn)
	prt_index_conn = prt_map_conn%entry ([ (j, j = 1, n_conn) ])
	do i = 1, 2
	if (present (qn_mask_rest)) then
	qn_mask(prt_index_in(i)%entry) = &
	pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) &
	.or. qn_mask_rest
	else
	qn_mask(prt_index_in(i)%entry) = &
	pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry)
	end if
	end do
	qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn
	call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask)
	m = 1
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	qn(prt_index_conn%entry) = &
	quantum_numbers_undefined (entry%qn_conn, qn_mask_conn)
	if (present (qn_filter_conn)) then
	if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) &
	cycle
	end if
	do j = 1, entry%n_index(1)
	qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j)
	do k = 1, entry%n_index(2)
	qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k)
	call int%add_state (qn, me_index = result_index)
	call index_map_set_entry &
	(connection_table%index_result, m, result_index)
	m = m + 1
	end do
	end do
	end do
	call int%freeze ()
	end subroutine make_product_interaction

	subroutine make_pairing_array (pa, n_matrix_elements, connection_table)
	type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
	integer, intent(in) :: n_matrix_elements
	type(connection_table_t), intent(in), target :: connection_table
	type(connection_entry_t), pointer :: entry
	integer, dimension(:), allocatable :: n_entries
	integer :: i, j, k, m, r
	allocate (pa (n_matrix_elements))
	allocate (n_entries (n_matrix_elements))
	n_entries = 0
	do m = 1, size (connection_table%index_result)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	end do
	call pairing_array_init &
	(pa, n_entries, has_i2=.true., has_factor=.false.)
	m = 1
	n_entries = 0
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	do j = 1, entry%n_index(1)
	do k = 1, entry%n_index(2)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	pa(r)%i1(n_entries(r)) = &
	index_map_get_entry (entry%index_in(1), j)
	pa(r)%i2(n_entries(r)) = &
	index_map_get_entry (entry%index_in(2), k)
	m = m + 1
	end do
	end do
	end do
	end subroutine make_pairing_array

	subroutine record_links (int, &
	int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
	prt_is_connected, connections_are_resonant)
	class(interaction_t), intent(inout) :: int
	class(interaction_t), intent(in), target :: int_in1, int_in2
	integer, dimension(:,:), intent(in) :: connection_index
	type(index_map_t), dimension(2), intent(in) :: prt_map_in
	type(index_map_t), intent(in) :: prt_map_conn
	type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
	logical, intent(in), optional :: connections_are_resonant
	type(index_map_t), dimension(2) :: prt_map_all
	integer :: i, j, k, ival
	call index_map_init (prt_map_all(1), size (prt_is_connected(1)))
	k = 0
	j = 0
	do i = 1, size (prt_is_connected(1))
	if (prt_is_connected(1)%entry(i)) then
	j = j + 1
	ival = index_map_get_entry (prt_map_in(1), j)
	call index_map_set_entry (prt_map_all(1), i, ival)
	else
	k = k + 1
	ival = index_map_get_entry (prt_map_conn, k)
	call index_map_set_entry (prt_map_all(1), i, ival)
	end if
	call int%set_source_link (ival, int_in1, i)
	end do
	call int_in1%transfer_relations (int, prt_map_all(1)%entry)
	call index_map_init (prt_map_all(2), size (prt_is_connected(2)))
	j = 0
	do i = 1, size (prt_is_connected(2))
	if (prt_is_connected(2)%entry(i)) then
	j = j + 1
	ival = index_map_get_entry (prt_map_in(2), j)
	call index_map_set_entry (prt_map_all(2), i, ival)
	call int%set_source_link (ival, int_in2, i)
	else
	call index_map_set_entry (prt_map_all(2), i, 0)
	end if
	end do
	call int_in2%transfer_relations (int, prt_map_all(2)%entry)
	call int%relate_connections &
	(int_in2, connection_index(:,2), prt_map_all(2)%entry, &
	prt_map_conn%entry, connections_are_resonant)
	end subroutine record_links

	end subroutine evaluator_init_product

	@ %def evaluator_init_product
	@
	\subsection{Creating an evaluator: square}
	The generic initializer for an evaluator that squares a matrix element.
	Depending on the provided mask, we select the appropriate specific initializer
	for either diagonal or non-diagonal helicity density matrices.
	<<Evaluators: evaluator: TBP>>=
	procedure :: init_square => evaluator_init_square
	<<Evaluators: procedures>>=
	subroutine evaluator_init_square (eval, int_in, qn_mask, &
	col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), intent(in), target :: int_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	integer, dimension(:,:), intent(in), optional :: col_flow_index
	complex(default), dimension(:), intent(in), optional :: col_factor
	integer, dimension(:), intent(in), optional :: col_index_hi
	logical, intent(in), optional :: expand_color_flows
	integer, intent(in), optional :: nc
	if (all (qn_mask%diagonal_helicity ())) then
	call eval%init_square_diag (int_in, qn_mask, &
	col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
	else
	call eval%init_square_nondiag (int_in, qn_mask, &
	col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
	end if
	end subroutine evaluator_init_square

	@ %def evaluator_init_square
	@
	\subsubsection{Color-summed squared matrix (diagonal helicities)}
	The initializer for an evaluator that squares a matrix element,
	including color factors. The mask must be such that off-diagonal matrix
	elements are excluded.

	If [[color_flows]] is set, the evaluator keeps color-flow entries
	separate and drops all interfering color structures. The color factors are
	set to unity in this case.

	There is only one input interaction. The quantum-number mask is an
	array, one entry for each particle, so they can be treated
	individually. For academic purposes, we allow for the number of
	colors being different from three (but 3 is the default).

	The algorithm is analogous to multiplication, with a few notable
	differences:
	\begin{enumerate}
	\item
	The connected particles are known, the correspondence is
	one-to-one. All particles are connected, and the mapping of indices
	is trivial, which simplifies the following steps.
	\item
	[[accumulate_connected_states]]: The matrix of connected states
	encompasses all particles, but color indices are removed. However,
	ghost states are still kept separate from physical color states. No
	color-index reassignment is necessary.
	\item
	The table of connections contains single index and quantum-number
	arrays instead of pairs of them. They are paired with themselves
	in all possible ways.
	\item
	[[make_squared_interaction]]: Now apply the predefined
	quantum-numbers mask, which usually collects all color states
	(physical and ghosts), and possibly a helicity sum.
	\item
	[[make_pairing_array]]: For each pair of input states, compute the
	color factor (including a potential ghost-parity sign) and store
	this in the pairing array together with the matrix-element indices
	for multiplication.
	\item
	[[record_links]]: This is again trivial due to the one-to-one
	correspondence.
	\end{enumerate}

	<<Evaluators: evaluator: TBP>>=
	procedure :: init_square_diag => evaluator_init_square_diag
	<<Evaluators: procedures>>=
	subroutine evaluator_init_square_diag (eval, int_in, qn_mask, &
	col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)

	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), intent(in), target :: int_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	integer, dimension(:,:), intent(in), optional :: col_flow_index
	complex(default), dimension(:), intent(in), optional :: col_factor
	integer, dimension(:), intent(in), optional :: col_index_hi
	logical, intent(in), optional :: expand_color_flows
	integer, intent(in), optional :: nc

	integer :: n_in, n_vir, n_out, n_tot
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
	type(state_matrix_t), pointer :: state_in

	type :: connection_table_t
	integer :: n_tot = 0
	integer :: n_me_conn = 0
	type(state_matrix_t) :: state
	type(index_map_t) :: index_conn
	type(connection_entry_t), dimension(:), allocatable :: entry
	type(index_map_t) :: index_result
	end type connection_table_t
	type(connection_table_t) :: connection_table

	logical :: sum_colors
	type(color_table_t) :: color_table

	if (present (expand_color_flows)) then
	sum_colors = .not. expand_color_flows
	else
	sum_colors = .true.
	end if

	if (sum_colors) then
	eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
	else
	eval%type = EVAL_SQUARED_FLOWS
	end if
	eval%int_in1 => int_in

	n_in = int_in%get_n_in ()
	n_vir = int_in%get_n_vir ()
	n_out = int_in%get_n_out ()
	n_tot = int_in%get_n_tot ()

	state_in => int_in%get_state_matrix_ptr ()

	allocate (qn_mask_initial (n_tot))
	qn_mask_initial = int_in%get_mask ()
	call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
	if (sum_colors) then
	call color_table_init (color_table, state_in, n_tot)
	if (present (col_flow_index) .and. present (col_factor) &
	.and. present (col_index_hi)) then
	call color_table_set_color_factors &
	(color_table, col_flow_index, col_factor, col_index_hi)
	end if
	end if

	call connection_table_init (connection_table, state_in, &
	qn_mask_initial, qn_mask, n_tot)
	call connection_table_fill (connection_table, state_in)
	call make_squared_interaction (eval%interaction_t, &
	n_in, n_vir, n_out, n_tot, &
	connection_table, sum_colors, qn_mask_initial .or. qn_mask)
	call make_pairing_array (eval%pairing_array, &
	eval%get_n_matrix_elements (), &
	connection_table, sum_colors, color_table, n_in, n_tot, nc)
	call record_links (eval, int_in, n_tot)
	call connection_table_final (connection_table)

	contains

	subroutine connection_table_init &
	(connection_table, state_in, qn_mask_in, qn_mask, n_tot)
	type(connection_table_t), intent(out) :: connection_table
	type(state_matrix_t), intent(in), target :: state_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	integer, intent(in) :: n_tot
	type(quantum_numbers_t), dimension(n_tot) :: qn
	type(state_iterator_t) :: it
	integer :: i, n_me_in, me_index_in
	integer :: me_index_conn, n_me_conn
	integer, dimension(1) :: me_count
	logical :: qn_passed
	connection_table%n_tot = n_tot
	n_me_in = state_in%get_n_matrix_elements ()
	call index_map_init (connection_table%index_conn, n_me_in)
	connection_table%index_conn = 0
	call connection_table%state%init (n_counters=1)
	call it%init (state_in)
	do while (it%is_valid ())
	qn = it%get_quantum_numbers ()
	if (all (quantum_numbers_are_physical (qn, qn_mask))) then
	call qn%undefine (qn_mask_in)
	qn_passed = .true.
	if (qn_passed) then
	me_index_in = it%get_me_index ()
	call connection_table%state%add_state (qn, &
	counter_index = 1, me_index = me_index_conn)
	call index_map_set_entry (connection_table%index_conn, &
	me_index_in, me_index_conn)
	end if
	end if
	call it%advance ()
	end do
	n_me_conn = connection_table%state%get_n_matrix_elements ()
	connection_table%n_me_conn = n_me_conn
	allocate (connection_table%entry (n_me_conn))
	call it%init (connection_table%state)
	do while (it%is_valid ())
	i = it%get_me_index ()
	me_count = it%get_me_count ()
	call connection_entry_init (connection_table%entry(i), 1, 2, &
	it%get_quantum_numbers (), me_count, [n_tot])
	call it%advance ()
	end do
	end subroutine connection_table_init

	subroutine connection_table_final (connection_table)
	type(connection_table_t), intent(inout) :: connection_table
	call connection_table%state%final ()
	end subroutine connection_table_final

	subroutine connection_table_write (connection_table, unit)
	type(connection_table_t), intent(in) :: connection_table
	integer, intent(in), optional :: unit
	integer :: i
	integer :: u
	u = given_output_unit (unit)
	write (u, *) "Connection table:"
	call connection_table%state%write (unit)
	if (index_map_exists (connection_table%index_conn)) then
	write (u, *) " Index mapping input => connection table:"
	do i = 1, size (connection_table%index_conn)
	write (u, *) i, &
	index_map_get_entry (connection_table%index_conn, i)
	end do
	end if
	if (allocated (connection_table%entry)) then
	write (u, *) " Connection table contents"
	do i = 1, size (connection_table%entry)
	call connection_entry_write (connection_table%entry(i), unit)
	end do
	end if
	if (index_map_exists (connection_table%index_result)) then
	write (u, *) " Index mapping connection table => output"
	do i = 1, size (connection_table%index_result)
	write (u, *) i, &
	index_map_get_entry (connection_table%index_result, i)
	end do
	end if
	end subroutine connection_table_write

	subroutine connection_table_fill (connection_table, state)
	type(connection_table_t), intent(inout) :: connection_table
	type(state_matrix_t), intent(in), target :: state
	integer :: index_in, index_conn, n_result_entries
	type(state_iterator_t) :: it
	integer :: k
	call it%init (state)
	do while (it%is_valid ())
	index_in = it%get_me_index ()
	index_conn = &
	index_map_get_entry (connection_table%index_conn, index_in)
	if (index_conn /= 0) then
	call connection_entry_add_state &
	(connection_table%entry(index_conn), &
	index_in, it%get_quantum_numbers ())
	end if
	call it%advance ()
	end do
	n_result_entries = 0
	do k = 1, size (connection_table%entry)
	n_result_entries = &
	n_result_entries + connection_table%entry(k)%n_index(1) ** 2
	end do
	call index_map_init (connection_table%index_result, n_result_entries)
	connection_table%index_result = 0
	end subroutine connection_table_fill

	subroutine connection_entry_add_state (entry, index_in, qn_in)
	type(connection_entry_t), intent(inout) :: entry
	integer, intent(in) :: index_in
	type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
	integer :: c
	entry%count = entry%count + 1
	c = entry%count(1)
	call index_map_set_entry (entry%index_in(1), c, index_in)
	entry%qn_in_list(1)%qn(:,c) = qn_in
	end subroutine connection_entry_add_state

	subroutine make_squared_interaction (int, &
	n_in, n_vir, n_out, n_tot, &
	connection_table, sum_colors, qn_mask)
	type(interaction_t), intent(out), target :: int
	integer, intent(in) :: n_in, n_vir, n_out, n_tot
	type(connection_table_t), intent(inout), target :: connection_table
	logical, intent(in) :: sum_colors
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	type(connection_entry_t), pointer :: entry
	integer :: result_index, n_contrib
	integer :: i, m
	type(quantum_numbers_t), dimension(n_tot) :: qn
	call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
	m = 0
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	qn = quantum_numbers_undefined (entry%qn_conn, qn_mask)
	if (.not. sum_colors) call qn(1:n_in)%invert_color ()
	call int%add_state (qn, me_index = result_index)
	n_contrib = entry%n_index(1) ** 2
	connection_table%index_result%entry(m+1:m+n_contrib) = result_index
	m = m + n_contrib
	end do
	call int%freeze ()
	end subroutine make_squared_interaction

	subroutine make_pairing_array (pa, &
	n_matrix_elements, connection_table, sum_colors, color_table, &
	n_in, n_tot, nc)
	type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
	integer, intent(in) :: n_matrix_elements
	type(connection_table_t), intent(in), target :: connection_table
	logical, intent(in) :: sum_colors
	type(color_table_t), intent(inout) :: color_table
	type(connection_entry_t), pointer :: entry
	integer, intent(in) :: n_in, n_tot
	integer, intent(in), optional :: nc
	integer, dimension(:), allocatable :: n_entries
	integer :: i, k, l, ks, ls, m, r
	integer :: color_multiplicity_in
	allocate (pa (n_matrix_elements))
	allocate (n_entries (n_matrix_elements))
	n_entries = 0
	do m = 1, size (connection_table%index_result)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	end do
	call pairing_array_init &
	(pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
	m = 1
	n_entries = 0
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	do k = 1, entry%n_index(1)
	if (sum_colors) then
	color_multiplicity_in = &
	product (abs (quantum_numbers_get_color_type &
	(entry%qn_in_list(1)%qn(:n_in, k))))
	do l = 1, entry%n_index(1)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	ks = index_map_get_entry (entry%index_in(1), k)
	ls = index_map_get_entry (entry%index_in(1), l)
	pa(r)%i1(n_entries(r)) = ks
	pa(r)%i2(n_entries(r)) = ls
	pa(r)%factor(n_entries(r)) = &
	color_table_get_color_factor (color_table, ks, ls, nc) &
	/ color_multiplicity_in
	m = m + 1
	end do
	else
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	ks = index_map_get_entry (entry%index_in(1), k)
	pa(r)%i1(n_entries(r)) = ks
	m = m + 1
	end if
	end do
	end do
	end subroutine make_pairing_array

	subroutine record_links (int, int_in, n_tot)
	class(interaction_t), intent(inout) :: int
	class(interaction_t), intent(in), target :: int_in
	integer, intent(in) :: n_tot
	integer, dimension(n_tot) :: map
	integer :: i
	do i = 1, n_tot
	call int%set_source_link (i, int_in, i)
	end do
	map = [ (i, i = 1, n_tot) ]
	call int_in%transfer_relations (int, map)
	end subroutine record_links

	end subroutine evaluator_init_square_diag

	@ %def evaluator_init_square_diag
	@
	\subsubsection{Color-summed squared matrix (support nodiagonal helicities)}
	The initializer for an evaluator that squares a matrix element,
	including color factors. Unless requested otherwise by the
	quantum-number mask, the result contains off-diagonal matrix elements.
	(The input interaction must be diagonal since it represents an
	amplitude, not a density matrix.)

	There is only one input interaction. The quantum-number mask is an
	array, one entry for each particle, so they can be treated
	individually. For academic purposes, we allow for the number of
	colors being different from three (but 3 is the default).

	The algorithm is analogous to the previous one, with some additional
	complications due to the necessity to loop over two helicity indices.
	<<Evaluators: evaluator: TBP>>=
	procedure :: init_square_nondiag => evaluator_init_square_nondiag
	<<Evaluators: procedures>>=
	subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, &
	col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)

	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), intent(in), target :: int_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	integer, dimension(:,:), intent(in), optional :: col_flow_index
	complex(default), dimension(:), intent(in), optional :: col_factor
	integer, dimension(:), intent(in), optional :: col_index_hi
	logical, intent(in), optional :: expand_color_flows
	integer, intent(in), optional :: nc

	integer :: n_in, n_vir, n_out, n_tot
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
	type(state_matrix_t), pointer :: state_in

	type :: connection_table_t
	integer :: n_tot = 0
	integer :: n_me_conn = 0
	type(state_matrix_t) :: state
	type(index_map2_t) :: index_conn
	type(connection_entry_t), dimension(:), allocatable :: entry
	type(index_map_t) :: index_result
	end type connection_table_t
	type(connection_table_t) :: connection_table

	logical :: sum_colors
	type(color_table_t) :: color_table

	if (present (expand_color_flows)) then
	sum_colors = .not. expand_color_flows
	else
	sum_colors = .true.
	end if

	if (sum_colors) then
	eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
	else
	eval%type = EVAL_SQUARED_FLOWS
	end if
	eval%int_in1 => int_in

	n_in = int_in%get_n_in ()
	n_vir = int_in%get_n_vir ()
	n_out = int_in%get_n_out ()
	n_tot = int_in%get_n_tot ()

	state_in => int_in%get_state_matrix_ptr ()

	allocate (qn_mask_initial (n_tot))
	qn_mask_initial = int_in%get_mask ()
	call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
	if (sum_colors) then
	call color_table_init (color_table, state_in, n_tot)
	if (present (col_flow_index) .and. present (col_factor) &
	.and. present (col_index_hi)) then
	call color_table_set_color_factors &
	(color_table, col_flow_index, col_factor, col_index_hi)
	end if
	end if

	call connection_table_init (connection_table, state_in, &
	qn_mask_initial, qn_mask, n_tot)
	call connection_table_fill (connection_table, state_in)
	call make_squared_interaction (eval%interaction_t, &
	n_in, n_vir, n_out, n_tot, &
	connection_table, sum_colors, qn_mask_initial .or. qn_mask)
	call make_pairing_array (eval%pairing_array, &
	eval%get_n_matrix_elements (), &
	connection_table, sum_colors, color_table, n_in, n_tot, nc)
	call record_links (eval, int_in, n_tot)
	call connection_table_final (connection_table)

	contains

	subroutine connection_table_init &
	(connection_table, state_in, qn_mask_in, qn_mask, n_tot)
	type(connection_table_t), intent(out) :: connection_table
	type(state_matrix_t), intent(in), target :: state_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	integer, intent(in) :: n_tot
	type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn
	type(state_iterator_t) :: it1, it2, it
	integer :: i, n_me_in, me_index_in1, me_index_in2
	integer :: me_index_conn, n_me_conn
	integer, dimension(1) :: me_count
	logical :: qn_passed
	connection_table%n_tot = n_tot
	n_me_in = state_in%get_n_matrix_elements ()
	call index_map2_init (connection_table%index_conn, n_me_in)
	connection_table%index_conn = 0
	call connection_table%state%init (n_counters=1)
	call it1%init (state_in)
	do while (it1%is_valid ())
	qn1 = it1%get_quantum_numbers ()
	me_index_in1 = it1%get_me_index ()
	call it2%init (state_in)
	do while (it2%is_valid ())
	qn2 = it2%get_quantum_numbers ()
	if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then
	qn = qn1 .merge. qn2
	call qn%undefine (qn_mask_in)
	qn_passed = .true.
	if (qn_passed) then
	me_index_in2 = it2%get_me_index ()
	call connection_table%state%add_state (qn, &
	counter_index = 1, me_index = me_index_conn)
	call index_map2_set_entry (connection_table%index_conn, &
	me_index_in1, me_index_in2, me_index_conn)
	end if
	end if
	call it2%advance ()
	end do
	call it1%advance ()
	end do
	n_me_conn = connection_table%state%get_n_matrix_elements ()
	connection_table%n_me_conn = n_me_conn
	allocate (connection_table%entry (n_me_conn))
	call it%init (connection_table%state)
	do while (it%is_valid ())
	i = it%get_me_index ()
	me_count = it%get_me_count ()
	call connection_entry_init (connection_table%entry(i), 1, 2, &
	it%get_quantum_numbers (), me_count, [n_tot])
	call it%advance ()
	end do
	end subroutine connection_table_init

	subroutine connection_table_final (connection_table)
	type(connection_table_t), intent(inout) :: connection_table
	call connection_table%state%final ()
	end subroutine connection_table_final

	subroutine connection_table_write (connection_table, unit)
	type(connection_table_t), intent(in) :: connection_table
	integer, intent(in), optional :: unit
	integer :: i, j
	integer :: u
	u = given_output_unit (unit)
	write (u, *) "Connection table:"
	call connection_table%state%write (unit)
	if (index_map2_exists (connection_table%index_conn)) then
	write (u, *) " Index mapping input => connection table:"
	do i = 1, size (connection_table%index_conn)
	do j = 1, size (connection_table%index_conn)
	write (u, *) i, j, &
	index_map2_get_entry (connection_table%index_conn, i, j)
	end do
	end do
	end if
	if (allocated (connection_table%entry)) then
	write (u, *) " Connection table contents"
	do i = 1, size (connection_table%entry)
	call connection_entry_write (connection_table%entry(i), unit)
	end do
	end if
	if (index_map_exists (connection_table%index_result)) then
	write (u, *) " Index mapping connection table => output"
	do i = 1, size (connection_table%index_result)
	write (u, *) i, &
	index_map_get_entry (connection_table%index_result, i)
	end do
	end if
	end subroutine connection_table_write

	subroutine connection_table_fill (connection_table, state)
	type(connection_table_t), intent(inout), target :: connection_table
	type(state_matrix_t), intent(in), target :: state
	integer :: index1_in, index2_in, index_conn, n_result_entries
	type(state_iterator_t) :: it1, it2
	integer :: k
	call it1%init (state)
	do while (it1%is_valid ())
	index1_in = it1%get_me_index ()
	call it2%init (state)
	do while (it2%is_valid ())
	index2_in = it2%get_me_index ()
	index_conn = index_map2_get_entry &
	(connection_table%index_conn, index1_in, index2_in)
	if (index_conn /= 0) then
	call connection_entry_add_state &
	(connection_table%entry(index_conn), &
	index1_in, index2_in, &
	it1%get_quantum_numbers () &
	.merge. &
	it2%get_quantum_numbers ())
	end if
	call it2%advance ()
	end do
	call it1%advance ()
	end do
	n_result_entries = 0
	do k = 1, size (connection_table%entry)
	n_result_entries = &
	n_result_entries + connection_table%entry(k)%n_index(1)
	end do
	call index_map_init (connection_table%index_result, n_result_entries)
	connection_table%index_result = 0
	end subroutine connection_table_fill

	subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in)
	type(connection_entry_t), intent(inout) :: entry
	integer, intent(in) :: index1_in, index2_in
	type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
	integer :: c
	entry%count = entry%count + 1
	c = entry%count(1)
	call index_map_set_entry (entry%index_in(1), c, index1_in)
	call index_map_set_entry (entry%index_in(2), c, index2_in)
	entry%qn_in_list(1)%qn(:,c) = qn_in
	end subroutine connection_entry_add_state

	subroutine make_squared_interaction (int, &
	n_in, n_vir, n_out, n_tot, &
	connection_table, sum_colors, qn_mask)
	type(interaction_t), intent(out), target :: int
	integer, intent(in) :: n_in, n_vir, n_out, n_tot
	type(connection_table_t), intent(inout), target :: connection_table
	logical, intent(in) :: sum_colors
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	type(connection_entry_t), pointer :: entry
	integer :: result_index
	integer :: i, k, m
	type(quantum_numbers_t), dimension(n_tot) :: qn
	call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
	m = 0
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	do k = 1, size (entry%qn_in_list(1)%qn, 2)
	qn = quantum_numbers_undefined &
	(entry%qn_in_list(1)%qn(:,k), qn_mask)
	if (.not. sum_colors) call qn(1:n_in)%invert_color ()
	call int%add_state (qn, me_index = result_index)
	call index_map_set_entry (connection_table%index_result, m + 1, &
	result_index)
	m = m + 1
	end do
	end do
	call int%freeze ()
	end subroutine make_squared_interaction

	subroutine make_pairing_array (pa, &
	n_matrix_elements, connection_table, sum_colors, color_table, &
	n_in, n_tot, nc)
	type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
	integer, intent(in) :: n_matrix_elements
	type(connection_table_t), intent(in), target :: connection_table
	logical, intent(in) :: sum_colors
	type(color_table_t), intent(inout) :: color_table
	type(connection_entry_t), pointer :: entry
	integer, intent(in) :: n_in, n_tot
	integer, intent(in), optional :: nc
	integer, dimension(:), allocatable :: n_entries
	integer :: i, k, k1s, k2s, m, r
	integer :: color_multiplicity_in
	allocate (pa (n_matrix_elements))
	allocate (n_entries (n_matrix_elements))
	n_entries = 0
	do m = 1, size (connection_table%index_result)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	end do
	call pairing_array_init &
	(pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
	m = 1
	n_entries = 0
	do i = 1, connection_table%n_me_conn
	entry => connection_table%entry(i)
	do k = 1, entry%n_index(1)
	r = index_map_get_entry (connection_table%index_result, m)
	n_entries(r) = n_entries(r) + 1
	if (sum_colors) then
	k1s = index_map_get_entry (entry%index_in(1), k)
	k2s = index_map_get_entry (entry%index_in(2), k)
	pa(r)%i1(n_entries(r)) = k1s
	pa(r)%i2(n_entries(r)) = k2s
	color_multiplicity_in = &
	product (abs (quantum_numbers_get_color_type &
	(entry%qn_in_list(1)%qn(:n_in, k))))
	pa(r)%factor(n_entries(r)) = &
	color_table_get_color_factor (color_table, k1s, k2s, nc) &
	/ color_multiplicity_in
	else
	k1s = index_map_get_entry (entry%index_in(1), k)
	pa(r)%i1(n_entries(r)) = k1s
	end if
	m = m + 1
	end do
	end do
	end subroutine make_pairing_array

	subroutine record_links (int, int_in, n_tot)
	class(interaction_t), intent(inout) :: int
	class(interaction_t), intent(in), target :: int_in
	integer, intent(in) :: n_tot
	integer, dimension(n_tot) :: map
	integer :: i
	do i = 1, n_tot
	call int%set_source_link (i, int_in, i)
	end do
	map = [ (i, i = 1, n_tot) ]
	call int_in%transfer_relations (int, map)
	end subroutine record_links

	end subroutine evaluator_init_square_nondiag

	@ %def evaluator_init_square_nondiag
	@
	\subsubsection{Copy with additional contracted color states}
	This evaluator involves no square or multiplication, its matrix
	elements are just copies of the (single) input interaction. However,
	the state matrix of the interaction contains additional states that
	have color indices contracted. This is used for copies of the beam or
	structure-function interactions that need to match the hard
	interaction also in the case where its color indices coincide.
	<<Evaluators: evaluator: TBP>>=
	procedure :: init_color_contractions => evaluator_init_color_contractions
	<<Evaluators: procedures>>=
	subroutine evaluator_init_color_contractions (eval, int_in)
	class(evaluator_t), intent(out), target :: eval
	type(interaction_t), intent(in), target :: int_in
	integer :: n_in, n_vir, n_out, n_tot
	type(state_matrix_t) :: state_with_contractions
	integer, dimension(:), allocatable :: me_index
	integer, dimension(:), allocatable :: result_index
	eval%type = EVAL_COLOR_CONTRACTION
	eval%int_in1 => int_in
	n_in = int_in%get_n_in ()
	n_vir = int_in%get_n_vir ()
	n_out = int_in%get_n_out ()
	n_tot = int_in%get_n_tot ()
	state_with_contractions = int_in%get_state_matrix_ptr ()
	call state_with_contractions%add_color_contractions ()
	call make_contracted_interaction (eval%interaction_t, &
	me_index, result_index, &
	n_in, n_vir, n_out, n_tot, &
	state_with_contractions, int_in%get_mask ())
	call make_pairing_array (eval%pairing_array, me_index, result_index)
	call record_links (eval, int_in, n_tot)
	call state_with_contractions%final ()

	contains

	subroutine make_contracted_interaction (int, &
	me_index, result_index, &
	n_in, n_vir, n_out, n_tot, state, qn_mask)
	type(interaction_t), intent(out), target :: int
	integer, dimension(:), intent(out), allocatable :: me_index
	integer, dimension(:), intent(out), allocatable :: result_index
	integer, intent(in) :: n_in, n_vir, n_out, n_tot
	type(state_matrix_t), intent(in) :: state
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	type(state_iterator_t) :: it
	integer :: n_me, i
	type(quantum_numbers_t), dimension(n_tot) :: qn
	call int%basic_init (n_in, n_vir, n_out, mask=qn_mask)
	n_me = state%get_n_leaves ()
	allocate (me_index (n_me))
	allocate (result_index (n_me))
	call it%init (state)
	i = 0
	do while (it%is_valid ())
	i = i + 1
	me_index(i) = it%get_me_index ()
	qn = it%get_quantum_numbers ()
	call int%add_state (qn, me_index = result_index(i))
	call it%advance ()
	end do
	call int%freeze ()
	end subroutine make_contracted_interaction

	subroutine make_pairing_array (pa, me_index, result_index)
	type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
	integer, dimension(:), intent(in) :: me_index, result_index
	integer, dimension(:), allocatable :: n_entries
	integer :: n_matrix_elements, r, i
	n_matrix_elements = size (me_index)
	allocate (pa (n_matrix_elements))
	allocate (n_entries (n_matrix_elements))
	n_entries = 1
	call pairing_array_init &
	(pa, n_entries, has_i2=.false., has_factor=.false.)
	do i = 1, n_matrix_elements
	r = result_index(i)
	pa(r)%i1(1) = me_index(i)
	end do
	end subroutine make_pairing_array

	subroutine record_links (int, int_in, n_tot)
	class(interaction_t), intent(inout) :: int
	class(interaction_t), intent(in), target :: int_in
	integer, intent(in) :: n_tot
	integer, dimension(n_tot) :: map
	integer :: i
	do i = 1, n_tot
	call int%set_source_link (i, int_in, i)
	end do
	map = [ (i, i = 1, n_tot) ]
	call int_in%transfer_relations (int, map)
	end subroutine record_links

	end subroutine evaluator_init_color_contractions

	@ %def evaluator_init_color_contractions
	@
	\subsubsection{Auxiliary procedure for initialization}
	This will become a standard procedure in F2008. The result is true if
	the number of true values in the mask is odd. We use the function for
	determining the ghost parity of a quantum-number array.

	[tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is
	a cooler implementation anyway.
	<<(UNUSED) Evaluators: procedures>>=
	function parity (mask)
	logical :: parity
	logical, dimension(:) :: mask
	integer :: i
	parity = .false.
	do i = 1, size (mask)
	if (mask(i)) parity = .not. parity
	end do
	end function parity

	@ %def parity
	@ Reassign external source links from one to another.
	<<Evaluators: public>>=
	public :: evaluator_reassign_links
	<<Evaluators: interfaces>>=
	interface evaluator_reassign_links
	module procedure evaluator_reassign_links_eval
	module procedure evaluator_reassign_links_int
	end interface

	<<Evaluators: procedures>>=
	subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target)
	type(evaluator_t), intent(inout) :: eval
	type(evaluator_t), intent(in) :: eval_src
	type(evaluator_t), intent(in), target :: eval_target
	if (associated (eval%int_in1)) then
	if (eval%int_in1%get_tag () == eval_src%get_tag ()) then
	eval%int_in1 => eval_target%interaction_t
	end if
	end if
	if (associated (eval%int_in2)) then
	if (eval%int_in2%get_tag () == eval_src%get_tag ()) then
	eval%int_in2 => eval_target%interaction_t
	end if
	end if
	call interaction_reassign_links &
	(eval%interaction_t, eval_src%interaction_t, &
	eval_target%interaction_t)
	end subroutine evaluator_reassign_links_eval

	subroutine evaluator_reassign_links_int (eval, int_src, int_target)
	type(evaluator_t), intent(inout) :: eval
	type(interaction_t), intent(in) :: int_src
	type(interaction_t), intent(in), target :: int_target
	if (associated (eval%int_in1)) then
	if (eval%int_in1%get_tag () == int_src%get_tag ()) then
	eval%int_in1 => int_target
	end if
	end if
	if (associated (eval%int_in2)) then
	if (eval%int_in2%get_tag () == int_src%get_tag ()) then
	eval%int_in2 => int_target
	end if
	end if
	call interaction_reassign_links (eval%interaction_t, int_src, int_target)
	end subroutine evaluator_reassign_links_int

	@ %def evaluator_reassign_links
	@ Return flavor, momentum, and position of the first unstable particle
	present in the interaction.
	<<Evaluators: public>>=
	public :: evaluator_get_unstable_particle
	<<Evaluators: procedures>>=
	subroutine evaluator_get_unstable_particle (eval, flv, p, i)
	type(evaluator_t), intent(in) :: eval
	type(flavor_t), intent(out) :: flv
	type(vector4_t), intent(out) :: p
	integer, intent(out) :: i
	call interaction_get_unstable_particle (eval%interaction_t, flv, p, i)
	end subroutine evaluator_get_unstable_particle

	@ %def evaluator_get_unstable_particle
	@
	<<Evaluators: public>>=
	public :: evaluator_get_int_in_ptr
	<<Evaluators: procedures>>=
	function evaluator_get_int_in_ptr (eval, i) result (int_in)
	class(interaction_t), pointer :: int_in
	type(evaluator_t), intent(in), target :: eval
	integer, intent(in) :: i
	if (i == 1) then
	int_in => eval%int_in1
	else if (i == 2) then
	int_in => eval%int_in2
	else
	int_in => null ()
	end if
	end function evaluator_get_int_in_ptr

	@ %def evaluator_get_int_in_ptr
	@
	\subsection{Creating an evaluator: identity}
	The identity evaluator creates a copy of the first input evaluator; the second
	input is not used.

	All particles link back to the input evaluatorand the internal
	relations are copied. As evaluation does take a shortcut by cloning the matrix
	elements, the pairing array is not used and does not have to be set up.

	<<Evaluators: evaluator: TBP>>=
	procedure :: init_identity => evaluator_init_identity
	<<Evaluators: procedures>>=
	subroutine evaluator_init_identity (eval, int)
	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), intent(in), target :: int
	integer :: n_in, n_out, n_vir, n_tot
	integer :: i
	integer, dimension(:), allocatable :: map
	type(state_matrix_t), pointer :: state
	type(state_iterator_t) :: it
	eval%type = EVAL_IDENTITY
	eval%int_in1 => int
	nullify (eval%int_in2)
	n_in = int%get_n_in ()
	n_out = int%get_n_out ()
	n_vir = int%get_n_vir ()
	n_tot = int%get_n_tot ()
	call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
	mask = int%get_mask (), &
	resonant = int%get_resonance_flags ())
	do i = 1, n_tot
	call eval%set_source_link (i, int, i)
	end do
	allocate (map(n_tot))
	map = [(i, i = 1, n_tot)]
	call int%transfer_relations (eval, map)
	state => int%get_state_matrix_ptr ()
	call it%init (state)
	do while (it%is_valid ())
	call eval%add_state (it%get_quantum_numbers (), &
	it%get_me_index ())
	call it%advance ()
	end do
	call eval%freeze ()

	end subroutine evaluator_init_identity

	@ %def evaluator_init_identity
	@
	\subsection {Creating an evaluator: quantum number sum}
	This evaluator operates on the diagonal of a density matrix and sums over the
	quantum numbers specified by the mask. The optional argument [[drop]] allows to
	drop a particle from the resulting density matrix. The handling of virtuals is
	not completely sane, especially in connection with dropping particles.

	When summing over matrix element entries, we keep the separation into
	entries and normalization (in the corresponding evaluation routine below).
	<<Evaluators: evaluator: TBP>>=
	procedure :: init_qn_sum => evaluator_init_qn_sum
	<<Evaluators: procedures>>=
	subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop)
	class(evaluator_t), intent(out), target :: eval
	class(interaction_t), target, intent(in) :: int
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
	logical, intent(in), optional, dimension(:) :: drop
	type(state_iterator_t) :: it_old, it_new
	integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new
	integer, dimension(:), allocatable :: map
	integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new
	integer :: i, j
	type(state_matrix_t), pointer :: state_new, state_old
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	logical :: matched
	logical, dimension(size (qn_mask)) :: dropped
	integer :: ndropped
	integer, dimension(:), allocatable :: inotdropped
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	logical, dimension(:), allocatable :: resonant

	eval%type = EVAL_QN_SUM
	eval%int_in1 => int
	nullify (eval%int_in2)
	if (present (drop)) then
	dropped = drop
	else
	dropped = .false.
	end if
	ndropped = count (dropped)

	n_in = int%get_n_in ()
	n_out = int%get_n_out () - ndropped
	n_vir = int%get_n_vir ()
	n_tot = int%get_n_tot () - ndropped

	allocate (inotdropped (n_tot))
	i = 1
	do j = 1, n_tot + ndropped
	if (dropped (j)) cycle
	inotdropped(i) = j
	i = i + 1
	end do

	allocate (mask(n_tot + ndropped))
	mask = int%get_mask ()
	allocate (resonant(n_tot + ndropped))
	resonant = int%get_resonance_flags ()
	call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
	mask = mask(inotdropped) .or. qn_mask(inotdropped), &
	resonant = resonant(inotdropped))
	i = 1
	do j = 1, n_tot + ndropped
	if (dropped(j)) cycle
	call eval%set_source_link (i, int, j)
	i = i + 1
	end do
	allocate (map(n_tot + ndropped))
	i = 1
	do j = 1, n_tot + ndropped
	if (dropped (j)) then
	map(j) = 0
	else
	map(j) = i
	i = i + 1
	end if
	end do
	call int%transfer_relations (eval, map)

	n_me_old = int%get_n_matrix_elements ()
	allocate (pairing_size (n_me_old), source = 0)
	allocate (pairing_target (n_me_old), source = 0)
	pairing_size = 0
	state_old => int%get_state_matrix_ptr ()
	state_new => eval%get_state_matrix_ptr ()
	call it_old%init (state_old)
	allocate (qn(n_tot + ndropped))
	do while (it_old%is_valid ())
	qn = it_old%get_quantum_numbers ()
	if (.not. all (qn%are_diagonal ())) then
	call it_old%advance ()
	cycle
	end if
	matched = .false.
	call it_new%init (state_new)
	if (eval%get_n_matrix_elements () > 0) then
	do while (it_new%is_valid ())
	if (all (qn(inotdropped) .match. &
	it_new%get_quantum_numbers ())) &
	then
	matched = .true.
	i = it_new%get_me_index ()
	exit
	end if
	call it_new%advance ()
	end do
	end if
	if (.not. matched) then
	call eval%add_state (qn(inotdropped))
	i = eval%get_n_matrix_elements ()
	end if
	pairing_size(i) = pairing_size(i) + 1
	pairing_target(it_old%get_me_index ()) = i
	call it_old%advance ()
	end do
	call eval%freeze ()

	n_me_new = eval%get_n_matrix_elements ()
	allocate (eval%pairing_array (n_me_new))
	do i = 1, n_me_new
	call pairing_array_init (eval%pairing_array(i), &
	pairing_size(i), .false., .false.)
	end do

	allocate (i_new (n_me_new), source = 0)
	do i = 1, n_me_old
	j = pairing_target(i)
	if (j > 0) then
	i_new(j) = i_new(j) + 1
	eval%pairing_array(j)%i1(i_new(j)) = i
	end if
	end do

	end subroutine evaluator_init_qn_sum

	@ %def evaluator_init_qn_sum
	@
	\subsection{Evaluation}
	When the input interactions (which are pointed to in the pairings
	stored within the evaluator) are filled with values, we can activate
	the evaluator, i.e., calculate the result values which are stored in
	the interaction.

	The evaluation of matrix elements can be done in parallel. A
	[[forall]] construct is not appropriate, however. We would need
	[[do concurrent]] here. Nevertheless, the evaluation functions are
	marked as [[pure]].
	<<Evaluators: evaluator: TBP>>=
	procedure :: evaluate => evaluator_evaluate
	<<Evaluators: procedures>>=
	subroutine evaluator_evaluate (eval)
	class(evaluator_t), intent(inout), target :: eval
	integer :: i
	select case (eval%type)
	case (EVAL_PRODUCT)
	do i = 1, size(eval%pairing_array)
	call eval%evaluate_product (i, &
	eval%int_in1, eval%int_in2, &
	eval%pairing_array(i)%i1, eval%pairing_array(i)%i2)
	if (debug2_active (D_QFT)) then
	print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 = ', &
	eval%pairing_array(i)%i1, eval%pairing_array(i)%i2
	print *, 'MEs = ', &
	eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), &
	eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2)
	end if
	end do
	case (EVAL_SQUARE_WITH_COLOR_FACTORS)
	do i = 1, size(eval%pairing_array)
	call eval%evaluate_product_cf (i, &
	eval%int_in1, eval%int_in1, &
	eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, &
	eval%pairing_array(i)%factor)
	end do
	case (EVAL_SQUARED_FLOWS)
	do i = 1, size(eval%pairing_array)
	call eval%evaluate_square_c (i, &
	eval%int_in1, &
	eval%pairing_array(i)%i1)
	end do
	case (EVAL_COLOR_CONTRACTION)
	do i = 1, size(eval%pairing_array)
	call eval%evaluate_sum (i, &
	eval%int_in1, &
	eval%pairing_array(i)%i1)
	end do
	case (EVAL_IDENTITY)
	call eval%set_matrix_element (eval%int_in1)
	case (EVAL_QN_SUM)
	do i = 1, size (eval%pairing_array)
	call eval%evaluate_me_sum (i, &
	eval%int_in1, eval%pairing_array(i)%i1)
	call eval%set_norm (eval%int_in1%get_norm ())
	end do
	end select
	end subroutine evaluator_evaluate

	@ %def evaluator_evaluate
	@
	\subsection{Unit tests}
	Test module, followed by the corresponding implementation module.
	<<[[evaluators_ut.f90]]>>=
	<<File header>>

	module evaluators_ut
	use unit_tests
	use evaluators_uti

	<<Standard module head>>

	<<Evaluators: public test>>

	contains

	<<Evaluators: test driver>>

	end module evaluators_ut
	@ %def evaluators_ut
	@
	<<[[evaluators_uti.f90]]>>=
	<<File header>>

	module evaluators_uti

	<<Use kinds>>
	use lorentz
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use interactions
	use model_data

	use evaluators

	<<Standard module head>>

	<<Evaluators: test declarations>>

	contains

	<<Evaluators: tests>>

	end module evaluators_uti
	@ %def evaluators_ut
	@ API: driver for the unit tests below.
	<<Evaluators: public test>>=
	public :: evaluator_test
	<<Evaluators: test driver>>=
	subroutine evaluator_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Evaluators: execute tests>>
	end subroutine evaluator_test

	@ %def evaluator_test
	@ Test: Create two interactions. The interactions are twofold
	connected. The first connection has a helicity index that is kept,
	the second connection has a helicity index that is summed over.
	Concatenate the interactions in an evaluator, which thus contains a
	result interaction. Fill the input interactions with values, activate
	the evaluator and print the result.
	<<Evaluators: execute tests>>=
	call test (evaluator_1, "evaluator_1", &
	"check evaluators (1)", &
	u, results)
	<<Evaluators: test declarations>>=
	public :: evaluator_1
	<<Evaluators: tests>>=
	subroutine evaluator_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(interaction_t), target :: int_qqtt, int_tbw, int1, int2
	type(flavor_t), dimension(:), allocatable :: flv
	type(color_t), dimension(:), allocatable :: col
	type(helicity_t), dimension(:), allocatable :: hel
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: f, c, h1, h2, h3
	type(vector4_t), dimension(4) :: p
	type(vector4_t), dimension(2) :: q
	type(quantum_numbers_mask_t) :: qn_mask_conn
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2
	type(evaluator_t), target :: eval, eval2, eval3

	call model%init_sm_test ()

	write (u, "(A)") "*** Evaluator for matrix product"
	write (u, "(A)") "*** Construct interaction for qq -> tt"
	write (u, "(A)")
	call int_qqtt%basic_init (2, 0, 2, set_relations=.true.)
	allocate (flv (4), col (4), hel (4), qn (4))
	allocate (qn_mask2 (4))
	do c = 1, 2
	select case (c)
	case (1)
	call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2])
	case (2)
	call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2])
	end select
	do f = 1, 2
	call flv%init ([f, -f, 6, -6], model)
	do h1 = -1, 1, 2
	call hel(3)%init (h1)
	do h2 = -1, 1, 2
	call hel(4)%init (h2)
	call qn%init (flv, col, hel)
	call int_qqtt%add_state (qn)
	end do
	end do
	end do
	end do
	call int_qqtt%freeze ()
	deallocate (flv, col, hel, qn)
	write (u, "(A)") "*** Construct interaction for t -> bW"
	call int_tbw%basic_init (1, 0, 2, set_relations=.true.)
	allocate (flv (3), col (3), hel (3), qn (3))
	call flv%init ([6, 5, 24], model)
	call col%init_col_acl ([1, 1, 0], [0, 0, 0])
	do h1 = -1, 1, 2
	call hel(1)%init (h1)
	do h2 = -1, 1, 2
	call hel(2)%init (h2)
	do h3 = -1, 1
	call hel(3)%init (h3)
	call qn%init (flv, col, hel)
	call int_tbw%add_state (qn)
	end do
	end do
	end do
	call int_tbw%freeze ()
	deallocate (flv, col, hel, qn)
	write (u, "(A)") "*** Link interactions"
	call int_tbw%set_source_link (1, int_qqtt, 3)
	qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.)
	write (u, "(A)")
	write (u, "(A)") "*** Show input"
	call int_qqtt%basic_write (unit = u)
	write (u, "(A)")
	call int_tbw%basic_write (unit = u)
	write (u, "(A)")
	write (u, "(A)") "*** Evaluate product"
	call eval%init_product (int_qqtt, int_tbw, qn_mask_conn)
	call eval%write (unit = u)

	call int1%basic_init (2, 0, 2, set_relations=.true.)
	call int2%basic_init (1, 0, 2, set_relations=.true.)
	p(1) = vector4_moving (1000._default, 1000._default, 3)
	p(2) = vector4_moving (200._default, 200._default, 2)
	p(3) = vector4_moving (100._default, 200._default, 1)
	p(4) = p(1) - p(2) - p(3)
	call int1%set_momenta (p)
	q(1) = vector4_moving (50._default,-50._default, 3)
	q(2) = p(2) + p(4) - q(1)
	call int2%set_momenta (q, outgoing=.true.)
	call int1%set_matrix_element ([(2._default,0._default), &
	(4._default,1._default), (-3._default,0._default)])
	call int2%set_matrix_element ([(-3._default,0._default), &
	(0._default,1._default), (1._default,2._default)])
	call eval%receive_momenta ()
	call eval%evaluate ()
	call int1%basic_write (unit = u)
	write (u, "(A)")
	call int2%basic_write (unit = u)
	write (u, "(A)")
	call eval%write (unit = u)
	write (u, "(A)")
	call int1%final ()
	call int2%final ()
	call eval%final ()

	write (u, "(A)")
	write (u, "(A)") "*** Evaluator for matrix square"
	allocate (flv(4), col(4), qn(4))
	call int1%basic_init (2, 0, 2, set_relations=.true.)
	call flv%init ([1, -1, 21, 21], model)
	call col(1)%init ([1])
	call col(2)%init ([-2])
	call col(3)%init ([2, -3])
	call col(4)%init ([3, -1])
	call qn%init (flv, col)
	call int1%add_state (qn)
	call col(3)%init ([3, -1])
	call col(4)%init ([2, -3])
	call qn%init (flv, col)
	call int1%add_state (qn)
	call col(3)%init ([2, -1])
	call col(4)%init (.true.)
	call qn%init (flv, col)
	call int1%add_state (qn)
	call int1%freeze ()
	! [qn_mask2 not set since default is false]
	call eval%init_square (int1, qn_mask2, nc=3)
	call eval2%init_square_nondiag (int1, qn_mask2)
	qn_mask2 = quantum_numbers_mask (.false., .true., .true.)
	call eval3%init_square_diag (eval, qn_mask2)
	call int1%set_matrix_element &
	([(2._default,0._default), &
	(4._default,1._default), (-3._default,0._default)])
	call int1%set_momenta (p)
	call int1%basic_write (unit = u)
	write (u, "(A)")
	call eval%receive_momenta ()
	call eval%evaluate ()
	call eval%write (unit = u)
	write (u, "(A)")
	call eval2%receive_momenta ()
	call eval2%evaluate ()
	call eval2%write (unit = u)
	write (u, "(A)")
	call eval3%receive_momenta ()
	call eval3%evaluate ()
	call eval3%write (unit = u)
	call int1%final ()
	call eval%final ()
	call eval2%final ()
	call eval3%final ()

	call model%final ()
	end subroutine evaluator_1

	@ %def evaluator_1
	@
	<<Evaluators: execute tests>>=
	call test (evaluator_2, "evaluator_2", &
	"check evaluators (2)", &
	u, results)
	<<Evaluators: test declarations>>=
	public :: evaluator_2
	<<Evaluators: tests>>=
	subroutine evaluator_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(interaction_t), target :: int
	integer :: h1, h2, h3, h4
	type(helicity_t), dimension(4) :: hel
	type(color_t), dimension(4) :: col
	type(flavor_t), dimension(4) :: flv
	type(quantum_numbers_t), dimension(4) :: qn
	type(vector4_t), dimension(4) :: p
	type(evaluator_t) :: eval
	integer :: i

	call model%init_sm_test ()

	write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-"
	write (u, "(A)")

	call flv%init ([11, -11, 24, -24], model)
	do i = 1, 4
	call col(i)%init ()
	end do
	call int%basic_init (2, 0, 2, set_relations=.true.)
	do h1 = -1, 1, 2
	call hel(1)%init (h1)
	do h2 = -1, 1, 2
	call hel(2)%init (h2)
	do h3 = -1, 1
	call hel(3)%init (h3)
	do h4 = -1, 1
	call hel(4)%init (h4)
	call qn%init (flv, col, hel)
	call int%add_state (qn)
	end do
	end do
	end do
	end do
	call int%freeze ()
	call int%set_matrix_element &
	([(cmplx (i, kind=default), i = 1, 36)])
	p(1) = vector4_moving (1000._default, 1000._default, 3)
	p(2) = vector4_moving (1000._default, -1000._default, 3)
	p(3) = vector4_moving (1000._default, &
	sqrt (1E6_default - 80._default**2), 3)
	p(4) = p(1) + p(2) - p(3)
	call int%set_momenta (p)
	write (u, "(A)") "*** Setting up evaluator"
	write (u, "(A)")

	call eval%init_identity (int)
	write (u, "(A)") "*** Transferring momenta and evaluating"
	write (u, "(A)")

	call eval%receive_momenta ()
	call eval%evaluate ()
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Interaction dump"
	write (u, "(A)") "*******************************************************"
	call int%basic_write (unit = u)
	write (u, "(A)")
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Evaluator dump"
	write (u, "(A)") "*******************************************************"
	call eval%write (unit = u)
	write (u, "(A)")
	write (u, "(A)") "*** cleaning up"
	call int%final ()
	call eval%final ()

	call model%final ()
	end subroutine evaluator_2

	@ %def evaluator_2
	@
	<<Evaluators: execute tests>>=
	call test (evaluator_3, "evaluator_3", &
	"check evaluators (3)", &
	u, results)
	<<Evaluators: test declarations>>=
	public :: evaluator_3
	<<Evaluators: tests>>=
	subroutine evaluator_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(interaction_t), target :: int
	integer :: h1, h2, h3, h4
	type(helicity_t), dimension(4) :: hel
	type(color_t), dimension(4) :: col
	type(flavor_t), dimension(4) :: flv1, flv2
	type(quantum_numbers_t), dimension(4) :: qn
	type(vector4_t), dimension(4) :: p
	type(evaluator_t) :: eval1, eval2, eval3
	type(quantum_numbers_mask_t), dimension(4) :: qn_mask
	integer :: i

	call model%init_sm_test ()

	write (u, "(A)") "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-"
	call flv1%init ([11, -11, 24, -24], model)
	call flv2%init ([13, -13, 24, -24], model)
	do i = 1, 4
	call col (i)%init ()
	end do
	call int%basic_init (2, 0, 2, set_relations=.true.)
	do h1 = -1, 1, 2
	call hel(1)%init (h1)
	do h2 = -1, 1, 2
	call hel(2)%init (h2)
	do h3 = -1, 1
	call hel(3)%init (h3)
	do h4 = -1, 1
	call hel(4)%init (h4)
	call qn%init (flv1, col, hel)
	call int%add_state (qn)
	call qn%init (flv2, col, hel)
	call int%add_state (qn)
	end do
	end do
	end do
	end do
	call int%freeze ()
	call int%set_matrix_element &
	([(cmplx (1, kind=default), i = 1, 72)])
	p(1) = vector4_moving (1000._default, 1000._default, 3)
	p(2) = vector4_moving (1000._default, -1000._default, 3)
	p(3) = vector4_moving (1000._default, &
	sqrt (1E6_default - 80._default**2), 3)
	p(4) = p(1) + p(2) - p(3)
	call int%set_momenta (p)
	write (u, "(A)") "*** Setting up evaluators"
	call qn_mask%init (.false., .true., .true.)
	call eval1%init_qn_sum (int, qn_mask)
	call qn_mask%init (.true., .true., .true.)
	call eval2%init_qn_sum (int, qn_mask)
	call qn_mask%init (.false., .true., .false.)
	call eval3%init_qn_sum (int, qn_mask, &
	[.false., .false., .false., .true.])
	write (u, "(A)") "*** Transferring momenta and evaluating"
	call eval1%receive_momenta ()
	call eval1%evaluate ()
	call eval2%receive_momenta ()
	call eval2%evaluate ()
	call eval3%receive_momenta ()
	call eval3%evaluate ()
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Interaction dump"
	write (u, "(A)") "*******************************************************"
	call int%basic_write (unit = u)
	write (u, "(A)")
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Evaluator dump --- spin sum"
	write (u, "(A)") "*******************************************************"
	call eval1%write (unit = u)
	call eval1%basic_write (unit = u)
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Evaluator dump --- spin / flavor sum"
	write (u, "(A)") "*******************************************************"
	call eval2%write (unit = u)
	call eval2%basic_write (unit = u)
	write (u, "(A)") "*******************************************************"
	write (u, "(A)") " Evaluator dump --- flavor sum, drop last W"
	write (u, "(A)") "*******************************************************"
	call eval3%write (unit = u)
	call eval3%basic_write (unit = u)
	write (u, "(A)")
	write (u, "(A)") "*** cleaning up"
	call int%final ()
	call eval1%final ()
	call eval2%final ()
	call eval3%final ()

	call model%final ()
	end subroutine evaluator_3

	@ %def evaluator_3
	@ This test evaluates a product with different quantum-number masks and
	filters for the linked entry.
	<<Evaluators: execute tests>>=
	call test (evaluator_4, "evaluator_4", &
	"check evaluator product with filter", &
	u, results)
	<<Evaluators: test declarations>>=
	public :: evaluator_4
	<<Evaluators: tests>>=
	subroutine evaluator_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(interaction_t), target :: int1, int2
	integer :: h1, h2, h3
	type(helicity_t), dimension(3) :: hel
	type(color_t), dimension(3) :: col
	type(flavor_t), dimension(2) :: flv1, flv2
	type(flavor_t), dimension(3) :: flv3, flv4
	type(quantum_numbers_t), dimension(3) :: qn
	type(evaluator_t) :: eval1, eval2, eval3, eval4
	type(quantum_numbers_mask_t) :: qn_mask
	type(flavor_t) :: flv_filter
	type(helicity_t) :: hel_filter
	type(color_t) :: col_filter
	type(quantum_numbers_t) :: qn_filter
	integer :: i

	write (u, "(A)") "* Test output: evaluator_4"
	write (u, "(A)") "* Purpose: test evaluator products &
	&with mask and filter"
	write (u, "(A)")

	call model%init_sm_test ()

	write (u, "(A)") "* Creating interaction for e- -> W+/Z"
	write (u, "(A)")

	call flv1%init ([11, 24], model)
	call flv2%init ([11, 23], model)
	do i = 1, 3
	call col(i)%init ()
	end do
	call int1%basic_init (1, 0, 1, set_relations=.true.)
	do h1 = -1, 1, 2
	call hel(1)%init (h1)
	do h2 = -1, 1
	call hel(2)%init (h2)
	call qn(:2)%init (flv1, col(:2), hel(:2))
	call int1%add_state (qn(:2))
	call qn(:2)%init (flv2, col(:2), hel(:2))
	call int1%add_state (qn(:2))
	end do
	end do
	call int1%freeze ()
	call int1%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Creating interaction for W+/Z -> u ubar/dbar"
	write (u, "(A)")

	call flv3%init ([24, 2, -1], model)
	call flv4%init ([23, 2, -2], model)

	call int2%basic_init (1, 0, 2, set_relations=.true.)
	do h1 = -1, 1
	call hel(1)%init (h1)
	do h2 = -1, 1, 2
	call hel(2)%init (h2)
	do h3 = -1, 1, 2
	call hel(3)%init (h3)
	call qn(:3)%init (flv3, col(:3), hel(:3))
	call int2%add_state (qn(:3))
	call qn(:3)%init (flv4, col(:3), hel(:3))
	call int2%add_state (qn(:3))
	end do
	end do
	end do
	call int2%freeze ()

	call int2%set_source_link (1, int1, 2)
	call int2%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Product evaluator"
	write (u, "(A)")

	call qn_mask%init (.false., .false., .false.)
	call eval1%init_product (int1, int2, qn_mask_conn = qn_mask)
	call eval1%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Product evaluator with helicity mask"
	write (u, "(A)")

	call qn_mask%init (.false., .false., .true.)
	call eval2%init_product (int1, int2, qn_mask_conn = qn_mask)
	call eval2%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Product with flavor filter and helicity mask"
	write (u, "(A)")

	call qn_mask%init (.false., .false., .true.)
	call flv_filter%init (24, model)
	call hel_filter%init ()
	call col_filter%init ()
	call qn_filter%init (flv_filter, col_filter, hel_filter)
	call eval3%init_product (int1, int2, &
	qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
	call eval3%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Product with helicity filter and mask"
	write (u, "(A)")

	call qn_mask%init (.false., .false., .true.)
	call flv_filter%init ()
	call hel_filter%init (0)
	call col_filter%init ()
	call qn_filter%init (flv_filter, col_filter, hel_filter)
	call eval4%init_product (int1, int2, &
	qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
	call eval4%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	call eval1%final ()
	call eval2%final ()
	call eval3%final ()
	call eval4%final ()

	call int1%final ()
	call int2%final ()

	call model%final ()

	write (u, "(A)")
	write (u, "(A)") "* Test output end: evaluator_4"

	end subroutine evaluator_4

	@ %def evaluator_4

File Metadata

Mime Type: text/x-diff
Expires: Sun, Feb 23, 2:10 PM (8 h, 5 m)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 4473845
Default Alt Text: (562 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions