No OneTemporary
Actions

Size

1 MB

Subscribers

None

View Options

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

	Index: trunk/src/phase_space/phase_space.nw
	===================================================================
	--- trunk/src/phase_space/phase_space.nw (revision 8877)
	+++ trunk/src/phase_space/phase_space.nw (revision 8878)
	@@ -1,31092 +1,31061 @@
	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: phase space
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Phase Space}
	\includemodulegraph{phase_space}

	The abstract representation of a type that parameterizes phase space,
	with methods for construction and evaluation.
	\begin{description}
	\item[phs\_base]
	Abstract phase-space representation.
	\end{description}

	A simple implementation:
	\begin{description}
	\item[phs\_none]
	This implements a non-functional dummy module for the phase space.
	A process which uses this module cannot be integrated. The purpose
	of this module is to provide a placeholder for processes which do
	not require phase-space evaluation. They may still allow for evaluating
	matrix elements.
	\item[phs\_single]
	Parameterize the phase space of a single particle, i.e., the solid
	angle. This is useful only for very restricted problems, but it
	avoids the complexity of a generic approach in those trivial cases.
	\end{description}

	The standard implementation is called \emph{wood} phase space. It
	consists of several auxiliary modules and the actual implementation
	module.
	\begin{description}
	\item[mappings]
	Generate invariant masses and decay angles from given
	random numbers (or the inverse operation). Each mapping pertains to a
	particular node in a phase-space tree. Different mappings account for
	uniform distributions, resonances, zero-mass behavior, and so on.
	\item[phs\_trees]
	Phase space parameterizations for scattering
	processes are defined recursively as if there was an initial particle
	decaying. This module sets up a representation in terms of abstract
	trees, where each node gets a unique binary number. Each tree is
	stored as an array of branches, where integers indicate the
	connections. This emulates pointers in a transparent way. Real
	pointers would also be possible, but seem to be less efficient for
	this particular case.
	\item[phs\_forests]
	The type defined by this module collects the
	decay trees corresponding to a given process and the applicable
	mappings. To set this up, a file is read which is either written by
	the user or by the \textbf{cascades} module functions. The module
	also contains the routines that evaluate phase space, i.e., generate
	momenta from random numbers and back.
	\item[cascades]
	This module is a pseudo Feynman diagram generator with the
	particular purpose of finding the phase space parameterizations best
	suited for a given process. It uses a model file to set up the
	possible vertices, generates all possible diagrams, identifies
	resonances and singularities, and simplifies the list by merging
	equivalent diagrams and dropping irrelevant ones. This process can be
	controlled at several points by user-defined parameters. Note that it
	depends on the particular values of particle masses, so it cannot be
	done before reading the input file.
	\item[phs\_wood]
	Make the functionality available in form of an implementation of the
	abstract phase-space type.
	\item[phs\_fks]
	Phase-space parameterization with modifications for the FKS scheme.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Abstract phase-space module}

	In this module we define an abstract base type (and a trivial test
	implementation) for multi-channel phase-space parameterizations.
	<<[[phs_base.f90]]>>=
	<<File header>>

	module phs_base

	<<Use kinds>>
	<<Use strings>>
	use lorentz
	use model_data
	use flavors
	use process_constants

	<<Standard module head>>

	<<PHS base: public>>

	<<PHS base: types>>

	<<PHS base: interfaces>>

	interface
	<<PHS base: sub interfaces>>
	end interface

	contains

	<<PHS base: main procedures>>

	end module phs_base
	@ %def phs_base
	@
	<<[[phs_base_sub.f90]]>>=
	<<File header>>

	submodule (phs_base) phs_base_s

	use io_units
	use constants, only: TWOPI, TWOPI4
	use string_utils, only: split_string
	use format_defs, only: FMT_19
	use numeric_utils
	use diagnostics
	use md5
	use physics_defs

	implicit none

	contains

	<<PHS base: procedures>>

	end submodule phs_base_s

	@ %def phs_base_s
	@
	\subsection{Phase-space channels}
	The kinematics configuration may generate multiple parameterizations of phase
	space. Some of those have specific properties, such as a resonance in the s
	channel.

	\subsubsection{Channel properties}
	This is the abstract type for the channel properties. We need them as
	a data transfer container, so everything is public and transparent.
	<<PHS base: public>>=
	public :: channel_prop_t
	<<PHS base: types>>=
	type, abstract :: channel_prop_t
	contains
	procedure (channel_prop_to_string), deferred :: to_string
	generic :: operator (==) => is_equal
	procedure (channel_eq), deferred :: is_equal
	end type channel_prop_t

	@ %def channel_prop_t
	<<PHS base: interfaces>>=
	abstract interface
	function channel_prop_to_string (object) result (string)
	import
	class(channel_prop_t), intent(in) :: object
	type(string_t) :: string
	end function channel_prop_to_string
	end interface

	@ %def channel_prop_to_string
	<<PHS base: interfaces>>=
	abstract interface
	function channel_eq (prop1, prop2) result (flag)
	import
	class(channel_prop_t), intent(in) :: prop1, prop2
	logical :: flag
	end function channel_eq
	end interface

	@ %def channel_prop_to_string
	@
	Here is a resonance as a channel property. Mass and width are stored
	here in physical units.
	<<PHS base: public>>=
	public :: resonance_t
	<<PHS base: types>>=
	type, extends (channel_prop_t) :: resonance_t
	real(default) :: mass = 0
	real(default) :: width = 0
	contains
	procedure :: to_string => resonance_to_string
	procedure :: is_equal => resonance_is_equal
	end type resonance_t

	@ %def resonance_t
	@ Print mass and width.
	<<PHS base: sub interfaces>>=
	module function resonance_to_string (object) result (string)
	class(resonance_t), intent(in) :: object
	type(string_t) :: string
	end function resonance_to_string
	<<PHS base: procedures>>=
	module function resonance_to_string (object) result (string)
	class(resonance_t), intent(in) :: object
	type(string_t) :: string
	character(32) :: buffer
	string = "resonant: m ="
	write (buffer, "(" // FMT_19 // ")") object%mass
	string = string // trim (buffer) // " GeV, w ="
	write (buffer, "(" // FMT_19 // ")") object%width
	string = string // trim (buffer) // " GeV"
	end function resonance_to_string

	@ %def resonance_to_string
	@ Equality.
	<<PHS base: sub interfaces>>=
	module function resonance_is_equal (prop1, prop2) result (flag)
	class(resonance_t), intent(in) :: prop1
	class(channel_prop_t), intent(in) :: prop2
	logical :: flag
	end function resonance_is_equal
	<<PHS base: procedures>>=
	module function resonance_is_equal (prop1, prop2) result (flag)
	class(resonance_t), intent(in) :: prop1
	class(channel_prop_t), intent(in) :: prop2
	logical :: flag
	select type (prop2)
	type is (resonance_t)
	flag = prop1%mass == prop2%mass .and. prop1%width == prop2%width
	class default
	flag = .false.
	end select
	end function resonance_is_equal

	@ %def resonance_is_equal
	@
	This is the limiting case of a resonance, namely an on-shell particle.
	We just store the mass in physical units.
	<<PHS base: public>>=
	public :: on_shell_t
	<<PHS base: types>>=
	type, extends (channel_prop_t) :: on_shell_t
	real(default) :: mass = 0
	contains
	procedure :: to_string => on_shell_to_string
	procedure :: is_equal => on_shell_is_equal
	end type on_shell_t

	@ %def on_shell_t
	@ Print mass and width.
	<<PHS base: sub interfaces>>=
	module function on_shell_to_string (object) result (string)
	class(on_shell_t), intent(in) :: object
	type(string_t) :: string
	end function on_shell_to_string
	<<PHS base: procedures>>=
	module function on_shell_to_string (object) result (string)
	class(on_shell_t), intent(in) :: object
	type(string_t) :: string
	character(32) :: buffer
	string = "on shell: m ="
	write (buffer, "(" // FMT_19 // ")") object%mass
	string = string // trim (buffer) // " GeV"
	end function on_shell_to_string

	@ %def on_shell_to_string
	@ Equality.
	<<PHS base: sub interfaces>>=
	module function on_shell_is_equal (prop1, prop2) result (flag)
	class(on_shell_t), intent(in) :: prop1
	class(channel_prop_t), intent(in) :: prop2
	logical :: flag
	end function on_shell_is_equal
	<<PHS base: procedures>>=
	module function on_shell_is_equal (prop1, prop2) result (flag)
	class(on_shell_t), intent(in) :: prop1
	class(channel_prop_t), intent(in) :: prop2
	logical :: flag
	select type (prop2)
	type is (on_shell_t)
	flag = prop1%mass == prop2%mass
	class default
	flag = .false.
	end select
	end function on_shell_is_equal

	@ %def on_shell_is_equal
	@
	\subsubsection{Channel equivalences}
	This type describes an equivalence. The current channel is equivalent
	to channel [[c]]. The equivalence involves a permutation [[perm]] of
	integration dimensions and, within each integration dimension, a
	mapping [[mode]].
	<<PHS base: types>>=
	type :: phs_equivalence_t
	integer :: c = 0
	integer, dimension(:), allocatable :: perm
	integer, dimension(:), allocatable :: mode
	contains
	<<PHS base: phs equivalence: TBP>>
	end type phs_equivalence_t

	@ %def phs_equivalence_t
	@
	The mapping modes are
	<<PHS base: types>>=
	integer, parameter, public :: &
	EQ_IDENTITY = 0, EQ_INVERT = 1, EQ_SYMMETRIC = 2, EQ_INVARIANT = 3

	@ %def EQ_IDENTITY EQ_INVERT EQ_SYMMETRIC
	@ In particular, if a channel is equivalent to itself in the
	[[EQ_SYMMETRIC]] mode, the integrand can be assumed to be symmetric
	w.r.t.\ a reflection $x\to 1 - x$ of the correponding integration variable.

	These are the associated tags, for output:
	<<PHS base: types>>=
	character, dimension(0:3), parameter :: TAG = ["+", "-", ":", "x"]

	@ %def TAG
	@ Write an equivalence.
	<<PHS base: phs equivalence: TBP>>=
	procedure :: write => phs_equivalence_write
	<<PHS base: sub interfaces>>=
	module subroutine phs_equivalence_write (object, unit)
	class(phs_equivalence_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_equivalence_write
	<<PHS base: procedures>>=
	module subroutine phs_equivalence_write (object, unit)
	class(phs_equivalence_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, j
	u = given_output_unit (unit)
	write (u, "(5x,'=',1x,I0,1x)", advance = "no") object%c
	if (allocated (object%perm)) then
	write (u, "(A)", advance = "no") "("
	do j = 1, size (object%perm)
	if (j > 1) write (u, "(1x)", advance = "no")
	write (u, "(I0,A1)", advance = "no") &
	object%perm(j), TAG(object%mode(j))
	end do
	write (u, "(A)") ")"
	else
	write (u, "(A)")
	end if
	end subroutine phs_equivalence_write

	@ %def phs_equivalence_write
	@ Initialize an equivalence. This allocates the [[perm]] and [[mode]]
	arrays with equal size.
	<<PHS base: phs equivalence: TBP>>=
	procedure :: init => phs_equivalence_init
	<<PHS base: sub interfaces>>=
	module subroutine phs_equivalence_init (eq, n_dim)
	class(phs_equivalence_t), intent(out) :: eq
	integer, intent(in) :: n_dim
	end subroutine phs_equivalence_init
	<<PHS base: procedures>>=
	module subroutine phs_equivalence_init (eq, n_dim)
	class(phs_equivalence_t), intent(out) :: eq
	integer, intent(in) :: n_dim
	allocate (eq%perm (n_dim), source = 0)
	allocate (eq%mode (n_dim), source = EQ_IDENTITY)
	end subroutine phs_equivalence_init

	@ %def phs_equivalence_init
	@
	\subsubsection{Channel objects}
	The channel entry holds (optionally) specific properties.

	[[sf_channel]] is the structure-function channel that corresponds to this
	phase-space channel. The structure-function channel may be set up with a
	specific mapping that depends on the phase-space channel properties. (The
	default setting is to leave the properties empty.)
	<<PHS base: public>>=
	public :: phs_channel_t
	<<PHS base: types>>=
	type :: phs_channel_t
	class(channel_prop_t), allocatable :: prop
	integer :: sf_channel = 1
	type(phs_equivalence_t), dimension(:), allocatable :: eq
	contains
	<<PHS base: phs channel: TBP>>
	end type phs_channel_t

	@ %def phs_channel_t
	@ Output.
	<<PHS base: phs channel: TBP>>=
	procedure :: write => phs_channel_write
	<<PHS base: sub interfaces>>=
	module subroutine phs_channel_write (object, unit)
	class(phs_channel_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_channel_write
	<<PHS base: procedures>>=
	module subroutine phs_channel_write (object, unit)
	class(phs_channel_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, j
	u = given_output_unit (unit)
	write (u, "(1x,I0)", advance="no") object%sf_channel
	if (allocated (object%prop)) then
	write (u, "(1x,A)") char (object%prop%to_string ())
	else
	write (u, *)
	end if
	if (allocated (object%eq)) then
	do j = 1, size (object%eq)
	call object%eq(j)%write (u)
	end do
	end if
	end subroutine phs_channel_write

	@ %def phs_channel_write
	@ Identify the channel with an s-channel resonance.
	Gfortran 7/8/9 bug: has to remain in the main module.
	<<PHS base: phs channel: TBP>>=
	procedure :: set_resonant => channel_set_resonant
	<<PHS base: main procedures>>=
	subroutine channel_set_resonant (channel, mass, width)
	class(phs_channel_t), intent(inout) :: channel
	real(default), intent(in) :: mass, width
	allocate (resonance_t :: channel%prop)
	select type (prop => channel%prop)
	type is (resonance_t)
	prop%mass = mass
	prop%width = width
	end select
	end subroutine channel_set_resonant

	@ %def channel_set_resonant
	@ Identify the channel with an on-shell particle.
	Gfortran 7/8/9 bug: has to remain in the main module.
	<<PHS base: phs channel: TBP>>=
	procedure :: set_on_shell => channel_set_on_shell
	<<PHS base: main procedures>>=
	subroutine channel_set_on_shell (channel, mass)
	class(phs_channel_t), intent(inout) :: channel
	real(default), intent(in) :: mass
	allocate (on_shell_t :: channel%prop)
	select type (prop => channel%prop)
	type is (on_shell_t)
	prop%mass = mass
	end select
	end subroutine channel_set_on_shell

	@ %def channel_set_on_shell
	@
	\subsection{Property collection}
	We can set up a list of all distinct channel properties for a given
	set of channels.
	<<PHS base: public>>=
	public :: phs_channel_collection_t
	<<PHS base: types>>=
	type :: prop_entry_t
	integer :: i = 0
	class(channel_prop_t), allocatable :: prop
	type(prop_entry_t), pointer :: next => null ()
	end type prop_entry_t

	type :: phs_channel_collection_t
	integer :: n = 0
	type(prop_entry_t), pointer :: first => null ()
	contains
	<<PHS base: phs channel collection: TBP>>
	end type phs_channel_collection_t

	@ %def prop_entry_t
	@ %def phs_channel_collection_t
	@ Finalizer for the list.
	<<PHS base: phs channel collection: TBP>>=
	procedure :: final => phs_channel_collection_final
	<<PHS base: sub interfaces>>=
	module subroutine phs_channel_collection_final (object)
	class(phs_channel_collection_t), intent(inout) :: object
	end subroutine phs_channel_collection_final
	<<PHS base: procedures>>=
	module subroutine phs_channel_collection_final (object)
	class(phs_channel_collection_t), intent(inout) :: object
	type(prop_entry_t), pointer :: entry
	do while (associated (object%first))
	entry => object%first
	object%first => entry%next
	deallocate (entry)
	end do
	end subroutine phs_channel_collection_final

	@ %def phs_channel_collection_final
	@ Output.
	<<PHS base: phs channel collection: TBP>>=
	procedure :: write => phs_channel_collection_write
	<<PHS base: sub interfaces>>=
	module subroutine phs_channel_collection_write (object, unit)
	class(phs_channel_collection_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_channel_collection_write
	<<PHS base: procedures>>=
	module subroutine phs_channel_collection_write (object, unit)
	class(phs_channel_collection_t), intent(in) :: object
	integer, intent(in), optional :: unit
	type(prop_entry_t), pointer :: entry
	integer :: u
	u = given_output_unit (unit)
	entry => object%first
	do while (associated (entry))
	if (allocated (entry%prop)) then
	write (u, "(1x,I0,1x,A)") entry%i, char (entry%prop%to_string ())
	else
	write (u, "(1x,I0)") entry%i
	end if
	entry => entry%next
	end do
	end subroutine phs_channel_collection_write

	@ %def phs_channel_collection_write
	@ Push a new property to the stack if it is not yet included.
	Simultaneously, set the [[sf_channel]] entry in the phase-space
	channel object to the index of the matching entry, or the new entry if
	there was no match.
	<<PHS base: phs channel collection: TBP>>=
	procedure :: push => phs_channel_collection_push
	<<PHS base: sub interfaces>>=
	module subroutine phs_channel_collection_push (coll, channel)
	class(phs_channel_collection_t), intent(inout) :: coll
	type(phs_channel_t), intent(inout) :: channel
	end subroutine phs_channel_collection_push
	<<PHS base: procedures>>=
	module subroutine phs_channel_collection_push (coll, channel)
	class(phs_channel_collection_t), intent(inout) :: coll
	type(phs_channel_t), intent(inout) :: channel
	type(prop_entry_t), pointer :: entry, new
	if (associated (coll%first)) then
	entry => coll%first
	do
	if (allocated (entry%prop)) then
	if (allocated (channel%prop)) then
	if (entry%prop == channel%prop) then
	channel%sf_channel = entry%i
	return
	end if
	end if
	else if (.not. allocated (channel%prop)) then
	channel%sf_channel = entry%i
	return
	end if
	if (associated (entry%next)) then
	entry => entry%next
	else
	exit
	end if
	end do
	allocate (new)
	entry%next => new
	else
	allocate (new)
	coll%first => new
	end if
	coll%n = coll%n + 1
	new%i = coll%n
	channel%sf_channel = new%i
	if (allocated (channel%prop)) then
	allocate (new%prop, source = channel%prop)
	end if
	end subroutine phs_channel_collection_push

	@ %def phs_channel_collection_push
	@ Return the number of collected distinct channels.
	<<PHS base: phs channel collection: TBP>>=
	procedure :: get_n => phs_channel_collection_get_n
	<<PHS base: sub interfaces>>=
	module function phs_channel_collection_get_n (coll) result (n)
	class(phs_channel_collection_t), intent(in) :: coll
	integer :: n
	end function phs_channel_collection_get_n
	<<PHS base: procedures>>=
	module function phs_channel_collection_get_n (coll) result (n)
	class(phs_channel_collection_t), intent(in) :: coll
	integer :: n
	n = coll%n
	end function phs_channel_collection_get_n

	@ %def phs_channel_collection_get_n
	@ Return a specific channel (property object).
	<<PHS base: phs channel collection: TBP>>=
	procedure :: get_entry => phs_channel_collection_get_entry
	<<PHS base: sub interfaces>>=
	module subroutine phs_channel_collection_get_entry (coll, i, prop)
	class(phs_channel_collection_t), intent(in) :: coll
	integer, intent(in) :: i
	class(channel_prop_t), intent(out), allocatable :: prop
	end subroutine phs_channel_collection_get_entry
	<<PHS base: procedures>>=
	module subroutine phs_channel_collection_get_entry (coll, i, prop)
	class(phs_channel_collection_t), intent(in) :: coll
	integer, intent(in) :: i
	class(channel_prop_t), intent(out), allocatable :: prop
	type(prop_entry_t), pointer :: entry
	integer :: k
	if (i > 0 .and. i <= coll%n) then
	entry => coll%first
	do k = 2, i
	entry => entry%next
	end do
	if (allocated (entry%prop)) then
	if (allocated (prop)) deallocate (prop)
	allocate (prop, source = entry%prop)
	end if
	else
	call msg_bug ("PHS channel collection: get entry: illegal index")
	end if
	end subroutine phs_channel_collection_get_entry

	@ %def phs_channel_collection_get_entry
	@
	\subsection{Kinematics configuration}
	Here, we store the universal information that is specifically relevant
	for phase-space generation. It is a subset of the process data,
	supplemented by basic information on phase-space parameterization
	channels.

	A concrete implementation will contain more data, that describe the
	phase space in detail.

	MD5 sums: the phase space setup depends on the process, it depends on
	the model parameters (the masses, that is), and on the configuration
	parameters. (It does not depend on the QCD setup.)
	<<PHS base: public>>=
	public :: phs_config_t
	<<PHS base: types>>=
	type, abstract :: phs_config_t
	! private
	type(string_t) :: id
	integer :: n_in = 0
	integer :: n_out = 0
	integer :: n_tot = 0
	integer :: n_state = 0
	integer :: n_par = 0
	integer :: n_channel = 0
	real(default) :: sqrts = 0
	logical :: sqrts_fixed = .true.
	logical :: lab_is_cm = .true.
	logical :: azimuthal_dependence = .false.
	integer, dimension(:), allocatable :: dim_flat
	logical :: provides_equivalences = .false.
	logical :: provides_chains = .false.
	logical :: vis_channels = .false.
	integer, dimension(:), allocatable :: chain
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(:,:), allocatable :: flv
	type(phs_channel_t), dimension(:), allocatable :: channel
	character(32) :: md5sum_process = ""
	character(32) :: md5sum_model_par = ""
	character(32) :: md5sum_phs_config = ""
	integer :: nlo_type
	contains
	<<PHS base: phs config: TBP>>
	end type phs_config_t

	@ %def phs_config_t
	@ Finalizer, deferred.
	<<PHS base: phs config: TBP>>=
	procedure (phs_config_final), deferred :: final
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_config_final (object)
	import
	class(phs_config_t), intent(inout) :: object
	end subroutine phs_config_final
	end interface

	@ %def phs_config_final
	@ Output. We provide an implementation for the output of the base-type
	contents and an interface for the actual write method.
	<<PHS base: phs config: TBP>>=
	procedure (phs_config_write), deferred :: write
	procedure :: base_write => phs_config_write
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_write (object, unit, include_id)
	class(phs_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_config_write
	<<PHS base: procedures>>=
	module subroutine phs_config_write (object, unit, include_id)
	class(phs_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u, i, j
	integer :: n_tot_flv
	logical :: use_id
	n_tot_flv = object%n_tot
	u = given_output_unit (unit)
	use_id = .true.; if (present (include_id)) use_id = include_id
	if (use_id) write (u, "(3x,A,A,A)") "ID = '", char (object%id), "'"
	write (u, "(3x,A,I0)") "n_in = ", object%n_in
	write (u, "(3x,A,I0)") "n_out = ", object%n_out
	write (u, "(3x,A,I0)") "n_tot = ", object%n_tot
	write (u, "(3x,A,I0)") "n_state = ", object%n_state
	write (u, "(3x,A,I0)") "n_par = ", object%n_par
	write (u, "(3x,A,I0)") "n_channel = ", object%n_channel
	write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts
	write (u, "(3x,A,L1)") "s_fixed = ", object%sqrts_fixed
	write (u, "(3x,A,L1)") "lab_is_cm = ", object%lab_is_cm
	write (u, "(3x,A,L1)") "azim.dep. = ", object%azimuthal_dependence
	if (allocated (object%dim_flat)) then
	write (u, "(3x,A,I0)") "flat dim. = ", object%dim_flat
	end if
	write (u, "(1x,A)") "Flavor combinations:"
	do i = 1, object%n_state
	write (u, "(3x,I0,':')", advance="no") i
	! do j = 1, object%n_tot
	do j = 1, n_tot_flv
	write (u, "(1x,A)", advance="no") char (object%flv(j,i)%get_name ())
	end do
	write (u, "(A)")
	end do
	if (allocated (object%channel)) then
	write (u, "(1x,A)") "Phase-space / structure-function channels:"
	do i = 1, object%n_channel
	write (u, "(3x,I0,':')", advance="no") i
	call object%channel(i)%write (u)
	end do
	end if
	if (object%md5sum_process /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (process) = '", &
	object%md5sum_process, "'"
	end if
	if (object%md5sum_model_par /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (model par) = '", &
	object%md5sum_model_par, "'"
	end if
	if (object%md5sum_phs_config /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (phs config) = '", &
	object%md5sum_phs_config, "'"
	end if
	end subroutine phs_config_write

	@ %def phs_config_write
	@ Similarly, a basic initializer and an interface. The model pointer is taken
	as an argument; we may verify that this has the expected model name.

	The intent is [[inout]]. We want to be able to set parameters in advance.
	<<PHS base: phs config: TBP>>=
	procedure :: init => phs_config_init
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_init (phs_config, data, model)
	class(phs_config_t), intent(inout) :: phs_config
	type(process_constants_t), intent(in) :: data
	class(model_data_t), intent(in), target :: model
	end subroutine phs_config_init
	<<PHS base: procedures>>=
	module subroutine phs_config_init (phs_config, data, model)
	class(phs_config_t), intent(inout) :: phs_config
	type(process_constants_t), intent(in) :: data
	class(model_data_t), intent(in), target :: model
	integer :: i, j
	phs_config%id = data%id
	phs_config%n_in = data%n_in
	phs_config%n_out = data%n_out
	phs_config%n_tot = data%n_in + data%n_out
	phs_config%n_state = data%n_flv
	if (data%model_name == model%get_name ()) then
	phs_config%model => model
	else
	call msg_bug ("phs_config_init: model name mismatch")
	end if
	allocate (phs_config%flv (phs_config%n_tot, phs_config%n_state))
	do i = 1, phs_config%n_state
	do j = 1, phs_config%n_tot
	call phs_config%flv(j,i)%init (data%flv_state(j,i), &
	phs_config%model)
	end do
	end do
	phs_config%md5sum_process = data%md5sum
	end subroutine phs_config_init

	@ %def phs_config_init
	@
	WK 2018-04-05: This procedure appears to be redundant?
	<<XXX PHS base: phs config: TBP>>=
	procedure :: set_component_index => phs_config_set_component_index
	<<XXX PHS base: procedures>>=
	subroutine phs_config_set_component_index (phs_config, index)
	class(phs_config_t), intent(inout) :: phs_config
	integer, intent(in) :: index
	type(string_t), dimension(:), allocatable :: id
	type(string_t) :: suffix
	integer :: i, n
	suffix = var_str ('i') // int2string (index)
	call split_string (phs_config%id, var_str ('_'), id)
	phs_config%id = var_str ('')
	n = size (id) - 1
	do i = 1, n
	phs_config%id = phs_config%id // id(i) // var_str ('_')
	end do
	phs_config%id = phs_config%id // suffix
	end subroutine phs_config_set_component_index

	@ %def phs_config_set_component_index
	@ This procedure should complete the phase-space configuration. We
	need the [[sqrts]] value as overall scale, which is known only after
	the beams have been defined. The procedure should determine the number of
	channels, their properties (if any), and allocate and fill the [[channel]]
	array accordingly.
	<<PHS base: phs config: TBP>>=
	procedure (phs_config_configure), deferred :: configure
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, &
	nlo_type, subdir)
	import
	class(phs_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_config_configure
	end interface

	@ %def phs_config_configure
	@ Manually assign structure-function channel indices to the phase-space
	channel objects. (Used by a test routine.)
	<<PHS base: phs config: TBP>>=
	procedure :: set_sf_channel => phs_config_set_sf_channel
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_set_sf_channel (phs_config, sf_channel)
	class(phs_config_t), intent(inout) :: phs_config
	integer, dimension(:), intent(in) :: sf_channel
	end subroutine phs_config_set_sf_channel
	<<PHS base: procedures>>=
	module subroutine phs_config_set_sf_channel (phs_config, sf_channel)
	class(phs_config_t), intent(inout) :: phs_config
	integer, dimension(:), intent(in) :: sf_channel
	phs_config%channel%sf_channel = sf_channel
	end subroutine phs_config_set_sf_channel

	@ %def phs_config_set_sf_channel
	@ Collect new channels not yet in the collection from this phase-space
	configuration object. At the same time, assign structure-function channels.
	<<PHS base: phs config: TBP>>=
	procedure :: collect_channels => phs_config_collect_channels
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_collect_channels (phs_config, coll)
	class(phs_config_t), intent(inout) :: phs_config
	type(phs_channel_collection_t), intent(inout) :: coll
	end subroutine phs_config_collect_channels
	<<PHS base: procedures>>=
	module subroutine phs_config_collect_channels (phs_config, coll)
	class(phs_config_t), intent(inout) :: phs_config
	type(phs_channel_collection_t), intent(inout) :: coll
	integer :: c
	do c = 1, phs_config%n_channel
	call coll%push (phs_config%channel(c))
	end do
	end subroutine phs_config_collect_channels

	@ %def phs_config_collect_channels
	@ Compute the MD5 sum. We abuse the [[write]] method. In
	type implementations, [[write]] should only display information that is
	relevant for the MD5 sum. The data include the process MD5 sum which is taken
	from the process constants, and the MD5 sum of the model parameters. This may
	change, so it is computed here.
	<<PHS base: phs config: TBP>>=
	procedure :: compute_md5sum => phs_config_compute_md5sum
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_compute_md5sum (phs_config, include_id)
	class(phs_config_t), intent(inout) :: phs_config
	logical, intent(in), optional :: include_id
	end subroutine phs_config_compute_md5sum
	<<PHS base: procedures>>=
	module subroutine phs_config_compute_md5sum (phs_config, include_id)
	class(phs_config_t), intent(inout) :: phs_config
	logical, intent(in), optional :: include_id
	integer :: u
	phs_config%md5sum_model_par = phs_config%model%get_parameters_md5sum ()
	phs_config%md5sum_phs_config = ""
	u = free_unit ()
	open (u, status = "scratch", action = "readwrite")
	call phs_config%write (u, include_id)
	rewind (u)
	phs_config%md5sum_phs_config = md5sum (u)
	close (u)
	end subroutine phs_config_compute_md5sum

	@ %def phs_config_compute_md5sum
	@ Print an informative message after phase-space configuration.
	<<PHS base: phs config: TBP>>=
	procedure (phs_startup_message), deferred :: startup_message
	procedure :: base_startup_message => phs_startup_message
	<<PHS base: sub interfaces>>=
	module subroutine phs_startup_message (phs_config, unit)
	class(phs_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_startup_message
	<<PHS base: procedures>>=
	module subroutine phs_startup_message (phs_config, unit)
	class(phs_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	write (msg_buffer, "(A,3(1x,I0,1x,A))") &
	"Phase space:", &
	phs_config%n_channel, "channels,", &
	phs_config%n_par, "dimensions"
	call msg_message (unit = unit)
	end subroutine phs_startup_message

	@ %def phs_startup_message
	@ This procedure should be implemented such that the phase-space
	configuration object allocates a phase-space instance of matching type.
	<<PHS base: phs config: TBP>>=
	procedure (phs_config_allocate_instance), nopass, deferred :: &
	allocate_instance
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_config_allocate_instance (phs)
	import
	class(phs_t), intent(inout), pointer :: phs
	end subroutine phs_config_allocate_instance
	end interface

	@ %def phs_config_allocate_instance
	@
	\subsection{Extract data}
	Return the number of MC input parameters.
	<<PHS base: phs config: TBP>>=
	procedure :: get_n_par => phs_config_get_n_par
	<<PHS base: sub interfaces>>=
	module function phs_config_get_n_par (phs_config) result (n)
	class(phs_config_t), intent(in) :: phs_config
	integer :: n
	end function phs_config_get_n_par
	<<PHS base: procedures>>=
	module function phs_config_get_n_par (phs_config) result (n)
	class(phs_config_t), intent(in) :: phs_config
	integer :: n
	n = phs_config%n_par
	end function phs_config_get_n_par

	@ %def phs_config_get_n_par
	@ Return dimensions (parameter indices) for which the phase-space
	dimension is flat, so integration and event generation can be simplified.
	<<PHS base: phs config: TBP>>=
	procedure :: get_flat_dimensions => phs_config_get_flat_dimensions
	<<PHS base: sub interfaces>>=
	module function phs_config_get_flat_dimensions &
	(phs_config) result (dim_flat)
	class(phs_config_t), intent(in) :: phs_config
	integer, dimension(:), allocatable :: dim_flat
	end function phs_config_get_flat_dimensions
	<<PHS base: procedures>>=
	module function phs_config_get_flat_dimensions &
	(phs_config) result (dim_flat)
	class(phs_config_t), intent(in) :: phs_config
	integer, dimension(:), allocatable :: dim_flat
	if (allocated (phs_config%dim_flat)) then
	allocate (dim_flat (size (phs_config%dim_flat)))
	dim_flat = phs_config%dim_flat
	else
	allocate (dim_flat (0))
	end if
	end function phs_config_get_flat_dimensions

	@ %def phs_config_get_flat_dimensions
	@ Return the number of phase-space channels.
	<<PHS base: phs config: TBP>>=
	procedure :: get_n_channel => phs_config_get_n_channel
	<<PHS base: sub interfaces>>=
	module function phs_config_get_n_channel (phs_config) result (n)
	class(phs_config_t), intent(in) :: phs_config
	integer :: n
	end function phs_config_get_n_channel
	<<PHS base: procedures>>=
	module function phs_config_get_n_channel (phs_config) result (n)
	class(phs_config_t), intent(in) :: phs_config
	integer :: n
	n = phs_config%n_channel
	end function phs_config_get_n_channel

	@ %def phs_config_get_n_channel
	@ Return the structure-function channel that corresponds to the
	phase-space channel [[c]]. If the channel array is not allocated (which
	happens if there is no structure function), return zero.
	<<PHS base: phs config: TBP>>=
	procedure :: get_sf_channel => phs_config_get_sf_channel
	<<PHS base: sub interfaces>>=
	module function phs_config_get_sf_channel (phs_config, c) result (c_sf)
	class(phs_config_t), intent(in) :: phs_config
	integer, intent(in) :: c
	integer :: c_sf
	end function phs_config_get_sf_channel
	<<PHS base: procedures>>=
	module function phs_config_get_sf_channel (phs_config, c) result (c_sf)
	class(phs_config_t), intent(in) :: phs_config
	integer, intent(in) :: c
	integer :: c_sf
	if (allocated (phs_config%channel)) then
	c_sf = phs_config%channel(c)%sf_channel
	else
	c_sf = 0
	end if
	end function phs_config_get_sf_channel

	@ %def phs_config_get_sf_channel
	@ Return the mass(es) of the incoming particle(s). We take the first flavor
	combination in the array, assuming that masses must be degenerate among
	flavors.
	<<PHS base: phs config: TBP>>=
	procedure :: get_masses_in => phs_config_get_masses_in
	<<PHS base: sub interfaces>>=
	module subroutine phs_config_get_masses_in (phs_config, m)
	class(phs_config_t), intent(in) :: phs_config
	real(default), dimension(:), intent(out) :: m
	end subroutine phs_config_get_masses_in
	<<PHS base: procedures>>=
	module subroutine phs_config_get_masses_in (phs_config, m)
	class(phs_config_t), intent(in) :: phs_config
	real(default), dimension(:), intent(out) :: m
	integer :: i
	do i = 1, phs_config%n_in
	m(i) = phs_config%flv(i,1)%get_mass ()
	end do
	end subroutine phs_config_get_masses_in

	@ %def phs_config_get_masses_in
	@ Return the MD5 sum of the configuration.
	<<PHS base: phs config: TBP>>=
	procedure :: get_md5sum => phs_config_get_md5sum
	<<PHS base: sub interfaces>>=
	module function phs_config_get_md5sum (phs_config) result (md5sum)
	class(phs_config_t), intent(in) :: phs_config
	character(32) :: md5sum
	end function phs_config_get_md5sum
	<<PHS base: procedures>>=
	module function phs_config_get_md5sum (phs_config) result (md5sum)
	class(phs_config_t), intent(in) :: phs_config
	character(32) :: md5sum
	md5sum = phs_config%md5sum_phs_config
	end function phs_config_get_md5sum

	@ %def phs_config_get_md5sum
	@
	\subsection{Phase-space point instance}
	The [[phs_t]] object holds the workspace for phase-space generation.
	In the base object, we have the MC input parameters [[r]] and the
	Jacobian factor [[f]], for each channel, and the incoming and outgoing
	momenta.

	Note: The [[active_channel]] array is not used yet, all elements are
	initialized with [[.true.]]. It should be touched by the integrator if it
	decides to drop irrelevant channels.
	<<PHS base: public>>=
	public :: phs_t
	<<PHS base: types>>=
	type, abstract :: phs_t
	class(phs_config_t), pointer :: config => null ()
	logical :: r_defined = .false.
	integer :: selected_channel = 0
	logical, dimension(:), allocatable :: active_channel
	real(default), dimension(:,:), allocatable :: r
	real(default), dimension(:), allocatable :: f
	real(default), dimension(:), allocatable :: m_in
	real(default), dimension(:), allocatable :: m_out
	real(default) :: flux = 0
	real(default) :: volume = 0
	type(lorentz_transformation_t) :: lt_cm_to_lab
	logical :: p_defined = .false.
	real(default) :: sqrts_hat = 0
	type(vector4_t), dimension(:), allocatable :: p
	logical :: q_defined = .false.
	type(vector4_t), dimension(:), allocatable :: q
	contains
	<<PHS base: phs: TBP>>
	end type phs_t

	@ %def phs_t
	@ Output. Since phase space may get complicated, we include a
	[[verbose]] option for the abstract [[write]] procedure.
	<<PHS base: phs: TBP>>=
	procedure (phs_write), deferred :: write
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_write (object, unit, verbose)
	import
	class(phs_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_write
	end interface

	@ %def phs_write
	@ This procedure can be called to print the contents of the base type.
	<<PHS base: phs: TBP>>=
	procedure :: base_write => phs_base_write
	<<PHS base: sub interfaces>>=
	module subroutine phs_base_write (object, unit)
	class(phs_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_base_write
	<<PHS base: procedures>>=
	module subroutine phs_base_write (object, unit)
	class(phs_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, c, i
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "Partonic phase space: parameters"
	if (object%r_defined) then
	write (u, *)
	else
	write (u, "(1x,A)") "[undefined]"
	end if
	write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_in =", object%m_in
	write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_out =", object%m_out
	write (u, "(3x,A," // FMT_19 // ")") "Flux = ", object%flux
	write (u, "(3x,A," // FMT_19 // ")") "Volume = ", object%volume
	if (allocated (object%f)) then
	do c = 1, size (object%r, 2)
	write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":"
	if (c == object%selected_channel) then
	write (u, "(1x,A)") "[selected]"
	else
	write (u, *)
	end if
	write (u, "(3x,A)", advance="no") "r ="
	do i = 1, size (object%r, 1)
	write (u, "(1x,F9.7)", advance="no") object%r(i,c)
	end do
	write (u, *)
	write (u, "(3x,A,1x,ES13.7)") "f =", object%f(c)
	end do
	end if
	write (u, "(1x,A)") "Partonic phase space: momenta"
	if (object%p_defined) then
	write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts_hat
	end if
	write (u, "(1x,A)", advance="no") "Incoming:"
	if (object%p_defined) then
	write (u, *)
	else
	write (u, "(1x,A)") "[undefined]"
	end if
	if (allocated (object%p)) then
	do i = 1, size (object%p)
	call vector4_write (object%p(i), u)
	end do
	end if
	write (u, "(1x,A)", advance="no") "Outgoing:"
	if (object%q_defined) then
	write (u, *)
	else
	write (u, "(1x,A)") "[undefined]"
	end if
	if (allocated (object%q)) then
	do i = 1, size (object%q)
	call vector4_write (object%q(i), u)
	end do
	end if
	if (object%p_defined .and. .not. object%config%lab_is_cm) then
	write (u, "(1x,A)") "Transformation c.m -> lab frame"
	call lorentz_transformation_write (object%lt_cm_to_lab, u)
	end if
	end subroutine phs_base_write

	@ %def phs_base_write
	@ Finalizer. The base type does not need it, but extensions may.
	<<PHS base: phs: TBP>>=
	procedure (phs_final), deferred :: final
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_final (object)
	import
	class(phs_t), intent(inout) :: object
	end subroutine phs_final
	end interface

	@ %def phs_final
	@ Initializer. Everything should be contained in the [[process_data]]
	configuration object, so we can require a universal interface.
	<<PHS base: phs: TBP>>=
	procedure (phs_init), deferred :: init
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_init (phs, phs_config)
	import
	class(phs_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_init
	end interface

	@ %def phs_init
	@ The base version will just allocate the arrays. It should be called
	at the beginning of the implementation of [[phs_init]].
	<<PHS base: phs: TBP>>=
	procedure :: base_init => phs_base_init
	<<PHS base: sub interfaces>>=
	module subroutine phs_base_init (phs, phs_config)
	class(phs_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_base_init
	<<PHS base: procedures>>=
	module subroutine phs_base_init (phs, phs_config)
	class(phs_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	phs%config => phs_config
	allocate (phs%active_channel (phs%config%n_channel))
	phs%active_channel = .true.
	allocate (phs%r (phs%config%n_par, phs%config%n_channel)); phs%r = 0
	allocate (phs%f (phs%config%n_channel)); phs%f = 0
	allocate (phs%p (phs%config%n_in))
	allocate (phs%m_in (phs%config%n_in), &
	source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
	allocate (phs%q (phs%config%n_out))
	allocate (phs%m_out (phs%config%n_out), &
	source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ())
	call phs%compute_flux ()
	end subroutine phs_base_init

	@ %def phs_base_init
	@ Manually select a channel.
	<<PHS base: phs: TBP>>=
	procedure :: select_channel => phs_base_select_channel
	<<PHS base: sub interfaces>>=
	module subroutine phs_base_select_channel (phs, channel)
	class(phs_t), intent(inout) :: phs
	integer, intent(in), optional :: channel
	end subroutine phs_base_select_channel
	<<PHS base: procedures>>=
	module subroutine phs_base_select_channel (phs, channel)
	class(phs_t), intent(inout) :: phs
	integer, intent(in), optional :: channel
	if (present (channel)) then
	phs%selected_channel = channel
	else
	phs%selected_channel = 0
	end if
	end subroutine phs_base_select_channel

	@ %def phs_base_select_channel
	@ Set incoming momenta. Assume that array shapes match. If
	requested, compute the Lorentz transformation from the c.m.\ to the
	lab frame and apply that transformation to the incoming momenta.

	In the c.m.\ frame, the sum of three-momenta is zero. In a scattering
	process, the $z$ axis is the direction of the first beam, the second
	beam is along the negative $z$ axis. The transformation from the
	c.m.\ to the lab frame is a rotation from the $z$ axis to the boost
	axis followed by a boost, such that the c.m.\ momenta are transformed
	into the lab-frame momenta. In a decay process, we just boost along
	the flight direction, without rotation.
	<<PHS base: phs: TBP>>=
	procedure :: set_incoming_momenta => phs_set_incoming_momenta
	<<PHS base: sub interfaces>>=
	module subroutine phs_set_incoming_momenta (phs, p)
	class(phs_t), intent(inout) :: phs
	type(vector4_t), dimension(:), intent(in) :: p
	end subroutine phs_set_incoming_momenta
	<<PHS base: procedures>>=
	module subroutine phs_set_incoming_momenta (phs, p)
	class(phs_t), intent(inout) :: phs
	type(vector4_t), dimension(:), intent(in) :: p
	type(vector4_t) :: p0, p1
	type(lorentz_transformation_t) :: lt0
	integer :: i
	phs%p = p
	if (phs%config%lab_is_cm) then
	phs%sqrts_hat = phs%config%sqrts
	phs%p = p
	phs%lt_cm_to_lab = identity
	else
	p0 = sum (p)
	if (phs%config%sqrts_fixed) then
	phs%sqrts_hat = phs%config%sqrts
	else
	phs%sqrts_hat = p0 ** 1
	end if
	lt0 = boost (p0, phs%sqrts_hat)
	select case (phs%config%n_in)
	case (1)
	phs%lt_cm_to_lab = lt0
	case (2)
	p1 = inverse (lt0) * p(1)
	phs%lt_cm_to_lab = lt0 * rotation_to_2nd (3, space_part (p1))
	end select
	phs%p = inverse (phs%lt_cm_to_lab) * p
	end if
	phs%p_defined = .true.
	end subroutine phs_set_incoming_momenta

	@ %def phs_set_incoming_momenta
	@ Set outgoing momenta. Assume that array shapes match. The incoming
	momenta must be known, so we can apply the Lorentz transformation from
	c.m.\ to lab (inverse) to the momenta.
	<<PHS base: phs: TBP>>=
	procedure :: set_outgoing_momenta => phs_set_outgoing_momenta
	<<PHS base: sub interfaces>>=
	module subroutine phs_set_outgoing_momenta (phs, q)
	class(phs_t), intent(inout) :: phs
	type(vector4_t), dimension(:), intent(in) :: q
	end subroutine phs_set_outgoing_momenta
	<<PHS base: procedures>>=
	module subroutine phs_set_outgoing_momenta (phs, q)
	class(phs_t), intent(inout) :: phs
	type(vector4_t), dimension(:), intent(in) :: q
	integer :: i
	if (phs%p_defined) then
	if (phs%config%lab_is_cm) then
	phs%q = q
	else
	phs%q = inverse (phs%lt_cm_to_lab) * q
	end if
	phs%q_defined = .true.
	end if
	end subroutine phs_set_outgoing_momenta

	@ %def phs_set_outgoing_momenta
	@ Return outgoing momenta. Apply the c.m.\ to lab transformation if
	necessary.
	<<PHS base: phs: TBP>>=
	procedure :: get_outgoing_momenta => phs_get_outgoing_momenta
	<<PHS base: sub interfaces>>=
	module subroutine phs_get_outgoing_momenta (phs, q)
	class(phs_t), intent(in) :: phs
	type(vector4_t), dimension(:), intent(out) :: q
	end subroutine phs_get_outgoing_momenta
	<<PHS base: procedures>>=
	module subroutine phs_get_outgoing_momenta (phs, q)
	class(phs_t), intent(in) :: phs
	type(vector4_t), dimension(:), intent(out) :: q
	if (phs%p_defined .and. phs%q_defined) then
	if (phs%config%lab_is_cm) then
	q = phs%q
	else
	q = phs%lt_cm_to_lab * phs%q
	end if
	else
	q = vector4_null
	end if
	end subroutine phs_get_outgoing_momenta

	@ %def phs_get_outgoing_momenta
	@
	<<PHS base: phs: TBP>>=
	procedure :: lab_is_cm => phs_lab_is_cm
	<<PHS base: sub interfaces>>=
	module function phs_lab_is_cm (phs) result (lab_is_cm)
	logical :: lab_is_cm
	class(phs_t), intent(in) :: phs
	end function phs_lab_is_cm
	<<PHS base: procedures>>=
	module function phs_lab_is_cm (phs) result (lab_is_cm)
	logical :: lab_is_cm
	class(phs_t), intent(in) :: phs
	lab_is_cm = phs%config%lab_is_cm
	end function phs_lab_is_cm

	@ %def phs_lab_is_cm
	@
	<<PHS base: phs: TBP>>=
	procedure :: get_n_tot => phs_get_n_tot
	<<PHS base: sub interfaces>>=
	elemental module function phs_get_n_tot (phs) result (n_tot)
	integer :: n_tot
	class(phs_t), intent(in) :: phs
	end function phs_get_n_tot
	<<PHS base: procedures>>=
	elemental module function phs_get_n_tot (phs) result (n_tot)
	integer :: n_tot
	class(phs_t), intent(in) :: phs
	n_tot = phs%config%n_tot
	end function phs_get_n_tot

	@ %def phs_get_n_tot
	@
	<<PHS base: phs: TBP>>=
	procedure :: set_lorentz_transformation => phs_set_lorentz_transformation
	<<PHS base: sub interfaces>>=
	module subroutine phs_set_lorentz_transformation (phs, lt)
	class(phs_t), intent(inout) :: phs
	type(lorentz_transformation_t), intent(in) :: lt
	end subroutine phs_set_lorentz_transformation
	<<PHS base: procedures>>=
	module subroutine phs_set_lorentz_transformation (phs, lt)
	class(phs_t), intent(inout) :: phs
	type(lorentz_transformation_t), intent(in) :: lt
	phs%lt_cm_to_lab = lt
	end subroutine phs_set_lorentz_transformation

	@ %def phs_set_lorentz_transformation
	@
	<<PHS base: phs: TBP>>=
	procedure :: get_lorentz_transformation => phs_get_lorentz_transformation
	<<PHS base: sub interfaces>>=
	module function phs_get_lorentz_transformation (phs) result (lt)
	type(lorentz_transformation_t) :: lt
	class(phs_t), intent(in) :: phs
	end function phs_get_lorentz_transformation
	<<PHS base: procedures>>=
	module function phs_get_lorentz_transformation (phs) result (lt)
	type(lorentz_transformation_t) :: lt
	class(phs_t), intent(in) :: phs
	lt = phs%lt_cm_to_lab
	end function phs_get_lorentz_transformation

	@ %def phs_get_lorentz_transformation
	@ Return the input parameter array for a channel.
	<<PHS base: phs: TBP>>=
	procedure :: get_mcpar => phs_get_mcpar
	<<PHS base: sub interfaces>>=
	module subroutine phs_get_mcpar (phs, c, r)
	class(phs_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default), dimension(:), intent(out) :: r
	end subroutine phs_get_mcpar
	<<PHS base: procedures>>=
	module subroutine phs_get_mcpar (phs, c, r)
	class(phs_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default), dimension(:), intent(out) :: r
	if (phs%r_defined) then
	r = phs%r(:,c)
	else
	r = 0
	end if
	end subroutine phs_get_mcpar

	@ %def phs_get_mcpar
	@ Return the Jacobian factor for a channel.
	<<PHS base: phs: TBP>>=
	procedure :: get_f => phs_get_f
	<<PHS base: sub interfaces>>=
	module function phs_get_f (phs, c) result (f)
	class(phs_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default) :: f
	end function phs_get_f
	<<PHS base: procedures>>=
	module function phs_get_f (phs, c) result (f)
	class(phs_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default) :: f
	if (phs%r_defined) then
	f = phs%f(c)
	else
	f = 0
	end if
	end function phs_get_f

	@ %def phs_get_f
	@ Return the overall factor, which is the product of the flux factor for the
	incoming partons and the phase-space volume for the outgoing partons.
	<<PHS base: phs: TBP>>=
	procedure :: get_overall_factor => phs_get_overall_factor
	<<PHS base: sub interfaces>>=
	module function phs_get_overall_factor (phs) result (f)
	class(phs_t), intent(in) :: phs
	real(default) :: f
	end function phs_get_overall_factor
	<<PHS base: procedures>>=
	module function phs_get_overall_factor (phs) result (f)
	class(phs_t), intent(in) :: phs
	real(default) :: f
	f = phs%flux * phs%volume
	end function phs_get_overall_factor

	@ %def phs_get_overall_factor
	@ Compute flux factor. We do this during initialization (when the
	incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do
	this again once for each phase-space point, but then we skip the calculation
	if [[sqrts]] is fixed.

	There are three different flux factors.
	\begin{enumerate}
	\item
	For a decaying massive particle, the factor is
	\begin{equation}
	f = (2\pi)^4 / (2M)
	\end{equation}
	\item
	For a $2\to n$ scattering process with $n>1$, the factor is
	\begin{equation}
	f = (2\pi)^4 / (2\sqrt{\lambda})
	\end{equation}
	where for massless incoming particles, $\sqrt{\lambda} = s$.
	\item For a $2\to 1$ on-shell production process, the factor includes
	an extra $1/(2\pi)^3$ factor and a $1/m^2$ factor from the
	phase-space delta function $\delta (x_1x_2 - m^2/s)$, which
	originate from the one-particle phase space that we integrate out.
	\begin{equation}
	f = 2\pi / (2s m^2)
	\end{equation}
	The delta function is handled by the structure-function
	parameterization.
	\end{enumerate}
	<<PHS base: phs: TBP>>=
	procedure :: compute_flux => phs_compute_flux
	procedure :: compute_base_flux => phs_compute_flux
	<<PHS base: sub interfaces>>=
	module subroutine phs_compute_flux (phs)
	class(phs_t), intent(inout) :: phs
	end subroutine phs_compute_flux
	<<PHS base: procedures>>=
	module subroutine phs_compute_flux (phs)
	class(phs_t), intent(inout) :: phs
	real(default) :: s_hat, lda
	select case (phs%config%n_in)
	case (1)
	if (.not. phs%p_defined) then
	phs%flux = twopi4 / (2 * phs%m_in(1))
	end if
	case (2)
	if (phs%p_defined) then
	if (phs%config%sqrts_fixed) then
	return
	else
	s_hat = sum (phs%p) ** 2
	end if
	else
	if (phs%config%sqrts_fixed) then
	s_hat = phs%config%sqrts ** 2
	else
	return
	end if
	end if
	select case (phs%config%n_out)
	case (2:)
	lda = lambda (s_hat, phs%m_in(1) 2, phs%m_in(2) 2)
	if (lda > 0) then
	phs%flux = conv * twopi4 / (2 * sqrt (lda))
	else
	phs%flux = 0
	end if
	case (1)
	phs%flux = conv * twopi &
	/ (2 * phs%config%sqrts ** 2 * phs%m_out(1) ** 2)
	case default
	phs%flux = 0
	end select
	end select
	end subroutine phs_compute_flux

	@ %def phs_compute_flux
	@ Evaluate the phase-space point for a particular channel and compute momenta,
	Jacobian, and phase-space volume. This is, of course, deferred to
	the implementation.
	<<PHS base: phs: TBP>>=
	procedure (phs_evaluate_selected_channel), deferred :: &
	evaluate_selected_channel
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_evaluate_selected_channel (phs, c_in, r_in)
	import
	class(phs_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), dimension(:), intent(in) :: r_in
	end subroutine phs_evaluate_selected_channel
	end interface

	@ %def phs_evaluate_selected_channel
	@ Compute the inverse mappings to completely fill the [[r]] and [[f]] arrays,
	for the non-selected channels.
	<<PHS base: phs: TBP>>=
	procedure (phs_evaluate_other_channels), deferred :: &
	evaluate_other_channels
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_evaluate_other_channels (phs, c_in)
	import
	class(phs_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_evaluate_other_channels
	end interface

	@ %def phs_evaluate_other_channels
	@ Inverse evaluation. If all momenta are known, we compute the
	inverse mappings to fill the [[r]] and [[f]] arrays.
	<<PHS base: phs: TBP>>=
	procedure (phs_inverse), deferred :: inverse
	<<PHS base: interfaces>>=
	abstract interface
	subroutine phs_inverse (phs)
	import
	class(phs_t), intent(inout) :: phs
	end subroutine phs_inverse
	end interface

	@ %def phs_inverse
	@
	<<PHS base: phs: TBP>>=
	procedure :: get_sqrts => phs_get_sqrts
	<<PHS base: sub interfaces>>=
	module function phs_get_sqrts (phs) result (sqrts)
	real(default) :: sqrts
	class(phs_t), intent(in) :: phs
	end function phs_get_sqrts
	<<PHS base: procedures>>=
	module function phs_get_sqrts (phs) result (sqrts)
	real(default) :: sqrts
	class(phs_t), intent(in) :: phs
	sqrts = phs%config%sqrts
	end function phs_get_sqrts

	@ %def phs_get_sqrts
	@
	\subsubsection{Uniform angular distribution}
	These procedures implement the uniform angular distribution, generated
	from two parameters $x_1$ and $x_2$:
	\begin{equation}
	\cos\theta = 1 - 2x_1, \qquad \phi = 2\pi x_2
	\end{equation}
	We generate a rotation (Lorentz transformation) which rotates the
	positive $z$ axis into this point on the unit sphere. This rotation
	is applied to the [[p]] momenta, which are assumed to be
	back-to-back, on-shell, and with the correct mass.

	We do not compute a Jacobian (constant). The uniform distribution is
	assumed to be normalized.
	<<PHS base: public>>=
	public :: compute_kinematics_solid_angle
	<<PHS base: sub interfaces>>=
	module subroutine compute_kinematics_solid_angle (p, q, x)
	type(vector4_t), dimension(2), intent(in) :: p
	type(vector4_t), dimension(2), intent(out) :: q
	real(default), dimension(2), intent(in) :: x
	end subroutine compute_kinematics_solid_angle
	<<PHS base: procedures>>=
	module subroutine compute_kinematics_solid_angle (p, q, x)
	type(vector4_t), dimension(2), intent(in) :: p
	type(vector4_t), dimension(2), intent(out) :: q
	real(default), dimension(2), intent(in) :: x
	real(default) :: ct, st, phi
	type(lorentz_transformation_t) :: rot
	integer :: i
	ct = 1 - 2*x(1)
	st = sqrt (1 - ct**2)
	phi = twopi * x(2)
	rot = rotation (phi, 3) * rotation (ct, st, 2)
	do i = 1, 2
	q(i) = rot * p(i)
	end do
	end subroutine compute_kinematics_solid_angle

	@ %def compute_kinematics_solid_angle
	@ This is the inverse transformation. We assume that the outgoing
	momenta are rotated versions of the incoming momenta, back-to-back.
	Thus, we determine the angles from $q(1)$ alone. [[p]] is unused.
	<<PHS base: public>>=
	public :: inverse_kinematics_solid_angle
	<<PHS base: sub interfaces>>=
	module subroutine inverse_kinematics_solid_angle (p, q, x)
	type(vector4_t), dimension(:), intent(in) :: p
	type(vector4_t), dimension(2), intent(in) :: q
	real(default), dimension(2), intent(out) :: x
	end subroutine inverse_kinematics_solid_angle
	<<PHS base: procedures>>=
	module subroutine inverse_kinematics_solid_angle (p, q, x)
	type(vector4_t), dimension(:), intent(in) :: p
	type(vector4_t), dimension(2), intent(in) :: q
	real(default), dimension(2), intent(out) :: x
	real(default) :: ct, phi
	ct = polar_angle_ct (q(1))
	phi = azimuthal_angle (q(1))
	x(1) = (1 - ct) / 2
	x(2) = phi / twopi
	end subroutine inverse_kinematics_solid_angle

	@ %def inverse_kinematics_solid_angle
	@
	\subsection{Auxiliary stuff}
	The [[pacify]] subroutine, which is provided by the Lorentz module,
	has the purpose of setting numbers to zero which are (by comparing
	with a [[tolerance]] parameter) considered equivalent with zero. This
	is useful for numerical checks.
	<<PHS base: public>>=
	public :: pacify
	<<PHS base: interfaces>>=
	interface pacify
	module procedure pacify_phs
	end interface pacify

	<<PHS base: sub interfaces>>=
	module subroutine pacify_phs (phs)
	class(phs_t), intent(inout) :: phs
	end subroutine pacify_phs
	<<PHS base: procedures>>=
	module subroutine pacify_phs (phs)
	class(phs_t), intent(inout) :: phs
	if (phs%p_defined) then
	call pacify (phs%p, 30 * epsilon (1._default) * phs%config%sqrts)
	call pacify (phs%lt_cm_to_lab, 30 * epsilon (1._default))
	end if
	if (phs%q_defined) then
	call pacify (phs%q, 30 * epsilon (1._default) * phs%config%sqrts)
	end if
	end subroutine pacify_phs

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

	module phs_base_ut
	use unit_tests
	use phs_base_uti

	<<Standard module head>>

	<<PHS base: public test>>

	<<PHS base: public test auxiliary>>

	contains

	<<PHS base: test driver>>

	end module phs_base_ut
	@ %def phs_base_ut
	@
	<<[[phs_base_uti.f90]]>>=
	<<File header>>

	module phs_base_uti

	<<Use kinds>>
	<<Use strings>>
	use diagnostics
	use io_units
	use format_defs, only: FMT_19
	use physics_defs, only: BORN
	use lorentz
	use flavors
	use model_data
	use process_constants

	use phs_base

	<<Standard module head>>

	<<PHS base: public test auxiliary>>

	<<PHS base: test declarations>>

	<<PHS base: test types>>

	contains

	<<PHS base: tests>>

	<<PHS base: test auxiliary>>

	end module phs_base_uti
	@ %def phs_base_ut
	@ API: driver for the unit tests below.
	<<PHS base: public test>>=
	public :: phs_base_test
	<<PHS base: test driver>>=
	subroutine phs_base_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS base: execute tests>>
	end subroutine phs_base_test

	@ %def phs_base_test
	@
	\subsubsection{Test process data}
	We provide a procedure that initializes a test case for the process
	constants. This set of process data contains just the minimal
	contents that we need for the phase space. The rest is left
	uninitialized.
	<<PHS base: public test auxiliary>>=
	public :: init_test_process_data
	<<PHS base: test auxiliary>>=
	subroutine init_test_process_data (id, data)
	type(process_constants_t), intent(out) :: data
	type(string_t), intent(in), optional :: id
	if (present (id)) then
	data%id = id
	else
	data%id = "testproc"
	end if
	data%model_name = "Test"
	data%n_in = 2
	data%n_out = 2
	data%n_flv = 1
	allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
	data%flv_state = 25
	end subroutine init_test_process_data

	@ %def init_test_process_data
	@ This is the variant for a decay process.
	<<PHS base: public test auxiliary>>=
	public :: init_test_decay_data
	<<PHS base: test auxiliary>>=
	subroutine init_test_decay_data (id, data)
	type(process_constants_t), intent(out) :: data
	type(string_t), intent(in), optional :: id
	if (present (id)) then
	data%id = id
	else
	data%id = "testproc"
	end if
	data%model_name = "Test"
	data%n_in = 1
	data%n_out = 2
	data%n_flv = 1
	allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
	data%flv_state(:,1) = [25, 6, -6]
	end subroutine init_test_decay_data

	@ %def init_test_decay_data
	@
	\subsubsection{Test kinematics configuration}
	This is a trivial implementation of the [[phs_config_t]] configuration object.
	<<PHS base: public test auxiliary>>=
	public :: phs_test_config_t
	<<PHS base: test types>>=
	type, extends (phs_config_t) :: phs_test_config_t
	logical :: create_equivalences = .false.
	contains
	procedure :: final => phs_test_config_final
	procedure :: write => phs_test_config_write
	procedure :: configure => phs_test_config_configure
	procedure :: startup_message => phs_test_config_startup_message
	procedure, nopass :: allocate_instance => phs_test_config_allocate_instance
	end type phs_test_config_t

	@ %def phs_test_config_t
	@ The finalizer is empty.
	<<PHS base: test auxiliary>>=
	subroutine phs_test_config_final (object)
	class(phs_test_config_t), intent(inout) :: object
	end subroutine phs_test_config_final

	@ %def phs_test_config_final
	@ The [[lab_is_cm]] parameter is not tested here; we defer this to the
	[[phs_single]] implementation.
	<<PHS base: test auxiliary>>=
	subroutine phs_test_config_write (object, unit, include_id)
	class(phs_test_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Partonic phase-space configuration:"
	call object%base_write (unit)
	end subroutine phs_test_config_write

	subroutine phs_test_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_test_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	phs_config%n_channel = 2
	phs_config%n_par = 2
	phs_config%sqrts = sqrts
	if (.not. present (nlo_type)) &
	phs_config%nlo_type = BORN
	if (present (sqrts_fixed)) then
	phs_config%sqrts_fixed = sqrts_fixed
	end if
	if (present (lab_is_cm)) then
	phs_config%lab_is_cm = lab_is_cm
	end if
	if (present (azimuthal_dependence)) then
	phs_config%azimuthal_dependence = azimuthal_dependence
	end if
	if (allocated (phs_config%channel)) deallocate (phs_config%channel)
	allocate (phs_config%channel (phs_config%n_channel))
	if (phs_config%create_equivalences) then
	call setup_test_equivalences (phs_config)
	call setup_test_channel_props (phs_config)
	end if
	call phs_config%compute_md5sum ()
	end subroutine phs_test_config_configure

	@ %def phs_test_config_write
	@ %def phs_test_config_configure
	@ If requested, we make up an arbitrary set of equivalences.
	<<PHS base: test auxiliary>>=
	subroutine setup_test_equivalences (phs_config)
	class(phs_test_config_t), intent(inout) :: phs_config
	integer :: i
	associate (channel => phs_config%channel(1))
	allocate (channel%eq (2))
	do i = 1, size (channel%eq)
	call channel%eq(i)%init (phs_config%n_par)
	end do
	associate (eq => channel%eq(1))
	eq%c = 1; eq%perm = [1, 2]; eq%mode = [EQ_IDENTITY, EQ_SYMMETRIC]
	end associate
	associate (eq => channel%eq(2))
	eq%c = 2; eq%perm = [2, 1]; eq%mode = [EQ_INVARIANT, EQ_IDENTITY]
	end associate
	end associate
	end subroutine setup_test_equivalences

	@ %def setup_test_equivalences
	@ Ditto, for channel properties.
	<<PHS base: test auxiliary>>=
	subroutine setup_test_channel_props (phs_config)
	class(phs_test_config_t), intent(inout) :: phs_config
	associate (channel => phs_config%channel(2))
	call channel%set_resonant (140._default, 3.1415_default)
	end associate
	end subroutine setup_test_channel_props

	@ %def setup_test_channel_props
	@ Startup message
	<<PHS base: test auxiliary>>=
	subroutine phs_test_config_startup_message (phs_config, unit)
	class(phs_test_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	call phs_config%base_startup_message (unit)
	write (msg_buffer, "(A)") "Phase space: Test"
	call msg_message (unit = unit)
	end subroutine phs_test_config_startup_message

	@ %def phs_test_config_startup_message
	@ The instance type that matches [[phs_test_config_t]] is [[phs_test_t]].
	<<PHS base: test auxiliary>>=
	subroutine phs_test_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_test_t :: phs)
	end subroutine phs_test_config_allocate_instance

	@ %def phs_test_config_allocate_instance
	@
	\subsubsection{Test kinematics implementation}
	This implementation of kinematics generates a simple two-particle
	configuration from the incoming momenta. The incoming momenta must be
	in the c.m.\ system, all masses equal.

	There are two channels: one generates $\cos\theta$ and $\phi$
	uniformly, in the other channel we map the $r_1$ parameter which
	belongs to $\cos\theta$.

	We should store the mass parameter that we need.
	<<PHS base: public test auxiliary>>=
	public :: phs_test_t
	<<PHS base: test types>>=
	type, extends (phs_t) :: phs_test_t
	real(default) :: m = 0
	real(default), dimension(:), allocatable :: x
	contains
	<<PHS base: phs test: TBP>>
	end type phs_test_t

	@ %def phs_test_t
	@ Output. The specific data are displayed only if [[verbose]] is set.
	<<PHS base: phs test: TBP>>=
	procedure :: write => phs_test_write
	<<PHS base: test auxiliary>>=
	subroutine phs_test_write (object, unit, verbose)
	class(phs_test_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	logical :: verb
	u = given_output_unit (unit)
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	write (u, "(1x,A)") "Partonic phase space: data"
	write (u, "(3x,A," // FMT_19 // ")") "m = ", object%m
	end if
	call object%base_write (u)
	end subroutine phs_test_write

	@ %def phs_test_write
	@ The finalizer is empty.
	<<PHS base: phs test: TBP>>=
	procedure :: final => phs_test_final
	<<PHS base: test auxiliary>>=
	subroutine phs_test_final (object)
	class(phs_test_t), intent(inout) :: object
	end subroutine phs_test_final

	@ %def phs_test_final
	@ Initialization: set the mass value.
	<<PHS base: phs test: TBP>>=
	procedure :: init => phs_test_init
	<<PHS base: test auxiliary>>=
	subroutine phs_test_init (phs, phs_config)
	class(phs_test_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	call phs%base_init (phs_config)
	phs%m = phs%config%flv(1,1)%get_mass ()
	allocate (phs%x (phs_config%n_par), source = 0._default)
	end subroutine phs_test_init

	@ %def phs_test_init
	@ Evaluation. In channel 1, we uniformly generate $\cos\theta$ and
	$\phi$, with Jacobian normalized to one. In channel 2, we prepend a
	mapping $r_1 \to r_1^(1/3)$ with Jacobian $f=3r_1^2$.

	The component [[x]] is allocated in the first subroutine, used and deallocated
	in the second one.
	<<PHS base: phs test: TBP>>=
	procedure :: evaluate_selected_channel => phs_test_evaluate_selected_channel
	procedure :: evaluate_other_channels => phs_test_evaluate_other_channels
	<<PHS base: test auxiliary>>=
	subroutine phs_test_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_test_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	if (phs%p_defined) then
	call phs%select_channel (c_in)
	phs%r(:,c_in) = r_in
	select case (c_in)
	case (1)
	phs%x = r_in
	case (2)
	phs%x(1) = r_in(1) ** (1 / 3._default)
	phs%x(2) = r_in(2)
	end select
	call compute_kinematics_solid_angle (phs%p, phs%q, phs%x)
	phs%volume = 1
	phs%q_defined = .true.
	end if
	end subroutine phs_test_evaluate_selected_channel

	subroutine phs_test_evaluate_other_channels (phs, c_in)
	class(phs_test_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	integer :: c, n_channel
	if (phs%p_defined) then
	n_channel = phs%config%n_channel
	do c = 1, n_channel
	if (c /= c_in) then
	call inverse_kinematics_solid_angle (phs%p, phs%q, phs%x)
	select case (c)
	case (1)
	phs%r(:,c) = phs%x
	case (2)
	phs%r(1,c) = phs%x(1) ** 3
	phs%r(2,c) = phs%x(2)
	end select
	end if
	end do
	phs%f(1) = 1
	if (phs%r(1,2) /= 0) then
	phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
	else
	phs%f(2) = 0
	end if
	phs%r_defined = .true.
	end if
	end subroutine phs_test_evaluate_other_channels

	@ %def phs_test_evaluate_selected_channels
	@ %def phs_test_evaluate_other_channels
	@ Inverse evaluation.
	<<PHS base: phs test: TBP>>=
	procedure :: inverse => phs_test_inverse
	<<PHS base: test auxiliary>>=
	subroutine phs_test_inverse (phs)
	class(phs_test_t), intent(inout) :: phs
	integer :: c, n_channel
	real(default), dimension(:), allocatable :: x
	if (phs%p_defined .and. phs%q_defined) then
	call phs%select_channel ()
	n_channel = phs%config%n_channel
	allocate (x (phs%config%n_par))
	do c = 1, n_channel
	call inverse_kinematics_solid_angle (phs%p, phs%q, x)
	select case (c)
	case (1)
	phs%r(:,c) = x
	case (2)
	phs%r(1,c) = x(1) ** 3
	phs%r(2,c) = x(2)
	end select
	end do
	phs%f(1) = 1
	if (phs%r(1,2) /= 0) then
	phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
	else
	phs%f(2) = 0
	end if
	phs%volume = 1
	phs%r_defined = .true.
	end if
	end subroutine phs_test_inverse

	@ %def phs_test_inverse
	@
	\subsubsection{Phase-space configuration data}
	Construct and display a test phase-space configuration object.
	<<PHS base: execute tests>>=
	call test (phs_base_1, "phs_base_1", &
	"phase-space configuration", &
	u, results)
	<<PHS base: test declarations>>=
	public :: phs_base_1
	<<PHS base: tests>>=
	subroutine phs_base_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data

	write (u, "(A)") "* Test output: phs_base_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test phase-space configuration data"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_base_1"), process_data)

	allocate (phs_test_config_t :: phs_data)
	call phs_data%init (process_data, model)

	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_base_1

	@ %def phs_base_1
	@
	\subsubsection{Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation.
	<<PHS base: execute tests>>=
	call test (phs_base_2, "phs_base_2", &
	"phase-space evaluation", &
	u, results)
	<<PHS base: test declarations>>=
	public :: phs_base_2
	<<PHS base: tests>>=
	subroutine phs_base_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q

	write (u, "(A)") "* Test output: phs_base_2"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_base_2"), process_data)

	allocate (phs_test_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	select type (phs)
	type is (phs_test_t)
	call phs%init (phs_data)
	end select

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	E = sqrts / 2
	p(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point in channel 1 &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point in channel 2 &
	&for x = 0.125, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (2, [0.125_default, 0.125_default])
	call phs%evaluate_other_channels (2)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	sqrts = 1000._default
	select type (phs_data)
	type is (phs_test_config_t)
	call phs_data%configure (sqrts)
	end select

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_base_2

	@ %def phs_base_2
	@
	\subsubsection{Phase-space equivalences}
	Construct a test phase-space configuration which contains channel
	equivalences.
	<<PHS base: execute tests>>=
	call test (phs_base_3, "phs_base_3", &
	"channel equivalences", &
	u, results)
	<<PHS base: test declarations>>=
	public :: phs_base_3
	<<PHS base: tests>>=
	subroutine phs_base_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data

	write (u, "(A)") "* Test output: phs_base_3"
	write (u, "(A)") "* Purpose: construct phase-space configuration data &
	&with equivalences"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_base_3"), process_data)

	allocate (phs_test_config_t :: phs_data)
	call phs_data%init (process_data, model)
	select type (phs_data)
	type is (phs_test_config_t)
	phs_data%create_equivalences = .true.
	end select

	call phs_data%configure (1000._default)
	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_base_3

	@ %def phs_base_3
	@
	\subsubsection{MD5 sum checks}
	Construct a test phase-space configuration, compute and compare MD5 sums.
	<<PHS base: execute tests>>=
	call test (phs_base_4, "phs_base_4", &
	"MD5 sum", &
	u, results)
	<<PHS base: test declarations>>=
	public :: phs_base_4
	<<PHS base: tests>>=
	subroutine phs_base_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data

	write (u, "(A)") "* Test output: phs_base_4"
	write (u, "(A)") "* Purpose: compute and compare MD5 sums"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Model parameters"
	write (u, "(A)")

	call model%write (unit = u, &
	show_parameters = .true., &
	show_particles = .false., show_vertices = .false.)

	write (u, "(A)")
	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_base_4"), process_data)
	process_data%md5sum = "test_process_data_m6sum_12345678"

	allocate (phs_test_config_t :: phs_data)
	call phs_data%init (process_data, model)

	call phs_data%compute_md5sum ()
	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Modify model parameter"
	write (u, "(A)")

	call model%set_par (var_str ("ms"), 100._default)
	call model%write (show_parameters = .true., &
	show_particles = .false., show_vertices = .false.)

	write (u, "(A)")
	write (u, "(A)") "* PHS configuration"
	write (u, "(A)")

	call phs_data%compute_md5sum ()
	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_base_4

	@ %def phs_base_4
	@
	\subsubsection{Phase-space channel collection}
	Set up an array of various phase-space channels and collect them in a list.
	<<PHS base: execute tests>>=
	call test (phs_base_5, "phs_base_5", &
	"channel collection", &
	u, results)
	<<PHS base: test declarations>>=
	public :: phs_base_5
	<<PHS base: tests>>=
	subroutine phs_base_5 (u)
	integer, intent(in) :: u
	type(phs_channel_t), dimension(:), allocatable :: channel
	type(phs_channel_collection_t) :: coll
	integer :: i, n

	write (u, "(A)") "* Test output: phs_base_5"
	write (u, "(A)") "* Purpose: collect channel properties"
	write (u, "(A)")

	write (u, "(A)") "* Set up an array of channels"
	write (u, "(A)")

	n = 6

	allocate (channel (n))
	call channel(2)%set_resonant (75._default, 3._default)
	call channel(4)%set_resonant (130._default, 1._default)
	call channel(5)%set_resonant (75._default, 3._default)
	call channel(6)%set_on_shell (33._default)

	do i = 1, n
	write (u, "(1x,I0)", advance="no") i
	call channel(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Collect distinct properties"
	write (u, "(A)")

	do i = 1, n
	call coll%push (channel(i))
	end do

	write (u, "(1x,A,I0)") "n = ", coll%get_n ()
	write (u, "(A)")

	call coll%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Channel array with collection index assigned"
	write (u, "(A)")

	do i = 1, n
	write (u, "(1x,I0)", advance="no") i
	call channel(i)%write (u)
	end do

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

	call coll%final ()

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

	end subroutine phs_base_5

	@ %def phs_base_5
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\clearpage
	\section{Dummy phase space}

	This module implements a dummy phase space module for cases where the
	program structure demands the existence of a phase-space module, but
	no phase space integration is performed.

	<<[[phs_none.f90]]>>=
	<<File header>>

	module phs_none

	<<Use kinds>>
	<<Use strings>>
	use phs_base, only: phs_config_t, phs_t

	<<Standard module head>>

	<<PHS none: public>>

	<<PHS none: types>>

	interface
	<<PHS none: sub interfaces>>
	end interface

	contains

	<<PHS none: main procedures>>

	end module phs_none
	@ %def phs_none
	@
	<<[[phs_none_sub.f90]]>>=
	<<File header>>

	submodule (phs_none) phs_none_s

	use io_units, only: given_output_unit
	use diagnostics, only: msg_message, msg_fatal

	implicit none

	contains

	<<PHS none: procedures>>

	end submodule phs_none_s

	@ %def phs_none_s
	@
	\subsection{Configuration}
	Nothing to configure, but we provide the type and methods.
	<<PHS none: public>>=
	public :: phs_none_config_t
	<<PHS none: types>>=
	type, extends (phs_config_t) :: phs_none_config_t
	contains
	<<PHS none: phs none config: TBP>>
	end type phs_none_config_t

	@ %def phs_none_config_t
	@ The finalizer is empty.
	<<PHS none: phs none config: TBP>>=
	procedure :: final => phs_none_config_final
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_config_final (object)
	class(phs_none_config_t), intent(inout) :: object
	end subroutine phs_none_config_final
	<<PHS none: procedures>>=
	module subroutine phs_none_config_final (object)
	class(phs_none_config_t), intent(inout) :: object
	end subroutine phs_none_config_final

	@ %def phs_none_final
	@ Output. No contents, just an informative line.
	<<PHS none: phs none config: TBP>>=
	procedure :: write => phs_none_config_write
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_config_write (object, unit, include_id)
	class(phs_none_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_none_config_write
	<<PHS none: procedures>>=
	module subroutine phs_none_config_write (object, unit, include_id)
	class(phs_none_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") &
	"Partonic phase-space configuration: non-functional dummy"
	end subroutine phs_none_config_write

	@ %def phs_none_config_write
	@ Configuration: we have to implement this method, but it obviously
	does nothing.
	<<PHS none: phs none config: TBP>>=
	procedure :: configure => phs_none_config_configure
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_none_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_none_config_configure
	<<PHS none: procedures>>=
	module subroutine phs_none_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_none_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_none_config_configure

	@ %def phs_none_config_configure
	@ Startup message, after configuration is complete.
	<<PHS none: phs none config: TBP>>=
	procedure :: startup_message => phs_none_config_startup_message
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_config_startup_message (phs_config, unit)
	class(phs_none_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_none_config_startup_message
	<<PHS none: procedures>>=
	module subroutine phs_none_config_startup_message (phs_config, unit)
	class(phs_none_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	call msg_message ("Phase space: none")
	end subroutine phs_none_config_startup_message

	@ %def phs_none_config_startup_message
	@ Allocate an instance: the actual phase-space object.
	Gfortran 7/8/9 bug: has to remain in the main module.
	<<PHS none: phs none config: TBP>>=
	procedure, nopass :: allocate_instance => phs_none_config_allocate_instance
	<<PHS none: main procedures>>=
	subroutine phs_none_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_none_t :: phs)
	end subroutine phs_none_config_allocate_instance

	@ %def phs_none_config_allocate_instance
	@
	\subsection{Kinematics implementation}
	This is considered as empty, but we have to implement the minimal set of methods.
	<<PHS none: public>>=
	public :: phs_none_t
	<<PHS none: types>>=
	type, extends (phs_t) :: phs_none_t
	contains
	<<PHS none: phs none: TBP>>
	end type phs_none_t

	@ %def phs_none_t
	@ Output.
	<<PHS none: phs none: TBP>>=
	procedure :: write => phs_none_write
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_write (object, unit, verbose)
	class(phs_none_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_none_write
	<<PHS none: procedures>>=
	module subroutine phs_none_write (object, unit, verbose)
	class(phs_none_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	write (u, "(A)") "Partonic phase space: none"
	end subroutine phs_none_write

	@ %def phs_none_write
	@ The finalizer is empty.
	<<PHS none: phs none: TBP>>=
	procedure :: final => phs_none_final
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_final (object)
	class(phs_none_t), intent(inout) :: object
	end subroutine phs_none_final
	<<PHS none: procedures>>=
	module subroutine phs_none_final (object)
	class(phs_none_t), intent(inout) :: object
	end subroutine phs_none_final

	@ %def phs_none_final
	@ Initialization, trivial.
	<<PHS none: phs none: TBP>>=
	procedure :: init => phs_none_init
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_init (phs, phs_config)
	class(phs_none_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_none_init
	<<PHS none: procedures>>=
	module subroutine phs_none_init (phs, phs_config)
	class(phs_none_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	call phs%base_init (phs_config)
	end subroutine phs_none_init

	@ %def phs_none_init
	@ Evaluation. This must not be called at all.
	<<PHS none: phs none: TBP>>=
	procedure :: evaluate_selected_channel => phs_none_evaluate_selected_channel
	procedure :: evaluate_other_channels => phs_none_evaluate_other_channels
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_none_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	end subroutine phs_none_evaluate_selected_channel
	module subroutine phs_none_evaluate_other_channels (phs, c_in)
	class(phs_none_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_none_evaluate_other_channels
	<<PHS none: procedures>>=
	module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_none_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	call msg_fatal &
	("Phase space: attempt to evaluate with the 'phs_none' method")
	end subroutine phs_none_evaluate_selected_channel

	module subroutine phs_none_evaluate_other_channels (phs, c_in)
	class(phs_none_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_none_evaluate_other_channels

	@ %def phs_none_evaluate_selected_channel
	@ %def phs_none_evaluate_other_channels
	@ Inverse evaluation, likewise.
	<<PHS none: phs none: TBP>>=
	procedure :: inverse => phs_none_inverse
	<<PHS none: sub interfaces>>=
	module subroutine phs_none_inverse (phs)
	class(phs_none_t), intent(inout) :: phs
	end subroutine phs_none_inverse
	<<PHS none: procedures>>=
	module subroutine phs_none_inverse (phs)
	class(phs_none_t), intent(inout) :: phs
	call msg_fatal ("Phase space: attempt to evaluate inverse " // &
	"with the 'phs_none' method")
	end subroutine phs_none_inverse

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

	module phs_none_ut
	use unit_tests
	use phs_none_uti

	<<Standard module head>>

	<<PHS none: public test>>

	contains

	<<PHS none: test driver>>

	end module phs_none_ut
	@ %def phs_none_ut
	@
	<<[[phs_none_uti.f90]]>>=
	<<File header>>

	module phs_none_uti

	<<Use kinds>>
	<<Use strings>>
	use flavors
	use lorentz
	use model_data
	use process_constants
	use phs_base

	use phs_none

	use phs_base_ut, only: init_test_process_data, init_test_decay_data

	<<Standard module head>>

	<<PHS none: test declarations>>

	contains

	<<PHS none: tests>>

	end module phs_none_uti
	@ %def phs_none_ut
	@ API: driver for the unit tests below.
	<<PHS none: public test>>=
	public :: phs_none_test
	<<PHS none: test driver>>=
	subroutine phs_none_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS none: execute tests>>
	end subroutine phs_none_test

	@ %def phs_none_test
	@
	\subsubsection{Phase-space configuration data}
	Construct and display a test phase-space configuration object. Also
	check the [[azimuthal_dependence]] flag.
	<<PHS none: execute tests>>=
	call test (phs_none_1, "phs_none_1", &
	"phase-space configuration dummy", &
	u, results)
	<<PHS none: test declarations>>=
	public :: phs_none_1
	<<PHS none: tests>>=
	subroutine phs_none_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data
	real(default) :: sqrts

	write (u, "(A)") "* Test output: phs_none_1"
	write (u, "(A)") "* Purpose: display &
	&phase-space configuration data"
	write (u, "(A)")

	allocate (phs_none_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts, azimuthal_dependence=.false.)

	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_none_1

	@ %def phs_none_1
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\clearpage
	\section{Single-particle phase space}

	This module implements the phase space for a single particle, i.e., the solid
	angle, in a straightforward parameterization with a single channel. The
	phase-space implementation may be used either for $1\to 2$ decays or for $2\to
	2$ scattering processes, so the number of incoming particles is the only free
	parameter in the configuration. In the latter case, we should restrict its
	use to non-resonant s-channel processes, because there is no mapping of the
	scattering angle.

	(We might extend this later to account for generic $2\to 2$ situations, e.g.,
	account for a Coulomb singularity or detect an s-channel resonance structure
	that requires matching structure-function mappings.)

	This is derived from the [[phs_test]] implementation in the
	[[phs_base]] module above, even more simplified, but intended for
	actual use.
	<<[[phs_single.f90]]>>=
	<<File header>>

	module phs_single

	<<Use kinds>>
	<<Use strings>>
	use lorentz
	use phs_base

	<<Standard module head>>

	<<PHS single: public>>

	<<PHS single: types>>

	interface
	<<PHS single: sub interfaces>>
	end interface

	contains

	<<PHS single: main procedures>>

	end module phs_single
	@ %def phs_single
	@
	<<[[phs_single_sub.f90]]>>=
	<<File header>>

	submodule (phs_single) phs_single_s

	use io_units
	use constants
	use numeric_utils
	use diagnostics
	use physics_defs

	implicit none

	contains

	<<PHS single: procedures>>

	end submodule phs_single_s

	@ %def phs_single_s
	@
	\subsection{Configuration}
	<<PHS single: public>>=
	public :: phs_single_config_t
	<<PHS single: types>>=
	type, extends (phs_config_t) :: phs_single_config_t
	contains
	<<PHS single: phs single config: TBP>>
	end type phs_single_config_t

	@ %def phs_single_config_t
	@ The finalizer is empty.
	<<PHS single: phs single config: TBP>>=
	procedure :: final => phs_single_config_final
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_config_final (object)
	class(phs_single_config_t), intent(inout) :: object
	end subroutine phs_single_config_final
	<<PHS single: procedures>>=
	module subroutine phs_single_config_final (object)
	class(phs_single_config_t), intent(inout) :: object
	end subroutine phs_single_config_final

	@ %def phs_single_final
	@ Output.
	<<PHS single: phs single config: TBP>>=
	procedure :: write => phs_single_config_write
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_config_write (object, unit, include_id)
	class(phs_single_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_single_config_write
	<<PHS single: procedures>>=
	module subroutine phs_single_config_write (object, unit, include_id)
	class(phs_single_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Partonic phase-space configuration (single-particle):"
	call object%base_write (unit)
	end subroutine phs_single_config_write

	@ %def phs_single_config_write
	@ Configuration: there is only one channel and two parameters. The
	second parameter is the azimuthal angle, which may be a flat dimension.
	<<PHS single: phs single config: TBP>>=
	procedure :: configure => phs_single_config_configure
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_single_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_single_config_configure
	<<PHS single: procedures>>=
	module subroutine phs_single_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_single_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	if (.not. present (nlo_type)) &
	phs_config%nlo_type = BORN
	if (phs_config%n_out == 2) then
	phs_config%n_channel = 1
	phs_config%n_par = 2
	phs_config%sqrts = sqrts
	if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed
	if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm
	if (present (azimuthal_dependence)) then
	phs_config%azimuthal_dependence = azimuthal_dependence
	if (.not. azimuthal_dependence) then
	allocate (phs_config%dim_flat (1))
	phs_config%dim_flat(1) = 2
	end if
	end if
	if (allocated (phs_config%channel)) deallocate (phs_config%channel)
	allocate (phs_config%channel (1))
	call phs_config%compute_md5sum ()
	else
	call msg_fatal ("Single-particle phase space requires n_out = 2")
	end if
	end subroutine phs_single_config_configure

	@ %def phs_single_config_configure
	@ Startup message, after configuration is complete.
	<<PHS single: phs single config: TBP>>=
	procedure :: startup_message => phs_single_config_startup_message
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_config_startup_message (phs_config, unit)
	class(phs_single_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_single_config_startup_message
	<<PHS single: procedures>>=
	module subroutine phs_single_config_startup_message (phs_config, unit)
	class(phs_single_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	call phs_config%base_startup_message (unit)
	write (msg_buffer, "(A,2(1x,I0,1x,A))") &
	"Phase space: single-particle"
	call msg_message (unit = unit)
	end subroutine phs_single_config_startup_message

	@ %def phs_single_config_startup_message
	@ Allocate an instance: the actual phase-space object.
	Gfortran 7/8/9 bug, has to remain in the main module.
	<<PHS single: phs single config: TBP>>=
	procedure, nopass :: allocate_instance => phs_single_config_allocate_instance
	<<PHS single: main procedures>>=
	subroutine phs_single_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_single_t :: phs)
	end subroutine phs_single_config_allocate_instance

	@ %def phs_single_config_allocate_instance
	@
	\subsection{Kinematics implementation}
	We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.

	Note: The incoming momenta must be in the c.m. system.
	<<PHS single: public>>=
	public :: phs_single_t
	<<PHS single: types>>=
	type, extends (phs_t) :: phs_single_t
	contains
	<<PHS single: phs single: TBP>>
	end type phs_single_t

	@ %def phs_single_t
	@ Output. The [[verbose]] setting is irrelevant, we just display the contents
	of the base object.
	<<PHS single: phs single: TBP>>=
	procedure :: write => phs_single_write
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_write (object, unit, verbose)
	class(phs_single_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_single_write
	<<PHS single: procedures>>=
	module subroutine phs_single_write (object, unit, verbose)
	class(phs_single_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (u)
	end subroutine phs_single_write

	@ %def phs_single_write
	@ The finalizer is empty.
	<<PHS single: phs single: TBP>>=
	procedure :: final => phs_single_final
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_final (object)
	class(phs_single_t), intent(inout) :: object
	end subroutine phs_single_final
	<<PHS single: procedures>>=
	module subroutine phs_single_final (object)
	class(phs_single_t), intent(inout) :: object
	end subroutine phs_single_final

	@ %def phs_single_final
	@ Initialization. We allocate arrays ([[base_init]]) and adjust the
	phase-space volume. The massless two-particle phase space volume is
	\begin{equation}
	\Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
	\end{equation}
	For a decay with nonvanishing masses ($m_3$, $m_4$), there is a correction
	factor
	\begin{equation}
	\Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s}
	\lambda^{1/2}(\hat s, m_3^2, m_4^2).
	\end{equation}
	For a scattering process with nonvanishing masses, the correction
	factor is
	\begin{equation}
	\Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s ^ 2}
	\lambda^{1/2}(\hat s, m_1^2, m_2^2)\,
	\lambda^{1/2}(\hat s, m_3^2, m_4^2).
	\end{equation}
	If the energy is fixed, this is constant. Otherwise, we have to account for
	varying $\hat s$.
	<<PHS single: phs single: TBP>>=
	procedure :: init => phs_single_init
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_init (phs, phs_config)
	class(phs_single_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_single_init
	<<PHS single: procedures>>=
	module subroutine phs_single_init (phs, phs_config)
	class(phs_single_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	call phs%base_init (phs_config)
	phs%volume = 1 / (4 * twopi5)
	call phs%compute_factor ()
	end subroutine phs_single_init

	@ %def phs_single_init
	@ Compute the correction factor for nonzero masses. We do this during
	initialization (when the incoming momenta [[p]] are undefined), unless
	[[sqrts]] is variable. We do this again once for each phase-space point, but
	then we skip the calculation if [[sqrts]] is fixed.
	<<PHS single: phs single: TBP>>=
	procedure :: compute_factor => phs_single_compute_factor
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_compute_factor (phs)
	class(phs_single_t), intent(inout) :: phs
	end subroutine phs_single_compute_factor
	<<PHS single: procedures>>=
	module subroutine phs_single_compute_factor (phs)
	class(phs_single_t), intent(inout) :: phs
	real(default) :: s_hat
	select case (phs%config%n_in)
	case (1)
	if (.not. phs%p_defined) then
	if (sum (phs%m_out) < phs%m_in(1)) then
	s_hat = phs%m_in(1) ** 2
	phs%f(1) = 1 / s_hat &
	* sqrt (lambda (s_hat, phs%m_out(1)2, phs%m_out(2)2))
	else
	print *, "m_in = ", phs%m_in
	print *, "m_out = ", phs%m_out
	call msg_fatal ("Decay is kinematically forbidden")
	end if
	end if
	case (2)
	if (phs%config%sqrts_fixed) then
	if (phs%p_defined) return
	s_hat = phs%config%sqrts ** 2
	else
	if (.not. phs%p_defined) return
	s_hat = sum (phs%p) ** 2
	end if
	if (sum (phs%m_in)2 < s_hat .and. sum (phs%m_out)2 < s_hat) then
	phs%f(1) = 1 / s_hat * &
	( lambda (s_hat, phs%m_in (1)2, phs%m_in (2)2) &
	* lambda (s_hat, phs%m_out(1)2, phs%m_out(2)2) ) &
	** 0.25_default
	else
	phs%f(1) = 0
	end if
	end select
	end subroutine phs_single_compute_factor

	@ %def phs_single_compute_factor
	@ Evaluation. We uniformly generate $\cos\theta$ and
	$\phi$, with Jacobian normalized to one.

	There is only a single channel, so the second subroutine does nothing.

	Note: the current implementation works for elastic scattering only.
	<<PHS single: phs single: TBP>>=
	procedure :: evaluate_selected_channel => phs_single_evaluate_selected_channel
	procedure :: evaluate_other_channels => phs_single_evaluate_other_channels
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_single_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	end subroutine phs_single_evaluate_selected_channel
	module subroutine phs_single_evaluate_other_channels (phs, c_in)
	class(phs_single_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_single_evaluate_other_channels
	<<PHS single: procedures>>=
	module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_single_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	if (phs%p_defined) then
	call phs%select_channel (c_in)
	phs%r(:,c_in) = r_in
	select case (phs%config%n_in)
	case (2)
	if (all (phs%m_in == phs%m_out)) then
	call compute_kinematics_solid_angle (phs%p, phs%q, r_in)
	else
	call msg_bug ("PHS single: inelastic scattering not implemented")
	end if
	case (1)
	call compute_kinematics_solid_angle (phs%decay_p (), phs%q, r_in)
	end select
	call phs%compute_factor ()
	phs%q_defined = .true.
	phs%r_defined = .true.
	end if
	end subroutine phs_single_evaluate_selected_channel

	module subroutine phs_single_evaluate_other_channels (phs, c_in)
	class(phs_single_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_single_evaluate_other_channels

	@ %def phs_single_evaluate_selected_channel
	@ %def phs_single_evaluate_other_channels
	@ Auxiliary: split a decaying particle at rest into the decay products,
	aligned along the $z$ axis.
	<<PHS single: phs single: TBP>>=
	procedure :: decay_p => phs_single_decay_p
	<<PHS single: sub interfaces>>=
	module function phs_single_decay_p (phs) result (p)
	class(phs_single_t), intent(in) :: phs
	type(vector4_t), dimension(2) :: p
	end function phs_single_decay_p
	<<PHS single: procedures>>=
	module function phs_single_decay_p (phs) result (p)
	class(phs_single_t), intent(in) :: phs
	type(vector4_t), dimension(2) :: p
	real(default) :: k
	real(default), dimension(2) :: E
	k = sqrt (lambda (phs%m_in(1) 2, phs%m_out(1) 2, phs%m_out(2) ** 2)) &
	/ (2 * phs%m_in(1))
	E = sqrt (phs%m_out 2 + k 2)
	p(1) = vector4_moving (E(1), k, 3)
	p(2) = vector4_moving (E(2),-k, 3)
	end function phs_single_decay_p

	@ %def phs_single_decay_p
	@ Inverse evaluation.
	<<PHS single: phs single: TBP>>=
	procedure :: inverse => phs_single_inverse
	<<PHS single: sub interfaces>>=
	module subroutine phs_single_inverse (phs)
	class(phs_single_t), intent(inout) :: phs
	end subroutine phs_single_inverse
	<<PHS single: procedures>>=
	module subroutine phs_single_inverse (phs)
	class(phs_single_t), intent(inout) :: phs
	real(default), dimension(:), allocatable :: x
	if (phs%p_defined .and. phs%q_defined) then
	call phs%select_channel ()
	allocate (x (phs%config%n_par))
	call inverse_kinematics_solid_angle (phs%p, phs%q, x)
	phs%r(:,1) = x
	call phs%compute_factor ()
	phs%r_defined = .true.
	end if
	end subroutine phs_single_inverse

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

	module phs_single_ut
	use unit_tests
	use phs_single_uti

	<<Standard module head>>

	<<PHS single: public test>>

	contains

	<<PHS single: test driver>>

	end module phs_single_ut
	@ %def phs_single_ut
	@
	<<[[phs_single_uti.f90]]>>=
	<<File header>>

	module phs_single_uti

	<<Use kinds>>
	<<Use strings>>
	use flavors
	use lorentz
	use model_data
	use process_constants
	use phs_base

	use phs_single

	use phs_base_ut, only: init_test_process_data, init_test_decay_data

	<<Standard module head>>

	<<PHS single: test declarations>>

	contains

	<<PHS single: tests>>

	end module phs_single_uti
	@ %def phs_single_ut
	@ API: driver for the unit tests below.
	<<PHS single: public test>>=
	public :: phs_single_test
	<<PHS single: test driver>>=
	subroutine phs_single_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS single: execute tests>>
	end subroutine phs_single_test

	@ %def phs_single_test
	@
	\subsubsection{Phase-space configuration data}
	Construct and display a test phase-space configuration object. Also
	check the [[azimuthal_dependence]] flag.
	<<PHS single: execute tests>>=
	call test (phs_single_1, "phs_single_1", &
	"phase-space configuration", &
	u, results)
	<<PHS single: test declarations>>=
	public :: phs_single_1
	<<PHS single: tests>>=
	subroutine phs_single_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data
	real(default) :: sqrts

	write (u, "(A)") "* Test output: phs_single_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&phase-space configuration data"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_single_1"), process_data)

	allocate (phs_single_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts, azimuthal_dependence=.false.)

	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_single_1

	@ %def phs_single_1
	@
	\subsubsection{Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation.
	<<PHS single: execute tests>>=
	call test (phs_single_2, "phs_single_2", &
	"phase-space evaluation", &
	u, results)
	<<PHS single: test declarations>>=
	public :: phs_single_2
	<<PHS single: tests>>=
	subroutine phs_single_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q

	write (u, "(A)") "* Test output: phs_single_2"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_single_2"), process_data)

	allocate (phs_single_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	E = sqrts / 2
	p(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_single_2

	@ %def phs_single_2
	@
	\subsubsection{Phase space for non-c.m. system}
	Compute kinematics for given parameters, also invert the calculation.
	Since this will involve cancellations, we call [[pacify]] to eliminate
	numerical noise.
	<<PHS single: execute tests>>=
	call test (phs_single_3, "phs_single_3", &
	"phase-space evaluation in lab frame", &
	u, results)
	<<PHS single: test declarations>>=
	public :: phs_single_3
	<<PHS single: tests>>=
	subroutine phs_single_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q
	type(lorentz_transformation_t) :: lt

	write (u, "(A)") "* Test output: phs_single_3"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)") "* without c.m. kinematics assumption"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_single_3"), process_data)

	allocate (phs_single_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta in lab system"
	write (u, "(A)")

	lt = boost (0.1_default, 1) * boost (0.3_default, 3)

	E = sqrts / 2
	p(1) = lt * vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = lt * vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call vector4_write (p(1), u)
	call vector4_write (p(2), u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call pacify (phs)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extract outgoing momenta in lab system"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	call vector4_write (q(1), u)
	call vector4_write (q(2), u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call pacify (phs)
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_single_3

	@ %def phs_single_3
	@
	\subsubsection{Decay Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation. This
	time, implement a decay process.
	<<PHS single: execute tests>>=
	call test (phs_single_4, "phs_single_4", &
	"decay phase-space evaluation", &
	u, results)
	<<PHS single: test declarations>>=
	public :: phs_single_4
	<<PHS single: tests>>=
	subroutine phs_single_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(1) :: p
	type(vector4_t), dimension(2) :: q

	write (u, "(A)") "* Test output: phs_single_4"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)")

	call model%init_test ()

	call model%set_par (var_str ("ff"), 0.4_default)
	call model%set_par (var_str ("mf"), &
	model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a decay and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_decay_data (var_str ("phs_single_4"), process_data)

	allocate (phs_single_config_t :: phs_data)
	call phs_data%init (process_data, model)

	call phs_data%configure (flv%get_mass ())

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	p(1) = vector4_at_rest (flv%get_mass ())

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs_data%configure (flv%get_mass ())

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_single_4

	@ %def phs_single_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Flat RAMBO phase space}

	This module implements the flat \texttt{RAMBO} phase space for
	massless and massive particles using the minimal d.o.f $3n - 4$ in a
	straightforward parameterization with a single channel.
	We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} =
	0$. We let each mass system decay $1 \rightarrow 2$ in a four-momentum
	conserving way. The four-momenta of the two particles are generated
	back-to-back where we map the d.o.f. to energy, azimuthal and polar
	angle. The particle momenta are then boosted to CMS by an appriopriate
	boost using the kinematics of the parent mass system.

	<<[[phs_rambo.f90]]>>=
	<<File header>>

	module phs_rambo

	<<Use kinds>>
	<<Use strings>>
	use lorentz
	use phs_base

	<<Standard module head>>

	<<PHS rambo: types>>

	<<PHS rambo: public>>

	interface
	<<PHS rambo: sub interfaces>>
	end interface

	contains

	<<PHS rambo: main procedures>>

	end module phs_rambo
	@ %def phs_rambo
	@
	<<[[phs_rambo_sub.f90]]>>=
	<<File header>>

	submodule (phs_rambo) phs_rambo_s

	use io_units
	use constants
	use numeric_utils
	use format_defs, only: FMT_19
	use permutations, only: factorial
	use diagnostics
	use physics_defs

	implicit none

	<<PHS rambo: parameters>>

	contains

	<<PHS rambo: procedures>>

	end submodule phs_rambo_s

	@ %def phs_rambo_s
	@
	\subsection{Configuration}
	<<PHS rambo: public>>=
	public :: phs_rambo_config_t
	<<PHS rambo: types>>=
	type, extends (phs_config_t) :: phs_rambo_config_t
	contains
	<<PHS rambo: phs rambo config: TBP>>
	end type phs_rambo_config_t

	@ %def phs_rambo_config_t
	@ The finalizer is empty.
	<<PHS rambo: phs rambo config: TBP>>=
	procedure :: final => phs_rambo_config_final
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_config_final (object)
	class(phs_rambo_config_t), intent(inout) :: object
	end subroutine phs_rambo_config_final
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_config_final (object)
	class(phs_rambo_config_t), intent(inout) :: object
	end subroutine phs_rambo_config_final

	@ %def phs_rambo_final
	@ Output.
	<<PHS rambo: phs rambo config: TBP>>=
	procedure :: write => phs_rambo_config_write
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_config_write (object, unit, include_id)
	class(phs_rambo_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_rambo_config_write
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_config_write (object, unit, include_id)
	class(phs_rambo_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Partonic, flat phase-space configuration (RAMBO):"
	call object%base_write (unit)
	end subroutine phs_rambo_config_write

	@ %def phs_rambo_config_write
	@ Configuration: there is only one channel and $3n - 4$ parameters.
	<<PHS rambo: phs rambo config: TBP>>=
	procedure :: configure => phs_rambo_config_configure
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_rambo_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_rambo_config_configure
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_rambo_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	if (.not. present (nlo_type)) &
	phs_config%nlo_type = BORN
	if (phs_config%n_out < 2) then
	call msg_fatal ("RAMBO phase space requires n_out >= 2")
	end if
	phs_config%n_channel = 1
	phs_config%n_par = 3 * phs_config%n_out - 4
	phs_config%sqrts = sqrts
	if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed
	if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm
	if (allocated (phs_config%channel)) deallocate (phs_config%channel)
	allocate (phs_config%channel (1))
	call phs_config%compute_md5sum ()
	end subroutine phs_rambo_config_configure

	@ %def phs_rambo_config_configure
	@ Startup message, after configuration is complete.
	<<PHS rambo: phs rambo config: TBP>>=
	procedure :: startup_message => phs_rambo_config_startup_message
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_config_startup_message (phs_config, unit)
	class(phs_rambo_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_rambo_config_startup_message
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_config_startup_message (phs_config, unit)
	class(phs_rambo_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	call phs_config%base_startup_message (unit)
	write (msg_buffer, "(A,2(1x,I0,1x,A))") &
	"Phase space: flat (RAMBO)"
	call msg_message (unit = unit)
	end subroutine phs_rambo_config_startup_message

	@ %def phs_rambo_config_startup_message
	@ Allocate an instance: the actual phase-space object.
	Gfortran 7/8/9 bug, has to remain in the main module.
	<<PHS rambo: phs rambo config: TBP>>=
	procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance
	<<PHS rambo: main procedures>>=
	subroutine phs_rambo_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_rambo_t :: phs)
	end subroutine phs_rambo_config_allocate_instance

	@ %def phs_rambo_config_allocate_instance
	@
	\subsection{Kinematics implementation}

	We generate $n - 2$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_n = 0$...

	Note: The incoming momenta must be in the c.m. system.
	<<PHS rambo: public>>=
	public :: phs_rambo_t
	<<PHS rambo: types>>=
	type, extends (phs_t) :: phs_rambo_t
	real(default), dimension(:), allocatable :: k
	real(default), dimension(:), allocatable :: m
	contains
	<<PHS rambo: phs rambo: TBP>>
	end type phs_rambo_t

	@ %def phs_rambo_t
	@ Output.
	<<PHS rambo: phs rambo: TBP>>=
	procedure :: write => phs_rambo_write
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_write (object, unit, verbose)
	class(phs_rambo_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_rambo_write
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_write (object, unit, verbose)
	class(phs_rambo_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (u)
	write (u, "(1X,A)") "Intermediate masses (massless):"
	write (u, "(3X,999(" // FMT_19 // "))") object%k
	write (u, "(1X,A)") "Intermediate masses (massive):"
	write (u, "(3X,999(" // FMT_19 // "))") object%m
	end subroutine phs_rambo_write

	@ %def phs_rambo_write
	@ The finalizer is empty.
	<<PHS rambo: phs rambo: TBP>>=
	procedure :: final => phs_rambo_final
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_final (object)
	class(phs_rambo_t), intent(inout) :: object
	end subroutine phs_rambo_final
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_final (object)
	class(phs_rambo_t), intent(inout) :: object
	end subroutine phs_rambo_final

	@ %def phs_rambo_final
	@ Initialization. We allocate arrays ([[base_init]]) and adjust the
	phase-space volume.
	The energy dependent factor of $s^{n - 2}$ is applied later.
	<<PHS rambo: phs rambo: TBP>>=
	procedure :: init => phs_rambo_init
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_init (phs, phs_config)
	class(phs_rambo_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_rambo_init
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_init (phs, phs_config)
	class(phs_rambo_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	call phs%base_init (phs_config)
	associate (n => phs%config%n_out)
	select case (n)
	case (1)
	if (sum (phs%m_out) > phs%m_in (1)) then
	print *, "m_in = ", phs%m_in
	print *, "m_out = ", phs%m_out
	call msg_fatal &
	("[phs_rambo_init] Decay is kinematically forbidden.")
	end if
	end select
	allocate (phs%k(n), source = 0._default)
	allocate (phs%m(n), source = 0._default)
	phs%volume = 1. / (twopi)*(3 n) &
	* (pi / 2.)*(n - 1) / (factorial(n - 1) factorial(n - 2))
	end associate
	end subroutine phs_rambo_init

	@ %def phs_rambo_init
	@ Evaluation. There is only one channel for RAMBO, so the second subroutine does nothing.

	Note: the current implementation works for elastic scattering only.
	<<PHS rambo: phs rambo: TBP>>=
	procedure :: evaluate_selected_channel => phs_rambo_evaluate_selected_channel
	procedure :: evaluate_other_channels => phs_rambo_evaluate_other_channels
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_rambo_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	end subroutine phs_rambo_evaluate_selected_channel
	module subroutine phs_rambo_evaluate_other_channels (phs, c_in)
	class(phs_rambo_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_rambo_evaluate_other_channels
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_rambo_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	type(vector4_t), dimension(2) :: p_rest, p_boosted
	type(vector4_t) :: q
	real(default), dimension(2) :: r_angle
	integer :: i
	if (.not. phs%p_defined) return
	call phs%select_channel (c_in)
	phs%r(:,c_in) = r_in
	associate (n => phs%config%n_out, m => phs%m)
	call phs%generate_intermediates (r_in(:n - 2))
	q = sum (phs%p)
	do i = 2, n
	r_angle(1) = r_in(n - 5 + 2 * i)
	r_angle(2) = r_in(n - 4 + 2 * i)
	call phs%decay_intermediate (i, r_angle, p_rest)
	p_boosted = boost(q, m(i - 1)) * p_rest
	q = p_boosted(1)
	phs%q(i - 1) = p_boosted(2)
	end do
	phs%q(n) = q
	end associate
	phs%q_defined = .true.
	phs%r_defined = .true.
	end subroutine phs_rambo_evaluate_selected_channel

	module subroutine phs_rambo_evaluate_other_channels (phs, c_in)
	class(phs_rambo_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_rambo_evaluate_other_channels

	@ %def phs_rambo_evaluate_selected_channel
	@ %def phs_rambo_evaluate_other_channels
	@ Decay intermediate mass system $M_{i - 1}$ into a on-shell particle with mass
	$m_{i - 1}$ and subsequent intermediate mass system with fixed $M_i$.
	<<PHS rambo: phs rambo: TBP>>=
	procedure, private :: decay_intermediate => phs_rambo_decay_intermediate
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p)
	class(phs_rambo_t), intent(in) :: phs
	integer, intent(in) :: i
	real(default), dimension(2), intent(in) :: r_angle
	type(vector4_t), dimension(2), intent(out) :: p
	end subroutine phs_rambo_decay_intermediate
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p)
	class(phs_rambo_t), intent(in) :: phs
	integer, intent(in) :: i
	real(default), dimension(2), intent(in) :: r_angle
	type(vector4_t), dimension(2), intent(out) :: p
	real(default) :: k_abs, cos_theta, phi
	type(vector3_t):: k
	real(default), dimension(2) :: E
	cos_theta = 2. * r_angle(1) - 1.
	phi = twopi * r_angle(2)
	if (phi > pi) phi = phi - twopi
	k_abs = sqrt (lambda (phs%m(i - 1)2, phs%m(i)2, phs%m_out(i - 1)**2)) &
	/ (2. * phs%m(i - 1))
	k = k_abs * [cos(phi) * sqrt(1. - cos_theta**2), &
	sin(phi) * sqrt(1. - cos_theta**2), cos_theta]
	E(1) = sqrt (phs%m(i)2 + k_abs2)
	E(2) = sqrt (phs%m_out(i - 1)2 + k_abs2)
	p(1) = vector4_moving (E(1), -k)
	p(2) = vector4_moving (E(2), k)
	end subroutine phs_rambo_decay_intermediate

	@ %def phs_rambo_decay_intermediate
	@ Generate intermediate masses.
	<<PHS rambo: parameters>>=
	integer, parameter :: BISECT_MAX_ITERATIONS = 1000
	real(default), parameter :: BISECT_MIN_PRECISION = tiny_10
	<<PHS rambo: phs rambo: TBP>>=
	procedure, private :: generate_intermediates => &
	phs_rambo_generate_intermediates
	procedure, private :: invert_intermediates => phs_rambo_invert_intermediates
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_generate_intermediates (phs, r)
	class(phs_rambo_t), intent(inout) :: phs
	real(default), dimension(:), intent(in) :: r
	end subroutine phs_rambo_generate_intermediates
	module subroutine phs_rambo_invert_intermediates (phs)
	class(phs_rambo_t), intent(inout) :: phs
	end subroutine phs_rambo_invert_intermediates
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_generate_intermediates (phs, r)
	class(phs_rambo_t), intent(inout) :: phs
	real(default), dimension(:), intent(in) :: r
	integer :: i, j
	associate (n => phs%config%n_out, k => phs%k, m => phs%m)
	m(1) = invariant_mass (sum (phs%p))
	m(n) = phs%m_out (n)
	call calculate_k (r)
	do i = 2, n - 1
	m(i) = k(i) + sum (phs%m_out (i:n))
	end do
	! Massless volume times reweighting for massive volume
	phs%f(1) = k(1)*(2 n - 4) &
	* 8. * rho(m(n - 1), phs%m_out(n), phs%m_out(n - 1))
	do i = 2, n - 1
	phs%f(1) = phs%f(1) * &
	rho(m(i - 1), m(i), phs%m_out(i - 1)) / &
	rho(k(i - 1), k(i), 0._default) * &
	M(i) / K(i)
	end do
	end associate
	contains
	subroutine calculate_k (r)
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), allocatable :: u
	integer :: i
	associate (n => phs%config%n_out, k => phs%k, m => phs%m)
	k = 0
	k(1) = m(1) - sum(phs%m_out(1:n))
	allocate (u(2:n - 1), source=0._default)
	call solve_for_u (r, u)
	do i = 2, n - 1
	k(i) = sqrt (u(i) * k(i - 1)**2)
	end do
	end associate
	end subroutine calculate_k

	subroutine solve_for_u (r, u)
	real(default), dimension(phs%config%n_out - 2), intent(in) :: r
	real(default), dimension(2:phs%config%n_out - 1), intent(out) :: u
	integer :: i, j
	real(default) :: f, f_mid, xl, xr, xmid
	associate (n => phs%config%n_out)
	do i = 2, n - 1
	xl = 0
	xr = 1
	if (r(i - 1) == 1 .or. r(i - 1) == 0) then
	u(i) = r(i - 1)
	else
	do j = 1, BISECT_MAX_ITERATIONS
	xmid = (xl + xr) / 2.
	f = f_rambo (xl, n - i) - r(i - 1)
	f_mid = f_rambo (xmid, n - i) - r(i - 1)
	if (f * f_mid > 0) then
	xl = xmid
	else
	xr = xmid
	end if
	if (abs(xl - xr) < BISECT_MIN_PRECISION) exit
	end do
	u(i) = xmid
	end if
	end do
	end associate
	end subroutine solve_for_u

	real(default) function f_rambo(u, n)
	real(default), intent(in) :: u
	integer, intent(in) :: n
	f_rambo = (n + 1) * u*n - n u**(n + 1)
	end function f_rambo

	real(default) function rho (M1, M2, m)
	real(default), intent(in) :: M1, M2, m
	real(default) :: MP, MM
	rho = sqrt ((M12 - (M2 + m)2) * (M12 - (M2 - m)2))
	! MP = (M1 - (M2 + m)) * (M1 + (M2 + m))
	! MM = (M1 - (M2 - m)) * (M1 + (M2 - m))
	! rho = sqrt (MP) * sqrt (MM)
	rho = rho / (8._default * M1**2)
	end function rho

	end subroutine phs_rambo_generate_intermediates

	module subroutine phs_rambo_invert_intermediates (phs)
	class(phs_rambo_t), intent(inout) :: phs
	real(default) :: u
	integer :: i
	associate (n => phs%config%n_out, k => phs%k, m => phs%m)
	k = m
	do i = 1, n - 1
	k(i) = k(i) - sum (phs%m_out(i:n))
	end do
	do i = 2, n - 1
	u = (k(i) / k(i - 1))**2
	phs%r(i - 1, 1) = (n + 1 - i) * u**(n - i) &
	- (n - i) * u**(n + 1 - i)
	end do
	end associate
	end subroutine phs_rambo_invert_intermediates

	@ %def phs_rambo_generate_intermediates
	@ Inverse evaluation.
	<<PHS rambo: phs rambo: TBP>>=
	procedure :: inverse => phs_rambo_inverse
	<<PHS rambo: sub interfaces>>=
	module subroutine phs_rambo_inverse (phs)
	class(phs_rambo_t), intent(inout) :: phs
	end subroutine phs_rambo_inverse
	<<PHS rambo: procedures>>=
	module subroutine phs_rambo_inverse (phs)
	class(phs_rambo_t), intent(inout) :: phs
	type(vector4_t), dimension(:), allocatable :: q
	type(vector4_t) :: p
	type(lorentz_transformation_t) :: L
	real(default) :: phi, cos_theta
	integer :: i
	if (.not. (phs%p_defined .and. phs%q_defined)) return
	call phs%select_channel ()
	associate (n => phs%config%n_out, m => phs%m)
	allocate(q(n))
	m(1) = invariant_mass (sum (phs%p))
	q(1) = vector4_at_rest (m(1))
	q(n) = phs%q(n)
	do i = 2, n - 1
	q(i) = q(i) + sum (phs%q(i:n))
	m(i) = invariant_mass (q(i))
	end do
	call phs%invert_intermediates ()
	do i = 2, n
	L = inverse (boost (q(i - 1), m(i - 1)))
	p = L * phs%q(i - 1)
	phi = azimuthal_angle (p); cos_theta = polar_angle_ct (p)
	phs%r(n - 5 + 2 * i, 1) = (cos_theta + 1.) / 2.
	phs%r(n - 4 + 2 * i, 1) = phi / twopi
	end do
	end associate
	phs%r_defined = .true.
	end subroutine phs_rambo_inverse

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

	module phs_rambo_ut
	use unit_tests
	use phs_rambo_uti

	<<Standard module head>>

	<<PHS rambo: public test>>

	contains

	<<PHS rambo: test driver>>

	end module phs_rambo_ut
	@ %def phs_rambo_ut
	@
	<<[[phs_rambo_uti.f90]]>>=
	<<File header>>

	module phs_rambo_uti

	<<Use kinds>>
	<<Use strings>>
	use flavors
	use lorentz
	use model_data
	use process_constants
	use phs_base

	use phs_rambo

	use phs_base_ut, only: init_test_process_data, init_test_decay_data

	<<Standard module head>>

	<<PHS rambo: test declarations>>

	contains

	<<PHS rambo: tests>>

	end module phs_rambo_uti
	@ %def phs_rambo_ut
	@ API: driver for the unit tests below.
	<<PHS rambo: public test>>=
	public :: phs_rambo_test
	<<PHS rambo: test driver>>=
	subroutine phs_rambo_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS rambo: execute tests>>
	end subroutine phs_rambo_test

	@ %def phs_rambo_test
	@
	\subsubsection{Phase-space configuration data}
	Construct and display a test phase-space configuration object. Also
	check the [[azimuthal_dependence]] flag.
	<<PHS rambo: execute tests>>=
	call test (phs_rambo_1, "phs_rambo_1", &
	"phase-space configuration", &
	u, results)
	<<PHS rambo: test declarations>>=
	public :: phs_rambo_1
	<<PHS rambo: tests>>=
	subroutine phs_rambo_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data
	real(default) :: sqrts

	write (u, "(A)") "* Test output: phs_rambo_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&phase-space configuration data"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_rambo_1"), process_data)

	allocate (phs_rambo_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_rambo_1

	@ %def phs_rambo_1
	@
	\subsubsection{Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation.
	<<PHS rambo: execute tests>>=
	call test (phs_rambo_2, "phs_rambo_2", &
	"phase-space evaluation", &
	u, results)
	<<PHS rambo: test declarations>>=
	public :: phs_rambo_2
	<<PHS rambo: tests>>=
	subroutine phs_rambo_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q

	write (u, "(A)") "* Test output: phs_rambo_2"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_rambo_2"), process_data)

	allocate (phs_rambo_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	E = sqrts / 2
	p(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_rambo_2

	@ %def phs_rambo_2
	@
	\subsubsection{Phase space for non-c.m. system}
	Compute kinematics for given parameters, also invert the calculation.
	Since this will involve cancellations, we call [[pacify]] to eliminate
	numerical noise.
	<<PHS rambo: execute tests>>=
	call test (phs_rambo_3, "phs_rambo_3", &
	"phase-space evaluation in lab frame", &
	u, results)
	<<PHS rambo: test declarations>>=
	public :: phs_rambo_3
	<<PHS rambo: tests>>=
	subroutine phs_rambo_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q
	type(lorentz_transformation_t) :: lt

	write (u, "(A)") "* Test output: phs_rambo_3"
	write (u, "(A)") "* Purpose: phase-space evaluation in lab frame"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_rambo_3"), process_data)

	allocate (phs_rambo_config_t :: phs_data)
	call phs_data%init (process_data, model)

	sqrts = 1000._default
	call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta in lab system"
	write (u, "(A)")

	lt = boost (0.1_default, 1) * boost (0.3_default, 3)

	E = sqrts / 2
	p(1) = lt * vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = lt * vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call vector4_write (p(1), u)
	call vector4_write (p(2), u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call pacify (phs)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extract outgoing momenta in lab system"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	call vector4_write (q(1), u)
	call vector4_write (q(2), u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call pacify (phs)
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_rambo_3

	@ %def phs_rambo_3
	@
	\subsubsection{Decay Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation. This
	time, implement a decay process.
	<<PHS rambo: execute tests>>=
	call test (phs_rambo_4, "phs_rambo_4", &
	"decay phase-space evaluation", &
	u, results)
	<<PHS rambo: test declarations>>=
	public :: phs_rambo_4
	<<PHS rambo: tests>>=
	subroutine phs_rambo_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(1) :: p
	type(vector4_t), dimension(2) :: q

	write (u, "(A)") "* Test output: phs_rambo_4"
	write (u, "(A)") "* Purpose: test simple two-channel phase space"
	write (u, "(A)")

	call model%init_test ()

	call model%set_par (var_str ("ff"), 0.4_default)
	call model%set_par (var_str ("mf"), &
	model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a decay and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_decay_data (var_str ("phs_rambo_4"), process_data)

	allocate (phs_rambo_config_t :: phs_data)
	call phs_data%init (process_data, model)

	call phs_data%configure (flv%get_mass ())

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	p(1) = vector4_at_rest (flv%get_mass ())

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.5, 0.125"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	deallocate (phs)
	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs_data%configure (flv%get_mass ())

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_rambo_4

	@ %def phs_rambo_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Resonance Handler}
	For various purposes (e.g., shower histories), we should extract the set of
	resonances and resonant channels from a phase-space tree set. A few methods
	do kinematics calculations specifically for those resonance data.
	<<[[resonances.f90]]>>=
	<<File header>>

	module resonances

	<<Use kinds>>
	<<Use strings>>
	use lorentz
	use model_data, only: model_data_t
	use flavors, only: flavor_t

	<<Standard module head>>

	<<Resonances: public>>

	<<Resonances: parameters>>

	<<Resonances: types>>

	interface
	<<Resonances: sub interfaces>>
	end interface

	end module resonances
	@ %def resonances
	@
	<<[[resonances_sub.f90]]>>=
	<<File header>>

	submodule (resonances) resonances_s

	<<Use debug>>
	use string_utils, only: str
	use format_utils, only: write_indent
	use constants, only: one
	use io_units
	use diagnostics

	implicit none

	contains

	<<Resonances: procedures>>

	end submodule resonances_s

	@ %def resonances_s
	@
	\subsection{Decay products (contributors)}
	This stores the indices of the particles that contribute to a resonance, i.e.,
	the decay products.
	<<Resonances: public>>=
	public :: resonance_contributors_t
	<<Resonances: types>>=
	type :: resonance_contributors_t
	integer, dimension(:), allocatable :: c
	contains
	<<Resonances: resonance contributors: TBP>>
	end type resonance_contributors_t

	@ %def resonance_contributors_t
	@ Equality (comparison)
	<<Resonances: resonance contributors: TBP>>=
	procedure, private :: resonance_contributors_equal
	generic :: operator(==) => resonance_contributors_equal
	<<Resonances: sub interfaces>>=
	elemental module function resonance_contributors_equal &
	(c1, c2) result (equal)
	logical :: equal
	class(resonance_contributors_t), intent(in) :: c1, c2
	end function resonance_contributors_equal
	<<Resonances: procedures>>=
	elemental module function resonance_contributors_equal &
	(c1, c2) result (equal)
	logical :: equal
	class(resonance_contributors_t), intent(in) :: c1, c2
	equal = allocated (c1%c) .and. allocated (c2%c)
	if (equal) equal = size (c1%c) == size (c2%c)
	if (equal) equal = all (c1%c == c2%c)
	end function resonance_contributors_equal

	@ %def resonance_contributors_equal
	@ Assignment
	<<Resonances: resonance contributors: TBP>>=
	procedure, private :: resonance_contributors_assign
	generic :: assignment(=) => resonance_contributors_assign
	<<Resonances: sub interfaces>>=
	pure module subroutine resonance_contributors_assign &
	(contributors_out, contributors_in)
	class(resonance_contributors_t), intent(inout) :: contributors_out
	class(resonance_contributors_t), intent(in) :: contributors_in
	end subroutine resonance_contributors_assign
	<<Resonances: procedures>>=
	pure module subroutine resonance_contributors_assign &
	(contributors_out, contributors_in)
	class(resonance_contributors_t), intent(inout) :: contributors_out
	class(resonance_contributors_t), intent(in) :: contributors_in
	if (allocated (contributors_out%c)) deallocate (contributors_out%c)
	if (allocated (contributors_in%c)) then
	allocate (contributors_out%c (size (contributors_in%c)))
	contributors_out%c = contributors_in%c
	end if
	end subroutine resonance_contributors_assign

	@ %def resonance_contributors_assign
	@
	\subsection{Resonance info object}
	This data structure augments the set of resonance contributors by a flavor
	object, such that we can perform calculations that take into
	account the particle properties, including mass and width.

	Avoiding nameclash with similar but different [[resonance_t]] of
	[[phs_base]]:
	<<Resonances: public>>=
	public :: resonance_info_t
	<<Resonances: types>>=
	type :: resonance_info_t
	type(flavor_t) :: flavor
	type(resonance_contributors_t) :: contributors
	contains
	<<Resonances: resonance info: TBP>>
	end type resonance_info_t

	@ %def resonance_info_t
	@
	<<Resonances: resonance info: TBP>>=
	procedure :: copy => resonance_info_copy
	<<Resonances: sub interfaces>>=
	module subroutine resonance_info_copy (resonance_in, resonance_out)
	class(resonance_info_t), intent(in) :: resonance_in
	type(resonance_info_t), intent(out) :: resonance_out
	end subroutine resonance_info_copy
	<<Resonances: procedures>>=
	module subroutine resonance_info_copy (resonance_in, resonance_out)
	class(resonance_info_t), intent(in) :: resonance_in
	type(resonance_info_t), intent(out) :: resonance_out
	resonance_out%flavor = resonance_in%flavor
	if (allocated (resonance_in%contributors%c)) then
	associate (c => resonance_in%contributors%c)
	allocate (resonance_out%contributors%c (size (c)))
	resonance_out%contributors%c = c
	end associate
	end if
	end subroutine resonance_info_copy

	@ %def resonance_info_copy
	@
	<<Resonances: resonance info: TBP>>=
	procedure :: write => resonance_info_write
	<<Resonances: sub interfaces>>=
	module subroutine resonance_info_write (resonance, unit, verbose)
	class(resonance_info_t), intent(in) :: resonance
	integer, optional, intent(in) :: unit
	logical, optional, intent(in) :: verbose
	end subroutine resonance_info_write
	<<Resonances: procedures>>=
	module subroutine resonance_info_write (resonance, unit, verbose)
	class(resonance_info_t), intent(in) :: resonance
	integer, optional, intent(in) :: unit
	logical, optional, intent(in) :: verbose
	integer :: u, i
	logical :: verb
	u = given_output_unit (unit); if (u < 0) return
	verb = .true.; if (present (verbose)) verb = verbose
	if (verb) then
	write (u, '(A)', advance='no') "Resonance contributors: "
	else
	write (u, '(1x)', advance="no")
	end if
	if (allocated (resonance%contributors%c)) then
	do i = 1, size(resonance%contributors%c)
	write (u, '(I0,1X)', advance='no') resonance%contributors%c(i)
	end do
	else if (verb) then
	write (u, "(A)", advance="no") "[not allocated]"
	end if
	if (resonance%flavor%is_defined ()) call resonance%flavor%write (u)
	write (u, '(A)')
	end subroutine resonance_info_write

	@ %def resonance_info_write
	@ Create a resonance-info object. The particle info may be available
	in term of a flavor object or as a PDG code; in the latter case we
	have to require a model data object that provides mass and width information.
	<<Resonances: resonance info: TBP>>=
	procedure, private :: resonance_info_init_pdg
	procedure, private :: resonance_info_init_flv
	generic :: init => resonance_info_init_pdg, resonance_info_init_flv
	<<Resonances: sub interfaces>>=
	module subroutine resonance_info_init_pdg &
	(resonance, mom_id, pdg, model, n_out)
	class(resonance_info_t), intent(out) :: resonance
	integer, intent(in) :: mom_id
	integer, intent(in) :: pdg, n_out
	class(model_data_t), intent(in), target :: model
	end subroutine resonance_info_init_pdg
	module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out)
	class(resonance_info_t), intent(out) :: resonance
	integer, intent(in) :: mom_id
	type(flavor_t), intent(in) :: flv
	integer, intent(in) :: n_out
	end subroutine resonance_info_init_flv
	<<Resonances: procedures>>=
	module subroutine resonance_info_init_pdg &
	(resonance, mom_id, pdg, model, n_out)
	class(resonance_info_t), intent(out) :: resonance
	integer, intent(in) :: mom_id
	integer, intent(in) :: pdg, n_out
	class(model_data_t), intent(in), target :: model
	type(flavor_t) :: flv
	if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_pdg")
	call flv%init (pdg, model)
	call resonance%init (mom_id, flv, n_out)
	end subroutine resonance_info_init_pdg

	module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out)
	class(resonance_info_t), intent(out) :: resonance
	integer, intent(in) :: mom_id
	type(flavor_t), intent(in) :: flv
	integer, intent(in) :: n_out
	integer :: i
	logical, dimension(n_out) :: contrib
	integer, dimension(n_out) :: tmp
	if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_flv")
	resonance%flavor = flv
	do i = 1, n_out
	tmp(i) = i
	end do
	contrib = btest (mom_id, tmp - 1)
	allocate (resonance%contributors%c (count (contrib)))
	resonance%contributors%c = pack (tmp, contrib)
	end subroutine resonance_info_init_flv

	@ %def resonance_info_init
	@
	<<Resonances: resonance info: TBP>>=
	procedure, private :: resonance_info_equal
	generic :: operator(==) => resonance_info_equal
	<<Resonances: sub interfaces>>=
	elemental module function resonance_info_equal (r1, r2) result (equal)
	logical :: equal
	class(resonance_info_t), intent(in) :: r1, r2
	end function resonance_info_equal
	<<Resonances: procedures>>=
	elemental module function resonance_info_equal (r1, r2) result (equal)
	logical :: equal
	class(resonance_info_t), intent(in) :: r1, r2
	equal = r1%flavor == r2%flavor .and. r1%contributors == r2%contributors
	end function resonance_info_equal

	@ %def resonance_info_equal
	@ With each resonance region we associate a Breit-Wigner function
	\begin{equation*}
	P = \frac{M_{res}^4}{(s - M_{res}^2)^2 + \Gamma_{res}^2 M_{res}^2},
	\end{equation*}
	where $s$ denotes the invariant mass of the outgoing momenta originating
	from this resonance. Note that the $M_{res}^4$ in the nominator makes
	the mapping a dimensionless quantity.
	<<Resonances: resonance info: TBP>>=
	procedure :: mapping => resonance_info_mapping
	<<Resonances: sub interfaces>>=
	module function resonance_info_mapping (resonance, s) result (bw)
	real(default) :: bw
	class(resonance_info_t), intent(in) :: resonance
	real(default), intent(in) :: s
	end function resonance_info_mapping
	<<Resonances: procedures>>=
	module function resonance_info_mapping (resonance, s) result (bw)
	real(default) :: bw
	class(resonance_info_t), intent(in) :: resonance
	real(default), intent(in) :: s
	real(default) :: m, gamma
	if (resonance%flavor%is_defined ()) then
	m = resonance%flavor%get_mass ()
	gamma = resonance%flavor%get_width ()
	bw = m4 / ((s - m2)2 + gamma2 * m**2)
	else
	bw = one
	end if
	end function resonance_info_mapping

	@ %def resonance_info_mapping
	@ Used for building a resonance tree below.
	<<Resonances: resonance info: TBP>>=
	procedure, private :: get_n_contributors => resonance_info_get_n_contributors
	procedure, private :: contains => resonance_info_contains
	<<Resonances: sub interfaces>>=
	elemental module function resonance_info_get_n_contributors &
	(resonance) result (n)
	class(resonance_info_t), intent(in) :: resonance
	integer :: n
	end function resonance_info_get_n_contributors
	elemental module function resonance_info_contains &
	(resonance, c) result (flag)
	class(resonance_info_t), intent(in) :: resonance
	integer, intent(in) :: c
	logical :: flag
	end function resonance_info_contains
	<<Resonances: procedures>>=
	elemental module function resonance_info_get_n_contributors &
	(resonance) result (n)
	class(resonance_info_t), intent(in) :: resonance
	integer :: n
	if (allocated (resonance%contributors%c)) then
	n = size (resonance%contributors%c)
	else
	n = 0
	end if
	end function resonance_info_get_n_contributors

	elemental module function resonance_info_contains &
	(resonance, c) result (flag)
	class(resonance_info_t), intent(in) :: resonance
	integer, intent(in) :: c
	logical :: flag
	if (allocated (resonance%contributors%c)) then
	flag = any (resonance%contributors%c == c)
	else
	flag = .false.
	end if
	end function resonance_info_contains

	@ %def resonance_info_get_n_contributors
	@ %def resonance_info_contains
	@
	\subsection{Resonance history object}
	This data structure stores a set of resonances, i.e., the resonances that
	appear in a particular Feynman graph or, in the context of phase space, phase
	space diagram.
	<<Resonances: public>>=
	public :: resonance_history_t
	<<Resonances: types>>=
	type :: resonance_history_t
	type(resonance_info_t), dimension(:), allocatable :: resonances
	integer :: n_resonances = 0
	contains
	<<Resonances: resonance history: TBP>>
	end type resonance_history_t

	@ %def resonance_history_t
	@ Clear the resonance history. Assuming that there are no
	pointer-allocated parts, a straightforward [[intent(out)]] will do.
	<<Resonances: resonance history: TBP>>=
	procedure :: clear => resonance_history_clear
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_clear (res_hist)
	class(resonance_history_t), intent(out) :: res_hist
	end subroutine resonance_history_clear
	<<Resonances: procedures>>=
	module subroutine resonance_history_clear (res_hist)
	class(resonance_history_t), intent(out) :: res_hist
	end subroutine resonance_history_clear

	@ %def resonance_history_clear
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: copy => resonance_history_copy
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_copy (res_hist_in, res_hist_out)
	class(resonance_history_t), intent(in) :: res_hist_in
	type(resonance_history_t), intent(out) :: res_hist_out
	end subroutine resonance_history_copy
	<<Resonances: procedures>>=
	module subroutine resonance_history_copy (res_hist_in, res_hist_out)
	class(resonance_history_t), intent(in) :: res_hist_in
	type(resonance_history_t), intent(out) :: res_hist_out
	integer :: i
	res_hist_out%n_resonances = res_hist_in%n_resonances
	allocate (res_hist_out%resonances (size (res_hist_in%resonances)))
	do i = 1, size (res_hist_in%resonances)
	call res_hist_in%resonances(i)%copy (res_hist_out%resonances(i))
	end do
	end subroutine resonance_history_copy

	@ %def resonance_history_copy
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: write => resonance_history_write
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_write (res_hist, unit, verbose, indent)
	class(resonance_history_t), intent(in) :: res_hist
	integer, optional, intent(in) :: unit
	logical, optional, intent(in) :: verbose
	integer, optional, intent(in) :: indent
	end subroutine resonance_history_write
	<<Resonances: procedures>>=
	module subroutine resonance_history_write (res_hist, unit, verbose, indent)
	class(resonance_history_t), intent(in) :: res_hist
	integer, optional, intent(in) :: unit
	logical, optional, intent(in) :: verbose
	integer, optional, intent(in) :: indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write(u, '(A,I0,A)') "Resonance history with ", &
	res_hist%n_resonances, " resonances:"
	do i = 1, res_hist%n_resonances
	call write_indent (u, indent)
	write (u, "(2x)", advance="no")
	call res_hist%resonances(i)%write (u, verbose)
	end do
	end subroutine resonance_history_write

	@ %def resonance_history_write
	@ Assignment. Indirectly calls type-bound assignment for the contributors.

	Strictly speaking, this is redundant. But NAGfor 6.208 intrinsic assignment
	crashes under certain conditions.
	<<Resonances: resonance history: TBP>>=
	procedure, private :: resonance_history_assign
	generic :: assignment(=) => resonance_history_assign
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_assign (res_hist_out, res_hist_in)
	class(resonance_history_t), intent(out) :: res_hist_out
	class(resonance_history_t), intent(in) :: res_hist_in
	end subroutine resonance_history_assign
	<<Resonances: procedures>>=
	module subroutine resonance_history_assign (res_hist_out, res_hist_in)
	class(resonance_history_t), intent(out) :: res_hist_out
	class(resonance_history_t), intent(in) :: res_hist_in
	if (allocated (res_hist_in%resonances)) then
	res_hist_out%resonances = res_hist_in%resonances
	res_hist_out%n_resonances = res_hist_in%n_resonances
	end if
	end subroutine resonance_history_assign

	@ %def resonance_history_assign
	@ Equality. If this turns out to slow down the program, we should
	change the implementation or use hash codes.
	<<Resonances: resonance history: TBP>>=
	procedure, private :: resonance_history_equal
	generic :: operator(==) => resonance_history_equal
	<<Resonances: sub interfaces>>=
	elemental module function resonance_history_equal (rh1, rh2) result (equal)
	logical :: equal
	class(resonance_history_t), intent(in) :: rh1, rh2
	end function resonance_history_equal
	<<Resonances: procedures>>=
	elemental module function resonance_history_equal (rh1, rh2) result (equal)
	logical :: equal
	class(resonance_history_t), intent(in) :: rh1, rh2
	integer :: i
	equal = .false.
	if (rh1%n_resonances == rh2%n_resonances) then
	do i = 1, rh1%n_resonances
	if (.not. rh1%resonances(i) == rh2%resonances(i)) then
	return
	end if
	end do
	equal = .true.
	end if
	end function resonance_history_equal

	@ %def resonance_history_equal
	@ Check if a resonance history is a strict superset of another one. This is
	true if the first one is nonempty and the second one is empty.
	Otherwise, we check if each entry of the second argument appears in
	the first one.
	<<Resonances: resonance history: TBP>>=
	procedure, private :: resonance_history_contains
	generic :: operator(.contains.) => resonance_history_contains
	<<Resonances: sub interfaces>>=
	elemental module function resonance_history_contains &
	(rh1, rh2) result (flag)
	logical :: flag
	class(resonance_history_t), intent(in) :: rh1, rh2
	end function resonance_history_contains
	<<Resonances: procedures>>=
	elemental module function resonance_history_contains &
	(rh1, rh2) result (flag)
	logical :: flag
	class(resonance_history_t), intent(in) :: rh1, rh2
	integer :: i
	if (rh1%n_resonances > rh2%n_resonances) then
	flag = .true.
	do i = 1, rh2%n_resonances
	flag = flag .and. any (rh1%resonances == rh2%resonances(i))
	end do
	else
	flag = .false.
	end if
	end function resonance_history_contains

	@ %def resonance_history_contains
	@ Number of entries for dynamically extending the resonance-info array.
	<<Resonances: parameters>>=
	integer, parameter :: n_max_resonances = 10
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: add_resonance => resonance_history_add_resonance
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_add_resonance (res_hist, resonance)
	class(resonance_history_t), intent(inout) :: res_hist
	type(resonance_info_t), intent(in) :: resonance
	end subroutine resonance_history_add_resonance
	<<Resonances: procedures>>=
	module subroutine resonance_history_add_resonance (res_hist, resonance)
	class(resonance_history_t), intent(inout) :: res_hist
	type(resonance_info_t), intent(in) :: resonance
	type(resonance_info_t), dimension(:), allocatable :: tmp
	integer :: n, i
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "resonance_history_add_resonance")
	if (.not. allocated (res_hist%resonances)) then
	n = 0
	allocate (res_hist%resonances (1))
	else
	n = res_hist%n_resonances
	allocate (tmp (n))
	do i = 1, n
	call res_hist%resonances(i)%copy (tmp(i))
	end do
	deallocate (res_hist%resonances)
	allocate (res_hist%resonances (n+1))
	do i = 1, n
	call tmp(i)%copy (res_hist%resonances(i))
	end do
	deallocate (tmp)
	end if
	call resonance%copy (res_hist%resonances(n+1))
	res_hist%n_resonances = n + 1
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "res_hist%n_resonances", res_hist%n_resonances)
	end subroutine resonance_history_add_resonance

	@ %def resonance_history_add_resonance
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: remove_resonance => resonance_history_remove_resonance
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_remove_resonance (res_hist, i_res)
	class(resonance_history_t), intent(inout) :: res_hist
	integer, intent(in) :: i_res
	end subroutine resonance_history_remove_resonance
	<<Resonances: procedures>>=
	module subroutine resonance_history_remove_resonance (res_hist, i_res)
	class(resonance_history_t), intent(inout) :: res_hist
	integer, intent(in) :: i_res
	type(resonance_info_t), dimension(:), allocatable :: tmp_1, tmp_2
	integer :: i, j, n
	n = res_hist%n_resonances
	res_hist%n_resonances = n - 1
	if (res_hist%n_resonances == 0) then
	deallocate (res_hist%resonances)
	else
	if (i_res > 1) allocate (tmp_1(1:i_res-1))
	if (i_res < n) allocate (tmp_2(i_res+1:n))
	if (allocated (tmp_1)) then
	do i = 1, i_res - 1
	call res_hist%resonances(i)%copy (tmp_1(i))
	end do
	end if
	if (allocated (tmp_2)) then
	do i = i_res + 1, n
	call res_hist%resonances(i)%copy (tmp_2(i))
	end do
	end if
	deallocate (res_hist%resonances)
	allocate (res_hist%resonances (res_hist%n_resonances))
	j = 1
	if (allocated (tmp_1)) then
	do i = 1, i_res - 1
	call tmp_1(i)%copy (res_hist%resonances(j))
	j = j + 1
	end do
	deallocate (tmp_1)
	end if
	if (allocated (tmp_2)) then
	do i = i_res + 1, n
	call tmp_2(i)%copy (res_hist%resonances(j))
	j = j + 1
	end do
	deallocate (tmp_2)
	end if
	end if
	end subroutine resonance_history_remove_resonance

	@ %def resonance_history_remove_resonance
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: add_offset => resonance_history_add_offset
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_add_offset (res_hist, n)
	class(resonance_history_t), intent(inout) :: res_hist
	integer, intent(in) :: n
	end subroutine resonance_history_add_offset
	<<Resonances: procedures>>=
	module subroutine resonance_history_add_offset (res_hist, n)
	class(resonance_history_t), intent(inout) :: res_hist
	integer, intent(in) :: n
	integer :: i_res
	do i_res = 1, res_hist%n_resonances
	associate (contributors => res_hist%resonances(i_res)%contributors%c)
	contributors = contributors + n
	end associate
	end do
	end subroutine resonance_history_add_offset

	@ %def resonance_history_add_offset
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: contains_leg => resonance_history_contains_leg
	<<Resonances: sub interfaces>>=
	module function resonance_history_contains_leg &
	(res_hist, i_leg) result (val)
	logical :: val
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: i_leg
	end function resonance_history_contains_leg
	<<Resonances: procedures>>=
	module function resonance_history_contains_leg &
	(res_hist, i_leg) result (val)
	logical :: val
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: i_leg
	integer :: i_res
	val = .false.
	do i_res = 1, res_hist%n_resonances
	if (any (res_hist%resonances(i_res)%contributors%c == i_leg)) then
	val = .true.
	exit
	end if
	end do
	end function resonance_history_contains_leg

	@ %def resonance_history_contains_leg
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: mapping => resonance_history_mapping
	<<Resonances: sub interfaces>>=
	module function resonance_history_mapping &
	(res_hist, p, i_gluon) result (p_map)
	real(default) :: p_map
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), intent(in), dimension(:) :: p
	integer, intent(in), optional :: i_gluon
	end function resonance_history_mapping
	<<Resonances: procedures>>=
	module function resonance_history_mapping &
	(res_hist, p, i_gluon) result (p_map)
	real(default) :: p_map
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), intent(in), dimension(:) :: p
	integer, intent(in), optional :: i_gluon
	integer :: i_res
	real(default) :: s
	p_map = one
	do i_res = 1, res_hist%n_resonances
	associate (res => res_hist%resonances(i_res))
	s = compute_resonance_mass (p, res%contributors%c, i_gluon)**2
	p_map = p_map * res%mapping (s)
	end associate
	end do
	end function resonance_history_mapping

	@ %def resonance_history_mapping
	@ This predicate is true if all resonances in the history have exactly
	[[n]] contributors. For instance, if $n=2$, all resonances have a
	two-particle decay.
	<<Resonances: resonance history: TBP>>=
	procedure :: only_has_n_contributors => &
	resonance_history_only_has_n_contributors
	<<Resonances: sub interfaces>>=
	module function resonance_history_only_has_n_contributors &
	(res_hist, n) result (value)
	logical :: value
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: n
	end function resonance_history_only_has_n_contributors
	<<Resonances: procedures>>=
	module function resonance_history_only_has_n_contributors &
	(res_hist, n) result (value)
	logical :: value
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: n
	integer :: i_res
	value = .true.
	do i_res = 1, res_hist%n_resonances
	associate (res => res_hist%resonances(i_res))
	value = value .and. size (res%contributors%c) == n
	end associate
	end do
	end function resonance_history_only_has_n_contributors

	@ %def resonance_history_only_has_n_contributors
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: has_flavor => resonance_history_has_flavor
	<<Resonances: sub interfaces>>=
	module function resonance_history_has_flavor &
	(res_hist, flv) result (has_flv)
	logical :: has_flv
	class(resonance_history_t), intent(in) :: res_hist
	type(flavor_t), intent(in) :: flv
	end function resonance_history_has_flavor
	<<Resonances: procedures>>=
	module function resonance_history_has_flavor &
	(res_hist, flv) result (has_flv)
	logical :: has_flv
	class(resonance_history_t), intent(in) :: res_hist
	type(flavor_t), intent(in) :: flv
	integer :: i
	has_flv = .false.
	do i = 1, res_hist%n_resonances
	has_flv = has_flv .or. res_hist%resonances(i)%flavor == flv
	end do
	end function resonance_history_has_flavor

	@ %def resonance_history_has_flavor
	@
	\subsection{Kinematics}
	Evaluate the distance from a resonance. The distance is given by
	$\|p^2-m^2\|/(m\Gamma)$. For $\Gamma\ll m$, this is the relative
	distance from the resonance peak in units of the half-width.
	<<Resonances: resonance info: TBP>>=
	procedure :: evaluate_distance => resonance_info_evaluate_distance
	<<Resonances: sub interfaces>>=
	module subroutine resonance_info_evaluate_distance (res_info, p, dist)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(out) :: dist
	end subroutine resonance_info_evaluate_distance
	<<Resonances: procedures>>=
	module subroutine resonance_info_evaluate_distance (res_info, p, dist)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(out) :: dist
	real(default) :: m, w
	type(vector4_t) :: q
	m = res_info%flavor%get_mass ()
	w = res_info%flavor%get_width ()
	q = sum (p(res_info%contributors%c))
	dist = abs (q2 - m2) / (m * w)
	end subroutine resonance_info_evaluate_distance

	@ %def resonance_info_evaluate_distance
	@
	Evaluate the array of distances from a resonance history. We assume that the
	array has been allocated with correct size, namely the number of resonances in
	this history.
	<<Resonances: resonance history: TBP>>=
	procedure :: evaluate_distances => resonance_history_evaluate_distances
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_evaluate_distances (res_hist, p, dist)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), dimension(:), intent(out) :: dist
	end subroutine resonance_history_evaluate_distances
	<<Resonances: procedures>>=
	module subroutine resonance_history_evaluate_distances (res_hist, p, dist)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), dimension(:), intent(out) :: dist
	integer :: i
	do i = 1, res_hist%n_resonances
	call res_hist%resonances(i)%evaluate_distance (p, dist(i))
	end do
	end subroutine resonance_history_evaluate_distances

	@ %def resonance_history_evaluate_distances
	@ Use the distance to determine a Gaussian turnoff factor for a
	resonance. The factor is given by a Gaussian function
	$e^{-d^2/\sigma^2}$, where $\sigma$ is the [[gw]] parameter multiplied
	by the resonance width, and $d$ is the distance (see above). So, for
	$d=\sigma$, the factor is $0.37$, and for $d=2\sigma$ we get $0.018$.

	If the [[gw]] factor is less or equal to zero, return $1$.
	<<Resonances: resonance info: TBP>>=
	procedure :: evaluate_gaussian => resonance_info_evaluate_gaussian
	<<Resonances: sub interfaces>>=
	module function resonance_info_evaluate_gaussian &
	(res_info, p, gw) result (factor)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	real(default) :: factor
	end function resonance_info_evaluate_gaussian
	<<Resonances: procedures>>=
	module function resonance_info_evaluate_gaussian &
	(res_info, p, gw) result (factor)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	real(default) :: factor
	real(default) :: dist, w
	if (gw > 0) then
	w = res_info%flavor%get_width ()
	call res_info%evaluate_distance (p, dist)
	factor = exp (- (dist / (gw * w)) **2)
	else
	factor = 1
	end if
	end function resonance_info_evaluate_gaussian

	@ %def resonance_info_evaluate_gaussian
	@ The Gaussian factor of the history is the product of all factors.
	<<Resonances: resonance history: TBP>>=
	procedure :: evaluate_gaussian => resonance_history_evaluate_gaussian
	<<Resonances: sub interfaces>>=
	module function resonance_history_evaluate_gaussian &
	(res_hist, p, gw) result (factor)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	real(default) :: factor
	end function resonance_history_evaluate_gaussian
	<<Resonances: procedures>>=
	module function resonance_history_evaluate_gaussian &
	(res_hist, p, gw) result (factor)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	real(default), dimension(:), allocatable :: dist
	real(default) :: factor
	integer :: i
	factor = 1
	do i = 1, res_hist%n_resonances
	factor = factor * res_hist%resonances(i)%evaluate_gaussian (p, gw)
	end do
	end function resonance_history_evaluate_gaussian

	@ %def resonance_history_evaluate_gaussian
	@
	Use the distances to determine whether the resonance history can qualify as
	on-shell. The criterion is whether the distance is greater than the number of
	width values as given by [[on_shell_limit]].
	<<Resonances: resonance info: TBP>>=
	procedure :: is_on_shell => resonance_info_is_on_shell
	<<Resonances: sub interfaces>>=
	module function resonance_info_is_on_shell (res_info, p, on_shell_limit) &
	result (flag)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	logical :: flag
	end function resonance_info_is_on_shell
	<<Resonances: procedures>>=
	module function resonance_info_is_on_shell (res_info, p, on_shell_limit) &
	result (flag)
	class(resonance_info_t), intent(in) :: res_info
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	logical :: flag
	real(default) :: dist
	call res_info%evaluate_distance (p, dist)
	flag = dist < on_shell_limit
	end function resonance_info_is_on_shell

	@ %def resonance_info_is_on_shell
	@
	<<Resonances: resonance history: TBP>>=
	procedure :: is_on_shell => resonance_history_is_on_shell
	<<Resonances: sub interfaces>>=
	module function resonance_history_is_on_shell &
	(res_hist, p, on_shell_limit) result (flag)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	logical :: flag
	end function resonance_history_is_on_shell
	<<Resonances: procedures>>=
	module function resonance_history_is_on_shell &
	(res_hist, p, on_shell_limit) result (flag)
	class(resonance_history_t), intent(in) :: res_hist
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	logical :: flag
	integer :: i
	flag = .true.
	do i = 1, res_hist%n_resonances
	flag = flag .and. res_hist%resonances(i)%is_on_shell (p, on_shell_limit)
	end do
	end function resonance_history_is_on_shell

	@ %def resonance_history_is_on_shell
	@
	\subsection{OMega restriction strings}
	One application of the resonance module is creating restriction
	strings that can be fed into process definitions with the OMega
	generator. Since OMega counts the incoming particles first, we have
	to supply [[n_in]] as an offset.
	<<Resonances: resonance info: TBP>>=
	procedure :: as_omega_string => resonance_info_as_omega_string
	<<Resonances: resonance history: TBP>>=
	procedure :: as_omega_string => resonance_history_as_omega_string
	<<Resonances: sub interfaces>>=
	module function resonance_info_as_omega_string &
	(res_info, n_in) result (string)
	class(resonance_info_t), intent(in) :: res_info
	integer, intent(in) :: n_in
	type(string_t) :: string
	end function resonance_info_as_omega_string
	module function resonance_history_as_omega_string &
	(res_hist, n_in) result (string)
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: n_in
	type(string_t) :: string
	end function resonance_history_as_omega_string
	<<Resonances: procedures>>=
	module function resonance_info_as_omega_string &
	(res_info, n_in) result (string)
	class(resonance_info_t), intent(in) :: res_info
	integer, intent(in) :: n_in
	type(string_t) :: string
	integer :: i
	string = ""
	if (allocated (res_info%contributors%c)) then
	do i = 1, size (res_info%contributors%c)
	if (i > 1) string = string // "+"
	string = string // str (res_info%contributors%c(i) + n_in)
	end do
	string = string // "~" // res_info%flavor%get_name ()
	end if
	end function resonance_info_as_omega_string

	module function resonance_history_as_omega_string &
	(res_hist, n_in) result (string)
	class(resonance_history_t), intent(in) :: res_hist
	integer, intent(in) :: n_in
	type(string_t) :: string
	integer :: i
	string = ""
	do i = 1, res_hist%n_resonances
	if (i > 1) string = string // " && "
	string = string // res_hist%resonances(i)%as_omega_string (n_in)
	end do
	end function resonance_history_as_omega_string

	@ %def resonance_info_as_omega_string
	@ %def resonance_history_as_omega_string
	@
	\subsection{Resonance history as tree}
	If we want to organize the resonances and their decay products, it can be
	useful to have them explicitly as a tree structure. We implement this in the
	traditional event-record form with the resonances sorted by decreasing number
	of contributors, and their decay products added as an extra array.
	<<Resonances: public>>=
	public :: resonance_tree_t
	<<Resonances: types>>=
	type :: resonance_branch_t
	integer :: i = 0
	type(flavor_t) :: flv
	integer, dimension(:), allocatable :: r_child
	integer, dimension(:), allocatable :: o_child
	end type resonance_branch_t

	type :: resonance_tree_t
	private
	integer :: n = 0
	type(resonance_branch_t), dimension(:), allocatable :: branch
	contains
	<<Resonances: resonance tree: TBP>>
	end type resonance_tree_t


	@ %def resonance_branch_t resonance_tree_t
	@
	<<Resonances: resonance tree: TBP>>=
	procedure :: write => resonance_tree_write
	<<Resonances: sub interfaces>>=
	module subroutine resonance_tree_write (tree, unit, indent)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in), optional :: unit, indent
	end subroutine resonance_tree_write
	<<Resonances: procedures>>=
	module subroutine resonance_tree_write (tree, unit, indent)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in), optional :: unit, indent
	integer :: u, b, c
	u = given_output_unit (unit)
	call write_indent (u, indent)
	write (u, "(A)", advance="no") "Resonance tree:"
	if (tree%n > 0) then
	write (u, *)
	do b = 1, tree%n
	call write_indent (u, indent)
	write (u, "(2x,'r',I0,':',1x)", advance="no") b
	associate (branch => tree%branch(b))
	call branch%flv%write (u)
	write (u, "(1x,'=>')", advance="no")
	if (allocated (branch%r_child)) then
	do c = 1, size (branch%r_child)
	write (u, "(1x,'r',I0)", advance="no") branch%r_child(c)
	end do
	end if
	if (allocated (branch%o_child)) then
	do c = 1, size (branch%o_child)
	write (u, "(1x,I0)", advance="no") branch%o_child(c)
	end do
	end if
	write (u, *)
	end associate
	end do
	else
	write (u, "(1x,A)") "[empty]"
	end if
	end subroutine resonance_tree_write

	@ %def resonance_tree_write
	@ Contents.
	<<Resonances: resonance tree: TBP>>=
	procedure :: get_n_resonances => resonance_tree_get_n_resonances
	procedure :: get_flv => resonance_tree_get_flv
	<<Resonances: sub interfaces>>=
	module function resonance_tree_get_n_resonances (tree) result (n)
	class(resonance_tree_t), intent(in) :: tree
	integer :: n
	end function resonance_tree_get_n_resonances
	module function resonance_tree_get_flv (tree, i) result (flv)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in) :: i
	type(flavor_t) :: flv
	end function resonance_tree_get_flv
	<<Resonances: procedures>>=
	module function resonance_tree_get_n_resonances (tree) result (n)
	class(resonance_tree_t), intent(in) :: tree
	integer :: n
	n = tree%n
	end function resonance_tree_get_n_resonances

	module function resonance_tree_get_flv (tree, i) result (flv)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in) :: i
	type(flavor_t) :: flv
	flv = tree%branch(i)%flv
	end function resonance_tree_get_flv

	@ %def resonance_tree_get_n_resonances
	@ %def resonance_tree_get_flv
	@ Return the shifted indices of the resonance children for branch [[i]]. For
	a child which is itself a resonance, add [[offset_r]] to the index value. For
	the others, add [[offset_o]]. Combine both in a single array.
	<<Resonances: resonance tree: TBP>>=
	procedure :: get_children => resonance_tree_get_children
	<<Resonances: sub interfaces>>=
	module function resonance_tree_get_children (tree, i, offset_r, offset_o) &
	result (child)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in) :: i, offset_r, offset_o
	integer, dimension(:), allocatable :: child
	end function resonance_tree_get_children
	<<Resonances: procedures>>=
	module function resonance_tree_get_children (tree, i, offset_r, offset_o) &
	result (child)
	class(resonance_tree_t), intent(in) :: tree
	integer, intent(in) :: i, offset_r, offset_o
	integer, dimension(:), allocatable :: child
	integer :: nr, no
	associate (branch => tree%branch(i))
	nr = size (branch%r_child)
	no = size (branch%o_child)
	allocate (child (nr + no))
	child(1:nr) = branch%r_child + offset_r
	child(nr+1:nr+no) = branch%o_child + offset_o
	end associate
	end function resonance_tree_get_children

	@ %def resonance_tree_get_children
	@ Transform a resonance history into a resonance tree.
	Algorithm:
	\begin{enumerate}
	\item
	Determine a mapping of the resonance array, such that in the new array the
	resonances are ordered by decreasing number of contributors.
	\item
	Copy the flavor entries to the mapped array.
	\item
	Scan all resonances and, for each one, find a resonance that is its parent.
	Since the resonances are ordered, later matches overwrite earlier ones. The
	last match is the correct one. Then scan again and, for each resonance,
	collect the resonances that have it as parent. This is the set of child
	resonances.
	\item
	Analogously, scan all outgoing particles that appear in any of the
	contributors list. Determine their immediate parent as above, and set the
	child outgoing parents for the resonances, as above.
	\end{enumerate}
	<<Resonances: resonance history: TBP>>=
	procedure :: to_tree => resonance_history_to_tree
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_to_tree (res_hist, tree)
	class(resonance_history_t), intent(in) :: res_hist
	type(resonance_tree_t), intent(out) :: tree
	end subroutine resonance_history_to_tree
	<<Resonances: procedures>>=
	module subroutine resonance_history_to_tree (res_hist, tree)
	class(resonance_history_t), intent(in) :: res_hist
	type(resonance_tree_t), intent(out) :: tree
	integer :: nr
	integer, dimension(:), allocatable :: r_branch, r_source

	nr = res_hist%n_resonances
	tree%n = nr
	allocate (tree%branch (tree%n), r_branch (tree%n), r_source (tree%n))
	if (tree%n > 0) then
	call find_branch_ordering ()
	call set_flavors ()
	call set_child_resonances ()
	call set_child_outgoing ()
	end if

	contains

	subroutine find_branch_ordering ()
	integer, dimension(:), allocatable :: nc_array
	integer :: r, ir, nc
	allocate (nc_array (tree%n))
	nc_array(:) = res_hist%resonances%get_n_contributors ()
	ir = 0
	do nc = maxval (nc_array), minval (nc_array), -1
	do r = 1, nr
	if (nc_array(r) == nc) then
	ir = ir + 1
	r_branch(r) = ir
	r_source(ir) = r
	end if
	end do
	end do
	end subroutine find_branch_ordering

	subroutine set_flavors ()
	integer :: r
	do r = 1, nr
	tree%branch(r_branch(r))%flv = res_hist%resonances(r)%flavor
	end do
	end subroutine set_flavors

	subroutine set_child_resonances ()
	integer, dimension(:), allocatable :: r_child, r_parent
	integer :: r, ir, pr
	allocate (r_parent (nr), source = 0)
	SCAN_RES: do r = 1, nr
	associate (this_res => res_hist%resonances(r))
	SCAN_PARENT: do ir = 1, nr
	pr = r_source(ir)
	if (pr == r) cycle SCAN_PARENT
	if (all (res_hist%resonances(pr)%contains &
	(this_res%contributors%c))) then
	r_parent (r) = pr
	end if
	end do SCAN_PARENT
	end associate
	end do SCAN_RES
	allocate (r_child (nr), source = [(r, r = 1, nr)])
	do r = 1, nr
	ir = r_branch(r)
	tree%branch(ir)%r_child = r_branch (pack (r_child, r_parent == r))
	end do
	end subroutine set_child_resonances

	subroutine set_child_outgoing ()
	integer, dimension(:), allocatable :: o_child, o_parent
	integer :: o_max, r, o, ir
	o_max = 0
	do r = 1, nr
	associate (this_res => res_hist%resonances(r))
	o_max = max (o_max, maxval (this_res%contributors%c))
	end associate
	end do
	allocate (o_parent (o_max), source=0)
	SCAN_OUT: do o = 1, o_max
	SCAN_PARENT: do ir = 1, nr
	r = r_source(ir)
	associate (this_res => res_hist%resonances(r))
	if (this_res%contains (o)) o_parent(o) = r
	end associate
	end do SCAN_PARENT
	end do SCAN_OUT
	allocate (o_child (o_max), source = [(o, o = 1, o_max)])
	do r = 1, nr
	ir = r_branch(r)
	tree%branch(ir)%o_child = pack (o_child, o_parent == r)
	end do
	end subroutine set_child_outgoing

	end subroutine resonance_history_to_tree

	@ %def resonance_history_to_tree
	@
	\subsection{Resonance history set}
	This is an array of resonance histories. The elements are supposed to
	be unique. That is, entering a new element is successful only if the
	element does not already exist.

	The current implementation uses a straightforward linear search for
	comparison. If this should become an issue, we may change the
	implementation to a hash table. To keep this freedom, the set should
	be an opaque object. In fact, we expect to use it as a transient data
	structure. Once the set is complete, we transform it into a
	contiguous array.
	<<Resonances: public>>=
	public :: resonance_history_set_t
	<<Resonances: types>>=
	type :: index_array_t
	integer, dimension(:), allocatable :: i
	end type index_array_t

	type :: resonance_history_set_t
	private
	logical :: complete = .false.
	integer :: n_filter = 0
	type(resonance_history_t), dimension(:), allocatable :: history
	type(index_array_t), dimension(:), allocatable :: contains_this
	type(resonance_tree_t), dimension(:), allocatable :: tree
	integer :: last = 0
	contains
	<<Resonances: resonance history set: TBP>>
	end type resonance_history_set_t

	@ %def resonance_history_set_t
	@ Display.

	The tree-format version of the histories is displayed only upon request.
	<<Resonances: resonance history set: TBP>>=
	procedure :: write => resonance_history_set_write
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_write &
	(res_set, unit, indent, show_trees)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: indent
	logical, intent(in), optional :: show_trees
	end subroutine resonance_history_set_write
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_write &
	(res_set, unit, indent, show_trees)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: indent
	logical, intent(in), optional :: show_trees
	logical :: s_trees
	integer :: u, i, j, ind
	u = given_output_unit (unit)
	s_trees = .false.; if (present (show_trees)) s_trees = show_trees
	ind = 0; if (present (indent)) ind = indent
	call write_indent (u, indent)
	write (u, "(A)", advance="no") "Resonance history set:"
	if (res_set%complete) then
	write (u, *)
	else
	write (u, "(1x,A)") "[incomplete]"
	end if
	do i = 1, res_set%last
	write (u, "(1x,I0,1x)", advance="no") i
	call res_set%history(i)%write (u, verbose=.false., indent=indent)
	if (allocated (res_set%contains_this)) then
	call write_indent (u, indent)
	write (u, "(3x,A)", advance="no") "contained in ("
	do j = 1, size (res_set%contains_this(i)%i)
	if (j>1) write (u, "(',')", advance="no")
	write (u, "(I0)", advance="no") res_set%contains_this(i)%i(j)
	end do
	write (u, "(A)") ")"
	end if
	if (s_trees .and. allocated (res_set%tree)) then
	call res_set%tree(i)%write (u, ind + 1)
	end if
	end do
	end subroutine resonance_history_set_write

	@ %def resonance_history_set_write
	@ Initialization. The default initial size is 16 elements, to be doubled in
	size repeatedly as needed.
	<<Resonances: parameters>>=
	integer, parameter :: resonance_history_set_initial_size = 16
	@ %def resonance_history_set_initial_size = 16
	<<Resonances: resonance history set: TBP>>=
	procedure :: init => resonance_history_set_init
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_init &
	(res_set, n_filter, initial_size)
	class(resonance_history_set_t), intent(out) :: res_set
	integer, intent(in), optional :: n_filter
	integer, intent(in), optional :: initial_size
	end subroutine resonance_history_set_init
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_init &
	(res_set, n_filter, initial_size)
	class(resonance_history_set_t), intent(out) :: res_set
	integer, intent(in), optional :: n_filter
	integer, intent(in), optional :: initial_size
	if (present (n_filter)) res_set%n_filter = n_filter
	if (present (initial_size)) then
	allocate (res_set%history (initial_size))
	else
	allocate (res_set%history (resonance_history_set_initial_size))
	end if
	end subroutine resonance_history_set_init

	@ %def resonance_history_set_init
	@ Enter an entry: append to the array if it does not yet exist, expand
	as needed. If a [[n_filter]] value has been provided, enter the
	resonance only if it fulfils the requirement.

	An empty resonance history is entered only if the [[trivial]] flag is set.
	<<Resonances: resonance history set: TBP>>=
	procedure :: enter => resonance_history_set_enter
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_enter &
	(res_set, res_history, trivial)
	class(resonance_history_set_t), intent(inout) :: res_set
	type(resonance_history_t), intent(in) :: res_history
	logical, intent(in), optional :: trivial
	end subroutine resonance_history_set_enter
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_enter &
	(res_set, res_history, trivial)
	class(resonance_history_set_t), intent(inout) :: res_set
	type(resonance_history_t), intent(in) :: res_history
	logical, intent(in), optional :: trivial
	integer :: i, new
	if (res_history%n_resonances == 0) then
	if (present (trivial)) then
	if (.not. trivial) return
	else
	return
	end if
	end if
	if (res_set%n_filter > 0) then
	if (.not. res_history%only_has_n_contributors (res_set%n_filter)) return
	end if
	do i = 1, res_set%last
	if (res_set%history(i) == res_history) return
	end do
	new = res_set%last + 1
	if (new > size (res_set%history)) call res_set%expand ()
	res_set%history(new) = res_history
	res_set%last = new
	end subroutine resonance_history_set_enter

	@ %def resonance_history_set_enter
	@ Freeze the resonance history set: determine the array that determines
	in which other resonance histories a particular history is contained.

	This can only be done once, and once this is done, no further histories can be
	entered.
	<<Resonances: resonance history set: TBP>>=
	procedure :: freeze => resonance_history_set_freeze
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_freeze (res_set)
	class(resonance_history_set_t), intent(inout) :: res_set
	end subroutine resonance_history_set_freeze
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_freeze (res_set)
	class(resonance_history_set_t), intent(inout) :: res_set
	integer :: i, n, c
	logical, dimension(:), allocatable :: contains_this
	integer, dimension(:), allocatable :: index_array
	n = res_set%last
	allocate (contains_this (n))
	allocate (index_array (n), source = [(i, i=1, n)])
	allocate (res_set%contains_this (n))
	do i = 1, n
	contains_this = resonance_history_contains &
	(res_set%history(1:n), res_set%history(i))
	c = count (contains_this)
	allocate (res_set%contains_this(i)%i (c))
	res_set%contains_this(i)%i = pack (index_array, contains_this)
	end do
	allocate (res_set%tree (n))
	do i = 1, n
	call res_set%history(i)%to_tree (res_set%tree(i))
	end do
	res_set%complete = .true.
	end subroutine resonance_history_set_freeze

	@ %def resonance_history_set_freeze
	@ Determine the histories (in form of their indices in the array) that can be
	considered on-shell, given a set of momenta and a maximum distance. The
	distance from the resonance is measured in multiples of the resonance width.

	Note that the momentum array must only contain the outgoing particles.

	If a particular history is on-shell, but there is another history which
	contains this and also is on-shell, only the latter is retained.
	<<Resonances: resonance history set: TBP>>=
	procedure :: determine_on_shell_histories &
	=> resonance_history_set_determine_on_shell_histories
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_determine_on_shell_histories &
	(res_set, p, on_shell_limit, index_array)
	class(resonance_history_set_t), intent(in) :: res_set
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	integer, dimension(:), allocatable, intent(out) :: index_array
	end subroutine resonance_history_set_determine_on_shell_histories
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_determine_on_shell_histories &
	(res_set, p, on_shell_limit, index_array)
	class(resonance_history_set_t), intent(in) :: res_set
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: on_shell_limit
	integer, dimension(:), allocatable, intent(out) :: index_array
	integer :: n, i
	integer, dimension(:), allocatable :: i_array
	if (res_set%complete) then
	n = res_set%last
	allocate (i_array (n), source=0)
	do i = 1, n
	if (res_set%history(i)%is_on_shell (p, on_shell_limit)) i_array(i) = i
	end do
	do i = 1, n
	if (any (i_array(res_set%contains_this(i)%i) /= 0)) then
	i_array(i) = 0
	end if
	end do
	allocate (index_array (count (i_array /= 0)))
	index_array(:) = pack (i_array, i_array /= 0)
	end if
	end subroutine resonance_history_set_determine_on_shell_histories

	@ %def resonance_history_set_determine_on_shell_histories
	@ For the selected history, compute the Gaussian turnoff factor.
	The turnoff parameter is [[gw]].
	<<Resonances: resonance history set: TBP>>=
	procedure :: evaluate_gaussian => resonance_history_set_evaluate_gaussian
	<<Resonances: sub interfaces>>=
	module function resonance_history_set_evaluate_gaussian &
	(res_set, p, gw, i) result (factor)
	class(resonance_history_set_t), intent(in) :: res_set
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	integer, intent(in) :: i
	real(default) :: factor
	end function resonance_history_set_evaluate_gaussian
	<<Resonances: procedures>>=
	module function resonance_history_set_evaluate_gaussian &
	(res_set, p, gw, i) result (factor)
	class(resonance_history_set_t), intent(in) :: res_set
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), intent(in) :: gw
	integer, intent(in) :: i
	real(default) :: factor
	factor = res_set%history(i)%evaluate_gaussian (p, gw)
	end function resonance_history_set_evaluate_gaussian

	@ %def resonance_history_set_evaluate_gaussian
	@ Return the number of histories. This is zero if there are none, or
	if [[freeze]] has not been called yet.
	<<Resonances: resonance history set: TBP>>=
	procedure :: get_n_history => resonance_history_set_get_n_history
	<<Resonances: sub interfaces>>=
	module function resonance_history_set_get_n_history (res_set) result (n)
	class(resonance_history_set_t), intent(in) :: res_set
	integer :: n
	end function resonance_history_set_get_n_history
	<<Resonances: procedures>>=
	module function resonance_history_set_get_n_history (res_set) result (n)
	class(resonance_history_set_t), intent(in) :: res_set
	integer :: n
	if (res_set%complete) then
	n = res_set%last
	else
	n = 0
	end if
	end function resonance_history_set_get_n_history

	@ %def resonance_history_set_get_n_history
	@ Return a single history.
	<<Resonances: resonance history set: TBP>>=
	procedure :: get_history => resonance_history_set_get_history
	<<Resonances: sub interfaces>>=
	module function resonance_history_set_get_history &
	(res_set, i) result (res_history)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in) :: i
	type(resonance_history_t) :: res_history
	end function resonance_history_set_get_history
	<<Resonances: procedures>>=
	module function resonance_history_set_get_history &
	(res_set, i) result (res_history)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in) :: i
	type(resonance_history_t) :: res_history
	if (res_set%complete .and. i <= res_set%last) then
	res_history = res_set%history(i)
	end if
	end function resonance_history_set_get_history

	@ %def resonance_history_set_get_history
	@ Conversion to a plain array, sized correctly.
	<<Resonances: resonance history set: TBP>>=
	procedure :: to_array => resonance_history_set_to_array
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_to_array (res_set, res_history)
	class(resonance_history_set_t), intent(in) :: res_set
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_history
	end subroutine resonance_history_set_to_array
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_to_array (res_set, res_history)
	class(resonance_history_set_t), intent(in) :: res_set
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_history
	if (res_set%complete) then
	allocate (res_history (res_set%last))
	res_history(:) = res_set%history(1:res_set%last)
	end if
	end subroutine resonance_history_set_to_array

	@ %def resonance_history_set_to_array
	@ Return a selected history in tree form.
	<<Resonances: resonance history set: TBP>>=
	procedure :: get_tree => resonance_history_set_get_tree
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_get_tree (res_set, i, res_tree)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in) :: i
	type(resonance_tree_t), intent(out) :: res_tree
	end subroutine resonance_history_set_get_tree
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_get_tree (res_set, i, res_tree)
	class(resonance_history_set_t), intent(in) :: res_set
	integer, intent(in) :: i
	type(resonance_tree_t), intent(out) :: res_tree
	if (res_set%complete) then
	res_tree = res_set%tree(i)
	end if
	end subroutine resonance_history_set_get_tree

	@ %def resonance_history_set_to_array
	@ Expand: double the size of the array. We do not need this in the API.
	<<Resonances: resonance history set: TBP>>=
	procedure, private :: expand => resonance_history_set_expand
	<<Resonances: sub interfaces>>=
	module subroutine resonance_history_set_expand (res_set)
	class(resonance_history_set_t), intent(inout) :: res_set
	end subroutine resonance_history_set_expand
	<<Resonances: procedures>>=
	module subroutine resonance_history_set_expand (res_set)
	class(resonance_history_set_t), intent(inout) :: res_set
	type(resonance_history_t), dimension(:), allocatable :: history_new
	integer :: s
	s = size (res_set%history)
	allocate (history_new (2 * s))
	history_new(1:s) = res_set%history(1:s)
	call move_alloc (history_new, res_set%history)
	end subroutine resonance_history_set_expand

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

	module resonances_ut
	use unit_tests
	use resonances_uti

	<<Standard module head>>

	<<Resonances: public test>>

	contains

	<<Resonances: test driver>>

	end module resonances_ut
	@ %def resonances_ut
	@
	<<[[resonances_uti.f90]]>>=
	<<File header>>

	module resonances_uti

	<<Use kinds>>
	<<Use strings>>
	use format_defs, only: FMF_12
	use lorentz, only: vector4_t, vector4_at_rest
	use model_data, only: model_data_t
	use flavors, only: flavor_t

	use resonances, only: resonance_history_t

	use resonances

	<<Standard module head>>

	<<Resonances: test declarations>>

	contains

	<<Resonances: tests>>

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

	@ %def resonances_test
	@ Basic operations on a resonance history object.
	<<Resonances: execute tests>>=
	call test (resonances_1, "resonances_1", &
	"check resonance history setup", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_1
	<<Resonances: tests>>=
	subroutine resonances_1 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(model_data_t), target :: model

	write (u, "(A)") "* Test output: resonances_1"
	write (u, "(A)") "* Purpose: test resonance history setup"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Empty resonance history"
	write (u, "(A)")

	call res_history%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Add resonance"
	write (u, "(A)")

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)


	write (u, "(A)")
	write (u, "(A)") "* Add another resonance"
	write (u, "(A)")

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Remove resonance"
	write (u, "(A)")

	call res_history%remove_resonance (1)
	call res_history%write (u)

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

	call model%final ()

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

	end subroutine resonances_1

	@ %def resonances_1
	@ Basic operations on a resonance history object.
	<<Resonances: execute tests>>=
	call test (resonances_2, "resonances_2", &
	"check O'Mega restriction strings", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_2
	<<Resonances: tests>>=
	subroutine resonances_2 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(model_data_t), target :: model
	type(string_t) :: restrictions

	write (u, "(A)") "* Test output: resonances_2"
	write (u, "(A)") "* Purpose: test OMega restrictions strings &
	&for resonance history"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Empty resonance history"
	write (u, "(A)")

	restrictions = res_history%as_omega_string (2)
	write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"

	write (u, "(A)")
	write (u, "(A)") "* Add resonance"
	write (u, "(A)")

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	restrictions = res_history%as_omega_string (2)
	write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"

	write (u, "(A)")
	write (u, "(A)") "* Add another resonance"
	write (u, "(A)")

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	restrictions = res_history%as_omega_string (2)
	write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"

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

	call model%final ()

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

	end subroutine resonances_2

	@ %def resonances_2
	@ Basic operations on a resonance history set.
	<<Resonances: execute tests>>=
	call test (resonances_3, "resonances_3", &
	"check resonance history set", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_3
	<<Resonances: tests>>=
	subroutine resonances_3 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(resonance_history_t), dimension(:), allocatable :: res_histories
	type(resonance_history_set_t) :: res_set
	type(model_data_t), target :: model
	integer :: i

	write (u, "(A)") "* Test output: resonances_3"
	write (u, "(A)") "* Purpose: test resonance history set"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Initialize resonance history set"
	write (u, "(A)")

	call res_set%init (initial_size = 2)

	write (u, "(A)") "* Add resonance histories, one at a time"
	write (u, "(A)")

	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_info%init (7, 25, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_set%freeze ()

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

	call res_set%write (u)

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

	write (u, "(A,1x,I0)") "n_history =", res_set%get_n_history ()

	write (u, "(A)")
	write (u, "(A)") "History #2:"

	res_history = res_set%get_history (2)
	call res_history%write (u, indent=1)
	call res_history%clear ()

	write (u, "(A)")
	write (u, "(A)") "* Result in array form"

	call res_set%to_array (res_histories)
	do i = 1, size (res_histories)
	write (u, *)
	call res_histories(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Re-initialize resonance history set with filter n=2"
	write (u, "(A)")

	call res_set%init (n_filter = 2)

	write (u, "(A)") "* Add resonance histories, one at a time"
	write (u, "(A)")

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	write (u, *)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_set%freeze ()

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

	call res_set%write (u)

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

	call model%final ()

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

	end subroutine resonances_3

	@ %def resonances_3
	@ Probe momenta for resonance histories
	<<Resonances: execute tests>>=
	call test (resonances_4, "resonances_4", &
	"resonance history: distance evaluation", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_4
	<<Resonances: tests>>=
	subroutine resonances_4 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(model_data_t), target :: model
	type(flavor_t) :: fw, fz
	real(default) :: mw, mz, ww, wz
	type(vector4_t), dimension(3) :: p
	real(default), dimension(2) :: dist
	real(default) :: gw, factor
	integer :: i

	write (u, "(A)") "* Test output: resonances_4"
	write (u, "(A)") "* Purpose: test resonance history evaluation"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* W and Z parameters"
	write (u, "(A)")

	call fw%init (24, model)
	call fz%init (23, model)
	mw = fw%get_mass ()
	ww = fw%get_width ()
	mz = fz%get_mass ()
	wz = fz%get_width ()

	write (u, "(A,1x," // FMF_12 // ")") "mW =", mw
	write (u, "(A,1x," // FMF_12 // ")") "wW =", ww
	write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz
	write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz

	write (u, "(A)")
	write (u, "(A)") "* Gaussian width parameter"
	write (u, "(A)")

	gw = 2
	write (u, "(A,1x," // FMF_12 // ")") "gw =", gw

	write (u, "(A)")
	write (u, "(A)") "* Setup resonance histories"
	write (u, "(A)")

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)

	call res_history%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Setup zero momenta"
	write (u, "(A)")

	do i = 1, 3
	call p(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Evaluate distances from resonances"
	write (u, "(A)")

	call res_history%evaluate_distances (p, dist)
	write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
	write (u, "(A,1x," // FMF_12 // ")") "m/w (W) =", mw / ww
	write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)
	write (u, "(A,1x," // FMF_12 // ")") "m/w (Z) =", mz / wz

	write (u, "(A)")
	write (u, "(A)") "* Evaluate Gaussian turnoff factor"
	write (u, "(A)")

	factor = res_history%evaluate_gaussian (p, gw)
	write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor

	write (u, "(A)")
	write (u, "(A)") "* Set momenta on W peak"
	write (u, "(A)")

	p(1) = vector4_at_rest (mw/2)
	p(2) = vector4_at_rest (mw/2)
	do i = 1, 3
	call p(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Evaluate distances from resonances"
	write (u, "(A)")

	call res_history%evaluate_distances (p, dist)
	write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
	write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)
	write (u, "(A,1x," // FMF_12 // ")") "expected =", &
	abs (mz2 - mw2) / (mz*wz)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate Gaussian turnoff factor"
	write (u, "(A)")

	factor = res_history%evaluate_gaussian (p, gw)
	write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor
	write (u, "(A,1x," // FMF_12 // ")") "expected =", &
	exp (- (abs (mz2 - mw2) / (mzwz))2 / (gw wz)**2)

	write (u, "(A)")
	write (u, "(A)") "* Set momenta on both peaks"
	write (u, "(A)")

	p(3) = vector4_at_rest (mz - mw)
	do i = 1, 3
	call p(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Evaluate distances from resonances"
	write (u, "(A)")

	call res_history%evaluate_distances (p, dist)
	write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
	write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate Gaussian turnoff factor"
	write (u, "(A)")

	factor = res_history%evaluate_gaussian (p, gw)
	write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor

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

	call model%final ()

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

	end subroutine resonances_4

	@ %def resonances_4
	@ Probe on-shell test for resonance histories
	<<Resonances: execute tests>>=
	call test (resonances_5, "resonances_5", &
	"resonance history: on-shell test", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_5
	<<Resonances: tests>>=
	subroutine resonances_5 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(resonance_history_set_t) :: res_set
	type(model_data_t), target :: model
	type(flavor_t) :: fw, fz
	real(default) :: mw, mz, ww, wz
	real(default) :: on_shell_limit
	integer, dimension(:), allocatable :: on_shell
	type(vector4_t), dimension(4) :: p

	write (u, "(A)") "* Test output: resonances_5"
	write (u, "(A)") "* Purpose: resonance history on-shell test"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* W and Z parameters"
	write (u, "(A)")

	call fw%init (24, model)
	call fz%init (23, model)
	mw = fw%get_mass ()
	ww = fw%get_width ()
	mz = fz%get_mass ()
	wz = fz%get_width ()

	write (u, "(A,1x," // FMF_12 // ")") "mW =", mw
	write (u, "(A,1x," // FMF_12 // ")") "wW =", ww
	write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz
	write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz

	write (u, "(A)")
	write (u, "(A)") "* On-shell parameter: distance as multiple of width"
	write (u, "(A)")

	on_shell_limit = 3
	write (u, "(A,1x," // FMF_12 // ")") "on-shell limit =", on_shell_limit


	write (u, "(A)")
	write (u, "(A)") "* Setup resonance history set"
	write (u, "(A)")

	call res_set%init ()

	call res_info%init (3, -24, model, 6)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (12, 24, model, 6)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (15, 23, model, 6)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (3, -24, model, 6)
	call res_history%add_resonance (res_info)
	call res_info%init (15, 23, model, 6)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (12, 24, model, 6)
	call res_history%add_resonance (res_info)
	call res_info%init (15, 23, model, 6)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_set%freeze ()
	call res_set%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Setup zero momenta"
	write (u, "(A)")

	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

	write (u, "(A)")
	write (u, "(A)") "* Setup momenta near W- resonance (2 widths off)"
	write (u, "(A)")

	p(1) = vector4_at_rest (82.5_default)
	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

	write (u, "(A)")
	write (u, "(A)") "* Setup momenta near W- resonance (4 widths off)"
	write (u, "(A)")

	p(1) = vector4_at_rest (84.5_default)
	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

	write (u, "(A)")
	write (u, "(A)") "* Setup momenta near Z resonance"
	write (u, "(A)")

	p(1) = vector4_at_rest (45._default)
	p(3) = vector4_at_rest (45._default)
	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

	write (u, "(A)")
	write (u, "(A)") "* Setup momenta near W- and W+ resonances"
	write (u, "(A)")

	p(1) = vector4_at_rest (40._default)
	p(2) = vector4_at_rest (40._default)
	p(3) = vector4_at_rest (40._default)
	p(4) = vector4_at_rest (40._default)
	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

	write (u, "(A)")
	write (u, "(A)") "* Setup momenta near W- and Z resonances, &
	&shadowing single resonances"
	write (u, "(A)")

	p(1) = vector4_at_rest (40._default)
	p(2) = vector4_at_rest (40._default)
	p(3) = vector4_at_rest (10._default)
	p(4) = vector4_at_rest ( 0._default)
	call write_momenta (p)

	call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
	call write_on_shell_histories (on_shell)

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

	call model%final ()

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

	contains

	subroutine write_momenta (p)
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: i
	do i = 1, size (p)
	call p(i)%write (u)
	end do
	end subroutine write_momenta

	subroutine write_on_shell_histories (on_shell)
	integer, dimension(:), intent(in) :: on_shell
	integer :: i
	write (u, *)
	write (u, "(A)", advance="no") "on-shell = ("
	do i = 1, size (on_shell)
	if (i > 1) write (u, "(',')", advance="no")
	write (u, "(I0)", advance="no") on_shell(i)
	end do
	write (u, "(')')")
	end subroutine write_on_shell_histories

	end subroutine resonances_5

	@ %def resonances_5
	@ Organize the resonance history as a tree structure.
	<<Resonances: execute tests>>=
	call test (resonances_6, "resonances_6", &
	"check resonance history setup", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_6
	<<Resonances: tests>>=
	subroutine resonances_6 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(resonance_tree_t) :: res_tree
	type(model_data_t), target :: model

	write (u, "(A)") "* Test output: resonances_6"
	write (u, "(A)") "* Purpose: retrieve resonance histories as trees"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Empty resonance history"
	write (u, "(A)")

	call res_history%write (u)

	write (u, "(A)")
	call res_history%to_tree (res_tree)
	call res_tree%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Single resonance"
	write (u, "(A)")

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)

	write (u, "(A)")
	call res_history%to_tree (res_tree)
	call res_tree%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Nested resonances"
	write (u, "(A)")

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%write (u)

	write (u, "(A)")
	call res_history%to_tree (res_tree)
	call res_tree%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Disjunct resonances"
	write (u, "(A)")

	call res_history%clear ()

	call res_info%init (5, 24, model, 7)
	call res_history%add_resonance (res_info)

	call res_info%init (7, 6, model, 7)
	call res_history%add_resonance (res_info)

	call res_info%init (80, -24, model, 7)
	call res_history%add_resonance (res_info)

	call res_info%init (112, -6, model, 7)
	call res_history%add_resonance (res_info)

	call res_history%write (u)

	write (u, "(A)")
	call res_history%to_tree (res_tree)
	call res_tree%write (u)

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

	call model%final ()

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

	end subroutine resonances_6

	@ %def resonances_6
	@ Basic operations on a resonance history set.
	<<Resonances: execute tests>>=
	call test (resonances_7, "resonances_7", &
	"display tree format of history set elements", &
	u, results)
	<<Resonances: test declarations>>=
	public :: resonances_7
	<<Resonances: tests>>=
	subroutine resonances_7 (u)
	integer, intent(in) :: u
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(resonance_tree_t) :: res_tree
	type(resonance_history_set_t) :: res_set
	type(model_data_t), target :: model
	type(flavor_t) :: flv

	write (u, "(A)") "* Test output: resonances_7"
	write (u, "(A)") "* Purpose: test tree format"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Initialize, fill and freeze resonance history set"
	write (u, "(A)")

	call res_set%init (initial_size = 2)

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_history%clear ()

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (7, 23, model, 5)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_info%init (3, -24, model, 5)
	call res_history%add_resonance (res_info)
	call res_info%init (7, 25, model, 5)
	call res_history%add_resonance (res_info)
	call res_set%enter (res_history)
	call res_history%clear ()

	call res_set%freeze ()

	call res_set%write (u, show_trees = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Extract tree #1"
	write (u, "(A)")

	call res_set%get_tree (1, res_tree)
	call res_tree%write (u)

	write (u, *)
	write (u, "(1x,A,1x,I0)") "n_resonances =", res_tree%get_n_resonances ()

	write (u, *)
	write (u, "(1x,A,1x)", advance="no") "flv(r1) ="
	flv = res_tree%get_flv (1)
	call flv%write (u)
	write (u, *)
	write (u, "(1x,A,1x)", advance="no") "flv(r2) ="
	flv = res_tree%get_flv (2)
	call flv%write (u)
	write (u, *)

	write (u, *)
	write (u, "(1x,A)") "[offset = 2, 4]"
	write (u, "(1x,A,9(1x,I0))") "children(r1) =", &
	res_tree%get_children(1, 2, 4)
	write (u, "(1x,A,9(1x,I0))") "children(r2) =", &
	res_tree%get_children(2, 2, 4)

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

	call model%final ()

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

	end subroutine resonances_7

	@ %def resonances_7
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\clearpage
	\section{Mappings}

	Mappings are objects that encode the transformation of the interval
	$(0,1)$ to a physical variable $m^2$ or $\cos\theta$ (and back), as it
	is used in the phase space parameterization. The mapping objects
	contain fixed parameters, the associated methods implement the mapping
	and inverse mapping operations, including the computation of the
	Jacobian (phase space factor).
	<<[[mappings.f90]]>>=
	<<File header>>

	module mappings

	<<Use kinds>>
	use kinds, only: TC
	<<Use strings>>
	use model_data
	use flavors

	<<Standard module head>>

	<<Mappings: public>>

	<<Mappings: parameters>>

	<<Mappings: types>>

	<<Mappings: interfaces>>

	interface
	<<Mappings: sub interfaces>>
	end interface

	end module mappings
	@ %def mappings
	@
	<<[[mappings_sub.f90]]>>=
	<<File header>>

	submodule (mappings) mappings_s

	use io_units
	use constants, only: pi
	use format_defs, only: FMT_19
	use diagnostics
	use md5

	implicit none

	contains

	<<Mappings: procedures>>

	end submodule mappings_s

	@ %def mappings_s
	@
	\subsection{Default parameters}
	This type holds the default parameters, needed for setting the scale
	in cases where no mass parameter is available. The contents are public.
	<<Mappings: public>>=
	public :: mapping_defaults_t
	<<Mappings: types>>=
	type :: mapping_defaults_t
	real(default) :: energy_scale = 10
	real(default) :: invariant_mass_scale = 10
	real(default) :: momentum_transfer_scale = 10
	logical :: step_mapping = .true.
	logical :: step_mapping_exp = .true.
	logical :: enable_s_mapping = .false.
	contains
	<<Mappings: mapping defaults: TBP>>
	end type mapping_defaults_t

	@ %def mapping_defaults_t
	@ Output.
	<<Mappings: mapping defaults: TBP>>=
	procedure :: write => mapping_defaults_write
	<<Mappings: sub interfaces>>=
	module subroutine mapping_defaults_write (object, unit)
	class(mapping_defaults_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine mapping_defaults_write
	<<Mappings: procedures>>=
	module subroutine mapping_defaults_write (object, unit)
	class(mapping_defaults_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(3x,A," // FMT_19 // ")") "energy scale = ", &
	object%energy_scale
	write (u, "(3x,A," // FMT_19 // ")") "mass scale = ", &
	object%invariant_mass_scale
	write (u, "(3x,A," // FMT_19 // ")") "q scale = ", &
	object%momentum_transfer_scale
	write (u, "(3x,A,L1)") "step mapping = ", &
	object%step_mapping
	write (u, "(3x,A,L1)") "step exp. mode = ", &
	object%step_mapping_exp
	write (u, "(3x,A,L1)") "allow s mapping = ", &
	object%enable_s_mapping
	end subroutine mapping_defaults_write

	@ %def mapping_defaults_write
	@
	<<Mappings: public>>=
	public :: mapping_defaults_md5sum
	<<Mappings: sub interfaces>>=
	module function mapping_defaults_md5sum &
	(mapping_defaults) result (md5sum_map)
	character(32) :: md5sum_map
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	end function mapping_defaults_md5sum
	<<Mappings: procedures>>=
	module function mapping_defaults_md5sum &
	(mapping_defaults) result (md5sum_map)
	character(32) :: md5sum_map
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	integer :: u
	u = free_unit ()
	open (u, status = "scratch")
	write (u, *) mapping_defaults%energy_scale
	write (u, *) mapping_defaults%invariant_mass_scale
	write (u, *) mapping_defaults%momentum_transfer_scale
	write (u, *) mapping_defaults%step_mapping
	write (u, *) mapping_defaults%step_mapping_exp
	write (u, *) mapping_defaults%enable_s_mapping
	rewind (u)
	md5sum_map = md5sum (u)
	close (u)
	end function mapping_defaults_md5sum

	@ %def mapping_defaults_md5sum
	@
	\subsection{The Mapping type}
	Each mapping has a type (e.g., s-channel, infrared), a binary code
	(redundant, but useful for debugging), and a reference particle. The
	flavor code of this particle is stored for bookkeeping reasons, what
	matters are the mass and width of this particle. Furthermore,
	depending on the type, various mapping parameters can be set and used.

	The parameters [[a1]] to [[a3]] (for $m^2$ mappings) and [[b1]] to
	[[b3]] (for $\cos\theta$ mappings) are values that are stored once to
	speed up the calculation, if [[variable_limits]] is false. The exact
	meaning of these parameters depends on the mapping type. The limits
	are fixed if there is a fixed c.m. energy.
	<<Mappings: public>>=
	public :: mapping_t
	<<Mappings: types>>=
	type :: mapping_t
	private
	integer :: type = NO_MAPPING
	integer(TC) :: bincode
	type(flavor_t) :: flv
	real(default) :: mass = 0
	real(default) :: width = 0
	logical :: a_unknown = .true.
	real(default) :: a1 = 0
	real(default) :: a2 = 0
	real(default) :: a3 = 0
	logical :: b_unknown = .true.
	real(default) :: b1 = 0
	real(default) :: b2 = 0
	real(default) :: b3 = 0
	logical :: variable_limits = .true.
	contains
	<<Mappings: mapping: TBP>>
	end type mapping_t

	@ %def mapping_t
	@ The valid mapping types. The extra type [[STEP_MAPPING]] is used
	only internally.
	<<Mappings: parameters>>=
	<<Mapping modes>>
	@
	\subsection{Screen output}
	Do not write empty mappings.
	<<Mappings: mapping: TBP>>=
	procedure :: write => mapping_write
	<<Mappings: sub interfaces>>=
	module subroutine mapping_write (map, unit, verbose)
	class(mapping_t), intent(in) :: map
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine mapping_write
	<<Mappings: procedures>>=
	module subroutine mapping_write (map, unit, verbose)
	class(mapping_t), intent(in) :: map
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	character(len=9) :: str
	u = given_output_unit (unit); if (u < 0) return
	select case(map%type)
	case(S_CHANNEL); str = "s_channel"
	case(COLLINEAR); str = "collinear"
	case(INFRARED); str = "infrared "
	case(RADIATION); str = "radiation"
	case(T_CHANNEL); str = "t_channel"
	case(U_CHANNEL); str = "u_channel"
	case(STEP_MAPPING_E); str = "step_exp"
	case(STEP_MAPPING_H); str = "step_hyp"
	case(ON_SHELL); str = "on_shell"
	case default; str = "????????"
	end select
	if (map%type /= NO_MAPPING) then
	write (u, '(1x,A,I4,A)') &
	"Branch #", map%bincode, ": " // &
	"Mapping (" // str // ") for particle " // &
	'"' // char (map%flv%get_name ()) // '"'
	if (present (verbose)) then
	if (verbose) then
	select case (map%type)
	case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
	write (u, "(1x,A,3(" // FMT_19 // "))") &
	" m/w = ", map%mass, map%width
	case default
	write (u, "(1x,A,3(" // FMT_19 // "))") &
	" m = ", map%mass
	end select
	select case (map%type)
	case (S_CHANNEL, T_CHANNEL, U_CHANNEL, &
	STEP_MAPPING_E, STEP_MAPPING_H, &
	COLLINEAR, INFRARED, RADIATION)
	write (u, "(1x,A,3(" // FMT_19 // "))") &
	" a1/2/3 = ", map%a1, map%a2, map%a3
	end select
	select case (map%type)
	case (T_CHANNEL, U_CHANNEL, COLLINEAR)
	write (u, "(1x,A,3(" // FMT_19 // "))") &
	" b1/2/3 = ", map%b1, map%b2, map%b3
	end select
	end if
	end if
	end if
	end subroutine mapping_write

	@ %def mapping_write
	@
	\subsection{Define a mapping}
	The initialization routine sets the mapping type and the particle
	(binary code and flavor code) for which the mapping applies (e.g., a
	$Z$ resonance in branch \#3).
	<<Mappings: mapping: TBP>>=
	procedure :: init => mapping_init
	<<Mappings: sub interfaces>>=
	module subroutine mapping_init (mapping, bincode, type, f, model)
	class(mapping_t), intent(inout) :: mapping
	integer(TC), intent(in) :: bincode
	type(string_t), intent(in) :: type
	integer, intent(in), optional :: f
	class(model_data_t), intent(in), optional, target :: model
	end subroutine mapping_init
	<<Mappings: procedures>>=
	module subroutine mapping_init (mapping, bincode, type, f, model)
	class(mapping_t), intent(inout) :: mapping
	integer(TC), intent(in) :: bincode
	type(string_t), intent(in) :: type
	integer, intent(in), optional :: f
	class(model_data_t), intent(in), optional, target :: model
	mapping%bincode = bincode
	select case (char (type))
	case ("s_channel"); mapping%type = S_CHANNEL
	case ("collinear"); mapping%type = COLLINEAR
	case ("infrared"); mapping%type = INFRARED
	case ("radiation"); mapping%type = RADIATION
	case ("t_channel"); mapping%type = T_CHANNEL
	case ("u_channel"); mapping%type = U_CHANNEL
	case ("step_exp"); mapping%type = STEP_MAPPING_E
	case ("step_hyp"); mapping%type = STEP_MAPPING_H
	case ("on_shell"); mapping%type = ON_SHELL
	case default
	call msg_bug ("Mappings: encountered undefined mapping key '" &
	// char (type) // "'")
	end select
	if (present (f) .and. present (model)) call mapping%flv%init (f, model)
	end subroutine mapping_init

	@ %def mapping_init
	@ This sets the actual mass and width, using a parameter set. Since
	the auxiliary parameters will only be determined when the mapping is
	first called, they are marked as unknown.
	<<Mappings: mapping: TBP>>=
	procedure :: set_parameters => mapping_set_parameters
	<<Mappings: sub interfaces>>=
	module subroutine mapping_set_parameters &
	(map, mapping_defaults, variable_limits)
	class(mapping_t), intent(inout) :: map
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	end subroutine mapping_set_parameters
	<<Mappings: procedures>>=
	module subroutine mapping_set_parameters &
	(map, mapping_defaults, variable_limits)
	class(mapping_t), intent(inout) :: map
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	if (map%type /= NO_MAPPING) then
	map%mass = map%flv%get_mass ()
	map%width = map%flv%get_width ()
	map%variable_limits = variable_limits
	map%a_unknown = .true.
	map%b_unknown = .true.
	select case (map%type)
	case (S_CHANNEL)
	if (map%mass <= 0) then
	call map%write ()
	call msg_fatal &
	& (" S-channel resonance must have positive mass")
	else if (map%width <= 0) then
	call map%write ()
	call msg_fatal &
	& (" S-channel resonance must have positive width")
	end if
	case (RADIATION)
	map%width = max (map%width, mapping_defaults%energy_scale)
	case (INFRARED, COLLINEAR)
	map%mass = max (map%mass, mapping_defaults%invariant_mass_scale)
	case (T_CHANNEL, U_CHANNEL)
	map%mass = max (map%mass, mapping_defaults%momentum_transfer_scale)
	end select
	end if
	end subroutine mapping_set_parameters

	@ %def mapping_set_code mapping_set_parameters
	@ For a step mapping the mass and width are set directly, instead of
	being determined from the flavor parameter (which is meaningless
	here). They correspond to the effective upper bound of phase space
	due to a resonance, as opposed to the absolute upper bound.
	<<Mappings: mapping: TBP>>=
	procedure :: set_step_mapping_parameters => &
	mapping_set_step_mapping_parameters
	<<Mappings: sub interfaces>>=
	module subroutine mapping_set_step_mapping_parameters (map, &
	mass, width, variable_limits)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: mass, width
	logical, intent(in) :: variable_limits
	end subroutine mapping_set_step_mapping_parameters
	<<Mappings: procedures>>=
	module subroutine mapping_set_step_mapping_parameters (map, &
	mass, width, variable_limits)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: mass, width
	logical, intent(in) :: variable_limits
	select case (map%type)
	case (STEP_MAPPING_E, STEP_MAPPING_H)
	map%variable_limits = variable_limits
	map%a_unknown = .true.
	map%b_unknown = .true.
	map%mass = mass
	map%width = width
	end select
	end subroutine mapping_set_step_mapping_parameters

	@ %def mapping_set_step_mapping_parameters
	@
	\subsection{Retrieve contents}
	Return true if there is any / an s-channel mapping.
	<<Mappings: mapping: TBP>>=
	procedure :: is_set => mapping_is_set
	procedure :: is_s_channel => mapping_is_s_channel
	procedure :: is_on_shell => mapping_is_on_shell
	<<Mappings: sub interfaces>>=
	module function mapping_is_set (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	end function mapping_is_set
	module function mapping_is_s_channel (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	end function mapping_is_s_channel
	module function mapping_is_on_shell (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	end function mapping_is_on_shell
	<<Mappings: procedures>>=
	module function mapping_is_set (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	flag = mapping%type /= NO_MAPPING
	end function mapping_is_set

	module function mapping_is_s_channel (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	flag = mapping%type == S_CHANNEL
	end function mapping_is_s_channel

	module function mapping_is_on_shell (mapping) result (flag)
	class(mapping_t), intent(in) :: mapping
	logical :: flag
	flag = mapping%type == ON_SHELL
	end function mapping_is_on_shell

	@ %def mapping_is_set
	@ %def mapping_is_s_channel
	@ %def mapping_is_on_shell
	@ Return the binary code for the mapped particle.
	<<Mappings: mapping: TBP>>=
	procedure :: get_bincode => mapping_get_bincode
	<<Mappings: sub interfaces>>=
	module function mapping_get_bincode (mapping) result (bincode)
	class(mapping_t), intent(in) :: mapping
	integer(TC) :: bincode
	end function mapping_get_bincode
	<<Mappings: procedures>>=
	module function mapping_get_bincode (mapping) result (bincode)
	class(mapping_t), intent(in) :: mapping
	integer(TC) :: bincode
	bincode = mapping%bincode
	end function mapping_get_bincode

	@ %def mapping_get_bincode
	@ Return the flavor object for the mapped particle.
	<<Mappings: mapping: TBP>>=
	procedure :: get_flv => mapping_get_flv
	<<Mappings: sub interfaces>>=
	module function mapping_get_flv (mapping) result (flv)
	class(mapping_t), intent(in) :: mapping
	type(flavor_t) :: flv
	end function mapping_get_flv
	<<Mappings: procedures>>=
	module function mapping_get_flv (mapping) result (flv)
	class(mapping_t), intent(in) :: mapping
	type(flavor_t) :: flv
	flv = mapping%flv
	end function mapping_get_flv

	@ %def mapping_get_flv
	@ Return stored mass and width, respectively.
	<<Mappings: mapping: TBP>>=
	procedure :: get_mass => mapping_get_mass
	procedure :: get_width => mapping_get_width
	<<Mappings: sub interfaces>>=
	module function mapping_get_mass (mapping) result (mass)
	class(mapping_t), intent(in) :: mapping
	real(default) :: mass
	end function mapping_get_mass
	module function mapping_get_width (mapping) result (width)
	class(mapping_t), intent(in) :: mapping
	real(default) :: width
	end function mapping_get_width
	<<Mappings: procedures>>=
	module function mapping_get_mass (mapping) result (mass)
	class(mapping_t), intent(in) :: mapping
	real(default) :: mass
	mass = mapping%mass
	end function mapping_get_mass

	module function mapping_get_width (mapping) result (width)
	class(mapping_t), intent(in) :: mapping
	real(default) :: width
	width = mapping%width
	end function mapping_get_width

	@ %def mapping_get_mass
	@ %def mapping_get_width
	@
	\subsection{Compare mappings}
	Equality for single mappings and arrays
	<<Mappings: public>>=
	public :: operator(==)
	<<Mappings: interfaces>>=
	interface operator(==)
	module procedure mapping_equal
	end interface
	<<Mappings: sub interfaces>>=
	module function mapping_equal (m1, m2) result (equal)
	type(mapping_t), intent(in) :: m1, m2
	logical :: equal
	end function mapping_equal
	<<Mappings: procedures>>=
	module function mapping_equal (m1, m2) result (equal)
	type(mapping_t), intent(in) :: m1, m2
	logical :: equal
	if (m1%type == m2%type) then
	select case (m1%type)
	case (NO_MAPPING)
	equal = .true.
	case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
	equal = (m1%mass == m2%mass) .and. (m1%width == m2%width)
	case default
	equal = (m1%mass == m2%mass)
	end select
	else
	equal = .false.
	end if
	end function mapping_equal

	@ %def mapping_equal
	@
	\subsection{Mappings of the invariant mass}
	Inserting an $x$ value between 0 and 1, we want to compute the
	corresponding invariant mass $m^2(x)$ and the jacobian, aka phase
	space factor $f(x)$. We also need the reverse operation.

	In general, the phase space factor $f$ is defined by
	\begin{equation}
	\frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
	= \int_0^1 dx\,\frac{1}{s}\,\frac{dm^2}{dx}\,g(m^2(x))
	= \int_0^1 dx\,f(x)\,g(x),
	\end{equation}
	where thus
	\begin{equation}
	f(x) = \frac{1}{s}\,\frac{dm^2}{dx}.
	\end{equation}
	With this mapping, a function of the form
	\begin{equation}
	g(m^2) = c\frac{dx(m^2)}{dm^2}
	\end{equation}
	is mapped to a constant:
	\begin{equation}
	\frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
	= \int_0^1 dx\,f(x)\,g(m^2(x)) = \int_0^1 dx\,\frac{c}{s}.
	\end{equation}

	Here is the mapping routine. Input are the available energy
	squared [[s]], the limits for $m^2$, and the $x$ value. Output are
	the $m^2$ value and the phase space factor $f$.
	<<Mappings: mapping: TBP>>=
	procedure :: compute_msq_from_x => mapping_compute_msq_from_x
	<<Mappings: sub interfaces>>=
	module subroutine mapping_compute_msq_from_x &
	(map, s, msq_min, msq_max, msq, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s, msq_min, msq_max
	real(default), intent(out) :: msq, f
	real(default), intent(in) :: x
	end subroutine mapping_compute_msq_from_x
	<<Mappings: procedures>>=
	module subroutine mapping_compute_msq_from_x &
	(map, s, msq_min, msq_max, msq, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s, msq_min, msq_max
	real(default), intent(out) :: msq, f
	real(default), intent(in) :: x
	real(default) :: z, msq0, msq1, tmp
	integer :: type
	type = map%type
	if (s == 0) &
	call msg_fatal (" Applying msq mapping for zero energy")
	<<Modify mapping type if necessary>>
	select case(type)
	case (NO_MAPPING)
	<<Constants for trivial msq mapping>>
	<<Apply trivial msq mapping>>
	case (S_CHANNEL)
	<<Constants for s-channel resonance mapping>>
	<<Apply s-channel resonance mapping>>
	case (COLLINEAR, INFRARED, RADIATION)
	<<Constants for s-channel pole mapping>>
	<<Apply s-channel pole mapping>>
	case (T_CHANNEL, U_CHANNEL)
	<<Constants for t-channel pole mapping>>
	<<Apply t-channel pole mapping>>
	case (STEP_MAPPING_E)
	<<Constants for exponential step mapping>>
	<<Apply exponential step mapping>>
	case (STEP_MAPPING_H)
	<<Constants for hyperbolic step mapping>>
	<<Apply hyperbolic step mapping>>
	case default
	call msg_fatal ( " Attempt to apply undefined msq mapping")
	end select
	end subroutine mapping_compute_msq_from_x

	@ %def mapping_compute_msq_from_x
	@ The inverse mapping
	<<Mappings: mapping: TBP>>=
	procedure :: compute_x_from_msq => mapping_compute_x_from_msq
	<<Mappings: sub interfaces>>=
	module subroutine mapping_compute_x_from_msq &
	(map, s, msq_min, msq_max, msq, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s, msq_min, msq_max
	real(default), intent(in) :: msq
	real(default), intent(out) :: f, x
	end subroutine mapping_compute_x_from_msq
	<<Mappings: procedures>>=
	module subroutine mapping_compute_x_from_msq &
	(map, s, msq_min, msq_max, msq, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s, msq_min, msq_max
	real(default), intent(in) :: msq
	real(default), intent(out) :: f, x
	real(default) :: msq0, msq1, tmp, z
	integer :: type
	type = map%type
	if (s == 0) &
	call msg_fatal (" Applying inverse msq mapping for zero energy")
	<<Modify mapping type if necessary>>
	select case (type)
	case (NO_MAPPING)
	<<Constants for trivial msq mapping>>
	<<Apply inverse trivial msq mapping>>
	case (S_CHANNEL)
	<<Constants for s-channel resonance mapping>>
	<<Apply inverse s-channel resonance mapping>>
	case (COLLINEAR, INFRARED, RADIATION)
	<<Constants for s-channel pole mapping>>
	<<Apply inverse s-channel pole mapping>>
	case (T_CHANNEL, U_CHANNEL)
	<<Constants for t-channel pole mapping>>
	<<Apply inverse t-channel pole mapping>>
	case (STEP_MAPPING_E)
	<<Constants for exponential step mapping>>
	<<Apply inverse exponential step mapping>>
	case (STEP_MAPPING_H)
	<<Constants for hyperbolic step mapping>>
	<<Apply inverse hyperbolic step mapping>>
	case default
	call msg_fatal ( " Attempt to apply undefined msq mapping")
	end select
	end subroutine mapping_compute_x_from_msq

	@ %def mapping_compute_x_from_msq
	@
	\subsubsection{Trivial mapping}
	We simply map the boundaries of the interval $(m_{\textrm{min}},
	m_{\textrm{max}})$ to $(0,1)$:
	\begin{equation}
	m^2 = (1-x) m_{\textrm{min}}^2 + x m_{\textrm{max}}^2;
	\end{equation}
	the inverse is
	\begin{equation}
	x = \frac{m^2 - m_{\textrm{min}}^2}{m_{\textrm{max}}^2- m_{\textrm{min}}^2}.
	\end{equation}
	Hence
	\begin{equation}
	f(x) = \frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{s},
	\end{equation}
	and we have, as required,
	\begin{equation}
	f(x)\,\frac{dx}{dm^2} = \frac{1}{s}.
	\end{equation}

	We store the constant parameters the first time the mapping is called
	-- or, if limits vary, recompute them each time.
	<<Constants for trivial msq mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	map%a1 = 0
	map%a2 = msq_max - msq_min
	map%a3 = map%a2 / s
	map%a_unknown = .false.
	end if
	<<Apply trivial msq mapping>>=
	msq = (1-x) * msq_min + x * msq_max
	f = map%a3
	<<Apply inverse trivial msq mapping>>=
	if (map%a2 /= 0) then
	x = (msq - msq_min) / map%a2
	else
	x = 0
	end if
	f = map%a3
	@ Resonance or step mapping does not make much sense if the resonance mass is
	outside the kinematical bounds. If this is the case, revert to
	[[NO_MAPPING]]. This is possible even if the kinematical bounds vary
	from event to event.
	<<Modify mapping type if necessary>>=
	select case (type)
	case (S_CHANNEL, STEP_MAPPING_E, STEP_MAPPING_H)
	msq0 = map%mass**2
	if (msq0 < msq_min .or. msq0 > msq_max) type = NO_MAPPING
	end select
	@
	\subsubsection{Breit-Wigner mapping}
	A Breit-Wigner resonance with mass $M$ and width $\Gamma$ is flattened
	by the following mapping:

	This mapping does not make much sense if the resonance mass is too low.
	If this is the case, revert to [[NO_MAPPING]]. There is a tricky
	point with this if the mass is too high: [[msq_max]] is not a
	constant if structure functions are around. However, switching the
	type depending on the overall energy does not change the integral, it
	is just another branching point.
	\begin{equation}
	m^2 = M(M+t\Gamma),
	\end{equation}
	where
	\begin{equation}
	t = \tan\left[(1-x)\arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}
	+ x \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}\right].
	\end{equation}
	The inverse:
	\begin{equation}
	x = \frac{ \arctan\frac{m^2 - M^2}{M\Gamma}
	- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
	{ \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
	- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
	\end{equation}
	The phase-space factor of this transformation is
	\begin{equation}
	f(x) = \frac{M\Gamma}{s}\left(
	\arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
	- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}\right)
	(1 + t^2).
	\end{equation}
	This maps any function proportional to
	\begin{equation}
	g(m^2) = \frac{M\Gamma}{(m^2-M^2)^2 + M^2\Gamma^2}
	\end{equation}
	to a constant times $1/s$.
	<<Constants for s-channel resonance mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	msq0 = map%mass ** 2
	map%a1 = atan ((msq_min - msq0) / (map%mass * map%width))
	map%a2 = atan ((msq_max - msq0) / (map%mass * map%width))
	map%a3 = (map%a2 - map%a1) * (map%mass * map%width) / s
	map%a_unknown = .false.
	end if
	<<Apply s-channel resonance mapping>>=
	z = (1-x) * map%a1 + x * map%a2
	if (-pi/2 < z .and. z < pi/2) then
	tmp = tan (z)
	msq = map%mass * (map%mass + map%width * tmp)
	f = map%a3 * (1 + tmp**2)
	else
	msq = 0
	f = 0
	end if
	<<Apply inverse s-channel resonance mapping>>=
	tmp = (msq - msq0) / (map%mass * map%width)
	x = (atan (tmp) - map%a1) / (map%a2 - map%a1)
	f = map%a3 * (1 + tmp**2)
	@
	\subsubsection{Mapping for massless splittings}
	This mapping accounts for approximately scale-invariant behavior where
	$\ln M^2$ is evenly distributed.
	\begin{equation}
	m^2 = m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
	\end{equation}
	where
	\begin{equation}
	L = \ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{M^2} + 1\right).
	\end{equation}
	The inverse:
	\begin{equation}
	x = \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
	\end{equation}
	The constant $M$ is a characteristic scale. Above this scale
	($m^2-m_{\textrm{min}}^2 \gg M^2$), this mapping behaves like
	$x\propto\ln m^2$, while below the scale it reverts to a linear
	mapping.

	The phase-space factor is
	\begin{equation}
	f(x) = \frac{M^2}{s}\,\exp(xL)\,L.
	\end{equation}
	A function proportional to
	\begin{equation}
	g(m^2) = \frac{1}{(m^2-m_{\textrm{min}}^2) + M^2}
	\end{equation}
	is mapped to a constant, i.e., a simple pole near $m_{\textrm{min}}$
	with a regulator mass $M$.

	This type of mapping is useful for massless collinear and infrared
	singularities, where the scale is stored as the mass parameter. In
	the radiation case (IR radiation off massive particle), the heavy
	particle width is the characteristic scale.
	<<Constants for s-channel pole mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	if (type == RADIATION) then
	msq0 = map%width**2
	else
	msq0 = map%mass**2
	end if
	map%a1 = msq0
	map%a2 = log ((msq_max - msq_min) / msq0 + 1)
	map%a3 = map%a2 / s
	map%a_unknown = .false.
	end if
	<<Apply s-channel pole mapping>>=
	msq1 = map%a1 * exp (x * map%a2)
	msq = msq1 - map%a1 + msq_min
	f = map%a3 * msq1
	<<Apply inverse s-channel pole mapping>>=
	msq1 = msq - msq_min + map%a1
	x = log (msq1 / map%a1) / map%a2
	f = map%a3 * msq1
	@
	\subsubsection{Mapping for t-channel poles}
	This is also approximately scale-invariant, and we use the same type
	of mapping as before. However, we map $1/x$ singularities at both
	ends of the interval; again, the mapping becomes linear when the
	distance is less than $M^2$:
	\begin{equation}
	m^2 =
	\begin{cases}
	m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
	&
	\text{for $0 < x < \frac12$}
	\\
	m_{\textrm{max}}^2 - M^2\left(\exp((1-x)L)-1\right)
	&
	\text{for $\frac12 \leq x < 1$}
	\end{cases}
	\end{equation}
	where
	\begin{equation}
	L = 2\ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{2M^2}
	+ 1\right).
	\end{equation}
	The inverse:
	\begin{equation}
	x =
	\begin{cases}
	\frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
	&
	\text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
	\\
	1 - \frac1L\ln\left(\frac{m_{\textrm{max}}-m^2}{M^2} + 1\right)
	&
	\text{for $m^2 \geq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
	\end{cases}
	\end{equation}
	The phase-space factor is
	\begin{equation}
	f(x) =
	\begin{cases}
	\frac{M^2}{s}\,\exp(xL)\,L.
	&
	\text{for $0 < x < \frac12$}
	\\
	\frac{M^2}{s}\,\exp((1-x)L)\,L.
	&
	\text{for $\frac12 \leq x < 1$}
	\end{cases}
	\end{equation}
	A (continuous) function proportional to
	\begin{equation}
	g(m^2) =
	\begin{cases}
	1/(m^2-m_{\textrm{min}}^2) + M^2)
	&
	\text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
	\\
	1/((m_{\textrm{max}}^2 - m^2) + M^2)
	&
	\text{for $m^2 \leq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
	\end{cases}
	\end{equation}
	is mapped to a constant by this mapping, i.e., poles near both ends of
	the interval.
	<<Constants for t-channel pole mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	msq0 = map%mass**2
	map%a1 = msq0
	map%a2 = 2 * log ((msq_max - msq_min)/(2*msq0) + 1)
	map%a3 = map%a2 / s
	map%a_unknown = .false.
	end if
	<<Apply t-channel pole mapping>>=
	if (x < .5_default) then
	msq1 = map%a1 * exp (x * map%a2)
	msq = msq1 - map%a1 + msq_min
	else
	msq1 = map%a1 * exp ((1-x) * map%a2)
	msq = -(msq1 - map%a1) + msq_max
	end if
	f = map%a3 * msq1
	<<Apply inverse t-channel pole mapping>>=
	if (msq < (msq_max + msq_min)/2) then
	msq1 = msq - msq_min + map%a1
	x = log (msq1/map%a1) / map%a2
	else
	msq1 = msq_max - msq + map%a1
	x = 1 - log (msq1/map%a1) / map%a2
	end if
	f = map%a3 * msq1
	@
	\subsection{Step mapping}
	Step mapping is useful when the allowed range for a squared-mass
	variable is large, but only a fraction at the lower end is populated
	because the particle in question is an (off-shell) decay product of a
	narrow resonance. I.e., if the resonance was forced to be on-shell,
	the upper end of the range would be the resonance mass, minus the
	effective (real or resonance) mass of the particle(s) in the sibling
	branch of the decay.

	The edge of this phase space section has a width which is determined
	by the width of the parent, plus the width of the sibling branch. (The
	widths might be added in quadrature, but this precision is probably
	not important.)

	\subsubsection{Fermi function}

	A possible mapping is derived from the Fermi function which has
	precisely this behavior. The Fermi function is given by
	\begin{equation}
	f(x) = \frac{1}{1 + \exp\frac{x-\mu}{\gamma}}
	\end{equation}
	where $x$ is taken as the invariant mass squared, $\mu$ is the
	invariant mass squared of the edge, and $\gamma$ is the effective
	width which is given by the widths of the parent and the sibling
	branch. (Widths might be added in quadrature, but we do not require
	this level of precision.)
	\begin{align}
	x &= \frac{m^2 - m_{\text{min}}^2}{\Delta m^2}
	\\
	\mu &=
	\frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
	{\Delta m^2}
	\\
	\gamma &= \frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}
	\end{align}
	with
	\begin{equation}
	\Delta m^2 = m_{\text{max}}^2 - m_{\text{min}}^2
	\end{equation}
	$m^2$ is thus given by
	\begin{equation}
	m^2(x) = xm_{\text{max}}^2 + (1-x)m_{\text{min}}^2
	\end{equation}
	For the mapping, we compute the integral $g(x)$ of the Fermi function,
	normalized such that $g(0)=0$ and $g(1)=1$. We introduce the abbreviations
	\begin{align}
	\alpha &= 1 - \gamma\ln\frac{1 + \beta e^{1/\gamma}}{1 + \beta}
	\\
	\beta &= e^{- \mu/\gamma}
	\end{align}
	and obtain
	\begin{equation}
	g(x) = \frac{1}{\alpha}
	\left(x - \gamma\ln\frac{1 + \beta e^{x/\gamma}}
	{1 + \beta}\right)
	\end{equation}
	The actual mapping is the inverse function $h(y) = g^{-1}(y)$,
	\begin{equation}
	h(y) = -\gamma\ln\left(e^{-\alpha y/\gamma}(1 + \beta) - \beta\right)
	\end{equation}
	The Jacobian is
	\begin{equation}
	\frac{dh}{dy} = \alpha\left(1 - e^{\alpha y/\gamma}
	\frac{\beta}{1 + \beta}\right)^{-1}
	\end{equation}
	which is equal to $1/(dg/dx)$, namely
	\begin{equation}
	\frac{dg}{dx} = \frac{1}{\alpha}\,\frac{1}{1 + \beta e^{x/\gamma}}
	\end{equation}
	The final result is
	\begin{align}
	\int_{m_{\text{min}}^2}^{m_{\text{max}}^2} dm^2\,F(m^2)
	&= \Delta m^2\int_0^1\,dx\,F(m^2(x))
	\\
	&= \Delta m^2\int_0^1\,dy\,F(m^2(h(y)))\,\frac{dh}{dy}
	\end{align}
	Here is the implementation. We fill [[a1]], [[a2]], [[a3]] with
	$\alpha,\beta,\gamma$, respectively.
	<<Constants for exponential step mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	map%a3 = max (2 * map%mass * map%width / (msq_max - msq_min), 0.01_default)
	map%a2 = exp (- (map%mass**2 - msq_min) / (msq_max - msq_min) &
	/ map%a3)
	map%a1 = 1 - map%a3 * log ((1 + map%a2 * exp (1 / map%a3)) / (1 + map%a2))
	end if
	<<Apply exponential step mapping>>=
	tmp = exp (- x * map%a1 / map%a3) * (1 + map%a2)
	z = - map%a3 * log (tmp - map%a2)
	msq = z * msq_max + (1 - z) * msq_min
	f = map%a1 / (1 - map%a2 / tmp) * (msq_max - msq_min) / s
	<<Apply inverse exponential step mapping>>=
	z = (msq - msq_min) / (msq_max - msq_min)
	tmp = 1 + map%a2 * exp (z / map%a3)
	x = (z - map%a3 * log (tmp / (1 + map%a2))) &
	/ map%a1
	f = map%a1 * tmp * (msq_max - msq_min) / s
	@
	\subsubsection{Hyperbolic mapping}

	The Fermi function has the drawback that it decreases exponentially.
	It might be preferable to take a function with a power-law decrease,
	such that the high-mass region is not completely depopulated.

	Here, we start with the actual mapping which we take as
	\begin{equation}
	h(y) = \frac{b}{a-y} - \frac{b}{a} + \mu y
	\end{equation}
	with the abbreviation
	\begin{equation}
	a = \frac12\left(1 + \sqrt{1 + \frac{4b}{1-\mu}}\right)
	\end{equation}
	This is a hyperbola in the $xy$ plane. The derivative is
	\begin{equation}
	\frac{dh}{dy} = \frac{b}{(a-y)^2} + \mu
	\end{equation}
	The constants correspond to
	\begin{align}
	\mu &=
	\frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
	{\Delta m^2}
	\\
	b &= \frac{1}{\mu}\left(\frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}\right)^2
	\end{align}
	The inverse function is the solution of a quadratic equation,
	\begin{equation}
	g(x) = \frac{1}{2}
	\left[\left(a + \frac{x}{\mu} + \frac{b}{a\mu}\right)
	- \sqrt{\left(a-\frac{x}{\mu}\right)^2
	+ 2\frac{b}{a\mu}\left(a + \frac{x}{\mu}\right)
	+ \left(\frac{b}{a\mu}\right)^2}\right]
	\end{equation}
	The constants $a_{1,2,3}$ are identified with $a,b,\mu$.
	<<Constants for hyperbolic step mapping>>=
	if (map%variable_limits .or. map%a_unknown) then
	map%a3 = (map%mass**2 - msq_min) / (msq_max - msq_min)
	map%a2 = max ((2 * map%mass * map%width / (msq_max - msq_min))**2 &
	/ map%a3, 1e-6_default)
	map%a1 = (1 + sqrt (1 + 4 * map%a2 / (1 - map%a3))) / 2
	end if
	<<Apply hyperbolic step mapping>>=
	z = map%a2 / (map%a1 - x) - map%a2 / map%a1 + map%a3 * x
	msq = z * msq_max + (1 - z) * msq_min
	f = (map%a2 / (map%a1 - x)*2 + map%a3) (msq_max - msq_min) / s
	<<Apply inverse hyperbolic step mapping>>=
	z = (msq - msq_min) / (msq_max - msq_min)
	tmp = map%a2 / (map%a1 * map%a3)
	x = ((map%a1 + z / map%a3 + tmp) &
	- sqrt ((map%a1 - z / map%a3)*2 + 2 tmp * (map%a1 + z / map%a3) &
	+ tmp**2)) / 2
	f = (map%a2 / (map%a1 - x)*2 + map%a3) (msq_max - msq_min) / s
	@
	\subsection{Mappings of the polar angle}
	The other type of singularity, a simple pole just outside the
	integration region, can occur in the integration over $\cos\theta$.
	This applies to exchange of massless (or light) particles.

	Double poles (Coulomb scattering) are also possible, but only in
	certain cases. These are also handled by the single-pole mapping.

	The mapping is analogous to the previous $m^2$ pole mapping, but with
	a different normalization and notation of variables:
	\begin{equation}
	\frac12\int_{-1}^1 d\cos\theta\,g(\theta)
	= \int_0^1 dx\,\frac{d\cos\theta}{dx}\,g(\theta(x))
	= \int_0^1 dx\,f(x)\,g(x),
	\end{equation}
	where thus
	\begin{equation}
	f(x) = \frac12\,\frac{d\cos\theta}{dx}.
	\end{equation}
	With this mapping, a function of the form
	\begin{equation}
	g(\theta) = c\frac{dx(\cos\theta)}{d\cos\theta}
	\end{equation}
	is mapped to a constant:
	\begin{equation}
	\int_{-1}^1 d\cos\theta\,g(\theta)
	= \int_0^1 dx\,f(x)\,g(\theta(x)) = \int_0^1 dx\,c.
	\end{equation}
	<<Mappings: mapping: TBP>>=
	procedure :: compute_ct_from_x => mapping_compute_ct_from_x
	<<Mappings: sub interfaces>>=
	module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s
	real(default), intent(out) :: ct, st, f
	real(default), intent(in) :: x
	end subroutine mapping_compute_ct_from_x
	<<Mappings: procedures>>=
	module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s
	real(default), intent(out) :: ct, st, f
	real(default), intent(in) :: x
	real(default) :: tmp, ct1
	select case (map%type)
	case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
	STEP_MAPPING_E, STEP_MAPPING_H)
	<<Apply trivial ct mapping>>
	case (T_CHANNEL, U_CHANNEL, COLLINEAR)
	<<Constants for ct pole mapping>>
	<<Apply ct pole mapping>>
	case default
	call msg_fatal (" Attempt to apply undefined ct mapping")
	end select
	end subroutine mapping_compute_ct_from_x

	@ %def mapping_compute_ct_from_x
	<<Mappings: mapping: TBP>>=
	procedure :: compute_x_from_ct => mapping_compute_x_from_ct
	<<Mappings: sub interfaces>>=
	module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s
	real(default), intent(in) :: ct
	real(default), intent(out) :: f, x
	end subroutine mapping_compute_x_from_ct
	<<Mappings: procedures>>=
	module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
	class(mapping_t), intent(inout) :: map
	real(default), intent(in) :: s
	real(default), intent(in) :: ct
	real(default), intent(out) :: f, x
	real(default) :: ct1
	select case (map%type)
	case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
	STEP_MAPPING_E, STEP_MAPPING_H)
	<<Apply inverse trivial ct mapping>>
	case (T_CHANNEL, U_CHANNEL, COLLINEAR)
	<<Constants for ct pole mapping>>
	<<Apply inverse ct pole mapping>>
	case default
	call msg_fatal (" Attempt to apply undefined inverse ct mapping")
	end select
	end subroutine mapping_compute_x_from_ct

	@ %def mapping_compute_x_from_ct
	@
	\subsubsection{Trivial mapping}
	This is just the mapping of the interval $(-1,1)$ to $(0,1)$:
	\begin{equation}
	\cos\theta = -1 + 2x
	\end{equation}
	and
	\begin{equation}
	f(x) = 1
	\end{equation}
	with the inverse
	\begin{equation}
	x = \frac{1+\cos\theta}{2}
	\end{equation}
	<<Apply trivial ct mapping>>=
	tmp = 2 * (1-x)
	ct = 1 - tmp
	st = sqrt (tmp * (2-tmp))
	f = 1
	<<Apply inverse trivial ct mapping>>=
	x = (ct + 1) / 2
	f = 1
	@
	\subsubsection{Pole mapping}
	As above for $m^2$, we simultaneously map poles at both ends of the
	$\cos\theta$ interval. The formulae are completely analogous:
	\begin{equation}
	\cos\theta =
	\begin{cases}
	\frac{M^2}{s}\left[\exp(xL)-1\right] - 1
	&
	\text{for $x<\frac12$}
	\\
	-\frac{M^2}{s}\left[\exp((1-x)L)-1\right] + 1
	&
	\text{for $x\geq\frac12$}
	\end{cases}
	\end{equation}
	where
	\begin{equation}
	L = 2\ln\frac{M^2+s}{M^2}.
	\end{equation}
	Inverse:
	\begin{equation}
	x =
	\begin{cases}
	\frac{1}{2L}\ln\frac{1 + \cos\theta + M^2/s}{M^2/s}
	&
	\text{for $\cos\theta < 0$}
	\\
	1 - \frac{1}{2L}\ln\frac{1 - \cos\theta + M^2/s}{M^2/s}
	&
	\text{for $\cos\theta \geq 0$}
	\end{cases}
	\end{equation}
	The phase-space factor:
	\begin{equation}
	f(x) =
	\begin{cases}
	\frac{M^2}{s}\exp(xL)\,L
	&
	\text{for $x<\frac12$}
	\\
	\frac{M^2}{s}\exp((1-x)L)\,L
	&
	\text{for $x\geq\frac12$}
	\end{cases}
	\end{equation}
	<<Constants for ct pole mapping>>=
	if (map%variable_limits .or. map%b_unknown) then
	map%b1 = map%mass**2 / s
	map%b2 = log ((map%b1 + 1) / map%b1)
	map%b3 = 0
	map%b_unknown = .false.
	end if
	<<Apply ct pole mapping>>=
	if (x < .5_default) then
	ct1 = map%b1 * exp (2 * x * map%b2)
	ct = ct1 - map%b1 - 1
	else
	ct1 = map%b1 * exp (2 * (1-x) * map%b2)
	ct = -(ct1 - map%b1) + 1
	end if
	if (ct >= -1 .and. ct <= 1) then
	st = sqrt (1 - ct**2)
	f = ct1 * map%b2
	else
	ct = 1; st = 0; f = 0
	end if
	<<Apply inverse ct pole mapping>>=
	if (ct < 0) then
	ct1 = ct + map%b1 + 1
	x = log (ct1 / map%b1) / (2 * map%b2)
	else
	ct1 = -ct + map%b1 + 1
	x = 1 - log (ct1 / map%b1) / (2 * map%b2)
	end if
	f = ct1 * map%b2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\clearpage
	\section{Phase-space trees}
	The phase space evaluation is organized in terms of trees, where each
	branch corresponds to three integrations: $m^2$, $\cos\theta$, and
	$\phi$. The complete tree thus makes up a specific parameterization
	of the multidimensional phase-space integral. For the multi-channel
	integration, the phase-space tree is a single channel.

	The trees imply mappings of formal Feynman tree graphs into arrays of
	integer numbers: Each branch, corresponding to a particular line in
	the graph, is assigned an integer code $c$ (with kind value [[TC]] =
	tree code).

	In this integer, each bit determines whether a particular external
	momentum flows through the line. The external branches therefore have
	codes $1,2,4,8,\ldots$. An internal branch has those bits ORed
	corresponding to the momenta flowing through it. For example, a
	branch with momentum $p_1+p_4$ has code $2^0+2^3=1+8=9$.

	There is a two-fold ambiguity: Momentum conservation implies that the
	branch with code
	\begin{equation}
	c_0 = \sum_{i=1}^{n(\rm{ext})} 2^{i-1}
	\end{equation}
	i.e. the branch with momentum $p_1+p_2+\ldots p_n$ has momentum zero,
	which is equivalent to tree code $0$ by definition. Correspondingly,
	\begin{equation}
	c \quad\textrm{and}\quad c_0 - c = c\;\textrm{XOR}\;c_0
	\end{equation}
	are equivalent. E.g., if there are five externals with codes
	$c=1,2,4,8,16$, then $c=9$ and $\bar c=31-9=22$ are equivalent.

	This ambiguity may be used to assign a direction to the line: If all
	momenta are understood as outgoing, $c=9$ in the example above means
	$p_1+p_4$, but $c=22$ means $p_2+p_3+p_5 = -(p_1+p_4)$.

	Here we make use of the ambiguity in a slightly different way. First,
	the initial particles are singled out as those externals with the
	highest bits, the IN-bits. (Here: $8$ and $16$ for a $2\to 3$
	scattering process, $16$ only for a $1\to 4$ decay.) Then we invert
	those codes where all IN-bits are set. For a decay process this maps
	each tree of an equivalence class onto a unique representative (that one
	with the smallest integer codes). For a scattering process we proceed
	further:

	The ambiguity remains in all branches where only one IN-bit is set,
	including the initial particles. If there are only externals with
	this property, we have an $s$-channel graph which we leave as it is.
	In all other cases, an internal with only one IN-bit is a $t$-channel
	line, which for phase space integration should be associated with one
	of the initial momenta as a reference axis. We take that one whose
	bit is set in the current tree code. (E.g., for branch $c=9$ we use
	the initial particle $c=8$ as reference axis, whereas for the same
	branch we would take $c=16$ if it had been assigned $\bar c=31-9=22$
	as tree code.) Thus, different ways of coding the same $t$-channel
	graph imply different phase space parameterizations.

	$s$-channel graphs have a unique parameterization. The same sets of
	parameterizations are used for $t$-channel graphs, except for the
	reference frames of their angular parts. We map each
	$t$-channel graph onto an $s$-channel graph as follows:

	Working in ascending order, for each $t$-channel line (whose code has
	exactly one IN-bit set) the attached initial line is flipped upstream,
	while the outgoing line is flipped downstream. (This works only if
	$t$-channel graphs are always parameterized beginning at their outer
	vertices, which we require as a restriction.) After all possible
	flips have been applied, we have an $s$-channel graph. We only have
	to remember the initial particle a vertex was originally attached to.
	<<[[phs_trees.f90]]>>=
	<<File header>>

	module phs_trees

	<<Use kinds>>
	use kinds, only: TC
	<<Use strings>>
	use lorentz
	use permutations, only: permutation_t, permutation_size
	use permutations, only: permutation_init, permutation_find
	use permutations, only: tc_decay_level, tc_permute
	use model_data
	use flavors
	use resonances, only: resonance_history_t, resonance_info_t
	use mappings

	<<Standard module head>>

	<<PHS trees: public>>

	<<PHS trees: types>>

	interface
	<<PHS trees: sub interfaces>>
	end interface

	end module phs_trees
	@ %def phs_trees
	@
	<<[[phs_trees_sub.f90]]>>=
	<<File header>>

	submodule (phs_trees) phs_trees_s

	use io_units
	use constants, only: twopi, twopi2, twopi5
	use format_defs, only: FMT_19
	use numeric_utils, only: vanishes
	use diagnostics

	implicit none

	contains

	<<PHS trees: procedures>>

	end submodule phs_trees_s

	@ %def phs_trees_s
	@
	\subsection{Particles}
	We define a particle type which contains only four-momentum and
	invariant mass squared, and a flag that tells whether the momentum is
	filled or not.
	<<PHS trees: public>>=
	public :: phs_prt_t
	<<PHS trees: types>>=
	type :: phs_prt_t
	private
	logical :: defined = .false.
	type(vector4_t) :: p
	real(default) :: p2
	contains
	<<PHS trees: prt: TBP>>
	end type phs_prt_t

	@ %def phs_prt_t
	@ Set contents:
	<<PHS trees: prt: TBP>>=
	procedure :: set_defined => phs_prt_set_defined
	procedure :: set_undefined => phs_prt_set_undefined
	procedure :: set_momentum => phs_prt_set_momentum
	procedure :: set_msq => phs_prt_set_msq
	<<PHS trees: sub interfaces>>=
	elemental module subroutine phs_prt_set_defined (prt)
	class(phs_prt_t), intent(inout) :: prt
	end subroutine phs_prt_set_defined
	elemental module subroutine phs_prt_set_undefined (prt)
	class(phs_prt_t), intent(inout) :: prt
	end subroutine phs_prt_set_undefined
	elemental module subroutine phs_prt_set_momentum (prt, p)
	class(phs_prt_t), intent(inout) :: prt
	type(vector4_t), intent(in) :: p
	end subroutine phs_prt_set_momentum
	elemental module subroutine phs_prt_set_msq (prt, p2)
	class(phs_prt_t), intent(inout) :: prt
	real(default), intent(in) :: p2
	end subroutine phs_prt_set_msq
	<<PHS trees: procedures>>=
	elemental module subroutine phs_prt_set_defined (prt)
	class(phs_prt_t), intent(inout) :: prt
	prt%defined = .true.
	end subroutine phs_prt_set_defined

	elemental module subroutine phs_prt_set_undefined (prt)
	class(phs_prt_t), intent(inout) :: prt
	prt%defined = .false.
	end subroutine phs_prt_set_undefined

	elemental module subroutine phs_prt_set_momentum (prt, p)
	class(phs_prt_t), intent(inout) :: prt
	type(vector4_t), intent(in) :: p
	prt%p = p
	end subroutine phs_prt_set_momentum

	elemental module subroutine phs_prt_set_msq (prt, p2)
	class(phs_prt_t), intent(inout) :: prt
	real(default), intent(in) :: p2
	prt%p2 = p2
	end subroutine phs_prt_set_msq

	@ %def phs_prt_set_defined phs_prt_set_momentum phs_prt_set_msq
	@ Access methods:
	<<PHS trees: prt: TBP>>=
	procedure :: is_defined => phs_prt_is_defined
	procedure :: get_momentum => phs_prt_get_momentum
	procedure :: get_msq => phs_prt_get_msq
	<<PHS trees: sub interfaces>>=
	elemental module function phs_prt_is_defined (prt) result (defined)
	logical :: defined
	class(phs_prt_t), intent(in) :: prt
	end function phs_prt_is_defined
	elemental module function phs_prt_get_momentum (prt) result (p)
	type(vector4_t) :: p
	class(phs_prt_t), intent(in) :: prt
	end function phs_prt_get_momentum
	elemental module function phs_prt_get_msq (prt) result (p2)
	real(default) :: p2
	class(phs_prt_t), intent(in) :: prt
	end function phs_prt_get_msq
	<<PHS trees: procedures>>=
	elemental module function phs_prt_is_defined (prt) result (defined)
	logical :: defined
	class(phs_prt_t), intent(in) :: prt
	defined = prt%defined
	end function phs_prt_is_defined

	elemental module function phs_prt_get_momentum (prt) result (p)
	type(vector4_t) :: p
	class(phs_prt_t), intent(in) :: prt
	p = prt%p
	end function phs_prt_get_momentum

	elemental module function phs_prt_get_msq (prt) result (p2)
	real(default) :: p2
	class(phs_prt_t), intent(in) :: prt
	p2 = prt%p2
	end function phs_prt_get_msq

	@ %def phs_prt_is_defined phs_prt_get_momentum phs_prt_get_msq
	@ Addition of momenta (invariant mass square is computed).
	<<PHS trees: prt: TBP>>=
	procedure :: combine => phs_prt_combine
	<<PHS trees: sub interfaces>>=
	elemental module subroutine phs_prt_combine (prt, prt1, prt2)
	class(phs_prt_t), intent(inout) :: prt
	type(phs_prt_t), intent(in) :: prt1, prt2
	end subroutine phs_prt_combine
	<<PHS trees: procedures>>=
	elemental module subroutine phs_prt_combine (prt, prt1, prt2)
	class(phs_prt_t), intent(inout) :: prt
	type(phs_prt_t), intent(in) :: prt1, prt2
	prt%defined = .true.
	prt%p = prt1%p + prt2%p
	prt%p2 = prt%p ** 2
	call phs_prt_check (prt)
	end subroutine phs_prt_combine

	@ %def phs_prt_combine
	@ Output
	<<PHS trees: prt: TBP>>=
	procedure :: write => phs_prt_write
	<<PHS trees: sub interfaces>>=
	module subroutine phs_prt_write (prt, unit)
	class(phs_prt_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	end subroutine phs_prt_write
	<<PHS trees: procedures>>=
	module subroutine phs_prt_write (prt, unit)
	class(phs_prt_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (prt%defined) then
	call vector4_write (prt%p, u)
	write (u, "(1x,A,1x," // FMT_19 // ")") "T = ", prt%p2
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine phs_prt_write

	@ %def phs_prt_write
	<<PHS trees: prt: TBP>>=
	procedure :: check => phs_prt_check
	<<PHS trees: sub interfaces>>=
	elemental module subroutine phs_prt_check (prt)
	class(phs_prt_t), intent(inout) :: prt
	end subroutine phs_prt_check
	<<PHS trees: procedures>>=
	elemental module subroutine phs_prt_check (prt)
	class(phs_prt_t), intent(inout) :: prt
	if (prt%p2 < 0._default) then
	prt%p2 = 0._default
	end if
	end subroutine phs_prt_check

	@ %def phs_prt_check
	@
	\subsection{The phase-space tree type}
	\subsubsection{Definition}
	In the concrete implementation, each branch $c$ may have two
	\emph{daughters} $c_1$ and $c_2$ such that $c_1+c_2=c$, a
	\emph{sibling} $c_s$ and a \emph{mother} $c_m$ such that $c+c_s =
	c_m$, and a \emph{friend} which is kept during flips, such that it can
	indicate a fixed reference frame. Absent entries are set $c=0$.

	First, declare the branch type. There is some need to have this
	public. Give initializations for all components, so no [[init]]
	routine is necessary. The branch has some information about the
	associated coordinates and about connections.
	<<PHS trees: types>>=
	type :: phs_branch_t
	private
	logical :: set = .false.
	logical :: inverted_decay = .false.
	logical :: inverted_axis = .false.
	integer(TC) :: mother = 0
	integer(TC) :: sibling = 0
	integer(TC) :: friend = 0
	integer(TC) :: origin = 0
	integer(TC), dimension(2) :: daughter = 0
	integer :: firstborn = 0
	logical :: has_children = .false.
	logical :: has_friend = .false.
	logical :: is_real = .false.
	end type phs_branch_t

	@ %def phs_branch_t
	@ The tree type: No initialization, this is done by
	[[phs_tree_init]]. In addition to the branch array which

	The branches are collected in an array which holds all possible
	branches, of which only a few are set. After flips have been applied,
	the branch $c_M=\sum_{i=1}^{n({\rm fin})}2^{i-1}$ must be there,
	indicating the mother of all decay products. In addition, we should
	check for consistency at the beginning.

	[[n_branches]] is the number of those actually set. [[n_externals]]
	defines the number of significant bit, and [[mask]] is a code where all
	bits are set. Analogous: [[n_in]] and [[mask_in]] for the incoming
	particles.

	The [[mapping]] array contains the mappings associated to the branches
	(corresponding indices). The array [[mass_sum]] contains the sum of
	the real masses of the external final-state particles associated to
	the branch. During phase-space evaluation, this determines the
	boundaries.
	<<PHS trees: public>>=
	public :: phs_tree_t
	<<PHS trees: types>>=
	type :: phs_tree_t
	private
	integer :: n_branches, n_externals, n_in, n_msq, n_angles
	integer(TC) :: n_branches_tot, n_branches_out
	integer(TC) :: mask, mask_in, mask_out
	type(phs_branch_t), dimension(:), allocatable :: branch
	type(mapping_t), dimension(:), allocatable :: mapping
	real(default), dimension(:), allocatable :: mass_sum
	real(default), dimension(:), allocatable :: effective_mass
	real(default), dimension(:), allocatable :: effective_width
	logical :: real_phsp = .false.
	integer, dimension(:), allocatable :: momentum_link
	contains
	<<PHS trees: phs tree: TBP>>
	end type phs_tree_t

	@ %def phs_tree_t
	@ The maximum number of external particles that can be represented is
	related to the bit size of the integer that stores binary codes. With
	the default integer of 32 bit on common machines, this is more than
	enough space. If [[TC]] is actually the default integer kind, there
	is no need to keep it separate, but doing so marks this as a
	special type of integer. So, just state that the maximum number is 32:
	<<Limits: public parameters>>=
	integer, parameter, public :: MAX_EXTERNAL = 32
	@ %def MAX_EXTERNAL
	@
	\subsubsection{Constructor and destructor}
	Allocate memory for a phase-space tree with given number of externals and
	incoming. The number of allocated branches can easily become large,
	but appears manageable for realistic cases, e.g., for [[n_in=2]] and
	[[n_out=8]] we get $2^{10}-1=1023$.
	Here we set the masks for incoming and for all externals.
	<<PHS trees: phs tree: TBP>>=
	procedure :: init => phs_tree_init
	procedure :: final => phs_tree_final
	<<PHS trees: sub interfaces>>=
	elemental module subroutine phs_tree_init &
	(tree, n_in, n_out, n_masses, n_angles)
	class(phs_tree_t), intent(inout) :: tree
	integer, intent(in) :: n_in, n_out, n_masses, n_angles
	end subroutine phs_tree_init
	elemental module subroutine phs_tree_final (tree)
	class(phs_tree_t), intent(inout) :: tree
	end subroutine phs_tree_final
	<<PHS trees: procedures>>=
	elemental module subroutine phs_tree_init &
	(tree, n_in, n_out, n_masses, n_angles)
	class(phs_tree_t), intent(inout) :: tree
	integer, intent(in) :: n_in, n_out, n_masses, n_angles
	integer(TC) :: i
	tree%n_externals = n_in + n_out
	tree%n_branches_tot = 2**(n_in+n_out) - 1
	tree%n_branches_out = 2**n_out - 1
	tree%mask = 0
	do i = 0, n_in + n_out - 1
	tree%mask = ibset (tree%mask, i)
	end do
	tree%n_in = n_in
	tree%mask_in = 0
	do i = n_out, n_in + n_out - 1
	tree%mask_in = ibset (tree%mask_in, i)
	end do
	tree%mask_out = ieor (tree%mask, tree%mask_in)
	tree%n_msq = n_masses
	tree%n_angles = n_angles
	allocate (tree%branch (tree%n_branches_tot))
	tree%n_branches = 0
	allocate (tree%mapping (tree%n_branches_out))
	allocate (tree%mass_sum (tree%n_branches_out))
	allocate (tree%effective_mass (tree%n_branches_out))
	allocate (tree%effective_width (tree%n_branches_out))
	end subroutine phs_tree_init

	elemental module subroutine phs_tree_final (tree)
	class(phs_tree_t), intent(inout) :: tree
	deallocate (tree%branch)
	deallocate (tree%mapping)
	deallocate (tree%mass_sum)
	deallocate (tree%effective_mass)
	deallocate (tree%effective_width)
	end subroutine phs_tree_final

	@ %def phs_tree_init phs_tree_final
	@
	\subsubsection{Screen output}
	Write only the branches that are set:
	<<PHS trees: phs tree: TBP>>=
	procedure :: write => phs_tree_write
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_write (tree, unit)
	class(phs_tree_t), intent(in) :: tree
	integer, intent(in), optional :: unit
	end subroutine phs_tree_write
	<<PHS trees: procedures>>=
	module subroutine phs_tree_write (tree, unit)
	class(phs_tree_t), intent(in) :: tree
	integer, intent(in), optional :: unit
	integer :: u
	integer(TC) :: k
	u = given_output_unit (unit); if (u < 0) return
	write (u, '(3X,A,1x,I0,5X,A,I3)') &
	'External:', tree%n_externals, 'Mask:', tree%mask
	write (u, '(3X,A,1x,I0,5X,A,I3)') &
	'Incoming:', tree%n_in, 'Mask:', tree%mask_in
	write (u, '(3X,A,1x,I0,5X,A,I3)') &
	'Branches:', tree%n_branches
	do k = size (tree%branch), 1, -1
	if (tree%branch(k)%set) &
	call phs_branch_write (tree%branch(k), unit=unit, kval=k)
	end do
	do k = 1, size (tree%mapping)
	call tree%mapping (k)%write (unit, verbose=.true.)
	end do
	write (u, "(3x,A)") "Arrays: mass_sum, effective_mass, effective_width"
	do k = 1, size (tree%mass_sum)
	if (tree%branch(k)%set) then
	write (u, "(5x,I0,3(2x," // FMT_19 // "))") k, tree%mass_sum(k), &
	tree%effective_mass(k), tree%effective_width(k)
	end if
	end do
	end subroutine phs_tree_write

	subroutine phs_branch_write (b, unit, kval)
	type(phs_branch_t), intent(in) :: b
	integer, intent(in), optional :: unit
	integer(TC), intent(in), optional :: kval
	integer :: u
	integer(TC) :: k
	character(len=6) :: tmp
	character(len=1) :: firstborn(2), sign_decay, sign_axis
	integer :: i
	u = given_output_unit (unit); if (u < 0) return
	k = 0; if (present (kval)) k = kval
	if (b%origin /= 0) then
	write(tmp, '(A,I4,A)') '(', b%origin, ')'
	else
	tmp = ' '
	end if
	do i=1, 2
	if (b%firstborn == i) then
	firstborn(i) = "*"
	else
	firstborn(i) = " "
	end if
	end do
	if (b%inverted_decay) then
	sign_decay = "-"
	else
	sign_decay = "+"
	end if
	if (b%inverted_axis) then
	sign_axis = "-"
	else
	sign_axis = "+"
	end if
	if (b%has_children) then
	if (b%has_friend) then
	write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A,1x,I0)') &
	& '*', k, tmp, &
	& 'Daughters: ', &
	& b%daughter(1), firstborn(1), &
	& b%daughter(2), firstborn(2), sign_decay, &
	& 'Friend: ', b%friend
	else
	write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A)') &
	& '*', k, tmp, &
	& 'Daughters: ', &
	& b%daughter(1), firstborn(1), &
	& b%daughter(2), firstborn(2), sign_decay, &
	& '(axis '//sign_axis//')'
	end if
	else
	write(u,'(5X,I0)') k
	end if
	end subroutine phs_branch_write

	@ %def phs_tree_write phs_branch_write
	@
	\subsection{PHS tree setup}
	\subsubsection{Transformation into an array of branch codes and back}
	Assume that the tree/array has been created before with the
	appropriate length and is empty.
	<<PHS trees: public>>=
	public :: phs_tree_from_array
	<<PHS trees: phs tree: TBP>>=
	procedure :: from_array => phs_tree_from_array
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_from_array (tree, a)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC), dimension(:), intent(in) :: a
	end subroutine phs_tree_from_array
	<<PHS trees: procedures>>=
	module subroutine phs_tree_from_array (tree, a)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC), dimension(:), intent(in) :: a
	integer :: i
	integer(TC) :: k
	<<Set branches from array [[a]]>>
	<<Set external branches if necessary>>
	<<Check number of branches>>
	<<Determine the connections>>
	contains
	<<Subroutine: set relatives>>
	end subroutine phs_tree_from_array

	@ %def phs_tree_from_array
	@ First, set all branches specified by the user. If all IN-bits
	are set, we invert the branch code.
	<<Set branches from array [[a]]>>=
	do i=1, size(a)
	k = a(i)
	if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k)
	tree%branch(k)%set = .true.
	tree%n_branches = tree%n_branches+1
	end do
	@ The external branches are understood, so set them now if not yet
	done. In all cases ensure that the representative with one bit set is
	used, except for decays where the in-particle is represented by all
	OUT-bits set instead.
	<<Set external branches if necessary>>=
	do i=0, tree%n_externals-1
	k = ibset(0,i)
	if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k)
	if (tree%branch(ieor(tree%mask, k))%set) then
	tree%branch(ieor(tree%mask, k))%set = .false.
	tree%branch(k)%set = .true.
	else if (.not.tree%branch(k)%set) then
	tree%branch(k)%set = .true.
	tree%n_branches = tree%n_branches+1
	end if
	end do
	@ Now the number of branches set can be checked. Here we assume that
	the tree is binary. For three externals there are three branches in
	total, and for each additional external branch we get another internal
	one.
	<<Check number of branches>>=
	if (tree%n_branches /= tree%n_externals*2-3) then
	call phs_tree_write (tree)
	call msg_bug &
	& (" Wrong number of branches set in phase space tree")
	end if
	@ For all branches that are set, except for the externals, we try to
	find the daughter branches:
	<<Determine the connections>>=
	do k=1, size (tree%branch)
	if (tree%branch(k)%set .and. tc_decay_level (k) /= 1) then
	call branch_set_relatives(k)
	end if
	end do
	@ To this end, we scan all codes less than the current code, whether
	we can find two branches which are set and which together give the
	current code. After that, the tree may still not be connected, but at
	least we know if a branch does not have daughters: This indicates some
	inconsistency.

	The algorithm ensures that, at this stage, the first daughter has a
	smaller code value than the second one.
	<<Subroutine: set relatives>>=
	subroutine branch_set_relatives (k)
	integer(TC), intent(in) :: k
	integer(TC) :: m,n
	do m=1, k-1
	if (iand(k,m)==m) then
	n = ieor(k,m)
	if ( tree%branch(m)%set .and. tree%branch(n)%set ) then
	tree%branch(k)%daughter(1) = m; tree%branch(k)%daughter(2) = n
	tree%branch(m)%mother = k; tree%branch(n)%mother = k
	tree%branch(m)%sibling = n; tree%branch(n)%sibling = m
	tree%branch(k)%has_children = .true.
	return
	end if
	end if
	end do
	call phs_tree_write (tree)
	call msg_bug &
	& (" Missing daughter branch(es) in phase space tree")
	end subroutine branch_set_relatives

	@ The inverse: this is trivial, fortunately.
	@
	\subsubsection{Flip $t$-channel into $s$-channel}
	Flipping the tree is done upwards, beginning from the decay products.
	First we select a $t$-channel branch [[k]]: one which is set, which
	does have an IN-bit, and which is not an external particle.

	Next, we determine the adjacent in-particle (called the 'friend' [[f]]
	here, since it will provide the reference axis for the angular
	integration). In addition, we look for the 'mother' and 'sibling' of
	this particle. If the latter field is empty, we select the (unique)
	other out-particle which has no mother, calling the internal
	subroutine [[find_orphan]].

	The flip is done as follows: We assume that the first daughter [[d]]
	is an $s$-channel line, which is true if the daughters are sorted.
	This will stay the first daughter. The second one is a $t$-channel
	line; it is exchanged with the 'sibling' [[s]]. The new line which
	replaces the branch [[k]] is just the sum of [[s]] and [[d]]. In
	addition, we have to rearrange the relatives of [[s]] and [[d]], as
	well of [[f]].

	Finally, we flip 'sibling' and 'friend' and set the new $s$-channel
	branch [[n]] which replaces the $t$-channel branch [[k]]. After this
	is complete, we are ready to execute another flip.

	[Although the friend is not needed for the final flip, since it would
	be an initial particle anyway, we need to know whether we have $t$- or
	$u$-channel.]
	<<PHS trees: phs tree: TBP>>=
	procedure :: flip_t_to_s_channel => phs_tree_flip_t_to_s_channel
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_flip_t_to_s_channel (tree)
	class(phs_tree_t), intent(inout) :: tree
	end subroutine phs_tree_flip_t_to_s_channel
	<<PHS trees: procedures>>=
	module subroutine phs_tree_flip_t_to_s_channel (tree)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC) :: k, f, m, n, d, s
	if (tree%n_in == 2) then
	FLIP: do k=3, tree%mask-1
	if (.not. tree%branch(k)%set) cycle FLIP
	f = iand(k,tree%mask_in)
	if (f==0 .or. f==k) cycle FLIP
	m = tree%branch(k)%mother
	s = tree%branch(k)%sibling
	if (s==0) call find_orphan(s)
	d = tree%branch(k)%daughter(1)
	n = ior(d,s)
	tree%branch(k)%set = .false.
	tree%branch(n)%set = .true.
	tree%branch(n)%origin = k
	tree%branch(n)%daughter(1) = d; tree%branch(d)%mother = n
	tree%branch(n)%daughter(2) = s; tree%branch(s)%mother = n
	tree%branch(n)%has_children = .true.
	tree%branch(d)%sibling = s; tree%branch(s)%sibling = d
	tree%branch(n)%sibling = f; tree%branch(f)%sibling = n
	tree%branch(n)%mother = m
	tree%branch(f)%mother = m
	if (m/=0) then
	tree%branch(m)%daughter(1) = n
	tree%branch(m)%daughter(2) = f
	end if
	tree%branch(n)%friend = f
	tree%branch(n)%has_friend = .true.
	tree%branch(n)%firstborn = 2
	end do FLIP
	end if
	contains
	subroutine find_orphan(s)
	integer(TC) :: s
	do s=1, tree%mask_out
	if (tree%branch(s)%set .and. tree%branch(s)%mother==0) return
	end do
	call phs_tree_write (tree)
	call msg_bug (" Can't flip phase space tree to channel")
	end subroutine find_orphan
	end subroutine phs_tree_flip_t_to_s_channel

	@ %def phs_tree_flip_t_to_s_channel
	@ After the tree has been flipped, one may need to determine what has
	become of a particular $t$-channel branch. This function gives the
	bincode of the flipped tree. If the original bincode does not contain
	IN-bits, we leave it as it is.
	<<PHS trees: procedures>>=
	function tc_flipped (tree, kt) result (ks)
	type(phs_tree_t), intent(in) :: tree
	integer(TC), intent(in) :: kt
	integer(TC) :: ks
	if (iand (kt, tree%mask_in) == 0) then
	ks = kt
	else
	ks = tree%branch(iand (kt, tree%mask_out))%mother
	end if
	end function tc_flipped

	@ %def tc_flipped
	@ Scan a tree and make sure that the first daughter has always a
	smaller code than the second one. Furthermore, delete any [[friend]]
	entry in the root branch -- this branching has the incoming particle
	direction as axis anyway. Keep track of reordering by updating
	[[inverted_axis]], [[inverted_decay]] and [[firstborn]].
	<<PHS trees: phs tree: TBP>>=
	procedure :: canonicalize => phs_tree_canonicalize
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_canonicalize (tree)
	class(phs_tree_t), intent(inout) :: tree
	end subroutine phs_tree_canonicalize
	<<PHS trees: procedures>>=
	module subroutine phs_tree_canonicalize (tree)
	class(phs_tree_t), intent(inout) :: tree
	integer :: n_out
	integer(TC) :: k_out
	call branch_canonicalize (tree%branch(tree%mask_out))
	n_out = tree%n_externals - tree%n_in
	k_out = tree%mask_out
	if (tree%branch(k_out)%has_friend &
	& .and. tree%branch(k_out)%friend == ibset (0, n_out)) then
	tree%branch(k_out)%inverted_axis = .not.tree%branch(k_out)%inverted_axis
	end if
	tree%branch(k_out)%has_friend = .false.
	tree%branch(k_out)%friend = 0
	contains
	recursive subroutine branch_canonicalize (b)
	type(phs_branch_t), intent(inout) :: b
	integer(TC) :: d1, d2
	if (b%has_children) then
	d1 = b%daughter(1)
	d2 = b%daughter(2)
	if (d1 > d2) then
	b%daughter(1) = d2
	b%daughter(2) = d1
	b%inverted_decay = .not.b%inverted_decay
	if (b%firstborn /= 0) b%firstborn = 3 - b%firstborn
	end if
	call branch_canonicalize (tree%branch(b%daughter(1)))
	call branch_canonicalize (tree%branch(b%daughter(2)))
	end if
	end subroutine branch_canonicalize
	end subroutine phs_tree_canonicalize

	@ %def phs_tree_canonicalize
	@
	\subsubsection{Mappings}
	Initialize a mapping for the current tree. This is done while reading
	from file, so the mapping parameters are read, but applied to the
	flipped tree. Thus, the size of the array of mappings is given by the
	number of outgoing particles only.
	<<PHS trees: phs tree: TBP>>=
	procedure :: init_mapping => phs_tree_init_mapping
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_init_mapping (tree, k, type, pdg, model)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC), intent(in) :: k
	type(string_t), intent(in) :: type
	integer, intent(in) :: pdg
	class(model_data_t), intent(in), target :: model
	end subroutine phs_tree_init_mapping
	<<PHS trees: procedures>>=
	module subroutine phs_tree_init_mapping (tree, k, type, pdg, model)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC), intent(in) :: k
	type(string_t), intent(in) :: type
	integer, intent(in) :: pdg
	class(model_data_t), intent(in), target :: model
	integer(TC) :: kk
	kk = tc_flipped (tree, k)
	call tree%mapping(kk)%init (kk, type, pdg, model)
	end subroutine phs_tree_init_mapping

	@ %def phs_tree_init_mapping
	@ Set the physical parameters for the mapping, using a specific
	parameter set. Also set the mass sum array.
	<<PHS trees: phs tree: TBP>>=
	procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_set_mapping_parameters &
	(tree, mapping_defaults, variable_limits)
	class(phs_tree_t), intent(inout) :: tree
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	end subroutine phs_tree_set_mapping_parameters
	<<PHS trees: procedures>>=
	module subroutine phs_tree_set_mapping_parameters &
	(tree, mapping_defaults, variable_limits)
	class(phs_tree_t), intent(inout) :: tree
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	integer(TC) :: k
	do k = 1, tree%n_branches_out
	call tree%mapping(k)%set_parameters (mapping_defaults, variable_limits)
	end do
	end subroutine phs_tree_set_mapping_parameters

	@ %def phs_tree_set_mapping_parameters
	@ Return the mapping for the sum of all outgoing particles. This
	should either be no mapping or a global s-channel mapping.
	<<PHS trees: phs tree: TBP>>=
	procedure :: assign_s_mapping => phs_tree_assign_s_mapping
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_assign_s_mapping (tree, mapping)
	class(phs_tree_t), intent(in) :: tree
	type(mapping_t), intent(out) :: mapping
	end subroutine phs_tree_assign_s_mapping
	<<PHS trees: procedures>>=
	module subroutine phs_tree_assign_s_mapping (tree, mapping)
	class(phs_tree_t), intent(in) :: tree
	type(mapping_t), intent(out) :: mapping
	mapping = tree%mapping(tree%mask_out)
	end subroutine phs_tree_assign_s_mapping

	@ %def phs_tree_assign_s_mapping
	@
	\subsubsection{Kinematics}
	Fill the mass sum array, starting from the external particles and
	working down to the tree root. For each bincode [[k]] we scan the
	bits in [[k]]; if only one is set, we take the physical mass of the
	corresponding external particle; if more then one is set, we sum up
	the two masses (which we know have already been set).
	<<PHS trees: phs tree: TBP>>=
	procedure :: set_mass_sum => phs_tree_set_mass_sum
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_set_mass_sum (tree, flv)
	class(phs_tree_t), intent(inout) :: tree
	type(flavor_t), dimension(:), intent(in) :: flv
	end subroutine phs_tree_set_mass_sum
	<<PHS trees: procedures>>=
	module subroutine phs_tree_set_mass_sum (tree, flv)
	class(phs_tree_t), intent(inout) :: tree
	type(flavor_t), dimension(:), intent(in) :: flv
	integer(TC) :: k
	integer :: i
	tree%mass_sum = 0
	do k = 1, tree%n_branches_out
	do i = 0, size (flv) - 1
	if (btest(k,i)) then
	if (ibclr(k,i) == 0) then
	tree%mass_sum(k) = flv(i+1)%get_mass ()
	else
	tree%mass_sum(k) = &
	tree%mass_sum(ibclr(k,i)) + tree%mass_sum(ibset(0,i))
	end if
	exit
	end if
	end do
	end do
	end subroutine phs_tree_set_mass_sum

	@ %def phs_tree_set_mass_sum
	@ Set the effective masses and widths. For each non-resonant branch
	in a tree, the effective mass is equal to the sum of the effective
	masses of the children (and analogous for the width). External
	particles have their real mass and width zero. For resonant branches,
	we insert mass and width from the corresponding mapping.

	This routine has [[phs_tree_set_mass_sum]] and
	[[phs_tree_set_mapping_parameters]] as prerequisites.
	<<PHS trees: phs tree: TBP>>=
	procedure :: set_effective_masses => phs_tree_set_effective_masses
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_set_effective_masses (tree)
	class(phs_tree_t), intent(inout) :: tree
	end subroutine phs_tree_set_effective_masses
	<<PHS trees: procedures>>=
	module subroutine phs_tree_set_effective_masses (tree)
	class(phs_tree_t), intent(inout) :: tree
	tree%effective_mass = 0
	tree%effective_width = 0
	call set_masses_x (tree%mask_out)
	contains
	recursive subroutine set_masses_x (k)
	integer(TC), intent(in) :: k
	integer(TC) :: k1, k2
	if (tree%branch(k)%has_children) then
	k1 = tree%branch(k)%daughter(1)
	k2 = tree%branch(k)%daughter(2)
	call set_masses_x (k1)
	call set_masses_x (k2)
	if (tree%mapping(k)%is_s_channel ()) then
	tree%effective_mass(k) = tree%mapping(k)%get_mass ()
	tree%effective_width(k) = tree%mapping(k)%get_width ()
	else
	tree%effective_mass(k) = &
	tree%effective_mass(k1) + tree%effective_mass(k2)
	tree%effective_width(k) = &
	tree%effective_width(k1) + tree%effective_width(k2)
	end if
	else
	tree%effective_mass(k) = tree%mass_sum(k)
	end if
	end subroutine set_masses_x
	end subroutine phs_tree_set_effective_masses

	@ %def phs_tree_set_effective_masses
	@ Define step mappings, recursively, for the decay products of all
	intermediate resonances. Step mappings account for the fact that a
	branch may originate from a resonance, which almost replaces the
	upper limit on the possible invariant mass. The step
	mapping implements a smooth cutoff that interpolates between the
	resonance and the real kinematic limit. The mapping width determines
	the sharpness of the cutoff.

	Step mappings are inserted only for branches that are not mapped
	otherwise.

	At each branch, we record the mass that is effectively available for
	phase space, by taking the previous limit and subtracting the
	effective mass of the sibling branch. Widths are added, not subtracted.

	If we encounter a resonance decay, we discard the previous limit and
	replace it by the mass and width of the resonance, also subtracting
	the sibling branch.

	Initially, the limit is zero, so it becomes negative at any branch. Only
	if there is a resonance, the limit becomes positive. Whenever the
	limit is positive, and the current branch decays, we activate a step
	mapping for the current branch.

	As a result, step mappings are implemented for all internal lines that
	originate from an intermediate resonance decay.

	The flag [[variable_limits]] applies to the ultimate limit from the
	available energy, not to the intermediate resonances whose masses are
	always fixed.

	This routine requires [[phs_tree_set_effective_masses]]
	<<PHS trees: phs tree: TBP>>=
	procedure :: set_step_mappings => phs_tree_set_step_mappings
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_set_step_mappings &
	(tree, exp_type, variable_limits)
	class(phs_tree_t), intent(inout) :: tree
	logical, intent(in) :: exp_type
	logical, intent(in) :: variable_limits
	end subroutine phs_tree_set_step_mappings
	<<PHS trees: procedures>>=
	module subroutine phs_tree_set_step_mappings &
	(tree, exp_type, variable_limits)
	class(phs_tree_t), intent(inout) :: tree
	logical, intent(in) :: exp_type
	logical, intent(in) :: variable_limits
	type(string_t) :: map_str
	integer(TC) :: k
	if (exp_type) then
	map_str = "step_exp"
	else
	map_str = "step_hyp"
	end if
	k = tree%mask_out
	call set_step_mappings_x (k, 0._default, 0._default)
	contains
	recursive subroutine set_step_mappings_x (k, m_limit, w_limit)
	integer(TC), intent(in) :: k
	real(default), intent(in) :: m_limit, w_limit
	integer(TC), dimension(2) :: kk
	real(default), dimension(2) :: m, w
	if (tree%branch(k)%has_children) then
	if (m_limit > 0) then
	if (.not. tree%mapping(k)%is_set ()) then
	call tree%mapping(k)%init (k, map_str)
	call tree%mapping(k)%set_step_mapping_parameters (m_limit, &
	w_limit, variable_limits)
	end if
	end if
	kk = tree%branch(k)%daughter
	m = tree%effective_mass(kk)
	w = tree%effective_width(kk)
	if (tree%mapping(k)%is_s_channel ()) then
	call set_step_mappings_x (kk(1), &
	tree%mapping(k)%get_mass () - m(2), &
	tree%mapping(k)%get_width () + w(2))
	call set_step_mappings_x (kk(2), &
	tree%mapping(k)%get_mass () - m(1), &
	tree%mapping(k)%get_width () + w(1))
	else if (m_limit > 0) then
	call set_step_mappings_x (kk(1), &
	m_limit - m(2), &
	w_limit + w(2))
	call set_step_mappings_x (kk(2), &
	m_limit - m(1), &
	w_limit + w(1))
	else
	call set_step_mappings_x (kk(1), &
	- m(2), &
	+ w(2))
	call set_step_mappings_x (kk(2), &
	- m(1), &
	+ w(1))
	end if
	end if
	end subroutine set_step_mappings_x
	end subroutine phs_tree_set_step_mappings

	@ %def phs_tree_set_step_mappings
	@
	\subsubsection{Resonance structure}
	We identify the resonances within a tree as the set of s-channel
	mappings. The [[resonance_history_t]] type serves as the result
	container.
	<<PHS trees: phs tree: TBP>>=
	procedure :: extract_resonance_history => phs_tree_extract_resonance_history
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_extract_resonance_history (tree, res_history)
	class(phs_tree_t), intent(in) :: tree
	type(resonance_history_t), intent(out) :: res_history
	end subroutine phs_tree_extract_resonance_history
	<<PHS trees: procedures>>=
	module subroutine phs_tree_extract_resonance_history (tree, res_history)
	class(phs_tree_t), intent(in) :: tree
	type(resonance_history_t), intent(out) :: res_history
	type(resonance_info_t) :: res_info
	integer :: i
	if (allocated (tree%mapping)) then
	do i = 1, size (tree%mapping)
	associate (mapping => tree%mapping(i))
	if (mapping%is_s_channel ()) then
	call res_info%init (mapping%get_bincode (), mapping%get_flv (), &
	n_out = tree%n_externals - tree%n_in)
	call res_history%add_resonance (res_info)
	end if
	end associate
	end do
	end if
	end subroutine phs_tree_extract_resonance_history

	@ %def phs_tree_extract_resonance_history
	@
	\subsubsection{Structural comparison}
	This function allows to check whether one tree is the permutation of
	another one. The permutation is applied to the second tree in the
	argument list. We do not make up a temporary permuted tree, but
	compare the two trees directly. The branches are scanned recursively,
	where for each daughter we check the friend and the mapping as well.
	Once a discrepancy is found, the recursion is exited immediately.
	<<PHS trees: public>>=
	public :: phs_tree_equivalent
	<<PHS trees: sub interfaces>>=
	module function phs_tree_equivalent (t1, t2, perm) result (is_equal)
	type(phs_tree_t), intent(in) :: t1, t2
	type(permutation_t), intent(in) :: perm
	logical :: equal, is_equal
	end function phs_tree_equivalent
	<<PHS trees: procedures>>=
	module function phs_tree_equivalent (t1, t2, perm) result (is_equal)
	type(phs_tree_t), intent(in) :: t1, t2
	type(permutation_t), intent(in) :: perm
	logical :: equal, is_equal
	integer(TC) :: k1, k2, mask_in
	k1 = t1%mask_out
	k2 = t2%mask_out
	mask_in = t1%mask_in
	equal = .true.
	call check (t1%branch(k1), t2%branch(k2), k1, k2)
	is_equal = equal
	contains
	recursive subroutine check (b1, b2, k1, k2)
	type(phs_branch_t), intent(in) :: b1, b2
	integer(TC), intent(in) :: k1, k2
	integer(TC), dimension(2) :: d1, d2, pd2
	integer :: i
	if (.not.b1%has_friend .and. .not.b2%has_friend) then
	equal = .true.
	else if (b1%has_friend .and. b2%has_friend) then
	equal = (b1%friend == tc_permute (b2%friend, perm, mask_in))
	end if
	if (equal) then
	if (b1%has_children .and. b2%has_children) then
	d1 = b1%daughter
	d2 = b2%daughter
	do i=1, 2
	pd2(i) = tc_permute (d2(i), perm, mask_in)
	end do
	if (d1(1)==pd2(1) .and. d1(2)==pd2(2)) then
	equal = (b1%firstborn == b2%firstborn)
	if (equal) call check &
	& (t1%branch(d1(1)), t2%branch(d2(1)), d1(1), d2(1))
	if (equal) call check &
	& (t1%branch(d1(2)), t2%branch(d2(2)), d1(2), d2(2))
	else if (d1(1)==pd2(2) .and. d1(2)==pd2(1)) then
	equal = ( (b1%firstborn == 0 .and. b2%firstborn == 0) &
	& .or. (b1%firstborn == 3 - b2%firstborn) )
	if (equal) call check &
	& (t1%branch(d1(1)), t2%branch(d2(2)), d1(1), d2(2))
	if (equal) call check &
	& (t1%branch(d1(2)), t2%branch(d2(1)), d1(2), d2(1))
	else
	equal = .false.
	end if
	end if
	end if
	if (equal) then
	equal = (t1%mapping(k1) == t2%mapping(k2))
	end if
	end subroutine check
	end function phs_tree_equivalent

	@ %def phs_tree_equivalent
	@ Scan two decay trees and determine the correspondence of mass
	variables, i.e., the permutation that transfers the ordered list of
	mass variables belonging to the second tree into the first one. Mass
	variables are assigned beginning from branches and ending at the root.
	<<PHS trees: public>>=
	public :: phs_tree_find_msq_permutation
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_find_msq_permutation &
	(tree1, tree2, perm2, msq_perm)
	type(phs_tree_t), intent(in) :: tree1, tree2
	type(permutation_t), intent(in) :: perm2
	type(permutation_t), intent(out) :: msq_perm
	end subroutine phs_tree_find_msq_permutation
	<<PHS trees: procedures>>=
	module subroutine phs_tree_find_msq_permutation &
	(tree1, tree2, perm2, msq_perm)
	type(phs_tree_t), intent(in) :: tree1, tree2
	type(permutation_t), intent(in) :: perm2
	type(permutation_t), intent(out) :: msq_perm
	type(permutation_t) :: perm1
	integer(TC) :: mask_in, root
	integer(TC), dimension(:), allocatable :: index1, index2
	integer :: i
	allocate (index1 (tree1%n_msq), index2 (tree2%n_msq))
	call permutation_init (perm1, permutation_size (perm2))
	mask_in = tree1%mask_in
	root = tree1%mask_out
	i = 0
	call tree_scan (tree1, root, perm1, index1)
	i = 0
	call tree_scan (tree2, root, perm2, index2)
	call permutation_find (msq_perm, index1, index2)
	contains
	recursive subroutine tree_scan (tree, k, perm, index)
	type(phs_tree_t), intent(in) :: tree
	integer(TC), intent(in) :: k
	type(permutation_t), intent(in) :: perm
	integer, dimension(:), intent(inout) :: index
	if (tree%branch(k)%has_children) then
	call tree_scan (tree, tree%branch(k)%daughter(1), perm, index)
	call tree_scan (tree, tree%branch(k)%daughter(2), perm, index)
	i = i + 1
	if (i <= size (index)) index(i) = tc_permute (k, perm, mask_in)
	end if
	end subroutine tree_scan
	end subroutine phs_tree_find_msq_permutation

	@ %def phs_tree_find_msq_permutation
	<<PHS trees: public>>=
	public :: phs_tree_find_angle_permutation
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_find_angle_permutation &
	(tree1, tree2, perm2, angle_perm, sig2)
	type(phs_tree_t), intent(in) :: tree1, tree2
	type(permutation_t), intent(in) :: perm2
	type(permutation_t), intent(out) :: angle_perm
	logical, dimension(:), allocatable, intent(out) :: sig2
	end subroutine phs_tree_find_angle_permutation
	<<PHS trees: procedures>>=
	module subroutine phs_tree_find_angle_permutation &
	(tree1, tree2, perm2, angle_perm, sig2)
	type(phs_tree_t), intent(in) :: tree1, tree2
	type(permutation_t), intent(in) :: perm2
	type(permutation_t), intent(out) :: angle_perm
	logical, dimension(:), allocatable, intent(out) :: sig2
	type(permutation_t) :: perm1
	integer(TC) :: mask_in, root
	integer(TC), dimension(:), allocatable :: index1, index2
	logical, dimension(:), allocatable :: sig1
	integer :: i
	allocate (index1 (tree1%n_angles), index2 (tree2%n_angles))
	allocate (sig1 (tree1%n_angles), sig2 (tree2%n_angles))
	call permutation_init (perm1, permutation_size (perm2))
	mask_in = tree1%mask_in
	root = tree1%mask_out
	i = 0
	call tree_scan (tree1, root, perm1, index1, sig1)
	i = 0
	call tree_scan (tree2, root, perm2, index2, sig2)
	call permutation_find (angle_perm, index1, index2)
	contains
	recursive subroutine tree_scan (tree, k, perm, index, sig)
	type(phs_tree_t), intent(in) :: tree
	integer(TC), intent(in) :: k
	type(permutation_t), intent(in) :: perm
	integer, dimension(:), intent(inout) :: index
	logical, dimension(:), intent(inout) :: sig
	integer(TC) :: k1, k2, kp
	logical :: s
	if (tree%branch(k)%has_children) then
	k1 = tree%branch(k)%daughter(1)
	k2 = tree%branch(k)%daughter(2)
	s = (tc_permute(k1, perm, mask_in) < tc_permute(k2, perm, mask_in))
	kp = tc_permute (k, perm, mask_in)
	i = i + 1
	index(i) = kp
	sig(i) = s
	i = i + 1
	index(i) = - kp
	sig(i) = s
	call tree_scan (tree, k1, perm, index, sig)
	call tree_scan (tree, k2, perm, index, sig)
	end if
	end subroutine tree_scan
	end subroutine phs_tree_find_angle_permutation

	@ %def phs_tree_find_angle_permutation
	@
	\subsection{Phase-space evaluation}
	\subsubsection{Phase-space volume}
	We compute the phase-space volume recursively, following the same path
	as for computing other kinematical variables. However, the volume
	depends just on $\sqrt{\hat s}$, not on the momentum configuration.

	Note: counting branches, we may replace this by a simple formula.
	<<PHS trees: phs tree: TBP>>=
	procedure :: compute_volume => phs_tree_compute_volume
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_compute_volume (tree, sqrts, volume)
	class(phs_tree_t), intent(in) :: tree
	real(default), intent(in) :: sqrts
	real(default), intent(out) :: volume
	end subroutine phs_tree_compute_volume
	<<PHS trees: procedures>>=
	module subroutine phs_tree_compute_volume (tree, sqrts, volume)
	class(phs_tree_t), intent(in) :: tree
	real(default), intent(in) :: sqrts
	real(default), intent(out) :: volume
	integer(TC) :: k
	k = tree%mask_out
	if (tree%branch(k)%has_children) then
	call compute_volume_x (tree%branch(k), k, volume, .true.)
	else
	volume = 1
	end if
	contains
	recursive subroutine compute_volume_x (b, k, volume, initial)
	type(phs_branch_t), intent(in) :: b
	integer(TC), intent(in) :: k
	real(default), intent(out) :: volume
	logical, intent(in) :: initial
	integer(TC) :: k1, k2
	real(default) :: v1, v2
	k1 = b%daughter(1); k2 = b%daughter(2)
	if (tree%branch(k1)%has_children) then
	call compute_volume_x (tree%branch(k1), k1, v1, .false.)
	else
	v1 = 1
	end if
	if (tree%branch(k2)%has_children) then
	call compute_volume_x (tree%branch(k2), k2, v2, .false.)
	else
	v2 = 1
	end if
	if (initial) then
	volume = v1 * v2 / (4 * twopi5)
	else
	volume = v1 * v2 * sqrts*2 / (4 twopi2)
	end if
	end subroutine compute_volume_x
	end subroutine phs_tree_compute_volume

	@ %def phs_tree_compute_volume
	@
	\subsubsection{Determine momenta}
	This is done in two steps: First the masses are determined. This step
	may fail, in which case [[ok]] is set to false. If successful, we
	generate angles and the actual momenta. The array [[decay_p]] serves
	for transferring the individual three-momenta of the daughter
	particles in their mother rest frame from the mass generation to the
	momentum generation step.
	<<PHS trees: phs tree: TBP>>=
	procedure :: compute_momenta_from_x => phs_tree_compute_momenta_from_x
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_compute_momenta_from_x &
	(tree, prt, factor, volume, sqrts, x, ok)
	class(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	real(default), intent(out) :: factor, volume
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(in) :: x
	logical, intent(out) :: ok
	end subroutine phs_tree_compute_momenta_from_x
	<<PHS trees: procedures>>=
	module subroutine phs_tree_compute_momenta_from_x &
	(tree, prt, factor, volume, sqrts, x, ok)
	class(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	real(default), intent(out) :: factor, volume
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(in) :: x
	logical, intent(out) :: ok
	real(default), dimension(tree%mask_out) :: decay_p
	integer :: n1, n2
	integer :: n_out
	if (tree%real_phsp) then
	n_out = tree%n_externals - tree%n_in - 1
	n1 = max (n_out-2, 0)
	n2 = n1 + max (2*n_out, 0)
	else
	n1 = tree%n_msq
	n2 = n1 + tree%n_angles
	end if
	call phs_tree_set_msq &
	(tree, prt, factor, volume, decay_p, sqrts, x(1:n1), ok)
	if (ok) call phs_tree_set_angles &
	(tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
	end subroutine phs_tree_compute_momenta_from_x

	@ %def phs_tree_compute_momenta_from_x
	@ Mass generation is done recursively. The [[ok]] flag causes the
	filled tree to be discarded if set to [[.false.]]. This happens if a
	three-momentum turns out to be imaginary, indicating impossible
	kinematics. The index [[ix]] tells us how far we have used up the
	input array [[x]].
	<<PHS trees: procedures>>=
	subroutine phs_tree_set_msq &
	(tree, prt, factor, volume, decay_p, sqrts, x, ok)
	type(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	real(default), intent(out) :: factor, volume
	real(default), dimension(:), intent(out) :: decay_p
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(in) :: x
	logical, intent(out) :: ok
	integer :: ix
	integer(TC) :: k
	real(default) :: m_tot
	ok =.true.
	ix = 1
	k = tree%mask_out
	m_tot = tree%mass_sum(k)
	decay_p(k) = 0.
	if (m_tot < sqrts .or. k == 1) then
	if (tree%branch(k)%has_children) then
	call set_msq_x (tree%branch(k), k, factor, volume, .true.)
	else
	factor = 1
	volume = 1
	end if
	else
	ok = .false.
	end if
	contains
	recursive subroutine set_msq_x (b, k, factor, volume, initial)
	type(phs_branch_t), intent(in) :: b
	integer(TC), intent(in) :: k
	real(default), intent(out) :: factor, volume
	logical, intent(in) :: initial
	real(default) :: msq, m, m_min, m_max, m1, m2, msq1, msq2, lda, rlda
	integer(TC) :: k1, k2
	real(default) :: f1, f2, v1, v2
	k1 = b%daughter(1); k2 = b%daughter(2)
	if (tree%branch(k1)%has_children) then
	call set_msq_x (tree%branch(k1), k1, f1, v1, .false.)
	if (.not.ok) return
	else
	f1 = 1; v1 = 1
	end if
	if (tree%branch(k2)%has_children) then
	call set_msq_x (tree%branch(k2), k2, f2, v2, .false.)
	if (.not.ok) return
	else
	f2 = 1; v2 = 1
	end if
	m_min = tree%mass_sum(k)
	if (initial) then
	msq = sqrts**2
	m = sqrts
	m_max = sqrts
	factor = f1 * f2
	volume = v1 * v2 / (4 * twopi5)
	else
	m_max = sqrts - m_tot + m_min
	call tree%mapping(k)%compute_msq_from_x (sqrts2, m_min2, &
	m_max**2, msq, factor, x(ix)); ix = ix + 1
	if (msq >= 0) then
	m = sqrt (msq)
	factor = f1 * f2 * factor
	volume = v1 * v2 * sqrts*2 / (4 twopi2)
	call prt(k)%set_msq (msq)
	call prt(k)%set_defined ()
	else
	ok = .false.
	end if
	end if
	if (ok) then
	msq1 = prt(k1)%get_msq (); m1 = sqrt (msq1)
	msq2 = prt(k2)%get_msq (); m2 = sqrt (msq2)
	lda = lambda (msq, msq1, msq2)
	if (lda > 0 .and. m > m1 + m2 .and. m <= m_max) then
	rlda = sqrt (lda)
	decay_p(k1) = rlda / (2*m)
	decay_p(k2) = - decay_p(k1)
	factor = rlda / msq * factor
	else
	ok = .false.
	end if
	end if
	end subroutine set_msq_x

	end subroutine phs_tree_set_msq

	@ %def phs_tree_set_msq
	@
	The heart of phase space generation: Now we have the invariant masses,
	let us generate angles. At each branch, we take a Lorentz
	transformation and augment it by a boost to the current particle
	rest frame, and by rotations $\phi$ and $\theta$ around the $z$ and
	$y$ axis, respectively. This transformation is passed down to the
	daughter particles, if present.
	<<PHS trees: procedures>>=
	subroutine phs_tree_set_angles (tree, prt, factor, decay_p, sqrts, x)
	type(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	real(default), intent(inout) :: factor
	real(default), dimension(:), intent(in) :: decay_p
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(in) :: x
	integer :: ix
	integer(TC) :: k
	ix = 1
	k = tree%mask_out
	call set_angles_x (tree%branch(k), k)
	contains
	recursive subroutine set_angles_x (b, k, L0)
	type(phs_branch_t), intent(in) :: b
	integer(TC), intent(in) :: k
	type(lorentz_transformation_t), intent(in), optional :: L0
	real(default) :: m, msq, ct, st, phi, f, E, p, bg
	type(lorentz_transformation_t) :: L, LL
	integer(TC) :: k1, k2
	type(vector3_t) :: axis
	p = decay_p(k)
	msq = prt(k)%get_msq (); m = sqrt (msq)
	E = sqrt (msq + p**2)
	if (present (L0)) then
	call prt(k)%set_momentum (L0 * vector4_moving (E,p,3))
	else
	call prt(k)%set_momentum (vector4_moving (E,p,3))
	end if
	call prt(k)%set_defined ()
	if (b%has_children) then
	k1 = b%daughter(1)
	k2 = b%daughter(2)
	if (m > 0) then
	bg = p / m
	else
	bg = 0
	end if
	phi = x(ix) * twopi; ix = ix + 1
	call tree%mapping(k)%compute_ct_from_x (sqrts**2, ct, st, f, &
	x(ix)); ix = ix + 1
	factor = factor * f
	if (.not. b%has_friend) then
	L = LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), bg)
	!!! The function above is equivalent to:
	! L = boost (bg,3) * rotation (phi,3) * rotation (ct,st,2)
	else
	LL = boost (-bg,3); if (present (L0)) LL = LL * inverse(L0)
	axis = space_part ( &
	LL * prt(tree%branch(k)%friend)%get_momentum () )
	L = boost(bg,3) * rotation_to_2nd (vector3_canonical(3), axis) &
	* LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), 0._default)
	end if
	if (present (L0)) L = L0 * L
	call set_angles_x (tree%branch(k1), k1, L)
	call set_angles_x (tree%branch(k2), k2, L)
	end if
	end subroutine set_angles_x

	end subroutine phs_tree_set_angles

	@ %def phs_tree_set_angles
	@
	\subsubsection{Recover random numbers}
	For the other channels we want to compute the random numbers that
	would have generated the momenta that we already know.
	<<PHS trees: phs tree: TBP>>=
	procedure :: compute_x_from_momenta => phs_tree_compute_x_from_momenta
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_compute_x_from_momenta &
	(tree, prt, factor, sqrts, x)
	class(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(in) :: prt
	real(default), intent(out) :: factor
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(inout) :: x
	end subroutine phs_tree_compute_x_from_momenta
	<<PHS trees: procedures>>=
	module subroutine phs_tree_compute_x_from_momenta &
	(tree, prt, factor, sqrts, x)
	class(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(in) :: prt
	real(default), intent(out) :: factor
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(inout) :: x
	real(default), dimension(tree%mask_out) :: decay_p
	integer :: n1, n2
	n1 = tree%n_msq
	n2 = n1 + tree%n_angles
	call phs_tree_get_msq &
	(tree, prt, factor, decay_p, sqrts, x(1:n1))
	call phs_tree_get_angles &
	(tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
	end subroutine phs_tree_compute_x_from_momenta

	@ %def phs_tree_compute_x_from_momenta
	@ The inverse operation follows exactly the same steps. The tree is
	[[inout]] because it contains mappings whose parameters can be reset
	when the mapping is applied.
	<<PHS trees: procedures>>=
	subroutine phs_tree_get_msq (tree, prt, factor, decay_p, sqrts, x)
	type(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(in) :: prt
	real(default), intent(out) :: factor
	real(default), dimension(:), intent(out) :: decay_p
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(inout) :: x
	integer :: ix
	integer(TC) :: k
	real(default) :: m_tot
	ix = 1
	k = tree%mask_out
	m_tot = tree%mass_sum(k)
	decay_p(k) = 0.
	if (tree%branch(k)%has_children) then
	call get_msq_x (tree%branch(k), k, factor, .true.)
	else
	factor = 1
	end if
	contains
	recursive subroutine get_msq_x (b, k, factor, initial)
	type(phs_branch_t), intent(in) :: b
	integer(TC), intent(in) :: k
	real(default), intent(out) :: factor
	logical, intent(in) :: initial
	real(default) :: msq, m, m_min, m_max, msq1, msq2, lda, rlda
	integer(TC) :: k1, k2
	real(default) :: f1, f2
	k1 = b%daughter(1); k2 = b%daughter(2)
	if (tree%branch(k1)%has_children) then
	call get_msq_x (tree%branch(k1), k1, f1, .false.)
	else
	f1 = 1
	end if
	if (tree%branch(k2)%has_children) then
	call get_msq_x (tree%branch(k2), k2, f2, .false.)
	else
	f2 = 1
	end if
	m_min = tree%mass_sum(k)
	m_max = sqrts - m_tot + m_min
	msq = prt(k)%get_msq (); m = sqrt (msq)
	if (initial) then
	factor = f1 * f2
	else
	call tree%mapping(k)%compute_x_from_msq (sqrts2, m_min2, &
	m_max**2, msq, factor, x(ix)); ix = ix + 1
	factor = f1 * f2 * factor
	end if
	msq1 = prt(k1)%get_msq ()
	msq2 = prt(k2)%get_msq ()
	lda = lambda (msq, msq1, msq2)
	if (lda > 0) then
	rlda = sqrt (lda)
	decay_p(k1) = rlda / (2 * m)
	decay_p(k2) = - decay_p(k1)
	factor = rlda / msq * factor
	else
	decay_p(k1) = 0
	decay_p(k2) = 0
	factor = 0
	end if
	end subroutine get_msq_x

	end subroutine phs_tree_get_msq

	@ %def phs_tree_get_msq
	@ This subroutine is the most time-critical part of the whole
	program. Therefore, we do not exactly parallel the angle generation
	routine above but make sure that things get evaluated only if they are
	really needed, at the expense of readability. Particularly important
	is to have as few multiplications of Lorentz transformations as
	possible.
	<<PHS trees: procedures>>=
	subroutine phs_tree_get_angles (tree, prt, factor, decay_p, sqrts, x)
	type(phs_tree_t), intent(inout) :: tree
	type(phs_prt_t), dimension(:), intent(in) :: prt
	real(default), intent(inout) :: factor
	real(default), dimension(:), intent(in) :: decay_p
	real(default), intent(in) :: sqrts
	real(default), dimension(:), intent(out) :: x
	integer :: ix
	integer(TC) :: k
	ix = 1
	k = tree%mask_out
	if (tree%branch(k)%has_children) then
	call get_angles_x (tree%branch(k), k)
	end if
	contains
	recursive subroutine get_angles_x (b, k, ct0, st0, phi0, L0)
	type(phs_branch_t), intent(in) :: b
	integer(TC), intent(in) :: k
	real(default), intent(in), optional :: ct0, st0, phi0
	type(lorentz_transformation_t), intent(in), optional :: L0
	real(default) :: cp0, sp0, m, msq, ct, st, phi, bg, f
	type(lorentz_transformation_t) :: L, LL
	type(vector4_t) :: p1, pf
	type(vector3_t) :: n, axis
	integer(TC) :: k1, k2, kf
	logical :: has_friend, need_L
	k1 = b%daughter(1)
	k2 = b%daughter(2)
	kf = b%friend
	has_friend = b%has_friend
	if (present(L0)) then
	p1 = L0 * prt(k1)%get_momentum ()
	if (has_friend) pf = L0 * prt(kf)%get_momentum ()
	else
	p1 = prt(k1)%get_momentum ()
	if (has_friend) pf = prt(kf)%get_momentum ()
	end if
	if (present(phi0)) then
	cp0 = cos (phi0)
	sp0 = sin (phi0)
	end if
	msq = prt(k)%get_msq (); m = sqrt (msq)
	if (m > 0) then
	bg = decay_p(k) / m
	else
	bg = 0
	end if
	if (has_friend) then
	if (present (phi0)) then
	axis = axis_from_p_r3_r2_b3 (pf, cp0, -sp0, ct0, -st0, -bg)
	LL = rotation_to_2nd (axis, vector3_canonical (3)) &
	* LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
	else
	axis = axis_from_p_b3 (pf, -bg)
	LL = rotation_to_2nd (axis, vector3_canonical(3))
	if (.not. vanishes (bg)) LL = LL * boost(-bg, 3)
	end if
	n = space_part (LL * p1)
	else if (present (phi0)) then
	n = axis_from_p_r3_r2_b3 (p1, cp0, -sp0, ct0, -st0, -bg)
	else
	n = axis_from_p_b3 (p1, -bg)
	end if
	phi = azimuthal_angle (n)
	x(ix) = phi / twopi; ix = ix + 1
	ct = polar_angle_ct (n)
	st = sqrt (1 - ct**2)
	call tree%mapping(k)%compute_x_from_ct (sqrts**2, ct, f, &
	x(ix)); ix = ix + 1
	factor = factor * f
	if (tree%branch(k1)%has_children .or. tree%branch(k2)%has_children) then
	need_L = .true.
	if (has_friend) then
	if (present (L0)) then
	L = LL * L0
	else
	L = LL
	end if
	else if (present (L0)) then
	L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) * L0
	else if (present (phi0)) then
	L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
	else if (bg /= 0) then
	L = boost(-bg, 3)
	else
	need_L = .false.
	end if
	if (need_L) then
	if (tree%branch(k1)%has_children) &
	call get_angles_x (tree%branch(k1), k1, ct, st, phi, L)
	if (tree%branch(k2)%has_children) &
	call get_angles_x (tree%branch(k2), k2, ct, st, phi, L)
	else
	if (tree%branch(k1)%has_children) &
	call get_angles_x (tree%branch(k1), k1, ct, st, phi)
	if (tree%branch(k2)%has_children) &
	call get_angles_x (tree%branch(k2), k2, ct, st, phi)
	end if
	end if
	end subroutine get_angles_x
	end subroutine phs_tree_get_angles

	@ %def phs_tree_get_angles
	@
	\subsubsection{Auxiliary stuff}
	This calculates all momenta that are not yet known by summing up
	daughter particle momenta. The external particles must be known.
	Only composite particles not yet known are calculated.
	<<PHS trees: public>>=
	public :: phs_tree_combine_particles
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_combine_particles (tree, prt)
	type(phs_tree_t), intent(in) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	end subroutine phs_tree_combine_particles
	<<PHS trees: procedures>>=
	module subroutine phs_tree_combine_particles (tree, prt)
	type(phs_tree_t), intent(in) :: tree
	type(phs_prt_t), dimension(:), intent(inout) :: prt
	call combine_particles_x (tree%mask_out)
	contains
	recursive subroutine combine_particles_x (k)
	integer(TC), intent(in) :: k
	integer :: k1, k2
	if (tree%branch(k)%has_children) then
	k1 = tree%branch(k)%daughter(1); k2 = tree%branch(k)%daughter(2)
	call combine_particles_x (k1)
	call combine_particles_x (k2)
	if (.not. prt(k)%defined) then
	call prt(k)%combine (prt(k1), prt(k2))
	end if
	end if
	end subroutine combine_particles_x
	end subroutine phs_tree_combine_particles

	@ %def phs_tree_combine_particles
	@ The previous routine is to be evaluated at runtime. Instead of
	scanning trees, we can as well set up a multiplication table. This is
	generated here. Note that the table is [[intent(out)]].
	<<PHS trees: public>>=
	public :: phs_tree_setup_prt_combinations
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_setup_prt_combinations (tree, comb)
	type(phs_tree_t), intent(in) :: tree
	integer, dimension(:,:), intent(out) :: comb
	end subroutine phs_tree_setup_prt_combinations
	<<PHS trees: procedures>>=
	module subroutine phs_tree_setup_prt_combinations (tree, comb)
	type(phs_tree_t), intent(in) :: tree
	integer, dimension(:,:), intent(out) :: comb
	comb = 0
	call setup_prt_combinations_x (tree%mask_out)
	contains
	recursive subroutine setup_prt_combinations_x (k)
	integer(TC), intent(in) :: k
	integer, dimension(2) :: kk
	if (tree%branch(k)%has_children) then
	kk = tree%branch(k)%daughter
	call setup_prt_combinations_x (kk(1))
	call setup_prt_combinations_x (kk(2))
	comb(:,k) = kk
	end if
	end subroutine setup_prt_combinations_x
	end subroutine phs_tree_setup_prt_combinations

	@ %def phs_tree_setup_prt_combinations
	@ JRR: 2022-01-22 [[reshuffle_mappings]] is commented out, and no
	longer used, not clear why?
	<<PHS trees: phs tree: TBP>>=
	procedure :: reshuffle_mappings => phs_tree_reshuffle_mappings
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_reshuffle_mappings (tree)
	class(phs_tree_t), intent(inout) :: tree
	end subroutine phs_tree_reshuffle_mappings
	<<PHS trees: procedures>>=
	module subroutine phs_tree_reshuffle_mappings (tree)
	class(phs_tree_t), intent(inout) :: tree
	integer(TC) :: k0, k_old, k_new, k2
	integer :: i
	type(mapping_t) :: mapping_tmp
	real(default) :: mass_tmp
	do i = 1, size (tree%momentum_link)
	if (i /= tree%momentum_link (i)) then
	k_old = 2**(i-tree%n_in-1)
	k_new = 2**(tree%momentum_link(i)-tree%n_in-1)
	k0 = tree%branch(k_old)%mother
	k2 = k_new + tree%branch(k_old)%sibling
	mapping_tmp = tree%mapping(k0)
	mass_tmp = tree%mass_sum(k0)
	tree%mapping(k0) = tree%mapping(k2)
	tree%mapping(k2) = mapping_tmp
	tree%mass_sum(k0) = tree%mass_sum(k2)
	tree%mass_sum(k2) = mass_tmp
	end if
	end do
	end subroutine phs_tree_reshuffle_mappings

	@ %def phs_tree_reshuffle_mappings
	@
	<<PHS trees: public>>=
	public :: phs_tree_set_momentum_links
	<<PHS trees: sub interfaces>>=
	module subroutine phs_tree_set_momentum_links (tree, list)
	type(phs_tree_t), intent(inout) :: tree
	integer, dimension(:), allocatable :: list
	end subroutine phs_tree_set_momentum_links
	<<PHS trees: procedures>>=
	module subroutine phs_tree_set_momentum_links (tree, list)
	type(phs_tree_t), intent(inout) :: tree
	integer, dimension(:), allocatable :: list
	tree%momentum_link = list
	end subroutine phs_tree_set_momentum_links

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

	module phs_trees_ut
	use unit_tests
	use phs_trees_uti

	<<Standard module head>>

	<<PHS trees: public test>>

	contains

	<<PHS trees: test driver>>

	end module phs_trees_ut
	@ %def phs_trees_ut
	@
	<<[[phs_trees_uti.f90]]>>=
	<<File header>>

	module phs_trees_uti

	!!!<<Use kinds>>
	use kinds, only: TC
	<<Use strings>>
	use flavors, only: flavor_t
	use model_data, only: model_data_t

	use resonances, only: resonance_history_t
	use mappings, only: mapping_defaults_t

	use phs_trees

	<<Standard module head>>

	<<PHS trees: test declarations>>

	contains

	<<PHS trees: tests>>

	end module phs_trees_uti
	@ %def phs_trees_ut
	@ API: driver for the unit tests below.
	<<PHS trees: public test>>=
	public :: phs_trees_test
	<<PHS trees: test driver>>=
	subroutine phs_trees_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS trees: execute tests>>
	end subroutine phs_trees_test

	@ %def phs_trees_test
	@
	Create a simple $2\to 3$ PHS tree and display it.
	<<PHS trees: execute tests>>=
	call test (phs_tree_1, "phs_tree_1", &
	"check phs tree setup", &
	u, results)
	<<PHS trees: test declarations>>=
	public :: phs_tree_1
	<<PHS trees: tests>>=
	subroutine phs_tree_1 (u)
	integer, intent(in) :: u
	type(phs_tree_t) :: tree
	type(model_data_t), target :: model
	type(flavor_t), dimension(5) :: flv
	integer :: i

	write (u, "(A)") "* Test output: phs_tree_1"
	write (u, "(A)") "* Purpose: test PHS tree routines"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Set up flavors"
	write (u, "(A)")

	call flv%init ([1, -2, 24, 5, -5], model)
	do i = 1, 5
	write (u, "(1x)", advance="no")
	call flv(i)%write (u)
	end do
	write (u, *)

	write (u, "(A)")
	write (u, "(A)") "* Create tree"
	write (u, "(A)")

	call tree%init (2, 3, 0, 0)
	call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
	call tree%set_mass_sum (flv)
	call tree%set_effective_masses ()

	call tree%write (u)

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

	call tree%final ()
	call model%final ()

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

	end subroutine phs_tree_1

	@ %def phs_tree_1
	@ The analogous tree with resonance (s-channel) mappings.
	<<PHS trees: execute tests>>=
	call test (phs_tree_2, "phs_tree_2", &
	"check phs tree with resonances", &
	u, results)
	<<PHS trees: test declarations>>=
	public :: phs_tree_2
	<<PHS trees: tests>>=
	subroutine phs_tree_2 (u)
	integer, intent(in) :: u
	type(phs_tree_t) :: tree
	type(model_data_t), target :: model
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(5) :: flv
	type(resonance_history_t) :: res_history
	integer :: i

	write (u, "(A)") "* Test output: phs_tree_2"
	write (u, "(A)") "* Purpose: test PHS tree with resonances"
	write (u, "(A)")

	write (u, "(A)") "* Read model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Set up flavors"
	write (u, "(A)")

	call flv%init ([1, -2, 24, 5, -5], model)
	do i = 1, 5
	write (u, "(1x)", advance="no")
	call flv(i)%write (u)
	end do
	write (u, *)

	write (u, "(A)")
	write (u, "(A)") "* Create tree with mappings"
	write (u, "(A)")

	call tree%init (2, 3, 0, 0)
	call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
	call tree%set_mass_sum (flv)

	call tree%init_mapping (3_TC, var_str ("s_channel"), -24, model)
	call tree%init_mapping (7_TC, var_str ("s_channel"), 23, model)

	call tree%set_mapping_parameters (mapping_defaults, variable_limits=.false.)
	call tree%set_effective_masses ()

	call tree%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extract resonances from mappings"
	write (u, "(A)")

	call tree%extract_resonance_history (res_history)
	call res_history%write (u)

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

	call tree%final ()
	call model%final ()

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

	end subroutine phs_tree_2

	@ %def phs_tree_2
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{The phase-space forest}
	Simply stated, a phase-space forest is a collection of phase-space
	trees. More precisely, a [[phs_forest]] object contains all
	parameterizations of phase space that \whizard\ will use for a single
	hard process, prepared in the form of [[phs_tree]] objects. This is
	suitable for evaluation by the \vamp\ integration package: each
	parameterization (tree) is a valid channel in the multi-channel
	adaptive integration, and each variable in a tree corresponds to an
	integration dimension, defined by an appropriate mapping of the
	$(0,1)$ interval to the allowed range of the integration variable.

	The trees are grouped in groves. The trees (integration channels)
	within a grove share a common weight, assuming that they are related
	by some approximate symmetry.

	Trees/channels that are related by an exact symmetry are connected by
	an array of equivalences; each equivalence object holds the data that
	relate one channel to another.

	The phase-space setup, i.e., the detailed structure of trees and
	forest, are read from a file. Therefore, this module also contains
	the syntax definition and the parser needed for interpreting this
	file.
	<<[[phs_forests.f90]]>>=
	<<File header>>

	module phs_forests

	<<Use kinds>>
	use kinds, only: TC
	<<Use strings>>
	use lorentz
	use permutations
	use syntax_rules
	use parser
	use model_data
	use flavors
	use interactions

	use phs_base
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t
	use mappings
	use phs_trees

	<<Standard module head>>

	<<PHS forests: public>>

	<<PHS forests: types>>

	<<PHS forests: interfaces>>

	<<PHS forests: variables>>

	interface
	<<PHS forests: sub interfaces>>
	end interface

	contains

	<<PHS forests: main procedures>>

	end module phs_forests
	@ %def phs_forests
	@
	<<[[phs_forests_sub.f90]]>>=
	<<File header>>

	submodule (phs_forests) phs_forests_s

	use io_units
	use format_defs, only: FMT_19
	use diagnostics
	use numeric_utils
	use ifiles
	use lexers
	!!! Intel oneAPI 2022/23 regression workaround
	use resonances, only: resonance_history_t

	implicit none

	contains

	<<PHS forests: procedures>>

	end submodule phs_forests_s

	@ %def phs_forests_s
	@
	\subsection{Phase-space setup parameters}
	This transparent container holds the parameters that the algorithm
	needs for phase-space setup, with reasonable defaults.

	The threshold mass (for considering a particle as effectively
	massless) is specified separately for s- and t-channel. The default is
	to treat $W$ and $Z$ bosons as massive in the s-channel, but as
	massless in the t-channel. The $b$-quark is treated always massless,
	the $t$-quark always massive.
	<<PHS forests: public>>=
	public :: phs_parameters_t
	<<PHS forests: types>>=
	type :: phs_parameters_t
	real(default) :: sqrts = 0
	real(default) :: m_threshold_s = 50._default
	real(default) :: m_threshold_t = 100._default
	integer :: off_shell = 1
	integer :: t_channel = 2
	logical :: keep_nonresonant = .true.
	contains
	<<PHS forests: phs parameters: TBP>>
	end type phs_parameters_t

	@ %def phs_parameters_t
	@ Write phase-space parameters to file.
	<<PHS forests: phs parameters: TBP>>=
	procedure :: write => phs_parameters_write
	<<PHS forests: sub interfaces>>=
	module subroutine phs_parameters_write (phs_par, unit)
	class(phs_parameters_t), intent(in) :: phs_par
	integer, intent(in), optional :: unit
	end subroutine phs_parameters_write
	<<PHS forests: procedures>>=
	module subroutine phs_parameters_write (phs_par, unit)
	class(phs_parameters_t), intent(in) :: phs_par
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", phs_par%sqrts
	write (u, "(3x,A," // FMT_19 // ")") "m_threshold_s = ", phs_par%m_threshold_s
	write (u, "(3x,A," // FMT_19 // ")") "m_threshold_t = ", phs_par%m_threshold_t
	write (u, "(3x,A,I0)") "off_shell = ", phs_par%off_shell
	write (u, "(3x,A,I0)") "t_channel = ", phs_par%t_channel
	write (u, "(3x,A,L1)") "keep_nonresonant = ", phs_par%keep_nonresonant
	end subroutine phs_parameters_write

	@ %def phs_parameters_write
	@ Read phase-space parameters from file.
	<<PHS forests: phs parameters: TBP>>=
	procedure :: read => phs_parameters_read
	<<PHS forests: sub interfaces>>=
	module subroutine phs_parameters_read (phs_par, unit)
	class(phs_parameters_t), intent(out) :: phs_par
	integer, intent(in) :: unit
	end subroutine phs_parameters_read
	<<PHS forests: procedures>>=
	module subroutine phs_parameters_read (phs_par, unit)
	class(phs_parameters_t), intent(out) :: phs_par
	integer, intent(in) :: unit
	character(20) :: dummy
	character :: equals
	read (unit, *) dummy, equals, phs_par%sqrts
	read (unit, *) dummy, equals, phs_par%m_threshold_s
	read (unit, *) dummy, equals, phs_par%m_threshold_t
	read (unit, *) dummy, equals, phs_par%off_shell
	read (unit, *) dummy, equals, phs_par%t_channel
	read (unit, *) dummy, equals, phs_par%keep_nonresonant
	end subroutine phs_parameters_read

	@ %def phs_parameters_write
	@ Comparison.
	<<PHS forests: interfaces>>=
	interface operator(==)
	module procedure phs_parameters_eq
	end interface
	interface operator(/=)
	module procedure phs_parameters_ne
	end interface
	<<PHS forests: sub interfaces>>=
	module function phs_parameters_eq (phs_par1, phs_par2) result (equal)
	logical :: equal
	type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
	end function phs_parameters_eq
	module function phs_parameters_ne (phs_par1, phs_par2) result (ne)
	logical :: ne
	type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
	end function phs_parameters_ne
	<<PHS forests: procedures>>=
	module function phs_parameters_eq (phs_par1, phs_par2) result (equal)
	logical :: equal
	type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
	equal = phs_par1%sqrts == phs_par2%sqrts &
	.and. phs_par1%m_threshold_s == phs_par2%m_threshold_s &
	.and. phs_par1%m_threshold_t == phs_par2%m_threshold_t &
	.and. phs_par1%off_shell == phs_par2%off_shell &
	.and. phs_par1%t_channel == phs_par2%t_channel &
	.and.(phs_par1%keep_nonresonant .eqv. phs_par2%keep_nonresonant)
	end function phs_parameters_eq

	module function phs_parameters_ne (phs_par1, phs_par2) result (ne)
	logical :: ne
	type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
	ne = phs_par1%sqrts /= phs_par2%sqrts &
	.or. phs_par1%m_threshold_s /= phs_par2%m_threshold_s &
	.or. phs_par1%m_threshold_t /= phs_par2%m_threshold_t &
	.or. phs_par1%off_shell /= phs_par2%off_shell &
	.or. phs_par1%t_channel /= phs_par2%t_channel &
	.or.(phs_par1%keep_nonresonant .neqv. phs_par2%keep_nonresonant)
	end function phs_parameters_ne

	@ %def phs_parameters_eq phs_parameters_ne
	@
	\subsection{Equivalences}
	This type holds information about equivalences between phase-space
	trees. We make a linked list, where each node contains the two
	trees which are equivalent and the corresponding permutation of
	external particles. Two more arrays are to be filled: The permutation
	of mass variables and the permutation of angular variables, where the
	signature indicates a necessary exchange of daughter branches.
	<<PHS forests: types>>=
	type :: equivalence_t
	private
	integer :: left, right
	type(permutation_t) :: perm
	type(permutation_t) :: msq_perm, angle_perm
	logical, dimension(:), allocatable :: angle_sig
	type(equivalence_t), pointer :: next => null ()
	end type equivalence_t

	@ %def equivalence_t
	<<PHS forests: types>>=
	type :: equivalence_list_t
	private
	integer :: length = 0
	type(equivalence_t), pointer :: first => null ()
	type(equivalence_t), pointer :: last => null ()
	end type equivalence_list_t

	@ %def equivalence_list_t
	@ Append an equivalence to the list
	<<PHS forests: procedures>>=
	subroutine equivalence_list_add (eql, left, right, perm)
	type(equivalence_list_t), intent(inout) :: eql
	integer, intent(in) :: left, right
	type(permutation_t), intent(in) :: perm
	type(equivalence_t), pointer :: eq
	allocate (eq)
	eq%left = left
	eq%right = right
	eq%perm = perm
	if (associated (eql%last)) then
	eql%last%next => eq
	else
	eql%first => eq
	end if
	eql%last => eq
	eql%length = eql%length + 1
	end subroutine equivalence_list_add

	@ %def equivalence_list_add
	@ Delete the list contents. Has to be pure because it is called from
	an elemental subroutine.
	<<PHS forests: procedures>>=
	pure subroutine equivalence_list_final (eql)
	type(equivalence_list_t), intent(inout) :: eql
	type(equivalence_t), pointer :: eq
	do while (associated (eql%first))
	eq => eql%first
	eql%first => eql%first%next
	deallocate (eq)
	end do
	eql%last => null ()
	eql%length = 0
	end subroutine equivalence_list_final

	@ %def equivalence_list_final
	@ Make a deep copy of the equivalence list. This allows for deep
	copies of groves and forests.
	<<PHS forests: interfaces>>=
	interface assignment(=)
	module procedure equivalence_list_assign
	end interface

	<<PHS forests: main procedures>>=
	subroutine equivalence_list_assign (eql_out, eql_in)
	type(equivalence_list_t), intent(out) :: eql_out
	type(equivalence_list_t), intent(in) :: eql_in
	type(equivalence_t), pointer :: eq, eq_copy
	eq => eql_in%first
	do while (associated (eq))
	allocate (eq_copy)
	eq_copy = eq
	eq_copy%next => null ()
	if (associated (eql_out%first)) then
	eql_out%last%next => eq_copy
	else
	eql_out%first => eq_copy
	end if
	eql_out%last => eq_copy
	eq => eq%next
	end do
	end subroutine equivalence_list_assign

	@ %def equivalence_list_assign
	@ The number of list entries
	<<PHS forests: procedures>>=
	elemental function equivalence_list_length (eql) result (length)
	integer :: length
	type(equivalence_list_t), intent(in) :: eql
	length = eql%length
	end function equivalence_list_length

	@ %def equivalence_list_length
	@ Recursively write the equivalences list
	<<PHS forests: procedures>>=
	subroutine equivalence_list_write (eql, unit)
	type(equivalence_list_t), intent(in) :: eql
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (associated (eql%first)) then
	call equivalence_write_rec (eql%first, u)
	else
	write (u, *) " [empty]"
	end if
	contains
	recursive subroutine equivalence_write_rec (eq, u)
	type(equivalence_t), intent(in) :: eq
	integer, intent(in) :: u
	integer :: i
	write (u, "(3x,A,1x,I0,1x,I0,2x,A)", advance="no") &
	"Equivalence:", eq%left, eq%right, "Final state permutation:"
	call permutation_write (eq%perm, u)
	write (u, "(1x,12x,1x,A,1x)", advance="no") &
	" msq permutation: "
	call permutation_write (eq%msq_perm, u)
	write (u, "(1x,12x,1x,A,1x)", advance="no") &
	" angle permutation:"
	call permutation_write (eq%angle_perm, u)
	write (u, "(1x,12x,1x,26x)", advance="no")
	do i = 1, size (eq%angle_sig)
	if (eq%angle_sig(i)) then
	write (u, "(1x,A)", advance="no") "+"
	else
	write (u, "(1x,A)", advance="no") "-"
	end if
	end do
	write (u, *)
	if (associated (eq%next)) call equivalence_write_rec (eq%next, u)
	end subroutine equivalence_write_rec
	end subroutine equivalence_list_write

	@ %def equivalence_list_write
	@
	\subsection{Groves}
	A grove is a group of trees (phase-space channels) that share a common
	weight in the integration. Within a grove, channels can be declared
	equivalent, so they also share their integration grids (up to
	symmetries). The grove contains a list of equivalences. The
	[[tree_count_offset]] is the total number of trees of the preceding
	groves; when the trees are counted per forest (integration channels),
	the offset has to be added to all tree indices.
	<<PHS forests: types>>=
	type :: phs_grove_t
	private
	integer :: tree_count_offset
	type(phs_tree_t), dimension(:), allocatable :: tree
	type(equivalence_list_t) :: equivalence_list
	end type phs_grove_t

	@ %def phs_grove_t
	@ Call [[phs_tree_init]] which is also elemental:
	<<PHS forests: procedures>>=
	elemental subroutine phs_grove_init &
	(grove, n_trees, n_in, n_out, n_masses, n_angles)
	type(phs_grove_t), intent(inout) :: grove
	integer, intent(in) :: n_trees, n_in, n_out, n_masses, n_angles
	grove%tree_count_offset = 0
	allocate (grove%tree (n_trees))
	call grove%tree%init (n_in, n_out, n_masses, n_angles)
	end subroutine phs_grove_init

	@ %def phs_grove_init
	@ The trees do not have pointer components, thus no call to
	[[phs_tree_final]]:
	<<PHS forests: procedures>>=
	elemental subroutine phs_grove_final (grove)
	type(phs_grove_t), intent(inout) :: grove
	deallocate (grove%tree)
	call equivalence_list_final (grove%equivalence_list)
	end subroutine phs_grove_final

	@ %def phs_grove_final
	@ Deep copy. This triggers double free corruption with the Intel
	compiler and hence has to remain in the main module.
	<<PHS forests: interfaces>>=
	interface assignment(=)
	module procedure phs_grove_assign0
	module procedure phs_grove_assign1
	end interface

	<<PHS forests: main procedures>>=
	subroutine phs_grove_assign0 (grove_out, grove_in)
	type(phs_grove_t), intent(out) :: grove_out
	type(phs_grove_t), intent(in) :: grove_in
	grove_out%tree_count_offset = grove_in%tree_count_offset
	if (allocated (grove_in%tree)) then
	allocate (grove_out%tree (size (grove_in%tree)))
	grove_out%tree = grove_in%tree
	end if
	grove_out%equivalence_list = grove_in%equivalence_list
	end subroutine phs_grove_assign0

	subroutine phs_grove_assign1 (grove_out, grove_in)
	type(phs_grove_t), dimension(:), intent(out) :: grove_out
	type(phs_grove_t), dimension(:), intent(in) :: grove_in
	integer :: i
	do i = 1, size (grove_in)
	call phs_grove_assign0 (grove_out(i), grove_in(i))
	end do
	end subroutine phs_grove_assign1

	@ %def phs_grove_assign
	@ Get the global (s-channel) mappings. Implemented as a subroutine
	which returns an array (slice).
	<<PHS forests: procedures>>=
	subroutine phs_grove_assign_s_mappings (grove, mapping)
	type(phs_grove_t), intent(in) :: grove
	type(mapping_t), dimension(:), intent(out) :: mapping
	integer :: i
	if (size (mapping) == size (grove%tree)) then
	do i = 1, size (mapping)
	call grove%tree(i)%assign_s_mapping (mapping(i))
	end do
	else
	call msg_bug ("phs_grove_assign_s_mappings: array size mismatch")
	end if
	end subroutine phs_grove_assign_s_mappings

	@ %def phs_grove_assign_s_mappings
	@
	\subsection{The forest type}
	This is a collection of trees and associated particles. In a given
	tree, each branch code corresponds to a particle in the [[prt]] array.
	Furthermore, we have an array of mass sums which is independent of the
	decay tree and of the particular event. The mappings directly
	correspond to the decay trees, and the decay groves collect the trees
	in classes. The permutation list consists of all permutations of
	outgoing particles that map the decay forest onto itself.

	The particle codes [[flv]] (one for each external particle) are needed
	for determining masses and such. The trees and associated information
	are collected in the [[grove]] array, together with a lookup table
	that associates tree indices to groves. Finally, the [[prt]] array
	serves as workspace for phase-space evaluation.

	The [[prt_combination]] is a list of index pairs, namely the particle
	momenta pairs that need to be combined in order to provide all
	momentum combinations that the phase-space trees need to know.
	<<PHS forests: public>>=
	public :: phs_forest_t
	<<PHS forests: types>>=
	type :: phs_forest_t
	private
	integer :: n_in, n_out, n_tot
	integer :: n_masses, n_angles, n_dimensions
	integer :: n_trees, n_equivalences
	type(flavor_t), dimension(:), allocatable :: flv
	type(phs_grove_t), dimension(:), allocatable :: grove
	integer, dimension(:), allocatable :: grove_lookup
	type(phs_prt_t), dimension(:), allocatable :: prt_in
	type(phs_prt_t), dimension(:), allocatable :: prt_out
	type(phs_prt_t), dimension(:), allocatable :: prt
	integer(TC), dimension(:,:), allocatable :: prt_combination
	type(mapping_t), dimension(:), allocatable :: s_mapping
	contains
	<<PHS forests: phs forest: TBP>>
	end type phs_forest_t

	@ %def phs_forest_t
	@
	The initialization merely allocates memory. We have to know how many
	trees there are in each grove, so we can initialize everything. The
	number of groves is the size of the [[n_tree]] array.

	In the [[grove_lookup]] table we store the grove index that belongs to
	each absolute tree index. The difference between the absolute index
	and the relative (to the grove) index is stored, for each grove, as
	[[tree_count_offset]].

	The particle array is allocated according to the total number of
	branches each tree has, but not filled.
	<<PHS forests: phs forest: TBP>>=
	procedure :: init => phs_forest_init
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
	class(phs_forest_t), intent(inout) :: forest
	integer, dimension(:), intent(in) :: n_tree
	integer, intent(in) :: n_in, n_out
	end subroutine phs_forest_init
	<<PHS forests: procedures>>=
	module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
	class(phs_forest_t), intent(inout) :: forest
	integer, dimension(:), intent(in) :: n_tree
	integer, intent(in) :: n_in, n_out
	integer :: g, count, k_root
	forest%n_in = n_in
	forest%n_out = n_out
	forest%n_tot = n_in + n_out
	forest%n_masses = max (n_out - 2, 0)
	forest%n_angles = max (2*n_out - 2, 0)
	forest%n_dimensions = forest%n_masses + forest%n_angles
	forest%n_trees = sum (n_tree)
	forest%n_equivalences = 0
	allocate (forest%grove (size (n_tree)))
	call phs_grove_init &
	(forest%grove, n_tree, n_in, n_out, forest%n_masses, &
	forest%n_angles)
	allocate (forest%grove_lookup (forest%n_trees))
	count = 0
	do g = 1, size (forest%grove)
	forest%grove(g)%tree_count_offset = count
	forest%grove_lookup (count+1:count+n_tree(g)) = g
	count = count + n_tree(g)
	end do
	allocate (forest%prt_in (n_in))
	allocate (forest%prt_out (forest%n_out))
	k_root = 2**forest%n_tot - 1
	allocate (forest%prt (k_root))
	allocate (forest%prt_combination (2, k_root))
	allocate (forest%s_mapping (forest%n_trees))
	end subroutine phs_forest_init

	@ %def phs_forest_init
	@ Assign the global (s-channel) mappings.
	<<PHS forests: phs forest: TBP>>=
	procedure :: set_s_mappings => phs_forest_set_s_mappings
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_s_mappings (forest)
	class(phs_forest_t), intent(inout) :: forest
	end subroutine phs_forest_set_s_mappings
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_s_mappings (forest)
	class(phs_forest_t), intent(inout) :: forest
	integer :: g, i0, i1, n
	do g = 1, size (forest%grove)
	call forest%get_grove_bounds (g, i0, i1, n)
	call phs_grove_assign_s_mappings &
	(forest%grove(g), forest%s_mapping(i0:i1))
	end do
	end subroutine phs_forest_set_s_mappings

	@ %def phs_forest_set_s_mappings
	@ The grove finalizer is called because it contains the equivalence list:
	<<PHS forests: phs forest: TBP>>=
	procedure :: final => phs_forest_final
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_final (forest)
	class(phs_forest_t), intent(inout) :: forest
	end subroutine phs_forest_final
	<<PHS forests: procedures>>=
	module subroutine phs_forest_final (forest)
	class(phs_forest_t), intent(inout) :: forest
	if (allocated (forest%grove)) then
	call phs_grove_final (forest%grove)
	deallocate (forest%grove)
	end if
	if (allocated (forest%grove_lookup)) deallocate (forest%grove_lookup)
	if (allocated (forest%prt)) deallocate (forest%prt)
	if (allocated (forest%s_mapping)) deallocate (forest%s_mapping)
	end subroutine phs_forest_final

	@ %def phs_forest_final
	@
	\subsection{Screen output}
	Write the particles that are non-null, then the trees which point to
	them:
	<<PHS forests: phs forest: TBP>>=
	procedure :: write => phs_forest_write
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_write (forest, unit)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in), optional :: unit
	end subroutine phs_forest_write
	<<PHS forests: procedures>>=
	module subroutine phs_forest_write (forest, unit)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in), optional :: unit
	integer :: u
	integer :: i, g, k
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "Phase space forest:"
	write (u, "(3x,A,I0)") "n_in = ", forest%n_in
	write (u, "(3x,A,I0)") "n_out = ", forest%n_out
	write (u, "(3x,A,I0)") "n_tot = ", forest%n_tot
	write (u, "(3x,A,I0)") "n_masses = ", forest%n_masses
	write (u, "(3x,A,I0)") "n_angles = ", forest%n_angles
	write (u, "(3x,A,I0)") "n_dim = ", forest%n_dimensions
	write (u, "(3x,A,I0)") "n_trees = ", forest%n_trees
	write (u, "(3x,A,I0)") "n_equiv = ", forest%n_equivalences
	write (u, "(3x,A)", advance="no") "flavors ="
	if (allocated (forest%flv)) then
	do i = 1, size (forest%flv)
	write (u, "(1x,I0)", advance="no") forest%flv(i)%get_pdg ()
	end do
	write (u, "(A)")
	else
	write (u, "(1x,A)") "[empty]"
	end if
	write (u, "(1x,A)") "Particle combinations:"
	if (allocated (forest%prt_combination)) then
	do k = 1, size (forest%prt_combination, 2)
	if (forest%prt_combination(1, k) /= 0) then
	write (u, "(3x,I0,1x,'<=',1x,I0,1x,'+',1x,I0)") &
	k, forest%prt_combination(:,k)
	end if
	end do
	else
	write (u, "(3x,A)") " [empty]"
	end if
	write (u, "(1x,A)") "Groves and trees:"
	if (allocated (forest%grove)) then
	do g = 1, size (forest%grove)
	write (u, "(3x,A,1x,I0)") "Grove ", g
	call phs_grove_write (forest%grove(g), unit)
	end do
	else
	write (u, "(3x,A)") " [empty]"
	end if
	write (u, "(1x,A,I0)") "Total number of equivalences: ", &
	forest%n_equivalences
	write (u, "(A)")
	write (u, "(1x,A)") "Global s-channel mappings:"
	if (allocated (forest%s_mapping)) then
	do i = 1, size (forest%s_mapping)
	associate (mapping => forest%s_mapping(i))
	if (mapping%is_s_channel () .or. mapping%is_on_shell ()) then
	write (u, "(1x,I0,':',1x)", advance="no") i
	call forest%s_mapping(i)%write (unit)
	end if
	end associate
	end do
	else
	write (u, "(3x,A)") " [empty]"
	end if
	write (u, "(A)")
	write (u, "(1x,A)") "Incoming particles:"
	if (allocated (forest%prt_in)) then
	if (any (forest%prt_in%is_defined ())) then
	do i = 1, size (forest%prt_in)
	if (forest%prt_in(i)%is_defined ()) then
	write (u, "(1x,A,1x,I0)") "Particle", i
	call forest%prt_in(i)%write (u)
	end if
	end do
	else
	write (u, "(3x,A)") "[all undefined]"
	end if
	else
	write (u, "(3x,A)") " [empty]"
	end if
	write (u, "(A)")
	write (u, "(1x,A)") "Outgoing particles:"
	if (allocated (forest%prt_out)) then
	if (any (forest%prt_out%is_defined ())) then
	do i = 1, size (forest%prt_out)
	if (forest%prt_out(i)%is_defined ()) then
	write (u, "(1x,A,1x,I0)") "Particle", i
	call forest%prt_out(i)%write (u)
	end if
	end do
	else
	write (u, "(3x,A)") "[all undefined]"
	end if
	else
	write (u, "(1x,A)") " [empty]"
	end if
	write (u, "(A)")
	write (u, "(1x,A)") "Tree particles:"
	if (allocated (forest%prt)) then
	if (any (forest%prt%is_defined ())) then
	do i = 1, size (forest%prt)
	if (forest%prt(i)%is_defined ()) then
	write (u, "(1x,A,1x,I0)") "Particle", i
	call forest%prt(i)%write (u)
	end if
	end do
	else
	write (u, "(3x,A)") "[all undefined]"
	end if
	else
	write (u, "(3x,A)") " [empty]"
	end if
	end subroutine phs_forest_write

	subroutine phs_grove_write (grove, unit)
	type(phs_grove_t), intent(in) :: grove
	integer, intent(in), optional :: unit
	integer :: u
	integer :: t
	u = given_output_unit (unit); if (u < 0) return
	do t = 1, size (grove%tree)
	write (u, "(3x,A,I0)") "Tree ", t
	call grove%tree(t)%write (unit)
	end do
	write (u, "(1x,A)") "Equivalence list:"
	call equivalence_list_write (grove%equivalence_list, unit)
	end subroutine phs_grove_write

	@ %def phs_grove_write phs_forest_write
	@ Deep copy.
	<<PHS forests: public>>=
	public :: assignment(=)
	<<PHS forests: interfaces>>=
	interface assignment(=)
	module procedure phs_forest_assign
	end interface

	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_assign (forest_out, forest_in)
	type(phs_forest_t), intent(out) :: forest_out
	type(phs_forest_t), intent(in) :: forest_in
	end subroutine phs_forest_assign
	<<PHS forests: procedures>>=
	module subroutine phs_forest_assign (forest_out, forest_in)
	type(phs_forest_t), intent(out) :: forest_out
	type(phs_forest_t), intent(in) :: forest_in
	forest_out%n_in = forest_in%n_in
	forest_out%n_out = forest_in%n_out
	forest_out%n_tot = forest_in%n_tot
	forest_out%n_masses = forest_in%n_masses
	forest_out%n_angles = forest_in%n_angles
	forest_out%n_dimensions = forest_in%n_dimensions
	forest_out%n_trees = forest_in%n_trees
	forest_out%n_equivalences = forest_in%n_equivalences
	if (allocated (forest_in%flv)) then
	allocate (forest_out%flv (size (forest_in%flv)))
	forest_out%flv = forest_in%flv
	end if
	if (allocated (forest_in%grove)) then
	allocate (forest_out%grove (size (forest_in%grove)))
	forest_out%grove = forest_in%grove
	end if
	if (allocated (forest_in%grove_lookup)) then
	allocate (forest_out%grove_lookup (size (forest_in%grove_lookup)))
	forest_out%grove_lookup = forest_in%grove_lookup
	end if
	if (allocated (forest_in%prt_in)) then
	allocate (forest_out%prt_in (size (forest_in%prt_in)))
	forest_out%prt_in = forest_in%prt_in
	end if
	if (allocated (forest_in%prt_out)) then
	allocate (forest_out%prt_out (size (forest_in%prt_out)))
	forest_out%prt_out = forest_in%prt_out
	end if
	if (allocated (forest_in%prt)) then
	allocate (forest_out%prt (size (forest_in%prt)))
	forest_out%prt = forest_in%prt
	end if
	if (allocated (forest_in%s_mapping)) then
	allocate (forest_out%s_mapping (size (forest_in%s_mapping)))
	forest_out%s_mapping = forest_in%s_mapping
	end if
	if (allocated (forest_in%prt_combination)) then
	allocate (forest_out%prt_combination &
	(2, size (forest_in%prt_combination, 2)))
	forest_out%prt_combination = forest_in%prt_combination
	end if
	end subroutine phs_forest_assign

	@ %def phs_forest_assign
	@
	\subsection{Accessing contents}
	Get the number of integration parameters
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_n_parameters => phs_forest_get_n_parameters
	<<PHS forests: sub interfaces>>=
	module function phs_forest_get_n_parameters (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	end function phs_forest_get_n_parameters
	<<PHS forests: procedures>>=
	module function phs_forest_get_n_parameters (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	n = forest%n_dimensions
	end function phs_forest_get_n_parameters

	@ %def phs_forest_get_n_parameters
	@ Get the number of integration channels
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_n_channels => phs_forest_get_n_channels
	<<PHS forests: sub interfaces>>=
	module function phs_forest_get_n_channels (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	end function phs_forest_get_n_channels
	<<PHS forests: procedures>>=
	module function phs_forest_get_n_channels (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	n = forest%n_trees
	end function phs_forest_get_n_channels

	@ %def phs_forest_get_n_channels
	@ Get the number of groves
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_n_groves => phs_forest_get_n_groves
	<<PHS forests: sub interfaces>>=
	module function phs_forest_get_n_groves (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	end function phs_forest_get_n_groves
	<<PHS forests: procedures>>=
	module function phs_forest_get_n_groves (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	n = size (forest%grove)
	end function phs_forest_get_n_groves

	@ %def phs_forest_get_n_groves
	@ Get the index bounds for a specific grove.
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_grove_bounds => phs_forest_get_grove_bounds
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: g
	integer, intent(out) :: i0, i1, n
	end subroutine phs_forest_get_grove_bounds
	<<PHS forests: procedures>>=
	module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: g
	integer, intent(out) :: i0, i1, n
	n = size (forest%grove(g)%tree)
	i0 = forest%grove(g)%tree_count_offset + 1
	i1 = forest%grove(g)%tree_count_offset + n
	end subroutine phs_forest_get_grove_bounds

	@ %def phs_forest_get_grove_bounds
	@ Get the number of equivalences
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_n_equivalences => phs_forest_get_n_equivalences
	<<PHS forests: sub interfaces>>=
	module function phs_forest_get_n_equivalences (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	end function phs_forest_get_n_equivalences
	<<PHS forests: procedures>>=
	module function phs_forest_get_n_equivalences (forest) result (n)
	integer :: n
	class(phs_forest_t), intent(in) :: forest
	n = forest%n_equivalences
	end function phs_forest_get_n_equivalences

	@ %def phs_forest_get_n_equivalences
	@ Return true if a particular channel has a global (s-channel)
	mapping; also return the resonance mass and width for this mapping.
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_s_mapping => phs_forest_get_s_mapping
	procedure :: get_on_shell => phs_forest_get_on_shell
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_get_s_mapping &
	(forest, channel, flag, mass, width)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: channel
	logical, intent(out) :: flag
	real(default), intent(out) :: mass, width
	end subroutine phs_forest_get_s_mapping
	module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: channel
	logical, intent(out) :: flag
	real(default), intent(out) :: mass
	end subroutine phs_forest_get_on_shell
	<<PHS forests: procedures>>=
	module subroutine phs_forest_get_s_mapping &
	(forest, channel, flag, mass, width)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: channel
	logical, intent(out) :: flag
	real(default), intent(out) :: mass, width
	flag = forest%s_mapping(channel)%is_s_channel ()
	if (flag) then
	mass = forest%s_mapping(channel)%get_mass ()
	width = forest%s_mapping(channel)%get_width ()
	else
	mass = 0
	width = 0
	end if
	end subroutine phs_forest_get_s_mapping

	module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
	class(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: channel
	logical, intent(out) :: flag
	real(default), intent(out) :: mass
	flag = forest%s_mapping(channel)%is_on_shell ()
	if (flag) then
	mass = forest%s_mapping(channel)%get_mass ()
	else
	mass = 0
	end if
	end subroutine phs_forest_get_on_shell

	@ %def phs_forest_get_s_mapping
	@ %def phs_forest_get_on_shell
	@
	Extract the set of unique resonance histories, in form of an array.
	<<PHS forests: phs forest: TBP>>=
	procedure :: extract_resonance_history_set &
	=> phs_forest_extract_resonance_history_set
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_extract_resonance_history_set &
	(forest, res_set, include_trivial)
	class(phs_forest_t), intent(in) :: forest
	type(resonance_history_set_t), intent(out) :: res_set
	logical, intent(in), optional :: include_trivial
	end subroutine phs_forest_extract_resonance_history_set
	<<PHS forests: procedures>>=
	module subroutine phs_forest_extract_resonance_history_set &
	(forest, res_set, include_trivial)
	class(phs_forest_t), intent(in) :: forest
	type(resonance_history_set_t), intent(out) :: res_set
	logical, intent(in), optional :: include_trivial
	type(resonance_history_t) :: rh
	integer :: g, t
	logical :: triv
	triv = .false.; if (present (include_trivial)) triv = include_trivial
	call res_set%init ()
	do g = 1, size (forest%grove)
	associate (grove => forest%grove(g))
	do t = 1, size (grove%tree)
	call grove%tree(t)%extract_resonance_history (rh)
	call res_set%enter (rh, include_trivial)
	end do
	end associate
	end do
	call res_set%freeze ()
	end subroutine phs_forest_extract_resonance_history_set

	@ %def phs_forest_extract_resonance_history_set
	@
	\subsection{Read the phase space setup from file}
	The phase space setup is stored in a file. The file may be generated
	by the [[cascades]] module below, or by other means. This file has to
	be read and parsed to create the PHS forest as the internal
	phase-space representation.

	Create lexer and syntax:
	<<PHS forests: procedures>>=
	subroutine define_phs_forest_syntax (ifile)
	type(ifile_t) :: ifile
	call ifile_append (ifile, "SEQ phase_space_list = process_phase_space*")
	call ifile_append (ifile, "SEQ process_phase_space = " &
	// "process_def process_header phase_space")
	call ifile_append (ifile, "SEQ process_def = process process_list")
	call ifile_append (ifile, "KEY process")
	call ifile_append (ifile, "LIS process_list = process_tag*")
	call ifile_append (ifile, "IDE process_tag")
	call ifile_append (ifile, "SEQ process_header = " &
	// "md5sum_process = md5sum " &
	// "md5sum_model_par = md5sum " &
	// "md5sum_phs_config = md5sum " &
	// "sqrts = real " &
	// "m_threshold_s = real " &
	// "m_threshold_t = real " &
	// "off_shell = integer " &
	// "t_channel = integer " &
	// "keep_nonresonant = logical")
	call ifile_append (ifile, "KEY '='")
	call ifile_append (ifile, "KEY '-'")
	call ifile_append (ifile, "KEY md5sum_process")
	call ifile_append (ifile, "KEY md5sum_model_par")
	call ifile_append (ifile, "KEY md5sum_phs_config")
	call ifile_append (ifile, "KEY sqrts")
	call ifile_append (ifile, "KEY m_threshold_s")
	call ifile_append (ifile, "KEY m_threshold_t")
	call ifile_append (ifile, "KEY off_shell")
	call ifile_append (ifile, "KEY t_channel")
	call ifile_append (ifile, "KEY keep_nonresonant")
	call ifile_append (ifile, "QUO md5sum = '""' ... '""'")
	call ifile_append (ifile, "REA real")
	call ifile_append (ifile, "INT integer")
	call ifile_append (ifile, "IDE logical")
	call ifile_append (ifile, "SEQ phase_space = grove_def+")
	call ifile_append (ifile, "SEQ grove_def = grove tree_def+")
	call ifile_append (ifile, "KEY grove")
	call ifile_append (ifile, "SEQ tree_def = tree bincodes mapping*")
	call ifile_append (ifile, "KEY tree")
	call ifile_append (ifile, "SEQ bincodes = bincode*")
	call ifile_append (ifile, "INT bincode")
	call ifile_append (ifile, "SEQ mapping = map bincode channel signed_pdg")
	call ifile_append (ifile, "KEY map")
	call ifile_append (ifile, "ALT channel = &
	&s_channel \| t_channel \| u_channel \| &
	&collinear \| infrared \| radiation \| on_shell")
	call ifile_append (ifile, "KEY s_channel")
	! call ifile_append (ifile, "KEY t_channel") !!! Key already exists
	call ifile_append (ifile, "KEY u_channel")
	call ifile_append (ifile, "KEY collinear")
	call ifile_append (ifile, "KEY infrared")
	call ifile_append (ifile, "KEY radiation")
	call ifile_append (ifile, "KEY on_shell")
	call ifile_append (ifile, "ALT signed_pdg = &
	&pdg \| negative_pdg")
	call ifile_append (ifile, "SEQ negative_pdg = '-' pdg")
	call ifile_append (ifile, "INT pdg")
	end subroutine define_phs_forest_syntax

	@ %def define_phs_forest_syntax
	@ The model-file syntax and lexer are fixed, therefore stored as
	module variables:
	<<PHS forests: variables>>=
	type(syntax_t), target, save :: syntax_phs_forest

	@ %def syntax_phs_forest
	<<PHS forests: public>>=
	public :: syntax_phs_forest_init
	<<PHS forests: sub interfaces>>=
	module subroutine syntax_phs_forest_init ()
	end subroutine syntax_phs_forest_init
	<<PHS forests: procedures>>=
	module subroutine syntax_phs_forest_init ()
	type(ifile_t) :: ifile
	call define_phs_forest_syntax (ifile)
	call syntax_init (syntax_phs_forest, ifile)
	call ifile_final (ifile)
	end subroutine syntax_phs_forest_init

	@ %def syntax_phs_forest_init
	<<PHS forests: procedures>>=
	subroutine lexer_init_phs_forest (lexer)
	type(lexer_t), intent(out) :: lexer
	call lexer_init (lexer, &
	comment_chars = "#!", &
	quote_chars = '"', &
	quote_match = '"', &
	single_chars = "-", &
	special_class = ["="] , &
	keyword_list = syntax_get_keyword_list_ptr (syntax_phs_forest))
	end subroutine lexer_init_phs_forest

	@ %def lexer_init_phs_forest
	<<PHS forests: public>>=
	public :: syntax_phs_forest_final
	<<PHS forests: sub interfaces>>=
	module subroutine syntax_phs_forest_final ()
	end subroutine syntax_phs_forest_final
	<<PHS forests: procedures>>=
	module subroutine syntax_phs_forest_final ()
	call syntax_final (syntax_phs_forest)
	end subroutine syntax_phs_forest_final

	@ %def syntax_phs_forest_final
	<<PHS forests: public>>=
	public :: syntax_phs_forest_write
	<<PHS forests: sub interfaces>>=
	module subroutine syntax_phs_forest_write (unit)
	integer, intent(in), optional :: unit
	end subroutine syntax_phs_forest_write
	<<PHS forests: procedures>>=
	module subroutine syntax_phs_forest_write (unit)
	integer, intent(in), optional :: unit
	call syntax_write (syntax_phs_forest, unit)
	end subroutine syntax_phs_forest_write

	@ %def syntax_phs_forest_write
	@ The concrete parser and interpreter. Generate an input stream for
	the external [[unit]], read the parse tree (with given [[syntax]] and
	[[lexer]]) from this stream, and transfer the contents of the parse
	tree to the PHS [[forest]].

	We look for the matching [[process]] tag, count groves and trees for
	initializing the [[forest]], and fill the trees.

	If the optional parameters are set, compare the parameters stored in
	the file to those. Set [[match]] true if everything agrees.
	<<PHS forests: phs forest: TBP>>=
	generic :: read => read_file, read_unit, read_parse_tree
	procedure :: read_file => phs_forest_read_file
	procedure :: read_unit => phs_forest_read_unit
	procedure :: read_parse_tree => phs_forest_read_parse_tree
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_read_file &
	(forest, filename, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, &
	md5sum_phs_config, phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	type(string_t), intent(in) :: filename
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	end subroutine phs_forest_read_file
	module subroutine phs_forest_read_unit &
	(forest, unit, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, &
	phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	integer, intent(in) :: unit
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	end subroutine phs_forest_read_unit
	module subroutine phs_forest_read_parse_tree &
	(forest, parse_tree, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, &
	phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	type(parse_tree_t), intent(in), target :: parse_tree
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	end subroutine phs_forest_read_parse_tree
	<<PHS forests: procedures>>=
	module subroutine phs_forest_read_file &
	(forest, filename, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, &
	md5sum_phs_config, phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	type(string_t), intent(in) :: filename
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	type(parse_tree_t), target :: parse_tree
	type(stream_t), target :: stream
	type(lexer_t) :: lexer
	call lexer_init_phs_forest (lexer)
	call stream_init (stream, char (filename))
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
	call phs_forest_read_parse_tree (forest, parse_tree, &
	process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
	call stream_final (stream)
	call lexer_final (lexer)
	call parse_tree_final (parse_tree)
	end subroutine phs_forest_read_file

	module subroutine phs_forest_read_unit &
	(forest, unit, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, &
	phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	integer, intent(in) :: unit
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	type(parse_tree_t), target :: parse_tree
	type(stream_t), target :: stream
	type(lexer_t) :: lexer
	call lexer_init_phs_forest (lexer)
	call stream_init (stream, unit)
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
	call phs_forest_read_parse_tree (forest, parse_tree, &
	process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, &
	phs_par, match)
	call stream_final (stream)
	call lexer_final (lexer)
	call parse_tree_final (parse_tree)
	end subroutine phs_forest_read_unit

	module subroutine phs_forest_read_parse_tree &
	(forest, parse_tree, process_id, n_in, n_out, model, found, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, &
	phs_par, match)
	class(phs_forest_t), intent(out) :: forest
	type(parse_tree_t), intent(in), target :: parse_tree
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: n_in, n_out
	class(model_data_t), intent(in), target :: model
	logical, intent(out) :: found
	character(32), intent(in), optional :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out), optional :: match
	type(parse_node_t), pointer :: node_header, node_phs, node_grove
	integer :: n_grove, g
	integer, dimension(:), allocatable :: n_tree
	integer :: t
	node_header => parse_tree_get_process_ptr (parse_tree, process_id)
	found = associated (node_header); if (.not. found) return
	if (present (match)) then
	call phs_forest_check_input (node_header, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
	if (.not. match) return
	end if
	node_phs => parse_node_get_next_ptr (node_header)
	n_grove = parse_node_get_n_sub (node_phs)
	allocate (n_tree (n_grove))
	do g = 1, n_grove
	node_grove => parse_node_get_sub_ptr (node_phs, g)
	n_tree(g) = parse_node_get_n_sub (node_grove) - 1
	end do
	call forest%init (n_tree, n_in, n_out)
	do g = 1, n_grove
	node_grove => parse_node_get_sub_ptr (node_phs, g)
	do t = 1, n_tree(g)
	call phs_tree_set (forest%grove(g)%tree(t), &
	parse_node_get_sub_ptr (node_grove, t+1), model)
	end do
	end do
	end subroutine phs_forest_read_parse_tree

	@ %def phs_forest
	@ Check the input for consistency. If any MD5 sum or phase-space
	parameter disagrees, the phase-space file cannot be used. The MD5
	sum checks are skipped if the stored MD5 sum is empty.
	<<PHS forests: procedures>>=
	subroutine phs_forest_check_input (pn_header, &
	md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
	type(parse_node_t), intent(in), target :: pn_header
	character(32), intent(in) :: &
	md5sum_process, md5sum_model_par, md5sum_phs_config
	type(phs_parameters_t), intent(in), optional :: phs_par
	logical, intent(out) :: match
	type(parse_node_t), pointer :: pn_md5sum, pn_rval, pn_ival, pn_lval
	character(32) :: md5sum
	type(phs_parameters_t) :: phs_par_old
	character(1) :: lstr
	pn_md5sum => parse_node_get_sub_ptr (pn_header, 3)
	md5sum = parse_node_get_string (pn_md5sum)
	if (md5sum /= "" .and. md5sum /= md5sum_process) then
	call msg_message ("Phase space: discarding old configuration &
	&(process changed)")
	match = .false.; return
	end if
	pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
	md5sum = parse_node_get_string (pn_md5sum)
	if (md5sum /= "" .and. md5sum /= md5sum_model_par) then
	call msg_message ("Phase space: discarding old configuration &
	&(model parameters changed)")
	match = .false.; return
	end if
	pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
	md5sum = parse_node_get_string (pn_md5sum)
	if (md5sum /= "" .and. md5sum /= md5sum_phs_config) then
	call msg_message ("Phase space: discarding old configuration &
	&(configuration parameters changed)")
	match = .false.; return
	end if
	if (present (phs_par)) then
	pn_rval => parse_node_get_next_ptr (pn_md5sum, 3)
	phs_par_old%sqrts = parse_node_get_real (pn_rval)
	pn_rval => parse_node_get_next_ptr (pn_rval, 3)
	phs_par_old%m_threshold_s = parse_node_get_real (pn_rval)
	pn_rval => parse_node_get_next_ptr (pn_rval, 3)
	phs_par_old%m_threshold_t = parse_node_get_real (pn_rval)
	pn_ival => parse_node_get_next_ptr (pn_rval, 3)
	phs_par_old%off_shell = parse_node_get_integer (pn_ival)
	pn_ival => parse_node_get_next_ptr (pn_ival, 3)
	phs_par_old%t_channel = parse_node_get_integer (pn_ival)
	pn_lval => parse_node_get_next_ptr (pn_ival, 3)
	lstr = parse_node_get_string (pn_lval)
	read (lstr, "(L1)") phs_par_old%keep_nonresonant
	if (phs_par_old /= phs_par) then
	call msg_message &
	("Phase space: discarding old configuration &
	&(configuration parameters changed)")
	match = .false.; return
	end if
	end if
	match = .true.
	end subroutine phs_forest_check_input

	@ %def phs_forest_check_input
	@ Initialize a specific tree in the forest, using the contents of the
	'tree' node. First, count the bincodes, allocate an array and read
	them in, and make the tree. Each $t$-channel tree is flipped to
	$s$-channel. Then, find mappings and initialize them.
	<<PHS forests: procedures>>=
	subroutine phs_tree_set (tree, node, model)
	type(phs_tree_t), intent(inout) :: tree
	type(parse_node_t), intent(in), target :: node
	class(model_data_t), intent(in), target :: model
	type(parse_node_t), pointer :: node_bincodes, node_mapping, pn_pdg
	integer :: n_bincodes, offset
	integer(TC), dimension(:), allocatable :: bincode
	integer :: b, n_mappings, m
	integer(TC) :: k
	type(string_t) :: type
	integer :: pdg
	node_bincodes => parse_node_get_sub_ptr (node, 2)
	if (associated (node_bincodes)) then
	select case (char (parse_node_get_rule_key (node_bincodes)))
	case ("bincodes")
	n_bincodes = parse_node_get_n_sub (node_bincodes)
	offset = 2
	case default
	n_bincodes = 0
	offset = 1
	end select
	else
	n_bincodes = 0
	offset = 2
	end if
	allocate (bincode (n_bincodes))
	do b = 1, n_bincodes
	bincode(b) = parse_node_get_integer &
	(parse_node_get_sub_ptr (node_bincodes, b))
	end do
	call phs_tree_from_array (tree, bincode)
	call tree%flip_t_to_s_channel ()
	call tree%canonicalize ()
	n_mappings = parse_node_get_n_sub (node) - offset
	do m = 1, n_mappings
	node_mapping => parse_node_get_sub_ptr (node, m + offset)
	k = parse_node_get_integer &
	(parse_node_get_sub_ptr (node_mapping, 2))
	type = parse_node_get_key &
	(parse_node_get_sub_ptr (node_mapping, 3))
	pn_pdg => parse_node_get_sub_ptr (node_mapping, 4)
	select case (char (pn_pdg%get_rule_key ()))
	case ("pdg")
	pdg = pn_pdg%get_integer ()
	case ("negative_pdg")
	pdg = - parse_node_get_integer (pn_pdg%get_sub_ptr (2))
	end select
	call tree%init_mapping (k, type, pdg, model)
	end do
	end subroutine phs_tree_set

	@ %def phs_tree_set
	@
	\subsection{Preparation}
	The trees that we read from file do not carry flavor information.
	This is set separately:

	The flavor list must be unique for a unique set of masses; if a given
	particle can have different flavor, the mass must be degenerate, so we
	can choose one of the possible flavor combinations.
	<<PHS forests: phs forest: TBP>>=
	procedure :: set_flavors => phs_forest_set_flavors
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
	class(phs_forest_t), intent(inout) :: forest
	type(flavor_t), dimension(:), intent(in) :: flv
	integer, intent(in), dimension(:), allocatable, optional :: reshuffle
	type(flavor_t), intent(in), optional :: flv_extra
	end subroutine phs_forest_set_flavors
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
	class(phs_forest_t), intent(inout) :: forest
	type(flavor_t), dimension(:), intent(in) :: flv
	integer, intent(in), dimension(:), allocatable, optional :: reshuffle
	type(flavor_t), intent(in), optional :: flv_extra
	integer :: i, n_flv0
	if (present (reshuffle) .and. present (flv_extra)) then
	n_flv0 = size (flv)
	do i = 1, n_flv0
	if (reshuffle(i) <= n_flv0) then
	forest%flv(i) = flv (reshuffle(i))
	else
	forest%flv(i) = flv_extra
	end if
	end do
	else
	allocate (forest%flv (size (flv)))
	forest%flv = flv
	end if
	end subroutine phs_forest_set_flavors

	@ %def phs_forest_set_flavors
	@
	<<PHS forests: phs forest: TBP>>=
	procedure :: set_momentum_links => phs_forest_set_momentum_links
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_momentum_links (forest, list)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in), dimension(:), allocatable :: list
	end subroutine phs_forest_set_momentum_links
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_momentum_links (forest, list)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in), dimension(:), allocatable :: list
	integer :: g, t
	do g = 1, size (forest%grove)
	do t = 1, size (forest%grove(g)%tree)
	associate (tree => forest%grove(g)%tree(t))
	call phs_tree_set_momentum_links (tree, list)
	!!! call tree%reshuffle_mappings ()
	end associate
	end do
	end do
	end subroutine phs_forest_set_momentum_links

	@ %def phs_forest_set_momentum_links
	@ Once the parameter set is fixed, the masses and the widths of the
	particles are known and the [[mass_sum]] arrays as well as the mapping
	parameters can be computed. Note that order is important: we first
	compute the mass sums, then the ordinary mappings. The resonances
	obtained here determine the effective masses, which in turn are used
	to implement step mappings for resonance decay products that are not
	mapped otherwise.
	<<PHS forests: phs forest: TBP>>=
	procedure :: set_parameters => phs_forest_set_parameters
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_parameters &
	(forest, mapping_defaults, variable_limits)
	class(phs_forest_t), intent(inout) :: forest
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	end subroutine phs_forest_set_parameters
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_parameters &
	(forest, mapping_defaults, variable_limits)
	class(phs_forest_t), intent(inout) :: forest
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	logical, intent(in) :: variable_limits
	integer :: g, t
	do g = 1, size (forest%grove)
	do t = 1, size (forest%grove(g)%tree)
	call forest%grove(g)%tree(t)%set_mass_sum (forest%flv(forest%n_in+1:))
	call forest%grove(g)%tree(t)%set_mapping_parameters &
	(mapping_defaults, variable_limits)
	call forest%grove(g)%tree(t)%set_effective_masses ()
	if (mapping_defaults%step_mapping) then
	call forest%grove(g)%tree(t)%set_step_mappings &
	(mapping_defaults%step_mapping_exp, variable_limits)
	end if
	end do
	end do
	end subroutine phs_forest_set_parameters

	@ %def phs_forest_set_parameters
	@ Generate the particle combination table. Scan all trees and merge
	their individual combination tables. At the end, valid entries are
	non-zero, and they indicate the indices of a pair of particles to be
	combined to a new particle. If a particle is accessible by more than
	one tree (this is usual), only keep the first possibility.
	<<PHS forests: phs forest: TBP>>=
	procedure :: setup_prt_combinations => phs_forest_setup_prt_combinations
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_setup_prt_combinations (forest)
	class(phs_forest_t), intent(inout) :: forest
	end subroutine phs_forest_setup_prt_combinations
	<<PHS forests: procedures>>=
	module subroutine phs_forest_setup_prt_combinations (forest)
	class(phs_forest_t), intent(inout) :: forest
	integer :: g, t
	integer, dimension(:,:), allocatable :: tree_prt_combination
	forest%prt_combination = 0
	allocate (tree_prt_combination (2, size (forest%prt_combination, 2)))
	do g = 1, size (forest%grove)
	do t = 1, size (forest%grove(g)%tree)
	call phs_tree_setup_prt_combinations &
	(forest%grove(g)%tree(t), tree_prt_combination)
	where (tree_prt_combination /= 0 .and. forest%prt_combination == 0)
	forest%prt_combination = tree_prt_combination
	end where
	end do
	end do
	end subroutine phs_forest_setup_prt_combinations

	@ %def phs_forest_setup_prt_combinations
	@
	\subsection{Accessing the particle arrays}
	Set the incoming particles from the contents of an interaction.
	<<PHS forests: phs forest: TBP>>=
	generic :: set_prt_in => set_prt_in_int, set_prt_in_mom
	procedure :: set_prt_in_int => phs_forest_set_prt_in_int
	procedure :: set_prt_in_mom => phs_forest_set_prt_in_mom
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(interaction_t), intent(in) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	end subroutine phs_forest_set_prt_in_int
	module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	end subroutine phs_forest_set_prt_in_mom
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(interaction_t), intent(in) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	if (present (lt_cm_to_lab)) then
	call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * &
	int%get_momenta (outgoing=.false.))
	else
	call forest%prt_in%set_momentum (int%get_momenta (outgoing=.false.))
	end if
	associate (m_in => forest%flv(:forest%n_in)%get_mass ())
	call forest%prt_in%set_msq (m_in ** 2)
	end associate
	call forest%prt_in%set_defined ()
	end subroutine phs_forest_set_prt_in_int

	module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	if (present (lt_cm_to_lab)) then
	call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * mom)
	else
	call forest%prt_in%set_momentum (mom)
	end if
	associate (m_in => forest%flv(:forest%n_in)%get_mass ())
	call forest%prt_in%set_msq (m_in ** 2)
	end associate
	call forest%prt_in%set_defined ()
	end subroutine phs_forest_set_prt_in_mom

	@ %def phs_forest_set_prt_in
	@ Set the outgoing particles from the contents of an interaction.
	<<PHS forests: phs forest: TBP>>=
	generic :: set_prt_out => set_prt_out_int, set_prt_out_mom
	procedure :: set_prt_out_int => phs_forest_set_prt_out_int
	procedure :: set_prt_out_mom => phs_forest_set_prt_out_mom
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(interaction_t), intent(in) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	end subroutine phs_forest_set_prt_out_int
	module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	end subroutine phs_forest_set_prt_out_mom
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(interaction_t), intent(in) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	if (present (lt_cm_to_lab)) then
	call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * &
	int%get_momenta (outgoing=.true.))
	else
	call forest%prt_out%set_momentum (int%get_momenta (outgoing=.true.))
	end if
	associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
	call forest%prt_out%set_msq (m_out ** 2)
	end associate
	call forest%prt_out%set_defined ()
	end subroutine phs_forest_set_prt_out_int

	module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
	class(phs_forest_t), intent(inout) :: forest
	type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	if (present (lt_cm_to_lab)) then
	call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * mom)
	else
	call forest%prt_out%set_momentum (mom)
	end if
	associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
	call forest%prt_out%set_msq (m_out ** 2)
	end associate
	call forest%prt_out%set_defined ()
	end subroutine phs_forest_set_prt_out_mom

	@ %def phs_forest_set_prt_out
	@ Combine particles as described by the particle combination table.
	Particle momentum sums will be calculated only if the resulting
	particle is contained in at least one of the trees in the current
	forest. The others are kept undefined.
	<<PHS forests: phs forest: TBP>>=
	procedure :: combine_particles => phs_forest_combine_particles
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_combine_particles (forest)
	class(phs_forest_t), intent(inout) :: forest
	end subroutine phs_forest_combine_particles
	<<PHS forests: procedures>>=
	module subroutine phs_forest_combine_particles (forest)
	class(phs_forest_t), intent(inout) :: forest
	integer :: k
	integer, dimension(2) :: kk
	do k = 1, size (forest%prt_combination, 2)
	kk = forest%prt_combination(:,k)
	if (kk(1) /= 0) then
	call forest%prt(k)%combine (forest%prt(kk(1)), forest%prt(kk(2)))
	end if
	end do
	end subroutine phs_forest_combine_particles

	@ %def phs_forest_combine_particles
	@ Extract the outgoing particles and insert into an interaction.
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_prt_out => phs_forest_get_prt_out
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(in) :: forest
	type(interaction_t), intent(inout) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	end subroutine phs_forest_get_prt_out
	<<PHS forests: procedures>>=
	module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
	class(phs_forest_t), intent(in) :: forest
	type(interaction_t), intent(inout) :: int
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	if (present (lt_cm_to_lab)) then
	call int%set_momenta (lt_cm_to_lab * &
	forest%prt_out%get_momentum (), outgoing=.true.)
	else
	call int%set_momenta (forest%prt_out%get_momentum (), &
	outgoing=.true.)
	end if
	end subroutine phs_forest_get_prt_out

	@ %def phs_forest_get_prt_out
	@ Extract the outgoing particle momenta
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_momenta_out => phs_forest_get_momenta_out
	<<PHS forests: sub interfaces>>=
	module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
	class(phs_forest_t), intent(in) :: forest
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	type(vector4_t), dimension(size (forest%prt_out)) :: p
	end function phs_forest_get_momenta_out
	<<PHS forests: procedures>>=
	module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
	class(phs_forest_t), intent(in) :: forest
	type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
	type(vector4_t), dimension(size (forest%prt_out)) :: p
	p = forest%prt_out%get_momentum ()
	if (present (lt_cm_to_lab)) p = p * lt_cm_to_lab
	end function phs_forest_get_momenta_out

	@ %def phs_forest_get_momenta_out
	@
	\subsection{Find equivalences among phase-space trees}
	Scan phase space for equivalences. We generate the complete set of
	unique permutations for the given list of outgoing particles, and use
	this for scanning equivalences within each grove.
	@ We scan all pairs of trees, using all permutations. This implies
	that trivial equivalences are included, and equivalences between
	different trees are recorded twice. This is intentional.
	<<PHS forests: procedures>>=
	subroutine phs_grove_set_equivalences (grove, perm_array)
	type(phs_grove_t), intent(inout) :: grove
	type(permutation_t), dimension(:), intent(in) :: perm_array
	type(equivalence_t), pointer :: eq
	integer :: t1, t2, i
	do t1 = 1, size (grove%tree)
	do t2 = 1, size (grove%tree)
	SCAN_PERM: do i = 1, size (perm_array)
	if (phs_tree_equivalent &
	(grove%tree(t1), grove%tree(t2), perm_array(i))) then
	call equivalence_list_add &
	(grove%equivalence_list, t1, t2, perm_array(i))
	eq => grove%equivalence_list%last
	call phs_tree_find_msq_permutation &
	(grove%tree(t1), grove%tree(t2), eq%perm, &
	eq%msq_perm)
	call phs_tree_find_angle_permutation &
	(grove%tree(t1), grove%tree(t2), eq%perm, &
	eq%angle_perm, eq%angle_sig)
	end if
	end do SCAN_PERM
	end do
	end do
	end subroutine phs_grove_set_equivalences

	@ %def phs_grove_set_equivalences
	<<PHS forests: phs forest: TBP>>=
	procedure :: set_equivalences => phs_forest_set_equivalences
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_set_equivalences (forest)
	class(phs_forest_t), intent(inout) :: forest
	end subroutine phs_forest_set_equivalences
	<<PHS forests: procedures>>=
	module subroutine phs_forest_set_equivalences (forest)
	class(phs_forest_t), intent(inout) :: forest
	type(permutation_t), dimension(:), allocatable :: perm_array
	integer :: i
	call permutation_array_make &
	(perm_array, forest%flv(forest%n_in+1:)%get_pdg ())
	do i = 1, size (forest%grove)
	call phs_grove_set_equivalences (forest%grove(i), perm_array)
	end do
	forest%n_equivalences = sum (forest%grove%equivalence_list%length)
	end subroutine phs_forest_set_equivalences

	@ %def phs_forest_set_equivalences
	@
	\subsection{Interface for channel equivalences}
	Here, we store the equivalence list in the appropriate containers that
	the [[phs_base]] module provides. There is one separate list for each
	channel.
	<<PHS forests: phs forest: TBP>>=
	procedure :: get_equivalences => phs_forest_get_equivalences
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_get_equivalences &
	(forest, channel, azimuthal_dependence)
	class(phs_forest_t), intent(in) :: forest
	type(phs_channel_t), dimension(:), intent(out) :: channel
	logical, intent(in) :: azimuthal_dependence
	end subroutine phs_forest_get_equivalences
	<<PHS forests: procedures>>=
	module subroutine phs_forest_get_equivalences &
	(forest, channel, azimuthal_dependence)
	class(phs_forest_t), intent(in) :: forest
	type(phs_channel_t), dimension(:), intent(out) :: channel
	logical, intent(in) :: azimuthal_dependence
	integer :: n_masses, n_angles
	integer :: mode_azimuthal_angle
	integer, dimension(:), allocatable :: n_eq
	type(equivalence_t), pointer :: eq
	integer, dimension(:), allocatable :: perm, mode
	integer :: g, c, j, left, right
	n_masses = forest%n_masses
	n_angles = forest%n_angles
	allocate (n_eq (forest%n_trees), source = 0)
	allocate (perm (forest%n_dimensions))
	allocate (mode (forest%n_dimensions), source = EQ_IDENTITY)
	do g = 1, size (forest%grove)
	eq => forest%grove(g)%equivalence_list%first
	do while (associated (eq))
	left = eq%left + forest%grove(g)%tree_count_offset
	n_eq(left) = n_eq(left) + 1
	eq => eq%next
	end do
	end do
	do c = 1, size (channel)
	allocate (channel(c)%eq (n_eq(c)))
	do j = 1, n_eq(c)
	call channel(c)%eq(j)%init (forest%n_dimensions)
	end do
	end do
	n_eq = 0
	if (azimuthal_dependence) then
	mode_azimuthal_angle = EQ_IDENTITY
	else
	mode_azimuthal_angle = EQ_INVARIANT
	end if
	do g = 1, size (forest%grove)
	eq => forest%grove(g)%equivalence_list%first
	do while (associated (eq))
	left = eq%left + forest%grove(g)%tree_count_offset
	right = eq%right + forest%grove(g)%tree_count_offset
	do j = 1, n_masses
	perm(j) = permute (j, eq%msq_perm)
	mode(j) = EQ_IDENTITY
	end do
	do j = 1, n_angles
	perm(n_masses+j) = n_masses + permute (j, eq%angle_perm)
	if (j == 1) then
	mode(n_masses+j) = mode_azimuthal_angle ! first az. angle
	else if (mod(j,2) == 1) then
	mode(n_masses+j) = EQ_SYMMETRIC ! other az. angles
	else if (eq%angle_sig(j)) then
	mode(n_masses+j) = EQ_IDENTITY ! polar angle +
	else
	mode(n_masses+j) = EQ_INVERT ! polar angle -
	end if
	end do
	n_eq(left) = n_eq(left) + 1
	associate (eq_cur => channel(left)%eq(n_eq(left)))
	eq_cur%c = right
	eq_cur%perm = perm
	eq_cur%mode = mode
	end associate
	eq => eq%next
	end do
	end do
	end subroutine phs_forest_get_equivalences

	@ %def phs_forest_get_equivalences
	@
	\subsection{Phase-space evaluation}
	Given one row of the [[x]] parameter array and the corresponding
	channel index, compute first all relevant momenta and then recover the
	remainder of the [[x]] array, the Jacobians [[phs_factor]], and the
	phase-space [[volume]].

	The output argument [[ok]] indicates whether this was successful.
	<<PHS forests: phs forest: TBP>>=
	procedure :: evaluate_selected_channel => phs_forest_evaluate_selected_channel
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_evaluate_selected_channel &
	(forest, channel, active, sqrts, x, phs_factor, volume, ok)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	logical, dimension(:), intent(in) :: active
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(out) :: phs_factor
	real(default), intent(out) :: volume
	logical, intent(out) :: ok
	end subroutine phs_forest_evaluate_selected_channel
	<<PHS forests: procedures>>=
	module subroutine phs_forest_evaluate_selected_channel &
	(forest, channel, active, sqrts, x, phs_factor, volume, ok)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	logical, dimension(:), intent(in) :: active
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(out) :: phs_factor
	real(default), intent(out) :: volume
	logical, intent(out) :: ok
	integer :: g, t
	integer(TC) :: k, k_root, k_in

	g = forest%grove_lookup (channel)
	t = channel - forest%grove(g)%tree_count_offset
	call forest%prt%set_undefined ()
	call forest%prt_out%set_undefined ()
	k_in = forest%n_tot

	do k = 1,forest%n_in
	forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
	end do

	do k = 1, forest%n_out
	call forest%prt(ibset(0,k-1))%set_msq &
	(forest%flv(forest%n_in+k)%get_mass () ** 2)
	end do


	k_root = 2**forest%n_out - 1
	select case (forest%n_in)
	case (1)
	forest%prt(k_root) = forest%prt_in(1)
	case (2)
	call forest%prt(k_root)%combine (forest%prt_in(1), forest%prt_in(2))
	end select
	call forest%grove(g)%tree(t)%compute_momenta_from_x (forest%prt, &
	phs_factor(channel), volume, sqrts, x(:,channel), ok)
	if (ok) then
	do k = 1, forest%n_out
	forest%prt_out(k) = forest%prt(ibset(0,k-1))
	end do
	end if
	end subroutine phs_forest_evaluate_selected_channel

	@ %def phs_forest_evaluate_selected_channel
	@ The remainder: recover $x$ values for all channels except for the current
	channel.

	NOTE: OpenMP not used for the first loop. [[combine_particles]] is not a
	channel-local operation.
	<<PHS forests: phs forest: TBP>>=
	procedure :: evaluate_other_channels => phs_forest_evaluate_other_channels
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_evaluate_other_channels &
	(forest, channel, active, sqrts, x, phs_factor, combine)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	logical, dimension(:), intent(in) :: active
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(inout) :: phs_factor
	logical, intent(in) :: combine
	end subroutine phs_forest_evaluate_other_channels
	<<PHS forests: procedures>>=
	module subroutine phs_forest_evaluate_other_channels &
	(forest, channel, active, sqrts, x, phs_factor, combine)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	logical, dimension(:), intent(in) :: active
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(inout) :: phs_factor
	logical, intent(in) :: combine
	integer :: g, t, ch, n_channel

	g = forest%grove_lookup (channel)
	t = channel - forest%grove(g)%tree_count_offset

	n_channel = forest%n_trees
	if (combine) then
	do ch = 1, n_channel
	if (ch == channel) cycle
	if (active(ch)) then
	g = forest%grove_lookup(ch)
	t = ch - forest%grove(g)%tree_count_offset
	call phs_tree_combine_particles &
	(forest%grove(g)%tree(t), forest%prt)
	end if
	end do
	end if

	!OMP PARALLEL PRIVATE (g,t,ch) SHARED(active,forest,sqrts,x,channel)
	!OMP DO SCHEDULE(STATIC)
	do ch = 1, n_channel
	if (ch == channel) cycle
	if (active(ch)) then
	g = forest%grove_lookup(ch)
	t = ch - forest%grove(g)%tree_count_offset
	call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, &
	phs_factor(ch), sqrts, x(:,ch))
	end if
	end do
	!OMP END DO
	!OMP END PARALLEL

	end subroutine phs_forest_evaluate_other_channels

	@ %def phs_forest_evaluate_other_channels
	@ The complement: recover one row of the [[x]] array and the
	associated Jacobian entry, corresponding to
	[[channel]], from incoming and outgoing momenta. Also compute the
	phase-space volume.
	<<PHS forests: phs forest: TBP>>=
	procedure :: recover_channel => phs_forest_recover_channel
	<<PHS forests: sub interfaces>>=
	module subroutine phs_forest_recover_channel &
	(forest, channel, sqrts, x, phs_factor, volume)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(inout) :: phs_factor
	real(default), intent(out) :: volume
	end subroutine phs_forest_recover_channel
	<<PHS forests: procedures>>=
	module subroutine phs_forest_recover_channel &
	(forest, channel, sqrts, x, phs_factor, volume)
	class(phs_forest_t), intent(inout) :: forest
	integer, intent(in) :: channel
	real(default), intent(in) :: sqrts
	real(default), dimension(:,:), intent(inout) :: x
	real(default), dimension(:), intent(inout) :: phs_factor
	real(default), intent(out) :: volume
	integer :: g, t
	integer(TC) :: k, k_in
	g = forest%grove_lookup (channel)
	t = channel - forest%grove(g)%tree_count_offset
	call forest%prt%set_undefined ()
	k_in = forest%n_tot
	forall (k = 1:forest%n_in)
	forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
	end forall
	forall (k = 1:forest%n_out)
	forest%prt(ibset(0,k-1)) = forest%prt_out(k)
	end forall
	call forest%combine_particles ()
	call forest%grove(g)%tree(t)%compute_volume (sqrts, volume)
	call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, &
	phs_factor(channel), sqrts, x(:,channel))
	end subroutine phs_forest_recover_channel

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

	module phs_forests_ut
	use unit_tests
	use phs_forests_uti

	<<Standard module head>>

	<<PHS forests: public test>>

	contains

	<<PHS forests: test driver>>

	end module phs_forests_ut
	@ %def phs_forests_ut
	@
	<<[[phs_forests_uti.f90]]>>=
	<<File header>>

	module phs_forests_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_12
	use lorentz
	use flavors
	use interactions
	use model_data
	use mappings
	use phs_base
	use resonances, only: resonance_history_set_t

	use phs_forests

	<<Standard module head>>

	<<PHS forests: test declarations>>

	contains

	<<PHS forests: tests>>

	end module phs_forests_uti
	@ %def phs_forests_ut
	@ API: driver for the unit tests below.
	<<PHS forests: public test>>=
	public :: phs_forests_test
	<<PHS forests: test driver>>=
	subroutine phs_forests_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS forests: execute tests>>
	end subroutine phs_forests_test

	@ %def phs_forests_test
	@
	\subsubsection{Basic universal test}
	Write a possible phase-space file for a $2\to 3$ process and make the
	corresponding forest, print the forest. Choose some in-particle
	momenta and a random-number array and evaluate out-particles and
	phase-space factors.
	<<PHS forests: execute tests>>=
	call test (phs_forest_1, "phs_forest_1", &
	"check phs forest setup", &
	u, results)
	<<PHS forests: test declarations>>=
	public :: phs_forest_1
	<<PHS forests: tests>>=
	subroutine phs_forest_1 (u)
	use os_interface
	integer, intent(in) :: u
	type(phs_forest_t) :: forest
	type(phs_channel_t), dimension(:), allocatable :: channel
	type(model_data_t), target :: model
	type(string_t) :: process_id
	type(flavor_t), dimension(5) :: flv
	type(string_t) :: filename
	type(interaction_t) :: int
	integer :: unit_fix
	type(mapping_defaults_t) :: mapping_defaults
	logical :: found_process, ok
	integer :: n_channel, ch, i
	logical, dimension(4) :: active = .true.
	real(default) :: sqrts = 1000
	real(default), dimension(5,4) :: x
	real(default), dimension(4) :: factor
	real(default) :: volume

	write (u, "(A)") "* Test output: PHS forest"
	write (u, "(A)") "* Purpose: test PHS forest routines"
	write (u, "(A)")

	write (u, "(A)") "* Reading model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Create phase-space file 'phs_forest_test.phs'"
	write (u, "(A)")

	call flv%init ([11, -11, 11, -11, 22], model)
	unit_fix = free_unit ()
	open (file="phs_forest_test.phs", unit=unit_fix, action="write")
	write (unit_fix, *) "process foo"
	write (unit_fix, *) 'md5sum_process = "6ABA33BC2927925D0F073B1C1170780A"'
	write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"'
	write (unit_fix, *) 'md5sum_phs_config = "B6A8877058809A8BDD54753CDAB83ACE"'
	write (unit_fix, *) "sqrts = 100.00000000000000"
	write (unit_fix, *) "m_threshold_s = 50.000000000000000"
	write (unit_fix, *) "m_threshold_t = 100.00000000000000"
	write (unit_fix, *) "off_shell = 2"
	write (unit_fix, *) "t_channel = 6"
	write (unit_fix, *) "keep_nonresonant = F"
	write (unit_fix, *) ""
	write (unit_fix, *) " grove"
	write (unit_fix, *) " tree 3 7"
	write (unit_fix, *) " map 3 s_channel 23"
	write (unit_fix, *) " tree 5 7"
	write (unit_fix, *) " tree 6 7"
	write (unit_fix, *) " grove"
	write (unit_fix, *) " tree 9 11"
	write (unit_fix, *) " map 9 t_channel 22"
	close (unit_fix)

	write (u, "(A)")
	write (u, "(A)") "* Read phase-space file 'phs_forest_test.phs'"

	call syntax_phs_forest_init ()
	process_id = "foo"
	filename = "phs_forest_test.phs"
	call forest%read (filename, process_id, 2, 3, model, found_process)

	write (u, "(A)")
	write (u, "(A)") "* Set parameters, flavors, equiv, momenta"
	write (u, "(A)")

	call forest%set_flavors (flv)
	call forest%set_parameters (mapping_defaults, .false.)
	call forest%setup_prt_combinations ()
	call forest%set_equivalences ()
	call int%basic_init (2, 0, 3)
	call int%set_momentum &
	(vector4_moving (500._default, 500._default, 3), 1)
	call int%set_momentum &
	(vector4_moving (500._default,-500._default, 3), 2)
	call forest%set_prt_in (int)
	n_channel = 2
	x = 0
	x(:,n_channel) = [0.3, 0.4, 0.1, 0.9, 0.6]
	write (u, "(A)") " Input values:"
	write (u, "(3x,5(1x," // FMT_12 // "))") x(:,n_channel)

	write (u, "(A)")
	write (u, "(A)") "* Evaluating phase space"

	call forest%evaluate_selected_channel (n_channel, active, sqrts, &
	x, factor, volume, ok)
	call forest%evaluate_other_channels (n_channel, active, sqrts, &
	x, factor, combine=.true.)
	call forest%get_prt_out (int)
	write (u, "(A)") " Output values:"
	do ch = 1, 4
	write (u, "(3x,5(1x," // FMT_12 // "))") x(:,ch)
	end do
	call int%basic_write (u)
	write (u, "(A)") " Factors:"
	write (u, "(3x,5(1x," // FMT_12 // "))") factor
	write (u, "(A)") " Volume:"
	write (u, "(3x,5(1x," // FMT_12 // "))") volume
	call forest%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute equivalences"

	n_channel = 4
	allocate (channel (n_channel))
	call forest%get_equivalences (channel, .true.)
	do i = 1, n_channel
	write (u, "(1x,I0,':')", advance = "no") ch
	call channel(i)%write (u)
	end do

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

	call model%final ()
	call forest%final ()
	call syntax_phs_forest_final ()

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

	end subroutine phs_forest_1

	@ %def phs_forest_1
	@
	\subsubsection{Resonance histories}
	Read a suitably nontrivial forest from file and recover the set of
	resonance histories.
	<<PHS forests: execute tests>>=
	call test (phs_forest_2, "phs_forest_2", &
	"handle phs forest resonance content", &
	u, results)
	<<PHS forests: test declarations>>=
	public :: phs_forest_2
	<<PHS forests: tests>>=
	subroutine phs_forest_2 (u)
	use os_interface
	integer, intent(in) :: u
	integer :: unit_fix
	type(phs_forest_t) :: forest
	type(model_data_t), target :: model
	type(string_t) :: process_id
	type(string_t) :: filename
	logical :: found_process
	type(resonance_history_set_t) :: res_set
	integer :: i

	write (u, "(A)") "* Test output: phs_forest_2"
	write (u, "(A)") "* Purpose: test PHS forest routines"
	write (u, "(A)")

	write (u, "(A)") "* Reading model file"

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Create phase-space file 'phs_forest_2.phs'"
	write (u, "(A)")

	unit_fix = free_unit ()
	open (file="phs_forest_2.phs", unit=unit_fix, action="write")
	write (unit_fix, *) "process foo"
	write (unit_fix, *) 'md5sum_process = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
	write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"'
	write (unit_fix, *) 'md5sum_phs_config = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
	write (unit_fix, *) "sqrts = 100.00000000000000"
	write (unit_fix, *) "m_threshold_s = 50.000000000000000"
	write (unit_fix, *) "m_threshold_t = 100.00000000000000"
	write (unit_fix, *) "off_shell = 2"
	write (unit_fix, *) "t_channel = 6"
	write (unit_fix, *) "keep_nonresonant = F"
	write (unit_fix, *) ""
	write (unit_fix, *) " grove"
	write (unit_fix, *) " tree 3 7"
	write (unit_fix, *) " tree 3 7"
	write (unit_fix, *) " map 3 s_channel -24"
	write (unit_fix, *) " tree 5 7"
	write (unit_fix, *) " tree 3 7"
	write (unit_fix, *) " map 3 s_channel -24"
	write (unit_fix, *) " map 7 s_channel 23"
	write (unit_fix, *) " tree 5 7"
	write (unit_fix, *) " map 7 s_channel 25"
	write (unit_fix, *) " tree 3 11"
	write (unit_fix, *) " map 3 s_channel -24"
	close (unit_fix)

	write (u, "(A)") "* Read phase-space file 'phs_forest_2.phs'"

	call syntax_phs_forest_init ()
	process_id = "foo"
	filename = "phs_forest_2.phs"
	call forest%read (filename, process_id, 2, 3, model, found_process)

	write (u, "(A)")
	write (u, "(A)") "* Extract resonance history set"
	write (u, "(A)")

	call forest%extract_resonance_history_set (res_set)
	call res_set%write (u)

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

	call model%final ()
	call forest%final ()
	call syntax_phs_forest_final ()

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

	end subroutine phs_forest_2

	@ %def phs_forest_2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Finding phase space parameterizations}
	If the phase space configuration is not found in the appropriate file,
	we should generate one.

	The idea is to construct all Feynman diagrams subject to certain
	constraints which eliminate everything that is probably irrelevant for
	the integration. These Feynman diagrams (cascades) are grouped in
	groves by finding equivalence classes related by symmetry and ordered
	with respect to their importance (resonances). Finally, the result
	(or part of it) is written to file and used for the integration.

	This module may eventually disappear and be replaced by CAML code.
	In particular, we need here a set of Feynman rules (vertices with
	particle codes, but not the factors). Thus, the module works for the
	Standard Model only.

	Note that this module is stand-alone, it communicates to the main
	program only via the generated ASCII phase-space configuration file.
	<<[[cascades.f90]]>>=
	<<File header>>

	module cascades

	<<Use kinds>>
	use kinds, only: TC, i8, i32
	<<Use strings>>
	<<Use debug>>
	use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use physics_defs, only: UNDEFINED
	use model_data
	use flavors

	use resonances, only: resonance_info_t
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t
	use phs_forests

	<<Standard module head>>

	<<Cascades: public>>

	<<Cascades: parameters>>

	<<Cascades: types>>

	<<Cascades: interfaces>>

	interface
	<<Cascades: sub interfaces>>
	end interface

	end module cascades
	@ %def cascades
	@
	<<[[cascades_sub.f90]]>>=
	<<File header>>

	submodule (cascades) cascades_s

	use io_units
	use constants, only: one
	use format_defs, only: FMT_12, FMT_19
	use numeric_utils
	use diagnostics
	use hashes
	use sorting
	use lorentz
	!!! Intel oneAPI 2022/23 regression workaround
	use resonances, only: resonance_info_t
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t

	implicit none

	contains

	<<Cascades: procedures>>

	end submodule cascades_s

	@ %def cascades_s
	@
	\subsection{The mapping modes}
	The valid mapping modes, to be used below. We will make use of the convention
	that mappings of internal particles have a positive value. Only for positive
	values, the flavor code is propagated when combining cascades.
	<<Mapping modes>>=
	integer, parameter :: &
	& EXTERNAL_PRT = -1, &
	& NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, &
	& RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
	& STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
	& ON_SHELL = 99
	@ %def EXTERNAL_PRT
	@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
	@ %def RADIATION COLLINEAR INFRARED
	@ %def STEP_MAPPING_E STEP_MAPPING_H
	@ %def ON_SHELL
	<<Cascades: parameters>>=
	<<Mapping modes>>
	@
	\subsection{The cascade type}
	A cascade is essentially the same as a decay tree (both definitions
	may be merged in a later version). It contains a linked tree of
	nodes, each of which representing an internal particle. In contrast
	to decay trees, each node has a definite particle code. These nodes
	need not be modified, therefore we can use pointers and do not have to
	copy them. Thus, physically each cascades has only a single node, the
	mother particle. However, to be able to compare trees quickly, we
	store in addition an array of binary codes which is always sorted in
	ascending order. This is accompanied by a corresponding list of
	particle codes. The index is the location of the corresponding
	cascade in the cascade set, this may be used to access the daughters
	directly.

	The real mass is the particle mass belonging to the particle code.
	The minimal mass is the sum of the real masses of all its daughters;
	this is the kinematical cutoff. The effective mass may be zero if the
	particle mass is below a certain threshold; it may be the real mass if
	the particle is resonant; or it may be some other value.

	The logical [[t_channel]] is set if this a $t$-channel line, while
	[[initial]] is true only for an initial particle. Note that both
	initial particles are also [[t_channel]] by definition, and that they
	are distinguished by the direction of the tree: One of them decays
	and is the root of the tree, while the other one is one of the leaves.

	The cascade is a list of nodes (particles) which are linked via the
	[[daughter]] entries. The node is the mother particle of
	the decay cascade. Much of the information in the nodes is repeated
	in arrays, to be accessible more easily. The arrays will be kept
	sorted by binary codes.

	The counter [[n_off_shell]] is increased for each internal line that
	is neither resonant nor log-enhanced. It is set to zero if the
	current line is resonant, since this implies on-shell particle production
	and subsequent decay.

	The counter [[n_t_channel]] is non-negative once an initial particle
	is included in the tree: then, it counts the number of $t$-channel lines.

	The [[multiplicity]] is the number of branchings to follow until all
	daughters are on-shell. A resonant or non-decaying particle has
	multiplicity one. Merging nodes, the multiplicities add unless the
	mother is a resonance. An initial or final node has multiplicity
	zero.

	The arrays correspond to the subnode tree [[tree]] of the current
	cascade. PDG codes are stored only for those positions which are
	resonant, with the exception of the last entry, i.e., the current node.
	Other positions, in particular external legs, are assigned undefined
	PDG code.

	A cascade is uniquely identified by its tree, the tree of PDG codes,
	and the tree of mappings. The tree of resonances is kept only to mask
	the PDG tree as described above.
	<<Cascades: types>>=
	type :: cascade_t
	private
	! counters
	integer :: index = 0
	integer :: grove = 0
	! status
	logical :: active = .false.
	logical :: complete = .false.
	logical :: incoming = .false.
	! this node
	integer(TC) :: bincode = 0
	type(flavor_t) :: flv
	integer :: pdg = UNDEFINED
	logical :: is_vector = .false.
	real(default) :: m_min = 0
	real(default) :: m_rea = 0
	real(default) :: m_eff = 0
	integer :: mapping = NO_MAPPING
	logical :: on_shell = .false.
	logical :: resonant = .false.
	logical :: log_enhanced = .false.
	logical :: t_channel = .false.
	! global tree properties
	integer :: multiplicity = 0
	integer :: internal = 0
	integer :: n_off_shell = 0
	integer :: n_resonances = 0
	integer :: n_log_enhanced = 0
	integer :: n_t_channel = 0
	integer :: res_hash = 0
	! the sub-node tree
	integer :: depth = 0
	integer(TC), dimension(:), allocatable :: tree
	integer, dimension(:), allocatable :: tree_pdg
	integer, dimension(:), allocatable :: tree_mapping
	logical, dimension(:), allocatable :: tree_resonant
	! branch connections
	logical :: has_children = .false.
	type(cascade_t), pointer :: daughter1 => null ()
	type(cascade_t), pointer :: daughter2 => null ()
	type(cascade_t), pointer :: mother => null ()
	! next in list
	type(cascade_t), pointer :: next => null ()
	contains
	<<Cascades: cascade: TBP>>
	end type cascade_t

	@ %def cascade_t
	<<Cascades: procedures>>=
	subroutine cascade_init (cascade, depth)
	type(cascade_t), intent(out) :: cascade
	integer, intent(in) :: depth
	integer, save :: index = 0
	index = cascade_index ()
	cascade%index = index
	cascade%depth = depth
	cascade%active = .true.
	allocate (cascade%tree (depth))
	allocate (cascade%tree_pdg (depth))
	allocate (cascade%tree_mapping (depth))
	allocate (cascade%tree_resonant (depth))
	end subroutine cascade_init
	@ %def cascade_init
	@ Keep and increment a global index
	<<Cascades: procedures>>=
	function cascade_index (seed) result (index)
	integer :: index
	integer, intent(in), optional :: seed
	integer, save :: i = 0
	if (present (seed)) i = seed
	i = i + 1
	index = i
	end function cascade_index

	@ %def cascade_index
	@ We need three versions of writing cascades. This goes to the
	phase-space file.

	For t/u channel mappings, we use the absolute value of the PDG code.
	<<Cascades: procedures>>=
	subroutine cascade_write_file_format (cascade, model, unit)
	type(cascade_t), intent(in) :: cascade
	class(model_data_t), intent(in), target :: model
	integer, intent(in), optional :: unit
	type(flavor_t) :: flv
	integer :: u, i
	2 format(3x,A,1x,I3,1x,A,1x,I9,1x,'!',1x,A)
	u = given_output_unit (unit); if (u < 0) return
	call write_reduced (cascade%tree, u)
	write (u, "(A)")
	do i = 1, cascade%depth
	call flv%init (cascade%tree_pdg(i), model)
	select case (cascade%tree_mapping(i))
	case (NO_MAPPING, EXTERNAL_PRT)
	case (S_CHANNEL)
	write(u,2) 'map', &
	cascade%tree(i), 's_channel', cascade%tree_pdg(i), &
	char (flv%get_name ())
	case (T_CHANNEL)
	write(u,2) 'map', &
	cascade%tree(i), 't_channel', abs (cascade%tree_pdg(i)), &
	char (flv%get_name ())
	case (U_CHANNEL)
	write(u,2) 'map', &
	cascade%tree(i), 'u_channel', abs (cascade%tree_pdg(i)), &
	char (flv%get_name ())
	case (RADIATION)
	write(u,2) 'map', &
	cascade%tree(i), 'radiation', cascade%tree_pdg(i), &
	char (flv%get_name ())
	case (COLLINEAR)
	write(u,2) 'map', &
	cascade%tree(i), 'collinear', cascade%tree_pdg(i), &
	char (flv%get_name ())
	case (INFRARED)
	write(u,2) 'map', &
	cascade%tree(i), 'infrared ', cascade%tree_pdg(i), &
	char (flv%get_name ())
	case (ON_SHELL)
	write(u,2) 'map', &
	cascade%tree(i), 'on_shell ', cascade%tree_pdg(i), &
	char (flv%get_name ())
	case default
	call msg_bug (" Impossible mapping mode encountered")
	end select
	end do
	contains
	subroutine write_reduced (array, unit)
	integer(TC), dimension(:), intent(in) :: array
	integer, intent(in) :: unit
	integer :: i
	write (u, "(3x,A,1x)", advance="no") "tree"
	do i = 1, size (array)
	if (decay_level (array(i)) > 1) then
	write (u, "(1x,I0)", advance="no") array(i)
	end if
	end do
	end subroutine write_reduced

	elemental function decay_level (k) result (l)
	integer(TC), intent(in) :: k
	integer :: l
	integer :: i
	l = 0
	do i = 0, bit_size(k) - 1
	if (btest(k,i)) l = l + 1
	end do
	end function decay_level
	subroutine start_comment (u)
	integer, intent(in) :: u
	write(u, '(1x,A)', advance='no') '!'
	end subroutine start_comment
	end subroutine cascade_write_file_format

	@ %def cascade_write_file_format
	@ This creates metapost source for graphical display:
	<<Cascades: procedures>>=
	subroutine cascade_write_graph_format (cascade, count, unit)
	type(cascade_t), intent(in) :: cascade
	integer, intent(in) :: count
	integer, intent(in), optional :: unit
	integer :: u
	integer(TC) :: mask
	type(string_t) :: left_str, right_str
	u = given_output_unit (unit); if (u < 0) return
	mask = 2**((cascade%depth+3)/2) - 1
	left_str = ""
	right_str = ""
	write (u, '(A)') "\begin{minipage}{105pt}"
	write (u, '(A)') "\vspace{30pt}"
	write (u, '(A)') "\begin{center}"
	write (u, '(A)') "\begin{fmfgraph*}(55,55)"
	call graph_write (cascade, mask)
	write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
	write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
	write (u, '(A)') "\end{fmfgraph*}\\"
	write (u, '(A,I5,A)') "\fbox{$", count, "$}"
	write (u, '(A)') "\end{center}"
	write (u, '(A)') "\end{minipage}"
	write (u, '(A)') "%"
	contains
	recursive subroutine graph_write (cascade, mask, reverse)
	type(cascade_t), intent(in) :: cascade
	integer(TC), intent(in) :: mask
	logical, intent(in), optional :: reverse
	type(flavor_t) :: anti
	logical :: rev
	rev = .false.; if (present(reverse)) rev = reverse
	if (cascade%has_children) then
	if (.not.rev) then
	call vertex_write (cascade, cascade%daughter1, mask)
	call vertex_write (cascade, cascade%daughter2, mask)
	else
	call vertex_write (cascade, cascade%daughter2, mask, .true.)
	call vertex_write (cascade, cascade%daughter1, mask, .true.)
	end if
	if (cascade%complete) then
	call vertex_write (cascade, cascade%mother, mask, .true.)
	write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
	end if
	else
	if (cascade%incoming) then
	anti = cascade%flv%anti ()
	call external_write (cascade%bincode, anti%get_tex_name (), &
	left_str)
	else
	call external_write (cascade%bincode, cascade%flv%get_tex_name (), &
	right_str)
	end if
	end if
	end subroutine graph_write
	recursive subroutine vertex_write (cascade, daughter, mask, reverse)
	type(cascade_t), intent(in) :: cascade, daughter
	integer(TC), intent(in) :: mask
	logical, intent(in), optional :: reverse
	integer :: bincode
	if (cascade%complete) then
	bincode = 0
	else
	bincode = cascade%bincode
	end if
	call graph_write (daughter, mask, reverse)
	if (daughter%has_children) then
	call line_write (bincode, daughter%bincode, daughter%flv, &
	mapping=daughter%mapping)
	else
	call line_write (bincode, daughter%bincode, daughter%flv)
	end if
	end subroutine vertex_write
	subroutine line_write (i1, i2, flv, mapping)
	integer(TC), intent(in) :: i1, i2
	type(flavor_t), intent(in) :: flv
	integer, intent(in), optional :: mapping
	integer :: k1, k2
	type(string_t) :: prt_type
	select case (flv%get_spin_type ())
	case (SCALAR); prt_type = "plain"
	case (SPINOR); prt_type = "fermion"
	case (VECTOR); prt_type = "boson"
	case (VECTORSPINOR); prt_type = "fermion"
	case (TENSOR); prt_type = "dbl_wiggly"
	case default; prt_type = "dashes"
	end select
	if (flv%is_antiparticle ()) then
	k1 = i2; k2 = i1
	else
	k1 = i1; k2 = i2
	end if
	if (present (mapping)) then
	select case (mapping)
	case (S_CHANNEL)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=blue,lab=\sm\blue$" // &
	& char (flv%get_tex_name ()) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (T_CHANNEL, U_CHANNEL)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=cyan,lab=\sm\cyan$" // &
	& char (flv%get_tex_name ()) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (RADIATION)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=green,lab=\sm\green$" // &
	& char (flv%get_tex_name ()) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (COLLINEAR)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=magenta,lab=\sm\magenta$" // &
	& char (flv%get_tex_name ()) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (INFRARED)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=red,lab=\sm\red$" // &
	& char (flv%get_tex_name ()) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case default
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=black}" // &
	& "{v", k1, ",v", k2, "}"
	end select
	else
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& "}" // &
	& "{v", k1, ",v", k2, "}"
	end if
	end subroutine line_write
	subroutine external_write (bincode, name, ext_str)
	integer(TC), intent(in) :: bincode
	type(string_t), intent(in) :: name
	type(string_t), intent(inout) :: ext_str
	character(len=20) :: str
	write (str, '(A2,I0)') ",v", bincode
	ext_str = ext_str // trim (str)
	write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
	// char (name) &
	// "\,(", bincode, ")" &
	// "$}{v", bincode, "}"
	end subroutine external_write
	end subroutine cascade_write_graph_format

	@ %def cascade_write_graph_format
	@ This is for screen/debugging output:
	<<Cascades: procedures>>=
	subroutine cascade_write (cascade, unit)
	type(cascade_t), intent(in) :: cascade
	integer, intent(in), optional :: unit
	integer :: u
	character(9) :: depth
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A,(1x,I7))") 'Cascade #', cascade%index
	write (u, "(A,(1x,I7))") ' Grove: #', cascade%grove
	write (u, "(A,3(1x,L1))") ' act/cmp/inc: ', &
	cascade%active, cascade%complete, cascade%incoming
	write (u, "(A,I0)") ' Bincode: ', cascade%bincode
	write (u, "(A)", advance="no") ' Flavor: '
	call cascade%flv%write (unit)
	write (u, "(A,I9)") ' Active flavor:', cascade%pdg
	write (u, "(A,L1)") ' Is vector: ', cascade%is_vector
	write (u, "(A,3(1x," // FMT_19 // "))") ' Mass (m/r/e): ', &
	cascade%m_min, cascade%m_rea, cascade%m_eff
	write (u, "(A,I1)") ' Mapping: ', cascade%mapping
	write (u, "(A,3(1x,L1))") ' res/log/tch: ', &
	cascade%resonant, cascade%log_enhanced, cascade%t_channel
	write (u, "(A,(1x,I7))") ' Multiplicity: ', cascade%multiplicity
	write (u, "(A,2(1x,I7))") ' n intern/off: ', &
	cascade%internal, cascade%n_off_shell
	write (u, "(A,3(1x,I7))") ' n res/log/tch:', &
	cascade%n_resonances, cascade%n_log_enhanced, cascade%n_t_channel
	write (u, "(A,I7)") ' Depth: ', cascade%depth
	write (depth, "(I7)") cascade%depth
	write (u, "(A," // depth // "(1x,I7))") &
	' Tree: ', cascade%tree
	write (u, "(A," // depth // "(1x,I7))") &
	' Tree(PDG): ', cascade%tree_pdg
	write (u, "(A," // depth // "(1x,I7))") &
	' Tree(mapping):', cascade%tree_mapping
	write (u, "(A," // depth // "(1x,L1))") &
	' Tree(res): ', cascade%tree_resonant
	if (cascade%has_children) then
	write (u, "(A,I7,1x,I7)") ' Daughter1/2: ', &
	cascade%daughter1%index, cascade%daughter2%index
	end if
	if (associated (cascade%mother)) then
	write (u, "(A,I7)") ' Mother: ', cascade%mother%index
	end if
	end subroutine cascade_write

	@ %def cascade_write
	@
	\subsection{Creating new cascades}
	This initializes a single-particle cascade (external, final state).
	The PDG entry in the tree is set undefined because the cascade is not
	resonant. However, the flavor entry is set, so the cascade flavor
	is identified nevertheless.
	<<Cascades: procedures>>=
	subroutine cascade_init_outgoing (cascade, flv, pos, m_thr)
	type(cascade_t), intent(out) :: cascade
	type(flavor_t), intent(in) :: flv
	integer, intent(in) :: pos
	real(default), intent(in) :: m_thr
	call cascade_init (cascade, 1)
	cascade%bincode = ibset (0_TC, pos-1)
	cascade%flv = flv
	cascade%pdg = cascade%flv%get_pdg ()
	cascade%is_vector = flv%get_spin_type () == VECTOR
	cascade%m_min = flv%get_mass ()
	cascade%m_rea = cascade%m_min
	if (cascade%m_rea >= m_thr) then
	cascade%m_eff = cascade%m_rea
	end if
	cascade%on_shell = .true.
	cascade%multiplicity = 1
	cascade%tree(1) = cascade%bincode
	cascade%tree_pdg(1) = cascade%pdg
	cascade%tree_mapping(1) = EXTERNAL_PRT
	cascade%tree_resonant(1) = .false.
	end subroutine cascade_init_outgoing

	@ %def cascade_init_outgoing
	@ The same for an incoming line:
	<<Cascades: procedures>>=
	subroutine cascade_init_incoming (cascade, flv, pos, m_thr)
	type(cascade_t), intent(out) :: cascade
	type(flavor_t), intent(in) :: flv
	integer, intent(in) :: pos
	real(default), intent(in) :: m_thr
	call cascade_init (cascade, 1)
	cascade%incoming = .true.
	cascade%bincode = ibset (0_TC, pos-1)
	cascade%flv = flv%anti ()
	cascade%pdg = cascade%flv%get_pdg ()
	cascade%is_vector = flv%get_spin_type () == VECTOR
	cascade%m_min = flv%get_mass ()
	cascade%m_rea = cascade%m_min
	if (cascade%m_rea >= m_thr) then
	cascade%m_eff = cascade%m_rea
	end if
	cascade%on_shell = .true.
	cascade%n_t_channel = 0
	cascade%n_off_shell = 0
	cascade%tree(1) = cascade%bincode
	cascade%tree_pdg(1) = cascade%pdg
	cascade%tree_mapping(1) = EXTERNAL_PRT
	cascade%tree_resonant(1) = .false.
	end subroutine cascade_init_incoming

	@ %def cascade_init_outgoing
	@
	\subsection{Tools}
	This function returns true if the two cascades share no common
	external particle. This is a requirement for joining them.
	<<Cascades: interfaces>>=
	interface operator(.disjunct.)
	module procedure cascade_disjunct
	end interface

	<<Cascades: sub interfaces>>=
	module function cascade_disjunct (cascade1, cascade2) result (flag)
	logical :: flag
	type(cascade_t), intent(in) :: cascade1, cascade2
	end function cascade_disjunct
	<<Cascades: procedures>>=
	module function cascade_disjunct (cascade1, cascade2) result (flag)
	logical :: flag
	type(cascade_t), intent(in) :: cascade1, cascade2
	flag = iand (cascade1%bincode, cascade2%bincode) == 0
	end function cascade_disjunct

	@ %def cascade_disjunct
	@ %def .disjunct.
	@ Compute a hash code for the resonance pattern of a cascade. We count the
	number of times each particle appears as a resonance.

	We pack the PDG codes of the resonances in two arrays (s-channel and
	t-channel), sort them both, concatenate the results, transfer to
	[[i8]] integers, and compute the hash code from this byte stream.

	For t/u-channel, we remove the sign for antiparticles since this is not
	well-defined.
	<<Cascades: procedures>>=
	subroutine cascade_assign_resonance_hash (cascade)
	type(cascade_t), intent(inout) :: cascade
	integer(i8), dimension(1) :: mold
	cascade%res_hash = hash (transfer &
	([sort (pack (cascade%tree_pdg, &
	cascade%tree_resonant)), &
	sort (pack (abs (cascade%tree_pdg), &
	cascade%tree_mapping == T_CHANNEL .or. &
	cascade%tree_mapping == U_CHANNEL))], &
	mold))
	end subroutine cascade_assign_resonance_hash

	@ %def cascade_assign_resonance_hash
	@
	\subsection{Hash entries for cascades}
	We will set up a hash array which contains keys of and pointers to
	cascades. We hold a list of cascade (pointers) within each bucket.
	This is not for collision resolution, but for keeping similar, but
	unequal cascades together.
	<<Cascades: types>>=
	type :: cascade_p
	type(cascade_t), pointer :: cascade => null ()
	type(cascade_p), pointer :: next => null ()
	end type cascade_p

	@ %def cascade_p
	@ Here is the bucket or hash entry type:
	<<Cascades: types>>=
	type :: hash_entry_t
	integer(i32) :: hashval = 0
	integer(i8), dimension(:), allocatable :: key
	type(cascade_p), pointer :: first => null ()
	type(cascade_p), pointer :: last => null ()
	end type hash_entry_t

	@ %def hash_entry_t
	<<Cascades: public>>=
	public :: hash_entry_init
	<<Cascades: sub interfaces>>=
	module subroutine hash_entry_init (entry, entry_in)
	type(hash_entry_t), intent(out) :: entry
	type(hash_entry_t), intent(in) :: entry_in
	end subroutine hash_entry_init
	<<Cascades: procedures>>=
	module subroutine hash_entry_init (entry, entry_in)
	type(hash_entry_t), intent(out) :: entry
	type(hash_entry_t), intent(in) :: entry_in
	type(cascade_p), pointer :: casc_iter, casc_copy
	entry%hashval = entry_in%hashval
	entry%key = entry_in%key
	casc_iter => entry_in%first
	do while (associated (casc_iter))
	allocate (casc_copy)
	casc_copy = casc_iter
	casc_copy%next => null ()
	if (associated (entry%first)) then
	entry%last%next => casc_copy
	else
	entry%first => casc_copy
	end if
	entry%last => casc_copy
	casc_iter => casc_iter%next
	end do
	end subroutine hash_entry_init

	@ %def hash_entry_init
	@ Finalize: just deallocate the list; the contents are just pointers.
	<<Cascades: procedures>>=
	subroutine hash_entry_final (hash_entry)
	type(hash_entry_t), intent(inout) :: hash_entry
	type(cascade_p), pointer :: current
	do while (associated (hash_entry%first))
	current => hash_entry%first
	hash_entry%first => current%next
	deallocate (current)
	end do
	end subroutine hash_entry_final

	@ %def hash_entry_final
	@ Output: concise format for debugging, just list cascade indices.
	<<Cascades: procedures>>=
	subroutine hash_entry_write (hash_entry, unit)
	type(hash_entry_t), intent(in) :: hash_entry
	integer, intent(in), optional :: unit
	type(cascade_p), pointer :: current
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)", advance="no") "Entry:"
	do i = 1, size (hash_entry%key)
	write (u, "(1x,I0)", advance="no") hash_entry%key(i)
	end do
	write (u, "(1x,A)", advance="no") "->"
	current => hash_entry%first
	do while (associated (current))
	write (u, "(1x,I7)", advance="no") current%cascade%index
	current => current%next
	end do
	write (u, *)
	end subroutine hash_entry_write

	@ %def hash_entry_write
	@ This function adds a cascade pointer to the bucket. If [[ok]] is
	present, check first if it is already there and return failure if yes.
	If [[cascade_ptr]] is also present, set it to the current cascade if
	successful. If not, set it to the cascade that is already there.
	<<Cascades: procedures>>=
	subroutine hash_entry_add_cascade_ptr (hash_entry, cascade, ok, cascade_ptr)
	type(hash_entry_t), intent(inout) :: hash_entry
	type(cascade_t), intent(in), target :: cascade
	logical, intent(out), optional :: ok
	type(cascade_t), optional, pointer :: cascade_ptr
	type(cascade_p), pointer :: current
	if (present (ok)) then
	call hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
	if (.not. ok) return
	end if
	allocate (current)
	current%cascade => cascade
	if (associated (hash_entry%last)) then
	hash_entry%last%next => current
	else
	hash_entry%first => current
	end if
	hash_entry%last => current
	end subroutine hash_entry_add_cascade_ptr

	@ %def hash_entry_add_cascade_ptr
	@ This function checks whether a cascade is already in the bucket.
	For incomplete cascades, we look for an exact match. It should suffice
	to verify the tree, the PDG codes, and the mapping modes. This is the
	information that is written to the phase space file.

	For complete cascades, we ignore the PDG code at positions with
	mappings infrared, collinear, or t/u-channel. Thus a cascade which is
	distinguished only by PDG code at such places, is flagged existent.
	If the convention is followed that light particles come before heavier
	ones (in the model definition), this ensures that the lightest
	particle is kept in the appropriate place, corresponding to the
	strongest peak.

	For external cascades (incoming/outgoing) we take the PDG code into
	account even though it is zeroed in the PDG-code tree.
	<<Cascades: procedures>>=
	subroutine hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
	type(hash_entry_t), intent(in), target :: hash_entry
	type(cascade_t), intent(in), target :: cascade
	logical, intent(out) :: ok
	type(cascade_t), optional, pointer :: cascade_ptr
	type(cascade_p), pointer :: current
	integer, dimension(:), allocatable :: tree_pdg
	ok = .true.
	allocate (tree_pdg (size (cascade%tree_pdg)))
	if (cascade%complete) then
	where (cascade%tree_mapping == INFRARED .or. &
	cascade%tree_mapping == COLLINEAR .or. &
	cascade%tree_mapping == T_CHANNEL .or. &
	cascade%tree_mapping == U_CHANNEL)
	tree_pdg = 0
	elsewhere
	tree_pdg = cascade%tree_pdg
	end where
	else
	tree_pdg = cascade%tree_pdg
	end if
	current => hash_entry%first
	do while (associated (current))
	if (current%cascade%depth == cascade%depth) then
	if (all (current%cascade%tree == cascade%tree)) then
	if (all (current%cascade%tree_mapping == cascade%tree_mapping)) &
	then
	if (all (current%cascade%tree_pdg .match. tree_pdg)) then
	if (present (cascade_ptr)) cascade_ptr => current%cascade
	ok = .false.; return
	end if
	end if
	end if
	end if
	current => current%next
	end do
	if (present (cascade_ptr)) cascade_ptr => cascade
	end subroutine hash_entry_check_cascade

	@ %def hash_entry_check_cascade
	@ For PDG codes, we specify that the undefined code matches any code.
	This is already defined for flavor objects, but here we need it for
	the codes themselves.
	<<Cascades: interfaces>>=
	interface operator(.match.)
	module procedure pdg_match
	end interface
	<<Cascades: sub interfaces>>=
	elemental module function pdg_match (pdg1, pdg2) result (flag)
	logical :: flag
	integer(TC), intent(in) :: pdg1, pdg2
	end function pdg_match
	<<Cascades: procedures>>=
	elemental module function pdg_match (pdg1, pdg2) result (flag)
	logical :: flag
	integer(TC), intent(in) :: pdg1, pdg2
	select case (pdg1)
	case (0)
	flag = .true.
	case default
	select case (pdg2)
	case (0)
	flag = .true.
	case default
	flag = pdg1 == pdg2
	end select
	end select
	end function pdg_match

	@ %def .match.
	@
	\subsection{The cascade set}
	The cascade set will later be transformed into the decay forest. It
	is set up as a linked list. In addition to the usual [[first]] and
	[[last]] pointers, there is a [[first_t]] pointer which points to the
	first t-channel cascade (after all s-channel cascades), and a
	[[first_k]] pointer which points to the first final cascade (with a
	keystone).

	As an auxiliary device, the object contains a hash array with
	associated parameters where an additional pointer is stored for each
	cascade. The keys are made from the relevant cascade data. This hash
	is used for fast detection (and thus avoidance) of double entries in
	the cascade list.
	<<Cascades: public>>=
	public :: cascade_set_t
	<<Cascades: types>>=
	type :: cascade_set_t
	private
	class(model_data_t), pointer :: model
	integer :: n_in, n_out, n_tot
	type(flavor_t), dimension(:,:), allocatable :: flv
	integer :: depth_out, depth_tot
	real(default) :: sqrts = 0
	real(default) :: m_threshold_s = 0
	real(default) :: m_threshold_t = 0
	integer :: off_shell = 0
	integer :: t_channel = 0
	logical :: keep_nonresonant
	integer :: n_groves = 0
	! The cascade list
	type(cascade_t), pointer :: first => null ()
	type(cascade_t), pointer :: last => null ()
	type(cascade_t), pointer :: first_t => null ()
	type(cascade_t), pointer :: first_k => null ()
	! The hashtable
	integer :: n_entries = 0
	real :: fill_ratio = 0
	integer :: n_entries_max = 0
	integer(i32) :: mask = 0
	logical :: fatal_beam_decay = .true.
	type(hash_entry_t), dimension(:), allocatable :: entry
	end type cascade_set_t

	@ %def cascade_set_t
	@
	<<Cascades: public>>=
	interface cascade_set_init
	module procedure cascade_set_init_base
	module procedure cascade_set_init_from_cascade
	end interface
	@ %def cascade_set_init
	@ This might be broken. Test before using.
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_init_from_cascade &
	(cascade_set, cascade_set_in)
	type(cascade_set_t), intent(out) :: cascade_set
	type(cascade_set_t), intent(in), target :: cascade_set_in
	end subroutine cascade_set_init_from_cascade
	<<Cascades: procedures>>=
	module subroutine cascade_set_init_from_cascade &
	(cascade_set, cascade_set_in)
	type(cascade_set_t), intent(out) :: cascade_set
	type(cascade_set_t), intent(in), target :: cascade_set_in
	type(cascade_t), pointer :: casc_iter, casc_copy
	cascade_set%model => cascade_set_in%model
	cascade_set%n_in = cascade_set_in%n_in
	cascade_set%n_out = cascade_set_in%n_out
	cascade_set%n_tot = cascade_set_in%n_tot
	cascade_set%flv = cascade_set_in%flv
	cascade_set%depth_out = cascade_set_in%depth_out
	cascade_set%depth_tot = cascade_set_in%depth_tot
	cascade_set%sqrts = cascade_set_in%sqrts
	cascade_set%m_threshold_s = cascade_set_in%m_threshold_s
	cascade_set%m_threshold_t = cascade_set_in%m_threshold_t
	cascade_set%off_shell = cascade_set_in%off_shell
	cascade_set%t_channel = cascade_set_in%t_channel
	cascade_set%keep_nonresonant = cascade_set_in%keep_nonresonant
	cascade_set%n_groves = cascade_set_in%n_groves

	casc_iter => cascade_set_in%first
	do while (associated (casc_iter))
	allocate (casc_copy)
	casc_copy = casc_iter
	casc_copy%next => null ()
	if (associated (cascade_set%first)) then
	cascade_set%last%next => casc_copy
	else
	cascade_set%first => casc_copy
	end if
	cascade_set%last => casc_copy
	casc_iter => casc_iter%next
	end do

	cascade_set%n_entries = cascade_set_in%n_entries
	cascade_set%fill_ratio = cascade_set_in%fill_ratio
	cascade_set%n_entries_max = cascade_set_in%n_entries_max
	cascade_set%mask = cascade_set_in%mask
	cascade_set%fatal_beam_decay = cascade_set_in%fatal_beam_decay
	allocate (cascade_set%entry (0:cascade_set%mask))
	cascade_set%entry = cascade_set_in%entry
	end subroutine cascade_set_init_from_cascade

	@ %def cascade_set_init_from_cascade
	@ Return true if there are cascades which are active and complete, so
	the phase space file would be nonempty.
	<<Cascades: public>>=
	public :: cascade_set_is_valid
	<<Cascades: sub interfaces>>=
	module function cascade_set_is_valid (cascade_set) result (flag)
	logical :: flag
	type(cascade_set_t), intent(in) :: cascade_set
	end function cascade_set_is_valid
	<<Cascades: procedures>>=
	module function cascade_set_is_valid (cascade_set) result (flag)
	logical :: flag
	type(cascade_set_t), intent(in) :: cascade_set
	type(cascade_t), pointer :: cascade
	flag = .false.
	cascade => cascade_set%first_k
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	flag = .true.
	return
	end if
	cascade => cascade%next
	end do
	end function cascade_set_is_valid

	@ %def cascade_set_is_valid
	@ The initializer sets up the hash table with some initial size
	guessed by looking at the number of external particles. We choose 256
	for 3 external particles and a factor of 4 for each additional
	particle, limited at $2^{30}$=1G.
	<<Cascades: parameters>>=
	real, parameter, public :: CASCADE_SET_FILL_RATIO = 0.1
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_init_base (cascade_set, model, &
	n_in, n_out, phs_par, fatal_beam_decay, flv)
	type(cascade_set_t), intent(out) :: cascade_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	type(flavor_t), dimension(:,:), intent(in), optional :: flv
	end subroutine cascade_set_init_base
	<<Cascades: procedures>>=
	module subroutine cascade_set_init_base (cascade_set, model, &
	n_in, n_out, phs_par, fatal_beam_decay, flv)
	type(cascade_set_t), intent(out) :: cascade_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	type(flavor_t), dimension(:,:), intent(in), optional :: flv
	integer :: size_guess
	integer :: i, j
	cascade_set%model => model
	cascade_set%n_in = n_in
	cascade_set%n_out = n_out
	cascade_set%n_tot = n_in + n_out
	if (present (flv)) then
	allocate (cascade_set%flv (size (flv, 1), size (flv, 2)))
	do i = 1, size (flv, 2)
	do j = 1, size (flv, 1)
	call cascade_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
	end do
	end do
	end if
	select case (n_in)
	case (1); cascade_set%depth_out = 2 * n_out - 3
	case (2); cascade_set%depth_out = 2 * n_out - 1
	end select
	cascade_set%depth_tot = 2 * cascade_set%n_tot - 3
	cascade_set%sqrts = phs_par%sqrts
	cascade_set%m_threshold_s = phs_par%m_threshold_s
	cascade_set%m_threshold_t = phs_par%m_threshold_t
	cascade_set%off_shell = phs_par%off_shell
	cascade_set%t_channel = phs_par%t_channel
	cascade_set%keep_nonresonant = phs_par%keep_nonresonant
	cascade_set%fill_ratio = CASCADE_SET_FILL_RATIO
	size_guess = ishft (256, min (2 * (cascade_set%n_tot - 3), 22))
	cascade_set%n_entries_max = size_guess * cascade_set%fill_ratio
	cascade_set%mask = size_guess - 1
	allocate (cascade_set%entry (0:cascade_set%mask))
	cascade_set%fatal_beam_decay = fatal_beam_decay
	end subroutine cascade_set_init_base

	@ %def cascade_set_init_base
	@ The finalizer has to delete both the hash and the list.
	<<Cascades: public>>=
	public :: cascade_set_final
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_final (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	end subroutine cascade_set_final
	<<Cascades: procedures>>=
	module subroutine cascade_set_final (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), pointer :: current
	integer :: i
	if (allocated (cascade_set%entry)) then
	do i = 0, cascade_set%mask
	call hash_entry_final (cascade_set%entry(i))
	end do
	deallocate (cascade_set%entry)
	end if
	do while (associated (cascade_set%first))
	current => cascade_set%first
	cascade_set%first => cascade_set%first%next
	deallocate (current)
	end do
	end subroutine cascade_set_final

	@ %def cascade_set_final
	@ Write the process in ASCII format, in columns that are headed by the
	corresponding bincode.
	<<Cascades: public>>=
	public :: cascade_set_write_process_bincode_format
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_write_process_bincode_format &
	(cascade_set, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	end subroutine cascade_set_write_process_bincode_format
	<<Cascades: procedures>>=
	module subroutine cascade_set_write_process_bincode_format &
	(cascade_set, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	integer, dimension(:), allocatable :: bincode, field_width
	integer :: n_in, n_out, n_tot, n_flv
	integer :: u, f, i, bc
	character(20) :: str
	type(string_t) :: fmt_head
	type(string_t), dimension(:), allocatable :: fmt_proc
	u = given_output_unit (unit); if (u < 0) return
	if (.not. allocated (cascade_set%flv)) return
	write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:"
	n_in = cascade_set%n_in
	n_out = cascade_set%n_out
	n_tot = cascade_set%n_tot
	n_flv = size (cascade_set%flv, 2)
	allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
	bc = 1
	do i = 1, n_out
	bincode(n_in + i) = bc
	bc = 2 * bc
	end do
	do i = n_in, 1, -1
	bincode(i) = bc
	bc = 2 * bc
	end do
	do i = 1, n_tot
	write (str, "(I0)") bincode(i)
	field_width(i) = len_trim (str)
	do f = 1, n_flv
	field_width(i) = max (field_width(i), &
	len (cascade_set%flv(i,f)%get_name ()))
	end do
	end do
	fmt_head = "('!'"
	do i = 1, n_tot
	fmt_head = fmt_head // ",1x,"
	fmt_proc(i) = "(1x,"
	write (str, "(I0)") field_width(i)
	fmt_head = fmt_head // "I" // trim(str)
	fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
	if (i == n_in) then
	fmt_head = fmt_head // ",1x,' '"
	end if
	end do
	do i = 1, n_tot
	fmt_proc(i) = fmt_proc(i) // ")"
	end do
	fmt_head = fmt_head // ")"
	write (u, char (fmt_head)) bincode
	do f = 1, n_flv
	write (u, "('!')", advance="no")
	do i = 1, n_tot
	write (u, char (fmt_proc(i)), advance="no") &
	char (cascade_set%flv(i,f)%get_name ())
	if (i == n_in) write (u, "(1x,'=>')", advance="no")
	end do
	write (u, *)
	end do
	write (u, char (fmt_head)) bincode
	end subroutine cascade_set_write_process_bincode_format

	@ %def cascade_set_write_process_tex_format
	@ Write the process as a \LaTeX\ expression.
	<<Cascades: procedures>>=
	subroutine cascade_set_write_process_tex_format (cascade_set, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	integer :: u, f, i
	u = given_output_unit (unit); if (u < 0) return
	if (.not. allocated (cascade_set%flv)) return
	write (u, "(A)") "\begin{align*}"
	do f = 1, size (cascade_set%flv, 2)
	do i = 1, cascade_set%n_in
	if (i > 1) write (u, "(A)", advance="no") "\quad "
	write (u, "(A)", advance="no") &
	char (cascade_set%flv(i,f)%get_tex_name ())
	end do
	write (u, "(A)", advance="no") "\quad &\to\quad "
	do i = cascade_set%n_in + 1, cascade_set%n_tot
	if (i > cascade_set%n_in + 1) write (u, "(A)", advance="no") "\quad "
	write (u, "(A)", advance="no") &
	char (cascade_set%flv(i,f)%get_tex_name ())
	end do
	if (f < size (cascade_set%flv, 2)) then
	write (u, "(A)") "\\"
	else
	write (u, "(A)") ""
	end if
	end do
	write (u, "(A)") "\end{align*}"
	end subroutine cascade_set_write_process_tex_format

	@ %def cascade_set_write_process_tex_format
	@ Three output routines: phase-space file, graph source code, and
	screen output.

	This version generates the phase space file. It deals only with
	complete cascades.
	<<Cascades: public>>=
	public :: cascade_set_write_file_format
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_write_file_format (cascade_set, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	end subroutine cascade_set_write_file_format
	<<Cascades: procedures>>=
	module subroutine cascade_set_write_file_format (cascade_set, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	type(cascade_t), pointer :: cascade
	integer :: u, grove, count
	logical :: first_in_grove
	u = given_output_unit (unit); if (u < 0) return
	count = 0
	do grove = 1, cascade_set%n_groves
	first_in_grove = .true.
	cascade => cascade_set%first_k
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	if (cascade%grove == grove) then
	if (first_in_grove) then
	first_in_grove = .false.
	write (u, "(A)")
	write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
	'Multiplicity =', cascade%multiplicity, ","
	select case (cascade%n_resonances)
	case (0)
	write (u, '(1x,A)', advance='no') 'no resonances, '
	case (1)
	write (u, '(1x,A)', advance='no') '1 resonance, '
	case default
	write (u, '(1x,I0,1x,A)', advance='no') &
	cascade%n_resonances, 'resonances, '
	end select
	write (u, '(1x,I0,1x,A)', advance='no') &
	cascade%n_log_enhanced, 'logs, '
	write (u, '(1x,I0,1x,A)', advance='no') &
	cascade%n_off_shell, 'off-shell, '
	select case (cascade%n_t_channel)
	case (0); write (u, '(1x,A)') 's-channel graph'
	case (1); write (u, '(1x,A)') '1 t-channel line'
	case default
	write(u,'(1x,I0,1x,A)') &
	cascade%n_t_channel, 't-channel lines'
	end select
	write (u, '(1x,A,I0)') 'grove #', grove
	end if
	count = count + 1
	write (u, "(1x,'!',1x,A,I0)") "Channel #", count
	call cascade_write_file_format (cascade, cascade_set%model, u)
	end if
	end if
	cascade => cascade%next
	end do
	end do
	end subroutine cascade_set_write_file_format

	@ %def cascade_set_write_file_format
	@ This is the graph output format, the driver-file
	<<Cascades: public>>=
	public :: cascade_set_write_graph_format
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_write_graph_format &
	(cascade_set, filename, process_id, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	type(string_t), intent(in) :: filename, process_id
	integer, intent(in), optional :: unit
	end subroutine cascade_set_write_graph_format
	<<Cascades: procedures>>=
	module subroutine cascade_set_write_graph_format &
	(cascade_set, filename, process_id, unit)
	type(cascade_set_t), intent(in), target :: cascade_set
	type(string_t), intent(in) :: filename, process_id
	integer, intent(in), optional :: unit
	type(cascade_t), pointer :: cascade
	integer :: u, grove, count, pgcount
	logical :: first_in_grove
	u = given_output_unit (unit); if (u < 0) return
	write (u, '(A)') "\documentclass[10pt]{article}"
	write (u, '(A)') "\usepackage{amsmath}"
	write (u, '(A)') "\usepackage{feynmp}"
	write (u, '(A)') "\usepackage{url}"
	write (u, '(A)') "\usepackage{color}"
	write (u, *)
	write (u, '(A)') "\textwidth 18.5cm"
	write (u, '(A)') "\evensidemargin -1.5cm"
	write (u, '(A)') "\oddsidemargin -1.5cm"
	write (u, *)
	write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
	write (u, '(A)') "\newcommand{\green}{\color{green}}"
	write (u, '(A)') "\newcommand{\red}{\color{red}}"
	write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
	write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
	write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
	write (u, '(A)') "\setlength{\parindent}{0pt}"
	write (u, '(A)') "\setlength{\parsep}{20pt}"
	write (u, *)
	write (u, '(A)') "\begin{document}"
	write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
	write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
	write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
	write (u, '(A)') "\begin{fmfshrink}{0.5}"
	write (u, '(A)') "\begin{flushleft}"
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
	& "\hfill\today"
	write (u, *)
	write (u, '(A)') "\vspace{10pt}"
	write (u, '(A)') "\noindent" // &
	& "\textbf{Process:} \url{" // char (process_id) // "}"
	call cascade_set_write_process_tex_format (cascade_set, u)
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{Note:} These are pseudo Feynman graphs that "
	write (u, '(A)') "visualize phase-space parameterizations " // &
	& "(``integration channels''). "
	write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
	& "matrix element."
	write (u, *)
	write (u, '(A)') "\textbf{Color code:} " // &
	& "{\blue resonance,} " // &
	& "{\cyan t-channel,} " // &
	& "{\green radiation,} "
	write (u, '(A)') "{\red infrared,} " // &
	& "{\magenta collinear,} " // &
	& "external/off-shell"
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{Black square:} Keystone, indicates ordering of " // &
	& "phase space parameters."
	write (u, *)
	write (u, '(A)') "\vspace{-20pt}"
	count = 0
	pgcount = 0
	do grove = 1, cascade_set%n_groves
	first_in_grove = .true.
	cascade => cascade_set%first
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	if (cascade%grove == grove) then
	if (first_in_grove) then
	first_in_grove = .false.
	write (u, *)
	write (u, '(A)') "\vspace{20pt}"
	write (u, '(A)') "\begin{tabular}{l}"
	write (u, '(A,I5,A)') &
	& "\fbox{\bf Grove \boldmath$", grove, "$} \\[10pt]"
	write (u, '(A,I1,A)') "Multiplicity: ", &
	cascade%multiplicity, "\\"
	write (u, '(A,I1,A)') "Resonances: ", &
	cascade%n_resonances, "\\"
	write (u, '(A,I1,A)') "Log-enhanced: ", &
	cascade%n_log_enhanced, "\\"
	write (u, '(A,I1,A)') "Off-shell: ", &
	cascade%n_off_shell, "\\"
	write (u, '(A,I1,A)') "t-channel: ", &
	cascade%n_t_channel, ""
	write (u, '(A)') "\end{tabular}"
	end if
	count = count + 1
	call cascade_write_graph_format (cascade, count, unit)
	if (pgcount >= 250) then
	write (u, '(A)') "\clearpage"
	pgcount = 0
	end if
	end if
	end if
	cascade => cascade%next
	end do
	end do
	write (u, '(A)') "\end{flushleft}"
	write (u, '(A)') "\end{fmfshrink}"
	write (u, '(A)') "\end{fmffile}"
	write (u, '(A)') "\end{document}"
	end subroutine cascade_set_write_graph_format

	@ %def cascade_set_write_graph_format
	@ This is for screen output and debugging:
	<<Cascades: public>>=
	public :: cascade_set_write
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_write &
	(cascade_set, unit, active_only, complete_only)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: active_only, complete_only
	end subroutine cascade_set_write
	<<Cascades: procedures>>=
	module subroutine cascade_set_write &
	(cascade_set, unit, active_only, complete_only)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: active_only, complete_only
	logical :: active, complete
	type(cascade_t), pointer :: cascade
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	active = .true.; if (present (active_only)) active = active_only
	complete = .false.; if (present (complete_only)) complete = complete_only
	write (u, "(A)") "Cascade set:"
	write (u, "(3x,A)", advance="no") "Model:"
	if (associated (cascade_set%model)) then
	write (u, "(1x,A)") char (cascade_set%model%get_name ())
	else
	write (u, "(1x,A)") "[none]"
	end if
	write (u, "(3x,A)", advance="no") "n_in/out/tot ="
	write (u, "(3(1x,I7))") &
	cascade_set%n_in, cascade_set%n_out, cascade_set%n_tot
	write (u, "(3x,A)", advance="no") "depth_out/tot ="
	write (u, "(2(1x,I7))") cascade_set%depth_out, cascade_set%depth_tot
	write (u, "(3x,A)", advance="no") "mass thr(s/t) ="
	write (u, "(2(1x," // FMT_19 // "))") &
	cascade_set%m_threshold_s, cascade_set%m_threshold_t
	write (u, "(3x,A)", advance="no") "off shell ="
	write (u, "(1x,I7)") cascade_set%off_shell
	write (u, "(3x,A)", advance="no") "keep_nonreson ="
	write (u, "(1x,L1)") cascade_set%keep_nonresonant
	write (u, "(3x,A)", advance="no") "n_groves ="
	write (u, "(1x,I7)") cascade_set%n_groves
	write (u, "(A)")
	write (u, "(A)") "Cascade list:"
	if (associated (cascade_set%first)) then
	cascade => cascade_set%first
	do while (associated (cascade))
	if (active .and. .not. cascade%active) cycle
	if (complete .and. .not. cascade%complete) cycle
	call cascade_write (cascade, unit)
	cascade => cascade%next
	end do
	else
	write (u, "(A)") "[empty]"
	end if
	write (u, "(A)") "Hash array"
	write (u, "(3x,A)", advance="no") "n_entries ="
	write (u, "(1x,I7)") cascade_set%n_entries
	write (u, "(3x,A)", advance="no") "fill_ratio ="
	write (u, "(1x," // FMT_12 // ")") cascade_set%fill_ratio
	write (u, "(3x,A)", advance="no") "n_entries_max ="
	write (u, "(1x,I7)") cascade_set%n_entries_max
	write (u, "(3x,A)", advance="no") "mask ="
	write (u, "(1x,I0)") cascade_set%mask
	do i = 0, ubound (cascade_set%entry, 1)
	if (allocated (cascade_set%entry(i)%key)) then
	write (u, "(1x,I7)") i
	call hash_entry_write (cascade_set%entry(i), u)
	end if
	end do
	end subroutine cascade_set_write

	@ %def cascade_set_write
	@
	\subsection{Adding cascades}
	Add a deep copy of a cascade to the set. The copy has all content of the
	original, but the pointers are nullified. We do not care whether insertion
	was successful or not. The pointer argument, if present, is assigned to the
	input cascade, or to the hash entry if it is already present.

	The procedure is recursive: any daughter or mother entries are also
	deep-copied and added to the cascade set before the current copy is added.
	<<Cascades: procedures>>=
	recursive subroutine cascade_set_add_copy &
	(cascade_set, cascade_in, cascade_ptr)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in) :: cascade_in
	type(cascade_t), optional, pointer :: cascade_ptr
	type(cascade_t), pointer :: cascade
	logical :: ok
	allocate (cascade)
	cascade = cascade_in
	if (associated (cascade_in%daughter1)) call cascade_set_add_copy &
	(cascade_set, cascade_in%daughter1, cascade%daughter1)
	if (associated (cascade_in%daughter2)) call cascade_set_add_copy &
	(cascade_set, cascade_in%daughter2, cascade%daughter2)
	if (associated (cascade_in%mother)) call cascade_set_add_copy &
	(cascade_set, cascade_in%mother, cascade%mother)
	cascade%next => null ()
	call cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
	if (.not. ok) deallocate (cascade)
	end subroutine cascade_set_add_copy

	@ %def cascade_set_add_copy
	@ Add a cascade to the set. This does not deep-copy. We first try to insert
	it in the hash array. If successful, add it to the list. Failure indicates
	that it is already present, and we drop it.

	The hash key is built solely from the tree array, so neither particle
	codes nor resonances count, just topology.

	Technically, hash and list receive only pointers, so the cascade can
	be considered as being in either of both. We treat it as part of the
	list.
	<<Cascades: procedures>>=
	subroutine cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade
	logical, intent(out) :: ok
	type(cascade_t), optional, pointer :: cascade_ptr
	integer(i8), dimension(1) :: mold
	call cascade_set_hash_insert &
	(cascade_set, transfer (cascade%tree, mold), cascade, ok, cascade_ptr)
	if (ok) call cascade_set_list_add (cascade_set, cascade)
	end subroutine cascade_set_add

	@ %def cascade_set_add
	@ Add a new cascade to the list:
	<<Cascades: procedures>>=
	subroutine cascade_set_list_add (cascade_set, cascade)
	type(cascade_set_t), intent(inout) :: cascade_set
	type(cascade_t), intent(in), target :: cascade
	if (associated (cascade_set%last)) then
	cascade_set%last%next => cascade
	else
	cascade_set%first => cascade
	end if
	cascade_set%last => cascade
	end subroutine cascade_set_list_add

	@ %def cascade_set_list_add
	@ Add a cascade entry to the hash array:
	<<Cascades: procedures>>=
	subroutine cascade_set_hash_insert &
	(cascade_set, key, cascade, ok, cascade_ptr)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer(i8), dimension(:), intent(in) :: key
	type(cascade_t), intent(in), target :: cascade
	logical, intent(out) :: ok
	type(cascade_t), optional, pointer :: cascade_ptr
	integer(i32) :: h
	if (cascade_set%n_entries >= cascade_set%n_entries_max) &
	call cascade_set_hash_expand (cascade_set)
	h = hash (key)
	call cascade_set_hash_insert_rec &
	(cascade_set, h, h, key, cascade, ok, cascade_ptr)
	end subroutine cascade_set_hash_insert

	@ %def cascade_set_hash_insert
	@ Double the hashtable size when necesssary:
	<<Cascades: procedures>>=
	subroutine cascade_set_hash_expand (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(hash_entry_t), dimension(:), allocatable, target :: table_tmp
	type(cascade_p), pointer :: current
	integer :: i, s
	allocate (table_tmp (0:cascade_set%mask))
	table_tmp = cascade_set%entry
	deallocate (cascade_set%entry)
	s = 2 * size (table_tmp)
	cascade_set%n_entries = 0
	cascade_set%n_entries_max = s * cascade_set%fill_ratio
	cascade_set%mask = s - 1
	allocate (cascade_set%entry (0:cascade_set%mask))
	do i = 0, ubound (table_tmp, 1)
	current => table_tmp(i)%first
	do while (associated (current))
	call cascade_set_hash_insert_rec &
	(cascade_set, table_tmp(i)%hashval, table_tmp(i)%hashval, &
	table_tmp(i)%key, current%cascade)
	current => current%next
	end do
	end do
	end subroutine cascade_set_hash_expand

	@ %def cascade_set_hash_expand
	@ Insert the cascade at the bucket determined by the hash value. If
	the bucket is filled, check first for a collision (unequal keys). In
	that case, choose the following bucket and repeat. Otherwise, add the
	cascade to the bucket.

	If the bucket is empty, record the hash value, allocate and store the
	key, and then add the cascade to the bucket.

	If [[ok]] is present, before insertion we check whether the cascade is
	already stored, and return failure if yes.
	<<Cascades: procedures>>=
	recursive subroutine cascade_set_hash_insert_rec &
	(cascade_set, h, hashval, key, cascade, ok, cascade_ptr)
	type(cascade_set_t), intent(inout) :: cascade_set
	integer(i32), intent(in) :: h, hashval
	integer(i8), dimension(:), intent(in) :: key
	type(cascade_t), intent(in), target :: cascade
	logical, intent(out), optional :: ok
	type(cascade_t), optional, pointer :: cascade_ptr
	integer(i32) :: i
	i = iand (h, cascade_set%mask)
	if (allocated (cascade_set%entry(i)%key)) then
	if (size (cascade_set%entry(i)%key) /= size (key)) then
	call cascade_set_hash_insert_rec &
	(cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
	else if (any (cascade_set%entry(i)%key /= key)) then
	call cascade_set_hash_insert_rec &
	(cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
	else
	call hash_entry_add_cascade_ptr &
	(cascade_set%entry(i), cascade, ok, cascade_ptr)
	end if
	else
	cascade_set%entry(i)%hashval = hashval
	allocate (cascade_set%entry(i)%key (size (key)))
	cascade_set%entry(i)%key = key
	call hash_entry_add_cascade_ptr &
	(cascade_set%entry(i), cascade, ok, cascade_ptr)
	cascade_set%n_entries = cascade_set%n_entries + 1
	end if
	end subroutine cascade_set_hash_insert_rec

	@ %def cascade_set_hash_insert_rec
	@
	\subsection{External particles}
	We want to initialize the cascade set with the outgoing particles. In
	case of multiple processes, initial cascades are prepared for all of
	them. The hash array check ensures that no particle appears more than
	once at the same place.
	<<Cascades: interfaces>>=
	interface cascade_set_add_outgoing
	module procedure cascade_set_add_outgoing1
	module procedure cascade_set_add_outgoing2
	end interface

	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_add_outgoing1 (cascade_set, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(flavor_t), dimension(:), intent(in) :: flv
	end subroutine cascade_set_add_outgoing1
	module subroutine cascade_set_add_outgoing2 (cascade_set, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(flavor_t), dimension(:,:), intent(in) :: flv
	end subroutine cascade_set_add_outgoing2
	<<Cascades: procedures>>=
	module subroutine cascade_set_add_outgoing2 (cascade_set, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(flavor_t), dimension(:,:), intent(in) :: flv
	integer :: pos, prc, n_out, n_prc
	type(cascade_t), pointer :: cascade
	logical :: ok
	n_out = size (flv, dim=1)
	n_prc = size (flv, dim=2)
	do prc = 1, n_prc
	do pos = 1, n_out
	allocate (cascade)
	call cascade_init_outgoing &
	(cascade, flv(pos,prc), pos, cascade_set%m_threshold_s)
	call cascade_set_add (cascade_set, cascade, ok)
	if (.not. ok) then
	deallocate (cascade)
	end if
	end do
	end do
	end subroutine cascade_set_add_outgoing2

	module subroutine cascade_set_add_outgoing1 (cascade_set, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(flavor_t), dimension(:), intent(in) :: flv
	integer :: pos, n_out
	type(cascade_t), pointer :: cascade
	logical :: ok
	n_out = size (flv, dim=1)
	do pos = 1, n_out
	allocate (cascade)
	call cascade_init_outgoing &
	(cascade, flv(pos), pos, cascade_set%m_threshold_s)
	call cascade_set_add (cascade_set, cascade, ok)
	if (.not. ok) then
	deallocate (cascade)
	end if
	end do
	end subroutine cascade_set_add_outgoing1

	@ %def cascade_set_add_outgoing
	@ The incoming particles are added one at a time. Nevertheless, we
	may have several processes which are looped over. At the first
	opportunity, we set the pointer [[first_t]] in the cascade set which
	should point to the first t-channel cascade.

	Return the indices of the first and last cascade generated.
	<<Cascades: interfaces>>=
	interface cascade_set_add_incoming
	module procedure cascade_set_add_incoming0
	module procedure cascade_set_add_incoming1
	end interface

	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(out) :: n1, n2
	integer, intent(in) :: pos
	type(flavor_t), dimension(:), intent(in) :: flv
	end subroutine cascade_set_add_incoming1
	module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(out) :: n1, n2
	integer, intent(in) :: pos
	type(flavor_t), intent(in) :: flv
	end subroutine cascade_set_add_incoming0
	<<Cascades: procedures>>=
	module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(out) :: n1, n2
	integer, intent(in) :: pos
	type(flavor_t), dimension(:), intent(in) :: flv
	integer :: prc, n_prc
	type(cascade_t), pointer :: cascade
	logical :: ok
	n1 = 0
	n2 = 0
	n_prc = size (flv)
	do prc = 1, n_prc
	allocate (cascade)
	call cascade_init_incoming &
	(cascade, flv(prc), pos, cascade_set%m_threshold_t)
	call cascade_set_add (cascade_set, cascade, ok)
	if (ok) then
	if (n1 == 0) n1 = cascade%index
	n2 = cascade%index
	if (.not. associated (cascade_set%first_t)) then
	cascade_set%first_t => cascade
	end if
	else
	deallocate (cascade)
	end if
	end do
	end subroutine cascade_set_add_incoming1

	module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(out) :: n1, n2
	integer, intent(in) :: pos
	type(flavor_t), intent(in) :: flv
	type(cascade_t), pointer :: cascade
	logical :: ok
	n1 = 0
	n2 = 0
	allocate (cascade)
	call cascade_init_incoming &
	(cascade, flv, pos, cascade_set%m_threshold_t)
	call cascade_set_add (cascade_set, cascade, ok)
	if (ok) then
	if (n1 == 0) n1 = cascade%index
	n2 = cascade%index
	if (.not. associated (cascade_set%first_t)) then
	cascade_set%first_t => cascade
	end if
	else
	deallocate (cascade)
	end if
	end subroutine cascade_set_add_incoming0

	@ %def cascade_set_add_incoming
	@
	\subsection{Cascade combination I: flavor assignment}
	We have two disjunct cascades, now use the vertex table to determine
	the possible flavors of the combination cascade. For each
	possibility, try to generate a new cascade. The total cascade depth
	has to be one less than the limit, because this is reached by setting
	the keystone.
	<<Cascades: procedures>>=
	subroutine cascade_match_pair (cascade_set, cascade1, cascade2, s_channel)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2
	logical, intent(in) :: s_channel
	integer, dimension(:), allocatable :: pdg3
	integer :: i, depth_max
	type(flavor_t) :: flv
	if (s_channel) then
	depth_max = cascade_set%depth_out
	else
	depth_max = cascade_set%depth_tot
	end if
	if (cascade1%depth + cascade2%depth < depth_max) then
	call cascade_set%model%match_vertex ( &
	cascade1%flv%get_pdg (), &
	cascade2%flv%get_pdg (), &
	pdg3)
	do i = 1, size (pdg3)
	call flv%init (pdg3(i), cascade_set%model)
	if (s_channel) then
	call cascade_combine_s (cascade_set, cascade1, cascade2, flv)
	else
	call cascade_combine_t (cascade_set, cascade1, cascade2, flv)
	end if
	end do
	deallocate (pdg3)
	end if
	end subroutine cascade_match_pair

	@ %def cascade_match_pair
	@ The triplet version takes a third cascade, and we check whether this
	triplet has a matching vertex in the database. If yes, we make a
	keystone cascade.
	<<Cascades: procedures>>=
	subroutine cascade_match_triplet &
	(cascade_set, cascade1, cascade2, cascade3, s_channel)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
	logical, intent(in) :: s_channel
	integer :: depth_max
	depth_max = cascade_set%depth_tot
	if (cascade1%depth + cascade2%depth + cascade3%depth == depth_max) then
	if (cascade_set%model%check_vertex ( &
	cascade1%flv%get_pdg (), &
	cascade2%flv%get_pdg (), &
	cascade3%flv%get_pdg ())) then
	call cascade_combine_keystone &
	(cascade_set, cascade1, cascade2, cascade3, s_channel)
	end if
	end if
	end subroutine cascade_match_triplet

	@ %def cascade_match_triplet
	@
	\subsection{Cascade combination II: kinematics setup and check}
	Having three matching flavors, we start constructing the combination
	cascade. We look at the mass hierarchies and determine whether the
	cascade is to be kept. In passing we set mapping modes, resonance
	properties and such.

	If successful, the cascade is finalized. For a resonant cascade, we
	prepare in addition a copy without the resonance.
	<<Cascades: procedures>>=
	subroutine cascade_combine_s (cascade_set, cascade1, cascade2, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2
	type(flavor_t), intent(in) :: flv
	type(cascade_t), pointer :: cascade3, cascade4
	real(default) :: width
	logical :: keep
	keep = .false.
	allocate (cascade3)
	call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
	cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
	cascade3%flv = flv%anti ()
	cascade3%pdg = cascade3%flv%get_pdg ()
	cascade3%is_vector = flv%get_spin_type () == VECTOR
	cascade3%m_min = cascade1%m_min + cascade2%m_min
	cascade3%m_rea = flv%get_mass ()
	width = flv%get_width ()
	if (cascade3%m_rea > cascade_set%m_threshold_s) then
	cascade3%m_eff = cascade3%m_rea
	end if
	! Potentially resonant cases [sqrts = m_rea for on-shell decay]
	if (cascade3%m_rea > cascade3%m_min .and. &
	cascade3%m_rea <= cascade_set%sqrts) then
	if (width /= 0) then
	if (cascade1%on_shell .or. cascade2%on_shell) then
	keep = .true.
	cascade3%mapping = S_CHANNEL
	cascade3%resonant = .true.
	end if
	else
	call warn_decay (flv)
	end if
	! Collinear and IR singular cases
	else if (cascade3%m_rea < cascade_set%sqrts) then
	! Massless splitting
	if (cascade1%m_eff == 0 .and. cascade2%m_eff == 0 &
	.and. cascade3%depth <= 3) then
	keep = .true.
	cascade3%log_enhanced = .true.
	if (cascade3%is_vector) then
	if (cascade1%is_vector .and. cascade2%is_vector) then
	cascade3%mapping = COLLINEAR ! three-vector-vertex
	else
	cascade3%mapping = INFRARED ! vector splitting into matter
	end if
	else
	if (cascade1%is_vector .or. cascade2%is_vector) then
	cascade3%mapping = COLLINEAR ! vector radiation off matter
	else
	cascade3%mapping = INFRARED ! scalar radiation/splitting
	end if
	end if
	! IR radiation off massive particle
	else if (cascade3%m_eff > 0 .and. cascade1%m_eff > 0 &
	.and. cascade2%m_eff == 0 &
	.and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
	.and. abs (cascade3%m_eff - cascade1%m_eff) &
	< cascade_set%m_threshold_s) &
	then
	keep = .true.
	cascade3%log_enhanced = .true.
	cascade3%mapping = RADIATION
	else if (cascade3%m_eff > 0 .and. cascade2%m_eff > 0 &
	.and. cascade1%m_eff == 0 &
	.and. (cascade2%on_shell .or. cascade2%mapping == RADIATION) &
	.and. abs (cascade3%m_eff - cascade2%m_eff) &
	< cascade_set%m_threshold_s) &
	then
	keep = .true.
	cascade3%log_enhanced = .true.
	cascade3%mapping = RADIATION
	end if
	end if
	! Non-singular cases, including failed resonances
	if (.not. keep) then
	! Two on-shell particles from a virtual mother
	if (cascade1%on_shell .or. cascade2%on_shell) then
	keep = .true.
	cascade3%m_eff = max (cascade3%m_min, &
	cascade1%m_eff + cascade2%m_eff)
	if (cascade3%m_eff < cascade_set%m_threshold_s) then
	cascade3%m_eff = 0
	end if
	end if
	end if
	! Complete and register the cascade (two in case of resonance)
	if (keep) then
	cascade3%on_shell = cascade3%resonant .or. cascade3%log_enhanced
	if (cascade3%resonant) then
	cascade3%pdg = cascade3%flv%get_pdg ()
	if (cascade_set%keep_nonresonant) then
	allocate (cascade4)
	cascade4 = cascade3
	cascade4%index = cascade_index ()
	cascade4%pdg = UNDEFINED
	cascade4%mapping = NO_MAPPING
	cascade4%resonant = .false.
	cascade4%on_shell = .false.
	end if
	cascade3%m_min = cascade3%m_rea
	call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
	if (cascade_set%keep_nonresonant) then
	call cascade_fusion (cascade_set, cascade1, cascade2, cascade4)
	end if
	else
	call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
	end if
	else
	deallocate (cascade3)
	end if
	contains
	subroutine warn_decay (flv)
	type(flavor_t), intent(in) :: flv
	integer :: i
	integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
	LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
	if (warned_code(i) == 0) then
	warned_code(i) = flv%get_pdg ()
	write (msg_buffer, "(A)") &
	& " Intermediate decay of zero-width particle " &
	& // char (flv%get_name ()) &
	& // " may be possible."
	call msg_warning
	exit LOOP_WARNED
	else if (warned_code(i) == flv%get_pdg ()) then
	exit LOOP_WARNED
	end if
	end do LOOP_WARNED
	end subroutine warn_decay
	end subroutine cascade_combine_s

	@ %def cascade_combine_s
	<<Cascades: parameters>>=
	integer, parameter, public :: MAX_WARN_RESONANCE = 50
	@ %def MAX_WARN_RESONANCE
	@ This is the t-channel version. [[cascade1]] is t-channel and
	contains the seed, [[cascade2]] is s-channel. We check for
	kinematically allowed beam decay (which is a fatal error), or massless
	splitting / soft radiation. The cascade is kept in all remaining
	cases and submitted for registration.
	<<Cascades: procedures>>=
	subroutine cascade_combine_t (cascade_set, cascade1, cascade2, flv)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2
	type(flavor_t), intent(in) :: flv
	type(cascade_t), pointer :: cascade3
	allocate (cascade3)
	call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
	cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
	cascade3%flv = flv%anti ()
	cascade3%pdg = abs (cascade3%flv%get_pdg ())
	cascade3%is_vector = flv%get_spin_type () == VECTOR
	if (cascade1%incoming) then
	cascade3%m_min = cascade2%m_min
	else
	cascade3%m_min = cascade1%m_min + cascade2%m_min
	end if
	cascade3%m_rea = flv%get_mass ()
	if (cascade3%m_rea > cascade_set%m_threshold_t) then
	cascade3%m_eff = max (cascade3%m_rea, cascade2%m_eff)
	else if (cascade2%m_eff > cascade_set%m_threshold_t) then
	cascade3%m_eff = cascade2%m_eff
	else
	cascade3%m_eff = 0
	end if
	! Allowed decay of beam particle
	if (cascade1%incoming &
	.and. cascade1%m_rea > cascade2%m_rea + cascade3%m_rea) then
	call beam_decay (cascade_set%fatal_beam_decay)
	! Massless splitting
	else if (cascade1%m_eff == 0 &
	.and. cascade2%m_eff < cascade_set%m_threshold_t &
	.and. cascade3%m_eff == 0) then
	cascade3%mapping = U_CHANNEL
	cascade3%log_enhanced = .true.
	! IR radiation off massive particle
	else if (cascade1%m_eff /= 0 .and. cascade2%m_eff == 0 &
	.and. cascade3%m_eff /= 0 &
	.and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
	.and. abs (cascade1%m_eff - cascade3%m_eff) &
	< cascade_set%m_threshold_t) &
	then
	cascade3%pdg = flv%get_pdg ()
	cascade3%log_enhanced = .true.
	cascade3%mapping = RADIATION
	end if
	cascade3%t_channel = .true.
	call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
	contains
	subroutine beam_decay (fatal_beam_decay)
	logical, intent(in) :: fatal_beam_decay
	write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
	char (cascade1%flv%get_name ()), &
	char (cascade3%flv%get_name ()), &
	char (cascade2%flv%get_name ())
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	char (cascade1%flv%get_name ()), cascade1%m_rea
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	char (cascade3%flv%get_name ()), cascade3%m_rea
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	char (cascade2%flv%get_name ()), cascade2%m_rea
	call msg_message
	if (fatal_beam_decay) then
	call msg_fatal (" Phase space: Initial beam particle can decay")
	else
	call msg_warning (" Phase space: Initial beam particle can decay")
	end if
	end subroutine beam_decay
	end subroutine cascade_combine_t

	@ %def cascade_combine_t
	@ Here we complete a decay cascade. The third input is the
	single-particle cascade for the initial particle. There is no
	resonance or mapping assignment. The only condition for keeping the
	cascade is the mass sum of the final state, which must be less than
	the available energy.

	Two modifications are necessary for scattering cascades: a pure
	s-channel diagram (cascade1 is the incoming particle) do not have a
	logarithmic mapping at top-level. And in a t-channel diagram, the
	last line exchanged is mapped t-channel, not u-channel. Finally, we
	can encounter the case of a $2\to 1$ process, where cascade1 is
	incoming, and cascade2 is the outgoing particle. In all three cases
	we register a new cascade with the modified mapping.
	<<Cascades: procedures>>=
	subroutine cascade_combine_keystone &
	(cascade_set, cascade1, cascade2, cascade3, s_channel)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
	logical, intent(in) :: s_channel
	type(cascade_t), pointer :: cascade4, cascade0
	logical :: keep, ok
	keep = .false.
	allocate (cascade4)
	call cascade_init &
	(cascade4, cascade1%depth + cascade2%depth + cascade3%depth)
	cascade4%complete = .true.
	if (s_channel) then
	cascade4%bincode = ior (cascade1%bincode, cascade2%bincode)
	else
	cascade4%bincode = cascade3%bincode
	end if
	cascade4%flv = cascade3%flv
	cascade4%pdg = cascade3%pdg
	cascade4%mapping = EXTERNAL_PRT
	cascade4%is_vector = cascade3%is_vector
	cascade4%m_min = cascade1%m_min + cascade2%m_min
	cascade4%m_rea = cascade3%m_rea
	cascade4%m_eff = cascade3%m_rea
	if (cascade4%m_min < cascade_set%sqrts) then
	keep = .true.
	end if
	if (keep) then
	if (cascade1%incoming .and. cascade2%log_enhanced) then
	allocate (cascade0)
	cascade0 = cascade2
	cascade0%next => null ()
	cascade0%index = cascade_index ()
	cascade0%mapping = NO_MAPPING
	cascade0%log_enhanced = .false.
	cascade0%n_log_enhanced = cascade0%n_log_enhanced - 1
	cascade0%tree_mapping(cascade0%depth) = NO_MAPPING
	call cascade_keystone &
	(cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
	if (ok) then
	call cascade_set_add (cascade_set, cascade0, ok)
	else
	deallocate (cascade0)
	end if
	else if (cascade1%t_channel .and. cascade1%mapping == U_CHANNEL) then
	allocate (cascade0)
	cascade0 = cascade1
	cascade0%next => null ()
	cascade0%index = cascade_index ()
	cascade0%mapping = T_CHANNEL
	cascade0%tree_mapping(cascade0%depth) = T_CHANNEL
	call cascade_keystone &
	(cascade_set, cascade0, cascade2, cascade3, cascade4, ok)
	if (ok) then
	call cascade_set_add (cascade_set, cascade0, ok)
	else
	deallocate (cascade0)
	end if
	else if (cascade1%incoming .and. cascade2%depth == 1) then
	allocate (cascade0)
	cascade0 = cascade2
	cascade0%next => null ()
	cascade0%index = cascade_index ()
	cascade0%mapping = ON_SHELL
	cascade0%tree_mapping(cascade0%depth) = ON_SHELL
	call cascade_keystone &
	(cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
	if (ok) then
	call cascade_set_add (cascade_set, cascade0, ok)
	else
	deallocate (cascade0)
	end if
	else
	call cascade_keystone &
	(cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
	end if
	else
	deallocate (cascade4)
	end if
	end subroutine cascade_combine_keystone

	@ %def cascade_combine_keystone
	@
	\subsection{Cascade combination III: node connections and tree fusion}
	Here we assign global tree properties. If the allowed number of
	off-shell lines is exceeded, discard the new cascade. Otherwise,
	assign the trees, sort them, and assign connections. Finally, append
	the cascade to the list. This may fail (because in the hash array
	there is already an equivalent cascade). On failure, discard the
	cascade.
	<<Cascades: procedures>>=
	subroutine cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2
	type(cascade_t), pointer :: cascade3
	integer :: i1, i2, i3, i4
	logical :: ok
	cascade3%internal = (cascade3%depth - 3) / 2
	if (cascade3%resonant) then
	cascade3%multiplicity = 1
	cascade3%n_resonances = &
	cascade1%n_resonances + cascade2%n_resonances + 1
	else
	cascade3%multiplicity = cascade1%multiplicity + cascade2%multiplicity
	cascade3%n_resonances = cascade1%n_resonances + cascade2%n_resonances
	end if
	if (cascade3%log_enhanced) then
	cascade3%n_log_enhanced = &
	cascade1%n_log_enhanced + cascade2%n_log_enhanced + 1
	else
	cascade3%n_log_enhanced = &
	cascade1%n_log_enhanced + cascade2%n_log_enhanced
	end if
	if (cascade3%resonant) then
	cascade3%n_off_shell = 0
	else if (cascade3%log_enhanced) then
	cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
	else
	cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell + 1
	end if
	if (cascade3%t_channel) then
	cascade3%n_t_channel = cascade1%n_t_channel + 1
	end if
	if (cascade3%n_off_shell > cascade_set%off_shell) then
	deallocate (cascade3)
	else if (cascade3%n_t_channel > cascade_set%t_channel) then
	deallocate (cascade3)
	else
	i1 = cascade1%depth
	i2 = i1 + 1
	i3 = i1 + cascade2%depth
	i4 = cascade3%depth
	cascade3%tree(:i1) = cascade1%tree
	where (cascade1%tree_mapping > NO_MAPPING)
	cascade3%tree_pdg(:i1) = cascade1%tree_pdg
	elsewhere
	cascade3%tree_pdg(:i1) = UNDEFINED
	end where
	cascade3%tree_mapping(:i1) = cascade1%tree_mapping
	cascade3%tree_resonant(:i1) = cascade1%tree_resonant
	cascade3%tree(i2:i3) = cascade2%tree
	where (cascade2%tree_mapping > NO_MAPPING)
	cascade3%tree_pdg(i2:i3) = cascade2%tree_pdg
	elsewhere
	cascade3%tree_pdg(i2:i3) = UNDEFINED
	end where
	cascade3%tree_mapping(i2:i3) = cascade2%tree_mapping
	cascade3%tree_resonant(i2:i3) = cascade2%tree_resonant
	cascade3%tree(i4) = cascade3%bincode
	cascade3%tree_pdg(i4) = cascade3%pdg
	cascade3%tree_mapping(i4) = cascade3%mapping
	cascade3%tree_resonant(i4) = cascade3%resonant
	call tree_sort (cascade3%tree, &
	cascade3%tree_pdg, cascade3%tree_mapping, cascade3%tree_resonant)
	cascade3%has_children = .true.
	cascade3%daughter1 => cascade1
	cascade3%daughter2 => cascade2
	call cascade_set_add (cascade_set, cascade3, ok)
	if (.not. ok) deallocate (cascade3)
	end if
	end subroutine cascade_fusion

	@ %def cascade_fusion
	@ Here we combine a cascade pair with an incoming particle, i.e., we
	set a keystone. Otherwise, this is similar. On the first
	opportunity, we set the [[first_k]] pointer in the cascade set.
	<<Cascades: procedures>>=
	subroutine cascade_keystone &
	(cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
	type(cascade_t), pointer :: cascade4
	logical, intent(out) :: ok
	integer :: i1, i2, i3, i4
	cascade4%internal = (cascade4%depth - 3) / 2
	cascade4%multiplicity = cascade1%multiplicity + cascade2%multiplicity
	cascade4%n_resonances = cascade1%n_resonances + cascade2%n_resonances
	cascade4%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
	cascade4%n_log_enhanced = &
	cascade1%n_log_enhanced + cascade2%n_log_enhanced
	cascade4%n_t_channel = cascade1%n_t_channel + cascade2%n_t_channel
	if (cascade4%n_off_shell > cascade_set%off_shell) then
	deallocate (cascade4)
	ok = .false.
	else if (cascade4%n_t_channel > cascade_set%t_channel) then
	deallocate (cascade4)
	ok = .false.
	else
	i1 = cascade1%depth
	i2 = i1 + 1
	i3 = i1 + cascade2%depth
	i4 = cascade4%depth
	cascade4%tree(:i1) = cascade1%tree
	where (cascade1%tree_mapping > NO_MAPPING)
	cascade4%tree_pdg(:i1) = cascade1%tree_pdg
	elsewhere
	cascade4%tree_pdg(:i1) = UNDEFINED
	end where
	cascade4%tree_mapping(:i1) = cascade1%tree_mapping
	cascade4%tree_resonant(:i1) = cascade1%tree_resonant
	cascade4%tree(i2:i3) = cascade2%tree
	where (cascade2%tree_mapping > NO_MAPPING)
	cascade4%tree_pdg(i2:i3) = cascade2%tree_pdg
	elsewhere
	cascade4%tree_pdg(i2:i3) = UNDEFINED
	end where
	cascade4%tree_mapping(i2:i3) = cascade2%tree_mapping
	cascade4%tree_resonant(i2:i3) = cascade2%tree_resonant
	cascade4%tree(i4) = cascade4%bincode
	cascade4%tree_pdg(i4) = UNDEFINED
	cascade4%tree_mapping(i4) = cascade4%mapping
	cascade4%tree_resonant(i4) = .false.
	call tree_sort (cascade4%tree, &
	cascade4%tree_pdg, cascade4%tree_mapping, cascade4%tree_resonant)
	cascade4%has_children = .true.
	cascade4%daughter1 => cascade1
	cascade4%daughter2 => cascade2
	cascade4%mother => cascade3
	call cascade_set_add (cascade_set, cascade4, ok)
	if (ok) then
	if (.not. associated (cascade_set%first_k)) then
	cascade_set%first_k => cascade4
	end if
	else
	deallocate (cascade4)
	end if
	end if
	end subroutine cascade_keystone

	@ %def cascade_keystone
	@
	Sort a tree (array of binary codes) and particle code array
	simultaneously, by ascending binary codes. A convenient method is to
	use the [[maxloc]] function iteratively, to find and remove the
	largest entry in the tree array one by one.
	<<Cascades: procedures>>=
	subroutine tree_sort (tree, pdg, mapping, resonant)
	integer(TC), dimension(:), intent(inout) :: tree
	integer, dimension(:), intent(inout) :: pdg, mapping
	logical, dimension(:), intent(inout) :: resonant
	integer(TC), dimension(size(tree)) :: tree_tmp
	integer, dimension(size(pdg)) :: pdg_tmp, mapping_tmp
	logical, dimension(size(resonant)) :: resonant_tmp
	integer, dimension(1) :: pos
	integer :: i
	tree_tmp = tree
	pdg_tmp = pdg
	mapping_tmp = mapping
	resonant_tmp = resonant
	do i = size(tree),1,-1
	pos = maxloc (tree_tmp)
	tree(i) = tree_tmp (pos(1))
	pdg(i) = pdg_tmp (pos(1))
	mapping(i) = mapping_tmp (pos(1))
	resonant(i) = resonant_tmp (pos(1))
	tree_tmp(pos(1)) = 0
	end do
	end subroutine tree_sort

	@ %def tree_sort
	@
	\subsection{Cascade set generation}
	These procedures loop over cascades and build up the cascade set. After each
	iteration of the innermost loop, we set a breakpoint.

	s-channel: We use a nested scan to combine all cascades with all other
	cascades.
	<<Cascades: procedures>>=
	subroutine cascade_set_generate_s (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), pointer :: cascade1, cascade2
	cascade1 => cascade_set%first
	LOOP1: do while (associated (cascade1))
	cascade2 => cascade_set%first
	LOOP2: do while (associated (cascade2))
	if (cascade2%index >= cascade1%index) exit LOOP2
	if (cascade1 .disjunct. cascade2) then
	call cascade_match_pair (cascade_set, cascade1, cascade2, .true.)
	end if
	call terminate_now_if_signal ()
	cascade2 => cascade2%next
	end do LOOP2
	cascade1 => cascade1%next
	end do LOOP1
	end subroutine cascade_set_generate_s

	@ %def cascade_set_generate_s
	@ The t-channel cascades are directed and have a seed (one of the
	incoming particles) and a target (the other one). We loop over all
	possible seeds and targets. Inside this, we loop over all t-channel
	cascades ([[cascade1]]) and s-channel cascades ([[cascade2]]) and try
	to combine them.
	<<Cascades: procedures>>=
	subroutine cascade_set_generate_t (cascade_set, pos_seed, pos_target)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(in) :: pos_seed, pos_target
	type(cascade_t), pointer :: cascade_seed, cascade_target
	type(cascade_t), pointer :: cascade1, cascade2
	integer(TC) :: bc_seed, bc_target
	bc_seed = ibset (0_TC, pos_seed-1)
	bc_target = ibset (0_TC, pos_target-1)
	cascade_seed => cascade_set%first_t
	LOOP_SEED: do while (associated (cascade_seed))
	if (cascade_seed%bincode == bc_seed) then
	cascade_target => cascade_set%first_t
	LOOP_TARGET: do while (associated (cascade_target))
	if (cascade_target%bincode == bc_target) then
	cascade1 => cascade_set%first_t
	LOOP_T: do while (associated (cascade1))
	if ((cascade1 .disjunct. cascade_target) &
	.and. .not. (cascade1 .disjunct. cascade_seed)) then
	cascade2 => cascade_set%first
	LOOP_S: do while (associated (cascade2))
	if ((cascade2 .disjunct. cascade_target) &
	.and. (cascade2 .disjunct. cascade1)) then
	call cascade_match_pair &
	(cascade_set, cascade1, cascade2, .false.)
	end if
	call terminate_now_if_signal ()
	cascade2 => cascade2%next
	end do LOOP_S
	end if
	call terminate_now_if_signal ()
	cascade1 => cascade1%next
	end do LOOP_T
	end if
	call terminate_now_if_signal ()
	cascade_target => cascade_target%next
	end do LOOP_TARGET
	end if
	call terminate_now_if_signal ()
	cascade_seed => cascade_seed%next
	end do LOOP_SEED
	end subroutine cascade_set_generate_t

	@ %def cascade_set_generate_t
	@ This part completes the phase space for decay processes. It is
	similar to s-channel cascade generation, but combines two cascade with
	the particular cascade of the incoming particle. This particular
	cascade is expected to be pointed at by [[first_t]].
	<<Cascades: procedures>>=
	subroutine cascade_set_generate_decay (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), pointer :: cascade1, cascade2
	type(cascade_t), pointer :: cascade_in
	cascade_in => cascade_set%first_t
	cascade1 => cascade_set%first
	do while (associated (cascade1))
	if (cascade1 .disjunct. cascade_in) then
	cascade2 => cascade1%next
	do while (associated (cascade2))
	if ((cascade2 .disjunct. cascade1) &
	.and. (cascade2 .disjunct. cascade_in)) then
	call cascade_match_triplet (cascade_set, &
	cascade1, cascade2, cascade_in, .true.)
	end if
	call terminate_now_if_signal ()
	cascade2 => cascade2%next
	end do
	end if
	call terminate_now_if_signal ()
	cascade1 => cascade1%next
	end do
	end subroutine cascade_set_generate_decay

	@ %def cascade_set_generate_decay
	@ This part completes the phase space for scattering processes. We
	combine a t-channel cascade (containing the seed) with a s-channel
	cascade and the target.
	<<Cascades: procedures>>=
	subroutine cascade_set_generate_scattering &
	(cascade_set, ns1, ns2, nt1, nt2, pos_seed, pos_target)
	type(cascade_set_t), intent(inout), target :: cascade_set
	integer, intent(in) :: pos_seed, pos_target
	integer, intent(in) :: ns1, ns2, nt1, nt2
	type(cascade_t), pointer :: cascade_seed, cascade_target
	type(cascade_t), pointer :: cascade1, cascade2
	integer(TC) :: bc_seed, bc_target
	bc_seed = ibset (0_TC, pos_seed-1)
	bc_target = ibset (0_TC, pos_target-1)
	cascade_seed => cascade_set%first_t
	LOOP_SEED: do while (associated (cascade_seed))
	if (cascade_seed%index < ns1) then
	cascade_seed => cascade_seed%next
	cycle LOOP_SEED
	else if (cascade_seed%index > ns2) then
	exit LOOP_SEED
	else if (cascade_seed%bincode == bc_seed) then
	cascade_target => cascade_set%first_t
	LOOP_TARGET: do while (associated (cascade_target))
	if (cascade_target%index < nt1) then
	cascade_target => cascade_target%next
	cycle LOOP_TARGET
	else if (cascade_target%index > nt2) then
	exit LOOP_TARGET
	else if (cascade_target%bincode == bc_target) then
	cascade1 => cascade_set%first_t
	LOOP_T: do while (associated (cascade1))
	if ((cascade1 .disjunct. cascade_target) &
	.and. .not. (cascade1 .disjunct. cascade_seed)) then
	cascade2 => cascade_set%first
	LOOP_S: do while (associated (cascade2))
	if ((cascade2 .disjunct. cascade_target) &
	.and. (cascade2 .disjunct. cascade1)) then
	call cascade_match_triplet (cascade_set, &
	cascade1, cascade2, cascade_target, .false.)
	end if
	call terminate_now_if_signal ()
	cascade2 => cascade2%next
	end do LOOP_S
	end if
	call terminate_now_if_signal ()
	cascade1 => cascade1%next
	end do LOOP_T
	end if
	call terminate_now_if_signal ()
	cascade_target => cascade_target%next
	end do LOOP_TARGET
	end if
	call terminate_now_if_signal ()
	cascade_seed => cascade_seed%next
	end do LOOP_SEED
	end subroutine cascade_set_generate_scattering

	@ %def cascade_set_generate_scattering
	@
	\subsection{Groves}
	Before assigning groves, assign hashcodes to the resonance patterns, so they
	can easily be compared.
	<<Cascades: procedures>>=
	subroutine cascade_set_assign_resonance_hash (cascade_set)
	type(cascade_set_t), intent(inout) :: cascade_set
	type(cascade_t), pointer :: cascade
	cascade => cascade_set%first_k
	do while (associated (cascade))
	call cascade_assign_resonance_hash (cascade)
	cascade => cascade%next
	end do
	end subroutine cascade_set_assign_resonance_hash

	@ %def cascade_assign_resonance_hash
	@ After all cascades are recorded, we group the complete cascades in
	groves. A grove consists of cascades with identical multiplicity,
	number of resonances, log-enhanced, t-channel lines, and resonance flavors.
	<<Cascades: procedures>>=
	subroutine cascade_set_assign_groves (cascade_set)
	type(cascade_set_t), intent(inout), target :: cascade_set
	type(cascade_t), pointer :: cascade1, cascade2
	integer :: multiplicity
	integer :: n_resonances, n_log_enhanced, n_t_channel, n_off_shell
	integer :: res_hash
	integer :: grove
	grove = 0
	cascade1 => cascade_set%first_k
	do while (associated (cascade1))
	if (cascade1%active .and. cascade1%complete &
	.and. cascade1%grove == 0) then
	grove = grove + 1
	cascade1%grove = grove
	multiplicity = cascade1%multiplicity
	n_resonances = cascade1%n_resonances
	n_log_enhanced = cascade1%n_log_enhanced
	n_off_shell = cascade1%n_off_shell
	n_t_channel = cascade1%n_t_channel
	res_hash = cascade1%res_hash
	cascade2 => cascade1%next
	do while (associated (cascade2))
	if (cascade2%grove == 0) then
	if (cascade2%multiplicity == multiplicity &
	.and. cascade2%n_resonances == n_resonances &
	.and. cascade2%n_log_enhanced == n_log_enhanced &
	.and. cascade2%n_off_shell == n_off_shell &
	.and. cascade2%n_t_channel == n_t_channel &
	.and. cascade2%res_hash == res_hash) then
	cascade2%grove = grove
	end if
	end if
	call terminate_now_if_signal ()
	cascade2 => cascade2%next
	end do
	end if
	call terminate_now_if_signal ()
	cascade1 => cascade1%next
	end do
	cascade_set%n_groves = grove
	end subroutine cascade_set_assign_groves

	@ %def cascade_set_assign_groves
	@
	\subsection{Generate the phase space file}
	Generate a complete phase space configuration.

	For each flavor assignment: First, all s-channel
	graphs that can be built up from the outgoing particles. Then we
	distinguish (1) decay, where we complete the s-channel graphs by
	connecting to the input line, and (2) scattering, where we now
	generate t-channel graphs by introducing an incoming particle, and
	complete this by connecting to the other incoming particle.

	After all cascade sets have been generated, merge them into a common set.
	This eliminates redunancies between flavor assignments.
	<<Cascades: public>>=
	public :: cascade_set_generate
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_generate &
	(cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay)
	type(cascade_set_t), intent(out) :: cascade_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(flavor_t), dimension(:,:), intent(in) :: flv
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	end subroutine cascade_set_generate
	<<Cascades: procedures>>=
	module subroutine cascade_set_generate &
	(cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay)
	type(cascade_set_t), intent(out) :: cascade_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(flavor_t), dimension(:,:), intent(in) :: flv
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	type(cascade_set_t), dimension(:), allocatable :: cset
	type(cascade_t), pointer :: cascade
	integer :: i
	if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return
	call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
	fatal_beam_decay, flv)
	allocate (cset (size (flv, 2)))
	do i = 1, size (cset)
	call cascade_set_generate_single (cset(i), &
	model, n_in, n_out, flv(:,i), phs_par, fatal_beam_decay)
	cascade => cset(i)%first_k
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	call cascade_set_add_copy (cascade_set, cascade)
	end if
	cascade => cascade%next
	end do
	call cascade_set_final (cset(i))
	end do
	cascade_set%first_k => cascade_set%first
	call cascade_set_assign_resonance_hash (cascade_set)
	call cascade_set_assign_groves (cascade_set)
	end subroutine cascade_set_generate

	@ %def cascade_set_generate
	@ This generates phase space for a single channel, without assigning groves.
	<<Cascades: procedures>>=
	subroutine cascade_set_generate_single (cascade_set, &
	model, n_in, n_out, flv, phs_par, fatal_beam_decay)
	type(cascade_set_t), intent(out) :: cascade_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(flavor_t), dimension(:), intent(in) :: flv
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	integer :: n11, n12, n21, n22
	call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
	fatal_beam_decay)
	call cascade_set_add_outgoing (cascade_set, flv(n_in+1:))
	call cascade_set_generate_s (cascade_set)
	select case (n_in)
	case(1)
	call cascade_set_add_incoming &
	(cascade_set, n11, n12, n_out + 1, flv(1))
	call cascade_set_generate_decay (cascade_set)
	case(2)
	call cascade_set_add_incoming &
	(cascade_set, n11, n12, n_out + 1, flv(2))
	call cascade_set_add_incoming &
	(cascade_set, n21, n22, n_out + 2, flv(1))
	call cascade_set_generate_t (cascade_set, n_out + 1, n_out + 2)
	call cascade_set_generate_t (cascade_set, n_out + 2, n_out + 1)
	call cascade_set_generate_scattering &
	(cascade_set, n11, n12, n21, n22, n_out + 1, n_out + 2)
	call cascade_set_generate_scattering &
	(cascade_set, n21, n22, n11, n12, n_out + 2, n_out + 1)
	end select
	end subroutine cascade_set_generate_single

	@ %def cascade_set_generate_single
	@ Sanity check: Before anything else is done, check if there could
	possibly be any phase space.
	<<Cascades: public>>=
	public :: phase_space_vanishes
	<<Cascades: sub interfaces>>=
	module function phase_space_vanishes (sqrts, n_in, flv) result (flag)
	logical :: flag
	real(default), intent(in) :: sqrts
	integer, intent(in) :: n_in
	type(flavor_t), dimension(:,:), intent(in) :: flv
	end function phase_space_vanishes
	<<Cascades: procedures>>=
	module function phase_space_vanishes (sqrts, n_in, flv) result (flag)
	logical :: flag
	real(default), intent(in) :: sqrts
	integer, intent(in) :: n_in
	type(flavor_t), dimension(:,:), intent(in) :: flv
	real(default), dimension(:,:), allocatable :: mass
	real(default), dimension(:), allocatable :: mass_in, mass_out
	integer :: n_prt, n_flv, i, j
	flag = .false.
	if (sqrts <= 0) then
	call msg_error ("Phase space vanishes (sqrts must be positive)")
	flag = .true.; return
	end if
	n_prt = size (flv, 1)
	n_flv = size (flv, 2)
	allocate (mass (n_prt, n_flv), mass_in (n_flv), mass_out (n_flv))
	mass = flv%get_mass ()
	mass_in = sum (mass(:n_in,:), 1)
	mass_out = sum (mass(n_in+1:,:), 1)
	if (any (mass_in > sqrts)) then
	call msg_error ("Mass sum of incoming particles " &
	// "is more than available energy")
	flag = .true.; return
	end if
	if (any (mass_out > sqrts)) then
	call msg_error ("Mass sum of outgoing particles " &
	// "is more than available energy")
	flag = .true.; return
	end if
	end function phase_space_vanishes

	@ %def phase_space_vanishes
	@
	\subsection{Return the resonance histories for subtraction}
	This appears to be essential (re-export of some imported assignment?)!
	<<Cascades: public>>=
	public :: assignment(=)
	@
	Extract the resonance set from a complete cascade.
	<<Cascades: cascade: TBP>>=
	procedure :: extract_resonance_history => cascade_extract_resonance_history
	<<Cascades: sub interfaces>>=
	module subroutine cascade_extract_resonance_history &
	(cascade, res_hist, model, n_out)
	class(cascade_t), intent(in), target :: cascade
	type(resonance_history_t), intent(out) :: res_hist
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_out
	end subroutine cascade_extract_resonance_history
	<<Cascades: procedures>>=
	module subroutine cascade_extract_resonance_history &
	(cascade, res_hist, model, n_out)
	class(cascade_t), intent(in), target :: cascade
	type(resonance_history_t), intent(out) :: res_hist
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_out
	type(resonance_info_t) :: resonance
	integer :: i, mom_id, pdg
	if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade_extract_resonance_history")
	if (cascade%n_resonances > 0) then
	if (cascade%has_children) then
	if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade has resonances and children")
	do i = 1, size(cascade%tree_resonant)
	if (cascade%tree_resonant (i)) then
	mom_id = cascade%tree (i)
	pdg = cascade%tree_pdg (i)
	call resonance%init (mom_id, pdg, model, n_out)
	if (debug2_active (D_PHASESPACE)) then
	print *, 'D: Adding resonance'
	call resonance%write ()
	end if
	call res_hist%add_resonance (resonance)
	end if
	end do
	end if
	end if
	end subroutine cascade_extract_resonance_history

	@ %def cascade_extract_resonance_history
	@
	<<Cascades: public>>=
	public :: cascade_set_get_n_trees
	<<Cascades: sub interfaces>>=
	module function cascade_set_get_n_trees (cascade_set) result (n)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer :: n
	end function cascade_set_get_n_trees
	<<Cascades: procedures>>=
	module function cascade_set_get_n_trees (cascade_set) result (n)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer :: n
	type(cascade_t), pointer :: cascade
	integer :: grove
	if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_n_trees")
	n = 0
	do grove = 1, cascade_set%n_groves
	cascade => cascade_set%first_k
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	if (cascade%grove == grove) then
	n = n + 1
	end if
	end if
	cascade => cascade%next
	end do
	end do
	if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
	end function cascade_set_get_n_trees

	@ %def cascade_set_get_n_trees
	@ Distill the set of resonance histories from the cascade set. The
	result is an array which contains each valid history exactly once.
	<<Cascades: public>>=
	public :: cascade_set_get_resonance_histories
	<<Cascades: sub interfaces>>=
	module subroutine cascade_set_get_resonance_histories &
	(cascade_set, n_filter, res_hists)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: n_filter
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_hists
	end subroutine cascade_set_get_resonance_histories
	<<Cascades: procedures>>=
	module subroutine cascade_set_get_resonance_histories &
	(cascade_set, n_filter, res_hists)
	type(cascade_set_t), intent(in), target :: cascade_set
	integer, intent(in), optional :: n_filter
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_hists
	type(resonance_history_t), dimension(:), allocatable :: tmp
	type(cascade_t), pointer :: cascade
	type(resonance_history_t) :: res_hist
	type(resonance_history_set_t) :: res_hist_set
	integer :: grove, i, n_hists
	logical :: included, add_to_list
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "cascade_set_get_resonance_histories")
	call res_hist_set%init (n_filter = n_filter)
	do grove = 1, cascade_set%n_groves
	cascade => cascade_set%first_k
	do while (associated (cascade))
	if (cascade%active .and. cascade%complete) then
	if (cascade%grove == grove) then
	if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", grove)
	call cascade%extract_resonance_history &
	(res_hist, cascade_set%model, cascade_set%n_out)
	call res_hist_set%enter (res_hist)
	end if
	end if
	cascade => cascade%next
	end do
	end do
	call res_hist_set%freeze ()
	call res_hist_set%to_array (res_hists)
	end subroutine cascade_set_get_resonance_histories

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

	module cascades_ut
	use unit_tests
	use cascades_uti

	<<Standard module head>>

	<<Cascades: public test>>

	contains

	<<Cascades: test driver>>

	end module cascades_ut
	@ %def cascades_ut
	@
	<<[[cascades_uti.f90]]>>=
	<<File header>>

	module cascades_uti

	<<Use kinds>>
	<<Use strings>>
	use numeric_utils
	use flavors
	use model_data
	use phs_forests, only: phs_parameters_t
	use resonances, only: resonance_history_t

	use cascades

	<<Standard module head>>

	<<Cascades: test declarations>>

	contains

	<<Cascades: tests>>

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

	@ %def cascades_test
	\subsubsection{Check cascade setup}
	@ Checking the basic setup up of the phase space cascade parameterizations.
	<<Cascades: execute tests>>=
	call test (cascades_1, "cascades_1", &
	"check cascade setup", &
	u, results)
	<<Cascades: test declarations>>=
	public :: cascades_1
	<<Cascades: tests>>=
	subroutine cascades_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(5,2) :: flv
	type(cascade_set_t) :: cascade_set
	type(phs_parameters_t) :: phs_par

	write (u, "(A)") "* Test output: cascades_1"
	write (u, "(A)") "* Purpose: test cascade phase space functions"
	write (u, "(A)")

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

	call model%init_sm_test ()

	call flv(1,1)%init ( 2, model)
	call flv(2,1)%init (-2, model)
	call flv(3,1)%init ( 1, model)
	call flv(4,1)%init (-1, model)
	call flv(5,1)%init (21, model)
	call flv(1,2)%init ( 2, model)
	call flv(2,2)%init (-2, model)
	call flv(3,2)%init ( 2, model)
	call flv(4,2)%init (-2, model)
	call flv(5,2)%init (21, model)
	phs_par%sqrts = 1000._default
	phs_par%off_shell = 2

	write (u, "(A)")
	write (u, "(A)") "* Generating the cascades"
	write (u, "(A)")

	call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
	call cascade_set_write (cascade_set, u)
	call cascade_set_write_file_format (cascade_set, u)

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

	call cascade_set_final (cascade_set)
	call model%final ()

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

	end subroutine cascades_1

	@ %def cascades_1
	@
	\subsubsection{Check resonance history}
	<<Cascades: execute tests>>=
	call test(cascades_2, "cascades_2", &
	"Check resonance history", u, results)
	<<Cascades: test declarations>>=
	public :: cascades_2
	<<Cascades: tests>>=
	subroutine cascades_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(5,1) :: flv
	type(cascade_set_t) :: cascade_set
	type(phs_parameters_t) :: phs_par
	type(resonance_history_t), dimension(:), allocatable :: res_hists
	integer :: n, i
	write (u, "(A)") "* Test output: cascades_2"
	write (u, "(A)") "* Purpose: Check resonance history"
	write (u, "(A)")

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

	call model%init_sm_test ()

	call flv(1,1)%init ( 2, model)
	call flv(2,1)%init (-2, model)
	call flv(3,1)%init ( 1, model)
	call flv(4,1)%init (-1, model)
	call flv(5,1)%init (22, model)
	phs_par%sqrts = 1000._default
	phs_par%off_shell = 2

	write (u, "(A)")
	write (u, "(A)") "* Generating the cascades"
	write (u, "(A)")

	call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
	call cascade_set_get_resonance_histories (cascade_set, res_hists = res_hists)
	n = cascade_set_get_n_trees (cascade_set)
	call assert_equal (u, n, 24, "Number of trees")
	do i = 1, size(res_hists)
	call res_hists(i)%write (u)
	write (u, "(A)")
	end do

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

	call cascade_set_final (cascade_set)
	call model%final ()

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

	@ %def cascades_2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{A lexer for O'Mega's phase-space output}
	This module provides three data types. One of them is the type
	[[dag_string_t]] which should contain the information of all Feynman
	diagrams in the factorized form which is provided by O'Mega in its
	phase-space outout. This output is translated into a string of tokens (in
	the form of an a array of the type [[dag_token_t]]) which have a certain
	meaning. The purpose of this module is only to identify these tokens
	correctly and to provide some procedures and interfaces which allow us to
	use these strings in a similar way as variables of the basic character
	type or the type [[iso_varying_string]]. Both [[character]] and
	[[iso_varying_string]] have some disadvantages at least if one wants to
	keep support for some older compiler versions. These can be circumvented
	by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used
	to create a larger string in several steps without always recreating the
	string, which is done in the form of a simple linked list. In the end
	one can create a single [[dag_string]] out of this list, which is more
	useful.
	<<[[cascades2_lexer.f90]]>>=
	<<File header>>

	module cascades2_lexer

	<<Use kinds>>
	use kinds, only: TC, i8

	<<Standard module head>>

	<<Cascades2 lexer: public>>

	<<Cascades2 lexer: parameters>>

	<<Cascades2 lexer: types>>

	<<Cascades2 lexer: interfaces>>

	interface
	<<Cascades2 lexer: sub interfaces>>
	end interface

	end module cascades2_lexer

	@ %def cascades2_lexer
	@
	<<[[cascades2_lexer_sub.f90]]>>=
	<<File header>>

	submodule (cascades2_lexer) cascades2_lexer_s

	implicit none

	contains

	<<Cascades2 lexer: procedures>>

	end submodule cascades2_lexer_s

	@ %def cascades2_lexer_s
	@
	This is the token type. By default the variable [[type]] is [[EMPTY_TK]]
	but can obtain other values corresponding to the parameters defined below.
	The type of the token corresponds to a particular sequence of characters.
	When the token corresponds to a node of a tree, i.e. some particle in the
	Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable
	is holding the name of the particle. O'Megas output contains in
	addition to the particle name some numbers which indicate the external
	momenta that are flowing through this line. These numbers are translated
	into a binary code and saved in the variable [[bincode]]. In this case
	the number 1 corresponds to a bit set at position 0, 2 corresponds to a
	bit set at position 1, etc. Instead of numbers which are composed out of
	several digits, letters are used, i.e. A instead of 10 (bit at position 9),
	B instead of 11 (bit at position 10), etc.\\
	When the DAG is reconstructed from a [[dag_string]] which was built from
	O'Mega's output, this string is modified such that a substring (a set of
	tokens) is replaced by a single token where the type variable is one of
	the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and
	[[DAG_COMBINATION_TK]]. These parameters correspond to the three types
	[[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]]
	for more information. In this case, since these objects are organized
	in arrays, the [[index]] variable holds the corresponding position in
	the array.\\
	In any case, we want to be able to reproduce the character string from
	which a token (or a string) has been created. The variable [[char_len]]
	is the length of this string. For tokens with the type [[DAG_NODE_TK]],
	[[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form
	[[<N23>]], [[<O23>]] or [[<C23>]] which is useful for debugging the parser.
	Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds
	to the [[type]].
	<<Cascades2 lexer: parameters>>=
	integer, parameter :: PRT_NAME_LEN = 20
	@ %def PRT_NAME_LEN
	<<Cascades2 lexer: public>>=
	public :: dag_token_t
	<<Cascades2 lexer: types>>=
	type :: dag_token_t
	integer :: type = EMPTY_TK
	integer :: char_len = 0
	integer(TC) :: bincode = 0
	character(len=PRT_NAME_LEN) :: particle_name=""
	integer :: index = 0
	contains
	<<Cascades2 lexer: dag token: TBP>>
	end type dag_token_t

	@ %def dag_token_t
	@ This is the string type. It also holds the number of characters in the
	corresponding character string. It contains an array of tokens. If the
	[[dag_string]] is constructed using the type [[dag_chain_t]], which creates
	a linked list, we also need the pointer [[next]].
	<<Cascades2 lexer: public>>=
	public :: dag_string_t
	<<Cascades2 lexer: types>>=
	type :: dag_string_t
	integer :: char_len = 0
	type(dag_token_t), dimension(:), allocatable :: t
	type(dag_string_t), pointer :: next => null ()
	contains
	<<Cascades2 lexer: dag string: TBP>>
	end type dag_string_t

	@ %def dag_string_t
	@ This is the chain of [[dag_strings]]. It allows us to construct a large
	string by appending new strings to the linked list, which can later be
	merged to a single string. This is very useful because the file written
	by O'Mega contains large strings where each string contains all Feynman
	diagrams in a factorized form, but these large strings are cut into
	several pieces and distributed over many lines. As the file can become
	large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would
	consume more and more time with each additional line. For recreating a
	single [[dag_string]] out of this chain, we need the total character
	length and the sum of all sizes of the [[dag_token]] arrays [[t]].
	<<Cascades2 lexer: public>>=
	public :: dag_chain_t
	<<Cascades2 lexer: types>>=
	type :: dag_chain_t
	integer :: char_len = 0
	integer :: t_size = 0
	type(dag_string_t), pointer :: first => null ()
	type(dag_string_t), pointer :: last => null ()
	contains
	<<Cascades2 lexer: dag chain: TBP>>
	end type dag_chain_t

	@ %def dag_chain_t
	@ We define two parameters holding the characters corresponding to a
	backslash and a blanc space.
	<<Cascades2 lexer: parameters>>=
	character(len=1), parameter, public :: BACKSLASH_CHAR = "\\"
	character(len=1), parameter :: BLANC_CHAR = " "
	@ %def BACKSLASH_CHAR BLANC_CHAR
	@ These are the parameters which correspond to meaningful types
	of [[token]].
	<<Cascades2 lexer: parameters>>=
	integer, parameter, public :: NEW_LINE_TK = -2
	integer, parameter :: BLANC_SPACE_TK = -1
	integer, parameter :: EMPTY_TK = 0
	integer, parameter, public :: NODE_TK = 1
	integer, parameter, public :: DAG_NODE_TK = 2
	integer, parameter, public :: DAG_OPTIONS_TK = 3
	integer, parameter, public :: DAG_COMBINATION_TK = 4
	integer, parameter, public :: COLON_TK = 11
	integer, parameter, public :: COMMA_TK = 12
	integer, parameter, public :: VERTICAL_BAR_TK = 13
	integer, parameter, public :: OPEN_PAR_TK = 21
	integer, parameter, public :: CLOSED_PAR_TK = 22
	integer, parameter, public :: OPEN_CURLY_TK = 31
	integer, parameter, public :: CLOSED_CURLY_TK = 32

	@ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK
	@ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK
	@ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK
	@ Different sorts of assignment. This contains the conversion
	of a [[character]] variable into a [[dag_token]] or [[dag_string]].
	<<Cascades2 lexer: public>>=
	public :: assignment (=)
	<<Cascades2 lexer: interfaces>>=
	interface assignment (=)
	module procedure dag_token_assign_from_char_string
	module procedure dag_token_assign_from_dag_token
	module procedure dag_string_assign_from_dag_token
	module procedure dag_string_assign_from_char_string
	module procedure dag_string_assign_from_dag_string
	module procedure dag_string_assign_from_dag_token_array
	end interface assignment (=)

	@ %def interfaces
	<<Cascades2 lexer: dag token: TBP>>=
	procedure :: init_dag_object_token => dag_token_init_dag_object_token
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_token_init_dag_object_token (dag_token, type, index)
	class(dag_token_t), intent(out) :: dag_token
	integer, intent(in) :: index
	integer :: type
	end subroutine dag_token_init_dag_object_token
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_token_init_dag_object_token (dag_token, type, index)
	class(dag_token_t), intent(out) :: dag_token
	integer, intent(in) :: index
	integer :: type
	dag_token%type = type
	dag_token%char_len = integer_n_dec_digits (index) + 3
	dag_token%index = index
	contains
	function integer_n_dec_digits (number) result (n_digits)
	integer, intent(in) :: number
	integer :: n_digits
	integer :: div_number
	n_digits = 0
	div_number = number
	do
	div_number = div_number / 10
	n_digits = n_digits + 1
	if (div_number == 0) exit
	end do
	end function integer_n_dec_digits
	end subroutine dag_token_init_dag_object_token

	@ %def dag_token_init_dag_object_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module subroutine dag_token_assign_from_char_string &
	(dag_token, char_string)
	type(dag_token_t), intent(out) :: dag_token
	character(len=*), intent(in) :: char_string
	end subroutine dag_token_assign_from_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module subroutine dag_token_assign_from_char_string &
	(dag_token, char_string)
	type(dag_token_t), intent(out) :: dag_token
	character(len=*), intent(in) :: char_string
	integer :: i, j
	logical :: set_bincode
	integer :: bit_pos
	character(len=10) :: index_char
	dag_token%char_len = len (char_string)
	if (dag_token%char_len == 1) then
	select case (char_string(1:1))
	case (BACKSLASH_CHAR)
	dag_token%type = NEW_LINE_TK
	case (" ")
	dag_token%type = BLANC_SPACE_TK
	case (":")
	dag_token%type = COLON_TK
	case (",")
	dag_token%type = COMMA_TK
	case ("\|")
	dag_token%type = VERTICAL_BAR_TK
	case ("(")
	dag_token%type = OPEN_PAR_TK
	case (")")
	dag_token%type = CLOSED_PAR_TK
	case ("{")
	dag_token%type = OPEN_CURLY_TK
	case ("}")
	dag_token%type = CLOSED_CURLY_TK
	end select
	else if (char_string(1:1) == "<") then
	select case (char_string(2:2))
	case ("N")
	dag_token%type = DAG_NODE_TK
	case ("O")
	dag_token%type = DAG_OPTIONS_TK
	case ("C")
	dag_token%type = DAG_COMBINATION_TK
	end select
	read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index
	else
	dag_token%bincode = 0
	set_bincode = .false.
	do i=1, dag_token%char_len
	select case (char_string(i:i))
	case ("[")
	dag_token%type = NODE_TK
	if (i > 1) then
	do j = 1, i - 1
	dag_token%particle_name(j:j) = char_string(j:j)
	end do
	end if
	set_bincode = .true.
	case ("]")
	set_bincode = .false.
	case default
	dag_token%type = NODE_TK
	if (set_bincode) then
	select case (char_string(i:i))
	case ("1", "2", "3", "4", "5", "6", "7", "8", "9")
	read (char_string(i:i), fmt="(I1)") bit_pos
	case ("A")
	bit_pos = 10
	case ("B")
	bit_pos = 11
	case ("C")
	bit_pos = 12
	end select
	dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1)
	end if
	end select
	if (dag_token%type /= NODE_TK) exit
	end do
	end if
	end subroutine dag_token_assign_from_char_string

	@ %def dag_token_assign_from_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module subroutine dag_token_assign_from_dag_token &
	(token_out, token_in)
	type(dag_token_t), intent(out) :: token_out
	type(dag_token_t), intent(in) :: token_in
	end subroutine dag_token_assign_from_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module subroutine dag_token_assign_from_dag_token &
	(token_out, token_in)
	type(dag_token_t), intent(out) :: token_out
	type(dag_token_t), intent(in) :: token_in
	token_out%type = token_in%type
	token_out%char_len = token_in%char_len
	token_out%bincode = token_in%bincode
	token_out%particle_name = token_in%particle_name
	token_out%index = token_in%index
	end subroutine dag_token_assign_from_dag_token

	@ %def dag_token_assign_from_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module subroutine dag_string_assign_from_dag_token &
	(dag_string, dag_token)
	type(dag_string_t), intent(out) :: dag_string
	type(dag_token_t), intent(in) :: dag_token
	end subroutine dag_string_assign_from_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module subroutine dag_string_assign_from_dag_token &
	(dag_string, dag_token)
	type(dag_string_t), intent(out) :: dag_string
	type(dag_token_t), intent(in) :: dag_token
	allocate (dag_string%t(1))
	dag_string%t(1) = dag_token
	dag_string%char_len = dag_token%char_len
	end subroutine dag_string_assign_from_dag_token

	@ %def dag_string_assign_from_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_string_assign_from_dag_token_array &
	(dag_string, dag_token)
	type(dag_string_t), intent(out) :: dag_string
	type(dag_token_t), dimension(:), intent(in) :: dag_token
	end subroutine dag_string_assign_from_dag_token_array
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_string_assign_from_dag_token_array &
	(dag_string, dag_token)
	type(dag_string_t), intent(out) :: dag_string
	type(dag_token_t), dimension(:), intent(in) :: dag_token
	allocate (dag_string%t(size(dag_token)))
	dag_string%t = dag_token
	dag_string%char_len = sum(dag_token%char_len)
	end subroutine dag_string_assign_from_dag_token_array

	@ %def dag_string_assign_from_dag_token_array
	<<Cascades2 lexer: sub interfaces>>=
	elemental module subroutine dag_string_assign_from_char_string &
	(dag_string, char_string)
	type(dag_string_t), intent(out) :: dag_string
	character(len=*), intent(in) :: char_string
	end subroutine dag_string_assign_from_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module subroutine dag_string_assign_from_char_string &
	(dag_string, char_string)
	type(dag_string_t), intent(out) :: dag_string
	character(len=*), intent(in) :: char_string
	type(dag_token_t), dimension(:), allocatable :: token
	integer :: token_pos
	integer :: i
	character(len=len(char_string)) :: node_char
	integer :: node_char_len
	node_char = ""
	dag_string%char_len = len (char_string)
	if (dag_string%char_len > 0) then
	allocate (token(dag_string%char_len))
	token_pos = 0
	node_char_len = 0
	do i=1, dag_string%char_len
	select case (char_string(i:i))
	case (BACKSLASH_CHAR, " ", ":", ",", "\|", "(", ")", "{", "}")
	if (node_char_len > 0) then
	token_pos = token_pos + 1
	token(token_pos) = node_char(:node_char_len)
	node_char_len = 0
	end if
	token_pos = token_pos + 1
	token(token_pos) = char_string(i:i)
	case default
	node_char_len = node_char_len + 1
	node_char(node_char_len:node_char_len) = char_string(i:i)
	end select
	end do
	if (node_char_len > 0) then
	token_pos = token_pos + 1
	token(token_pos) = node_char(:node_char_len)
	end if
	if (token_pos > 0) then
	allocate (dag_string%t(token_pos))
	dag_string%t = token(:token_pos)
	deallocate (token)
	end if
	end if
	end subroutine dag_string_assign_from_char_string

	@ %def dag_string_assign_from_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module subroutine dag_string_assign_from_dag_string &
	(string_out, string_in)
	type(dag_string_t), intent(out) :: string_out
	type(dag_string_t), intent(in) :: string_in
	end subroutine dag_string_assign_from_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module subroutine dag_string_assign_from_dag_string &
	(string_out, string_in)
	type(dag_string_t), intent(out) :: string_out
	type(dag_string_t), intent(in) :: string_in
	if (allocated (string_in%t)) then
	allocate (string_out%t (size(string_in%t)))
	string_out%t = string_in%t
	end if
	string_out%char_len = string_in%char_len
	end subroutine dag_string_assign_from_dag_string

	@ %def dag_string_assign_from_dag_string
	@ Concatenate strings/tokens. The result is always a [[dag_string]].
	<<Cascades2 lexer: public>>=
	public :: operator (//)
	<<Cascades2 lexer: interfaces>>=
	interface operator (//)
	module procedure concat_dag_token_dag_token
	module procedure concat_dag_string_dag_token
	module procedure concat_dag_token_dag_string
	module procedure concat_dag_string_dag_string
	end interface operator (//)

	@ %def interfaces
	<<Cascades2 lexer: sub interfaces>>=
	module function concat_dag_token_dag_token &
	(token1, token2) result (res_string)
	type(dag_token_t), intent(in) :: token1, token2
	type(dag_string_t) :: res_string
	end function concat_dag_token_dag_token
	<<Cascades2 lexer: procedures>>=
	module function concat_dag_token_dag_token &
	(token1, token2) result (res_string)
	type(dag_token_t), intent(in) :: token1, token2
	type(dag_string_t) :: res_string
	if (token1%type == EMPTY_TK) then
	call dag_string_assign_from_dag_token (res_string, token2)
	else if (token2%type == EMPTY_TK) then
	call dag_string_assign_from_dag_token (res_string, token1)
	else
	allocate (res_string%t(2))
	res_string%t(1) = token1
	res_string%t(2) = token2
	res_string%char_len = token1%char_len + token2%char_len
	end if
	end function concat_dag_token_dag_token

	@ %def concat_dag_token_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	module function concat_dag_string_dag_token &
	(dag_string, dag_token) result (res_string)
	type(dag_string_t), intent(in) :: dag_string
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t) :: res_string
	end function concat_dag_string_dag_token
	<<Cascades2 lexer: procedures>>=
	module function concat_dag_string_dag_token &
	(dag_string, dag_token) result (res_string)
	type(dag_string_t), intent(in) :: dag_string
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t) :: res_string
	integer :: t_size
	if (dag_string%char_len == 0) then
	call dag_string_assign_from_dag_token (res_string, dag_token)
	else if (dag_token%type == EMPTY_TK) then
	res_string = dag_string
	else
	t_size = size (dag_string%t)
	allocate (res_string%t(t_size+1))
	res_string%t(:t_size) = dag_string%t
	res_string%t(t_size+1) = dag_token
	res_string%char_len = dag_string%char_len + dag_token%char_len
	end if
	end function concat_dag_string_dag_token

	@ %def concat_dag_string_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	module function concat_dag_token_dag_string &
	(dag_token, dag_string) result (res_string)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	type(dag_string_t) :: res_string
	integer :: t_size
	end function concat_dag_token_dag_string
	<<Cascades2 lexer: procedures>>=
	module function concat_dag_token_dag_string &
	(dag_token, dag_string) result (res_string)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	type(dag_string_t) :: res_string
	integer :: t_size
	if (dag_token%type == EMPTY_TK) then
	res_string = dag_string
	else if (dag_string%char_len == 0) then
	call dag_string_assign_from_dag_token (res_string, dag_token)
	else
	t_size = size (dag_string%t)
	allocate (res_string%t(t_size+1))
	res_string%t(2:t_size+1) = dag_string%t
	res_string%t(1) = dag_token
	res_string%char_len = dag_token%char_len + dag_string%char_len
	end if
	end function concat_dag_token_dag_string

	@ %def concat_dag_token_dag_string
	<<Cascades2 lexer: sub interfaces>>=
	module function concat_dag_string_dag_string &
	(string1, string2) result (res_string)
	type(dag_string_t), intent(in) :: string1, string2
	type(dag_string_t) :: res_string
	end function concat_dag_string_dag_string
	<<Cascades2 lexer: procedures>>=
	module function concat_dag_string_dag_string &
	(string1, string2) result (res_string)
	type(dag_string_t), intent(in) :: string1, string2
	type(dag_string_t) :: res_string
	integer :: t1_size, t2_size, t_size
	if (string1%char_len == 0) then
	res_string = string2
	else if (string2%char_len == 0) then
	res_string = string1
	else
	t1_size = size (string1%t)
	t2_size = size (string2%t)
	t_size = t1_size + t2_size
	if (t_size > 0) then
	allocate (res_string%t(t_size))
	res_string%t(:t1_size) = string1%t
	res_string%t(t1_size+1:) = string2%t
	res_string%char_len = string1%char_len + string2%char_len
	end if
	end if
	end function concat_dag_string_dag_string

	@ %def concat_dag_string_dag_string
	@ Compare strings/tokens/characters. Each character is relevant, including
	all blanc spaces. An exception is the [[newline]] character which is not
	treated by the types used in this module (not to confused with the type
	parameter [[NEW_LINE_TK]] which corresponds to the backslash character
	and simply tells us that the string continues on the next line in the file).
	<<Cascades2 lexer: public>>=
	public :: operator (==)
	<<Cascades2 lexer: interfaces>>=
	interface operator (==)
	module procedure dag_token_eq_dag_token
	module procedure dag_string_eq_dag_string
	module procedure dag_token_eq_dag_string
	module procedure dag_string_eq_dag_token
	module procedure dag_token_eq_char_string
	module procedure char_string_eq_dag_token
	module procedure dag_string_eq_char_string
	module procedure char_string_eq_dag_string
	end interface operator (==)

	@ %def interfaces
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_eq_dag_token &
	(token1, token2) result (flag)
	type(dag_token_t), intent(in) :: token1, token2
	logical :: flag
	end function dag_token_eq_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_eq_dag_token &
	(token1, token2) result (flag)
	type(dag_token_t), intent(in) :: token1, token2
	logical :: flag
	flag = (token1%type == token2%type) .and. &
	(token1%char_len == token2%char_len) .and. &
	(token1%bincode == token2%bincode) .and. &
	(token1%index == token2%index) .and. &
	(token1%particle_name == token2%particle_name)
	end function dag_token_eq_dag_token

	@ %def dag_token_eq_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_eq_dag_string &
	(string1, string2) result (flag)
	type(dag_string_t), intent(in) :: string1, string2
	logical :: flag
	end function dag_string_eq_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_eq_dag_string &
	(string1, string2) result (flag)
	type(dag_string_t), intent(in) :: string1, string2
	logical :: flag
	flag = (string1%char_len == string2%char_len) .and. &
	(allocated (string1%t) .eqv. allocated (string2%t))
	if (flag) then
	if (allocated (string1%t)) flag = all (string1%t == string2%t)
	end if
	end function dag_string_eq_dag_string

	@ %def dag_string_eq_dag_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_eq_dag_string &
	(dag_token, dag_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	end function dag_token_eq_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_eq_dag_string &
	(dag_token, dag_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	flag = size (dag_string%t) == 1 .and. &
	dag_string%char_len == dag_token%char_len
	if (flag) flag = (dag_string%t(1) == dag_token)
	end function dag_token_eq_dag_string

	@ %def dag_token_eq_dag_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_eq_dag_token &
	(dag_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	end function dag_string_eq_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_eq_dag_token &
	(dag_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	flag = (dag_token == dag_string)
	end function dag_string_eq_dag_token

	@ %def dag_string_eq_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_eq_char_string &
	(dag_token, char_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function dag_token_eq_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_eq_char_string &
	(dag_token, char_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = (char (dag_token) == char_string)
	end function dag_token_eq_char_string

	@ %def dag_token_eq_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function char_string_eq_dag_token &
	(char_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function char_string_eq_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function char_string_eq_dag_token &
	(char_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = (char (dag_token) == char_string)
	end function char_string_eq_dag_token

	@ %def char_string_eq_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_eq_char_string &
	(dag_string, char_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function dag_string_eq_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_eq_char_string &
	(dag_string, char_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = (char (dag_string) == char_string)
	end function dag_string_eq_char_string

	@ %def dag_string_eq_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function char_string_eq_dag_string &
	(char_string, dag_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function char_string_eq_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function char_string_eq_dag_string &
	(char_string, dag_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = (char (dag_string) == char_string)
	end function char_string_eq_dag_string

	@ %def char_string_eq_dag_string
	<<Cascades2 lexer: public>>=
	public :: operator (/=)
	<<Cascades2 lexer: interfaces>>=
	interface operator (/=)
	module procedure dag_token_ne_dag_token
	module procedure dag_string_ne_dag_string
	module procedure dag_token_ne_dag_string
	module procedure dag_string_ne_dag_token
	module procedure dag_token_ne_char_string
	module procedure char_string_ne_dag_token
	module procedure dag_string_ne_char_string
	module procedure char_string_ne_dag_string
	end interface operator (/=)

	@ %def interfaces
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_ne_dag_token &
	(token1, token2) result (flag)
	type(dag_token_t), intent(in) :: token1, token2
	logical :: flag
	end function dag_token_ne_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_ne_dag_token &
	(token1, token2) result (flag)
	type(dag_token_t), intent(in) :: token1, token2
	logical :: flag
	flag = .not. (token1 == token2)
	end function dag_token_ne_dag_token

	@ %def dag_token_ne_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_ne_dag_string &
	(string1, string2) result (flag)
	type(dag_string_t), intent(in) :: string1, string2
	logical :: flag
	end function dag_string_ne_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_ne_dag_string &
	(string1, string2) result (flag)
	type(dag_string_t), intent(in) :: string1, string2
	logical :: flag
	flag = .not. (string1 == string2)
	end function dag_string_ne_dag_string

	@ %def dag_string_ne_dag_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_ne_dag_string &
	(dag_token, dag_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	end function dag_token_ne_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_ne_dag_string &
	(dag_token, dag_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	flag = .not. (dag_token == dag_string)
	end function dag_token_ne_dag_string

	@ %def dag_token_ne_dag_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_ne_dag_token &
	(dag_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	end function dag_string_ne_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_ne_dag_token &
	(dag_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	type(dag_string_t), intent(in) :: dag_string
	logical :: flag
	flag = .not. (dag_string == dag_token)
	end function dag_string_ne_dag_token

	@ %def dag_string_ne_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_token_ne_char_string &
	(dag_token, char_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function dag_token_ne_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_token_ne_char_string &
	(dag_token, char_string) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = .not. (dag_token == char_string)
	end function dag_token_ne_char_string

	@ %def dag_token_ne_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function char_string_ne_dag_token &
	(char_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function char_string_ne_dag_token
	<<Cascades2 lexer: procedures>>=
	elemental module function char_string_ne_dag_token &
	(char_string, dag_token) result (flag)
	type(dag_token_t), intent(in) :: dag_token
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = .not. (char_string == dag_token)
	end function char_string_ne_dag_token

	@ %def char_string_ne_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function dag_string_ne_char_string &
	(dag_string, char_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function dag_string_ne_char_string
	<<Cascades2 lexer: procedures>>=
	elemental module function dag_string_ne_char_string &
	(dag_string, char_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = .not. (dag_string == char_string)
	end function dag_string_ne_char_string

	@ %def dag_string_ne_char_string
	<<Cascades2 lexer: sub interfaces>>=
	elemental module function char_string_ne_dag_string &
	(char_string, dag_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	end function char_string_ne_dag_string
	<<Cascades2 lexer: procedures>>=
	elemental module function char_string_ne_dag_string &
	(char_string, dag_string) result (flag)
	type(dag_string_t), intent(in) :: dag_string
	character(len=*), intent(in) :: char_string
	logical :: flag
	flag = .not. (char_string == dag_string)
	end function char_string_ne_dag_string

	@ %def char_string_ne_dag_string
	@ Convert a [[dag_token]] or [[dag_string]] to character.
	<<Cascades2 lexer: public>>=
	public :: char
	<<Cascades2 lexer: interfaces>>=
	interface char
	module procedure char_dag_token
	module procedure char_dag_string
	end interface char

	@ %def interfaces
	<<Cascades2 lexer: sub interfaces>>=
	pure module function char_dag_token (dag_token) result (char_string)
	type(dag_token_t), intent(in) :: dag_token
	character (dag_token%char_len) :: char_string
	end function char_dag_token
	<<Cascades2 lexer: procedures>>=
	pure module function char_dag_token (dag_token) result (char_string)
	type(dag_token_t), intent(in) :: dag_token
	character (dag_token%char_len) :: char_string
	integer :: i
	integer :: name_len
	integer :: bc_pos
	integer :: n_digits
	character(len=9) :: fmt_spec
	select case (dag_token%type)
	case (EMPTY_TK)
	char_string = ""
	case (NEW_LINE_TK)
	char_string = BACKSLASH_CHAR
	case (BLANC_SPACE_TK)
	char_string = " "
	case (COLON_TK)
	char_string = ":"
	case (COMMA_TK)
	char_string = ","
	case (VERTICAL_BAR_TK)
	char_string = "\|"
	case (OPEN_PAR_TK)
	char_string = "("
	case (CLOSED_PAR_TK)
	char_string = ")"
	case (OPEN_CURLY_TK)
	char_string = "{"
	case (CLOSED_CURLY_TK)
	char_string = "}"
	case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
	n_digits = dag_token%char_len - 3
	fmt_spec = ""
	if (n_digits > 9) then
	write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)"
	else
	write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)"
	end if
	select case (dag_token%type)
	case (DAG_NODE_TK)
	write (char_string, fmt=fmt_spec) "<N", dag_token%index, ">"
	case (DAG_OPTIONS_TK)
	write (char_string, fmt=fmt_spec) "<O", dag_token%index, ">"
	case (DAG_COMBINATION_TK)
	write (char_string, fmt=fmt_spec) "<C", dag_token%index, ">"
	end select
	case (NODE_TK)
	name_len = len_trim (dag_token%particle_name)
	char_string = dag_token%particle_name
	bc_pos = name_len + 1
	char_string(bc_pos:bc_pos) = "["
	do i=0, bit_size (dag_token%bincode) - 1
	if (btest (dag_token%bincode, i)) then
	bc_pos = bc_pos + 1
	select case (i)
	case (0, 1, 2, 3, 4, 5, 6, 7, 8)
	write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1
	case (9)
	write (char_string(bc_pos:bc_pos), fmt="(A1)") "A"
	case (10)
	write (char_string(bc_pos:bc_pos), fmt="(A1)") "B"
	case (11)
	write (char_string(bc_pos:bc_pos), fmt="(A1)") "C"
	end select
	bc_pos = bc_pos + 1
	if (bc_pos == dag_token%char_len) then
	write (char_string(bc_pos:bc_pos), fmt="(A1)") "]"
	return
	else
	write (char_string(bc_pos:bc_pos), fmt="(A1)") "/"
	end if
	end if
	end do
	end select
	end function char_dag_token

	@ %def char_dag_token
	<<Cascades2 lexer: sub interfaces>>=
	pure module function char_dag_string (dag_string) result (char_string)
	type(dag_string_t), intent(in) :: dag_string
	character (dag_string%char_len) :: char_string
	end function char_dag_string
	<<Cascades2 lexer: procedures>>=
	pure module function char_dag_string (dag_string) result (char_string)
	type(dag_string_t), intent(in) :: dag_string
	character (dag_string%char_len) :: char_string
	integer :: pos
	integer :: i
	char_string = ""
	pos = 0
	do i=1, size(dag_string%t)
	char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i))
	pos = pos + dag_string%t(i)%char_len
	end do
	end function char_dag_string

	@ %def char_dag_string
	@ Remove all tokens which are irrelevant for parsing. These are of type
	[[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]].
	<<Cascades2 lexer: dag string: TBP>>=
	procedure :: clean => dag_string_clean
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_string_clean (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	end subroutine dag_string_clean
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_string_clean (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	type(dag_token_t), dimension(:), allocatable :: tmp_token
	integer :: n_keep
	integer :: i
	n_keep = 0
	dag_string%char_len = 0
	allocate (tmp_token (size(dag_string%t)))
	do i=1, size (dag_string%t)
	select case (dag_string%t(i)%type)
	case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK)
	case default
	n_keep = n_keep + 1
	tmp_token(n_keep) = dag_string%t(i)
	dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len
	end select
	end do
	deallocate (dag_string%t)
	allocate (dag_string%t(n_keep))
	dag_string%t = tmp_token(:n_keep)
	end subroutine dag_string_clean

	@ %def dag_string_clean
	@ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]],
	the variable [[char_len]] is not automatically modified. It can however be
	determined afterwards using the following subroutine.
	<<Cascades2 lexer: dag string: TBP>>=
	procedure :: update_char_len => dag_string_update_char_len
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_string_update_char_len (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	end subroutine dag_string_update_char_len
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_string_update_char_len (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	integer :: char_len
	integer :: i
	char_len = 0
	if (allocated (dag_string%t)) then
	do i=1, size (dag_string%t)
	char_len = char_len + dag_string%t(i)%char_len
	end do
	end if
	dag_string%char_len = char_len
	end subroutine dag_string_update_char_len

	@ %def dag_string_update_char_len
	@ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]]
	is of type [[character]] because the subroutine is used for reading from
	the file produced by O'Mega which is first read line by line to a character
	variable.
	<<Cascades2 lexer: dag chain: TBP>>=
	procedure :: append => dag_chain_append_string
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_chain_append_string (dag_chain, char_string)
	class(dag_chain_t), intent(inout) :: dag_chain
	character(len=*), intent(in) :: char_string
	end subroutine dag_chain_append_string
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_chain_append_string (dag_chain, char_string)
	class(dag_chain_t), intent(inout) :: dag_chain
	character(len=*), intent(in) :: char_string
	if (.not. associated (dag_chain%first)) then
	allocate (dag_chain%first)
	dag_chain%last => dag_chain%first
	else
	allocate (dag_chain%last%next)
	dag_chain%last => dag_chain%last%next
	end if
	dag_chain%last = char_string
	dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len
	dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t)
	end subroutine dag_chain_append_string

	@ %def dag_chain_append_string
	@ Reduce the linked list of [[dag_string]] objects which are attached
	to a given [[dag_chain]] object to a single [[dag_string]].
	<<Cascades2 lexer: dag chain: TBP>>=
	procedure :: compress => dag_chain_compress
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_chain_compress (dag_chain)
	class(dag_chain_t), intent(inout) :: dag_chain
	end subroutine dag_chain_compress
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_chain_compress (dag_chain)
	class(dag_chain_t), intent(inout) :: dag_chain
	type(dag_string_t), pointer :: current
	type(dag_string_t), pointer :: remove
	integer :: filled_t
	current => dag_chain%first
	dag_chain%first => null ()
	allocate (dag_chain%first)
	dag_chain%last => dag_chain%first
	dag_chain%first%char_len = dag_chain%char_len
	allocate (dag_chain%first%t (dag_chain%t_size))
	filled_t = 0
	do while (associated (current))
	dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t
	filled_t = filled_t + size (current%t)
	remove => current
	current => current%next
	deallocate (remove)
	end do
	end subroutine dag_chain_compress

	@ %def dag_chain_compress
	@ Finalizer for [[dag_string_t]].
	<<Cascades2 lexer: dag string: TBP>>=
	procedure :: final => dag_string_final
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_string_final (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	end subroutine dag_string_final
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_string_final (dag_string)
	class(dag_string_t), intent(inout) :: dag_string
	if (allocated (dag_string%t)) deallocate (dag_string%t)
	dag_string%next => null ()
	end subroutine dag_string_final

	@ %def dag_string_final
	@ Finalizer for [[dag_chain_t]].
	<<Cascades2 lexer: dag chain: TBP>>=
	procedure :: final => dag_chain_final
	<<Cascades2 lexer: sub interfaces>>=
	module subroutine dag_chain_final (dag_chain)
	class(dag_chain_t), intent(inout) :: dag_chain
	end subroutine dag_chain_final
	<<Cascades2 lexer: procedures>>=
	module subroutine dag_chain_final (dag_chain)
	class(dag_chain_t), intent(inout) :: dag_chain
	type(dag_string_t), pointer :: current
	current => dag_chain%first
	do while (associated (current))
	dag_chain%first => dag_chain%first%next
	call current%final ()
	deallocate (current)
	current => dag_chain%first
	end do
	dag_chain%last => null ()
	end subroutine dag_chain_final

	@ %def dag_chain_final
	<<[[cascades2_lexer_ut.f90]]>>=
	<<File header>>

	module cascades2_lexer_ut
	use unit_tests
	use cascades2_lexer_uti

	<<Standard module head>>

	<<Cascades2 lexer: public test>>

	contains

	<<Cascades2 lexer: test driver>>

	end module cascades2_lexer_ut
	@ %def cascades2_lexer_ut
	@
	<<[[cascades2_lexer_uti.f90]]>>=
	<<File header>>

	module cascades2_lexer_uti

	<<Use kinds>>
	<<Use strings>>
	use numeric_utils

	use cascades2_lexer

	<<Standard module head>>

	<<Cascades2 lexer: test declarations>>

	contains

	<<Cascades2 lexer: tests>>

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

	@ %def cascades2_lexer_test
	@
	<<Cascades2 lexer: execute tests>>=
	call test (cascades2_lexer_1, "cascades2_lexer_1", &
	"make phase-space", u, results)
	<<Cascades2 lexer: test declarations>>=
	public :: cascades2_lexer_1
	<<Cascades2 lexer: tests>>=
	subroutine cascades2_lexer_1 (u)
	integer, intent(in) :: u
	integer :: u_in = 8
	character(len=300) :: line
	integer :: stat
	logical :: fail
	type(dag_string_t) :: dag_string

	write (u, "(A)") "* Test output: cascades2_lexer_1"
	write (u, "(A)") "* Purpose: read lines of O'Mega's phase space output, translate"
	write (u, "(A)") "* to dag_string, retranslate to character string and"
	write (u, "(A)") "* compare"
	write (u, "(A)")

	open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read')

	stat = 0
	fail = .false.
	read (unit=u_in, fmt="(A)", iostat=stat) line
	do while (stat == 0 .and. .not. fail)
	read (unit=u_in, fmt="(A)", iostat=stat) line
	if (stat /= 0) exit
	dag_string = line
	fail = (char(dag_string) /= line)
	end do
	if (fail) then
	write (u, "(A)") "* Test result: Test failed!"
	else
	write (u, "(A)") "* Test result: Test passed"
	end if

	close (u_in)
	write (u, *)
	write (u, "(A)") "* Test output end: cascades2_lexer_1"
	end subroutine cascades2_lexer_1

	@ %def cascades2_lexer_1
	@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{An alternative cascades module}
	This module might replace the module [[cascades]], which generates
	suitable phase space parametrizations and generates the phase space file.
	The mappings, as well as the criteria to determine these, do not change.

	The advantage of this module is that it makes use of the [[O'Mega]] matrix
	element generator which provides the relevant Feynman diagrams (the ones
	which can be constructed only from 3-vertices). In principle, the
	construction of these diagrams is also one of the tasks of the existing
	[[cascades]] module, in which the diagrams would correspond to a set of
	cascades. It starts by creating cascades which correspond to the
	outgoing particles. These are combined to a new cascade using the
	vertices of the model. In this way, since each cascade knows the
	daughter cascades from which it is built, complete Feynman diagrams are
	represented by sets of cascades, as soon as the existing cascades can be
	recombined with the incoming particle(s).

	In this module, the Feynman diagrams are represented by the type
	[[feyngraph_t]], which represents the Feynman diagrams as a tree of
	nodes. The object which contains the necessary kinematical information
	to determine mappings, and hence sensible phase space parametrizations
	is of another type, called [[kingraph_t]], which is built from a
	corresponding [[feyngraph]] object.

	There are two types of output which can be produced by [[O'Mega]] and
	are potentially relevant here. The first type contains all tree
	diagrams for the process under consideration, where each line of the
	output corresponds to one Feynman diagram. This output is easy to read,
	but can be very large, depending on the number of particles involved in
	the process. Moreover, it repeats substructures of the diagrams which
	are part of more than one diagram. One could in principle work with
	this output and construct a [[feyngraph]] from each line, if allowed,
	i.e. if there are only 3-vertices.

	The other output contains also all of these Feynman diagrams, but in
	a factorized form. This means that the substructures which appear in
	several Feynman diagrams, are written only once, if possible. This
	leads to a much shorter input file, which speeds up the parsing
	process. Furthermore it makes it possible to reconstruct the
	[[feyngraphs]] in such a way that the calculations concerning
	subdiagrams which reappear in other [[feyngraphs]] have to be
	performed only once. This is already the case in the existing
	[[cascades]] module but can be exploited more efficiently here
	because the possible graphs are well known from the input file, whereas
	the [[cascades]] module would create a large number of [[cascades]]
	which do not lead to a complete Feynman diagram of the given process.
	<<[[cascades2.f90]]>>=
	<<File header>>

	module cascades2

	use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit
	<<Use kinds>>
	use kinds, only: TC, i8
	<<Use strings>>
	<<Use debug>>
	use diagnostics
	use flavors
	use model_data
	use phs_forests, only: phs_parameters_t
	use resonances, only: resonance_info_t
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t
	use cascades2_lexer

	<<Standard module head>>

	<<Cascades2: public>>

	<<Cascades2: parameters>>

	<<Cascades2: types>>

	<<Cascades2: interfaces>>

	interface
	<<Cascades2: sub interfaces>>
	end interface

	contains

	<<Cascades2: main procedures>>

	end module cascades2

	@ %def cascades2
	@
	<<[[cascades2_sub.f90]]>>=
	<<File header>>

	submodule (cascades2) cascades2_s

	use sorting
	use io_units
	use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use hashes
	use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE

	implicit none

	contains

	<<Cascades2: procedures>>

	end submodule cascades2_s

	@ %def cascades2_s
	@
	\subsection{Particle properties}
	We define a type holding the properties of the particles which are needed
	for parsing and finding the phase space parametrizations and mappings.
	The properties of all particles which appear in the parsed
	Feynman diagrams for the given process will be stored in a central place,
	and only pointers to these objects are used.
	<<Cascades2: types>>=
	type :: part_prop_t
	character(len=LABEL_LEN) :: particle_label
	integer :: pdg = 0
	real(default) :: mass = 0.
	real :: width = 0.
	integer :: spin_type = 0
	logical :: is_vector = .false.
	logical :: empty = .true.
	type(part_prop_t), pointer :: anti => null ()
	type(string_t) :: tex_name
	contains
	<<Cascades2: part prop: TBP>>
	end type part_prop_t

	@ %def part_prop_t
	@ The [[particle_label]] in [[part_prop_t]] is simply the particle name
	(e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains
	some additional information related to the external momenta, see below.
	The length of the [[character]] variable is fixed as:
	<<Cascades2: parameters>>=
	integer, parameter :: LABEL_LEN=30
	@ %def LABEL_LEN
	<<Cascades2: part prop: TBP>>=
	procedure :: final => part_prop_final
	<<Cascades2: sub interfaces>>=
	module subroutine part_prop_final (part)
	class(part_prop_t), intent(inout) :: part
	end subroutine part_prop_final
	<<Cascades2: procedures>>=
	module subroutine part_prop_final (part)
	class(part_prop_t), intent(inout) :: part
	part%anti => null ()
	end subroutine part_prop_final

	@ %def part_prop_final
	@
	\subsection{The mapping modes}
	The possible mappings are essentially the same as in [[cascades]], but we
	introduce in addition the mapping constant [[NON_RESONANT]], which does
	not refer to a new mapping; it corresponds to the nonresonant version of
	a potentially resonant particle (or [[k_node]]). This becomes relevant
	when we compare [[k_nodes]] to eliminate equivalences.
	<<Cascades2: parameters>>=
	integer, parameter :: &
	& NONRESONANT = -2, EXTERNAL_PRT = -1, &
	& NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, &
	& RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
	& STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
	& ON_SHELL = 99
	@ %def NONRESONANT EXTERNAL_PRT
	@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
	@ %def RADIATION COLLINEAR INFRARED
	@ %def STEP_MAPPING_E STEP_MAPPING_H
	@ %def ON_SHELL
	@
	\subsection{Grove properties}
	The channels or [[kingraphs]] will be grouped in groves, i.e. sets of
	channels, which share some characteristic numbers. These numbers are
	stored in the following type:
	<<Cascades2: types>>=
	type :: grove_prop_t
	integer :: multiplicity = 0
	integer :: n_resonances = 0
	integer :: n_log_enhanced = 0
	integer :: n_off_shell = 0
	integer :: n_t_channel = 0
	integer :: res_hash = 0
	end type grove_prop_t

	@ %def grove_prop_t
	@
	\subsection{The tree type}
	This type contains all the information which is needed to
	reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes
	and mappings for all nodes of a valid [[kingraph]]. If we label the
	external particles as given in the process definition with integer
	numbers representing their position in the process definition, the bincode
	would be the number that one obtains by setting the bit at the position
	that is given by this number. If we combine two particles/nodes to a third
	one (using a three-vertex of the given model), the bincode is the number which
	one obtains by setting all the bits which are set for the two particles.
	The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the
	position (i.e. propagator or external particle) which is specified by the
	corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]],
	but also for all [[k_nodes]], which are a subtree of a [[kingraph]].
	<<Cascades2: types>>=
	type :: tree_t
	integer(TC), dimension(:), allocatable :: bc
	integer, dimension(:), allocatable :: pdg
	integer, dimension(:), allocatable :: mapping
	integer :: n_entries = 0
	logical :: keep = .true.
	logical :: empty = .true.
	contains
	<<Cascades2: tree: TBP>>
	end type tree_t

	@ %def tree_t
	<<Cascades2: tree: TBP>>=
	procedure :: final => tree_final
	<<Cascades2: sub interfaces>>=
	module subroutine tree_final (tree)
	class(tree_t), intent(inout) :: tree
	end subroutine tree_final
	<<Cascades2: procedures>>=
	module subroutine tree_final (tree)
	class(tree_t), intent(inout) :: tree
	if (allocated (tree%bc)) deallocate (tree%bc)
	if (allocated (tree%pdg)) deallocate (tree%pdg)
	if (allocated (tree%mapping)) deallocate (tree%mapping)
	end subroutine tree_final

	@ %def tree_final
	<<Cascades2: interfaces>>=
	interface assignment (=)
	module procedure tree_assign
	end interface assignment (=)

	<<Cascades2: sub interfaces>>=
	module subroutine tree_assign (tree1, tree2)
	type(tree_t), intent(inout) :: tree1
	type(tree_t), intent(in) :: tree2
	end subroutine tree_assign
	<<Cascades2: procedures>>=
	module subroutine tree_assign (tree1, tree2)
	type(tree_t), intent(inout) :: tree1
	type(tree_t), intent(in) :: tree2
	if (allocated (tree2%bc)) then
	allocate (tree1%bc(size(tree2%bc)))
	tree1%bc = tree2%bc
	end if
	if (allocated (tree2%pdg)) then
	allocate (tree1%pdg(size(tree2%pdg)))
	tree1%pdg = tree2%pdg
	end if
	if (allocated (tree2%mapping)) then
	allocate (tree1%mapping(size(tree2%mapping)))
	tree1%mapping = tree2%mapping
	end if
	tree1%n_entries = tree2%n_entries
	tree1%keep = tree2%keep
	tree1%empty = tree2%empty
	end subroutine tree_assign

	@ %def tree_assign
	@
	\subsection{Add entries to the tree}
	The following procedures fill the arrays in [[tree_t]] with entries
	resulting from the bincode and mapping assignment.
	<<Cascades2: tree: TBP>>=
	procedure :: add_entry_from_numbers => tree_add_entry_from_numbers
	procedure :: add_entry_from_node => tree_add_entry_from_node
	generic :: add_entry => add_entry_from_numbers, add_entry_from_node
	@ Here we add a single entry to each of the arrays. This will exclusively
	be used for external particles.
	<<Cascades2: sub interfaces>>=
	module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping)
	class(tree_t), intent(inout) :: tree
	integer(TC), intent(in) :: bincode
	integer, intent(in) :: pdg
	integer, intent(in) :: mapping
	end subroutine tree_add_entry_from_numbers
	<<Cascades2: procedures>>=
	module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping)
	class(tree_t), intent(inout) :: tree
	integer(TC), intent(in) :: bincode
	integer, intent(in) :: pdg
	integer, intent(in) :: mapping
	integer :: pos
	if (tree%empty) then
	allocate (tree%bc(1))
	allocate (tree%pdg(1))
	allocate (tree%mapping(1))
	pos = tree%n_entries + 1
	tree%bc(pos) = bincode
	tree%pdg(pos) = pdg
	tree%mapping(pos) = mapping
	tree%n_entries = pos
	tree%empty = .false.
	end if
	end subroutine tree_add_entry_from_numbers

	@ %def tree_add_entry_from_numbers
	@ Here we merge two existing subtrees and a single entry (bc, pdg and
	mapping).
	<<Cascades2: procedures>>=
	subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping)
	class(tree_t), intent(inout) :: tree
	type(tree_t), intent(in) :: tree1, tree2
	integer(TC), intent(in) :: bc
	integer, intent(in) :: pdg, mapping
	integer :: tree_size
	integer :: i1, i2
	if (tree%empty) then
	i1 = tree1%n_entries
	i2 = tree1%n_entries + tree2%n_entries
	!! Proof: tree_size > 0 (always)
	tree_size = tree1%n_entries + tree2%n_entries + 1
	allocate (tree%bc (tree_size))
	allocate (tree%pdg (tree_size))
	allocate (tree%mapping (tree_size))
	if (.not. tree1%empty) then
	tree%bc(:i1) = tree1%bc
	tree%pdg(:i1) = tree1%pdg
	tree%mapping(:i1) = tree1%mapping
	end if
	if (.not. tree2%empty) then
	tree%bc(i1+1:i2) = tree2%bc
	tree%pdg(i1+1:i2) = tree2%pdg
	tree%mapping(i1+1:i2) = tree2%mapping
	end if
	tree%bc(tree_size) = bc
	tree%pdg(tree_size) = pdg
	tree%mapping(tree_size) = mapping
	tree%n_entries = tree_size
	tree%empty = .false.
	end if
	end subroutine tree_merge

	@ %def tree_merge
	@ Here we add entries to a tree for a given [[k_node]], which means that
	we first have to determine whether the node is external or internal.
	The arrays are sorted after the entries have been added (see below for
	details).
	<<Cascades2: sub interfaces>>=
	module subroutine tree_add_entry_from_node (tree, node)
	class(tree_t), intent(inout) :: tree
	type(k_node_t), intent(in) :: node
	end subroutine tree_add_entry_from_node
	<<Cascades2: procedures>>=
	module subroutine tree_add_entry_from_node (tree, node)
	class(tree_t), intent(inout) :: tree
	type(k_node_t), intent(in) :: node
	integer :: pdg
	if (node%t_line) then
	pdg = abs (node%particle%pdg)
	else
	pdg = node%particle%pdg
	end if
	if (associated (node%daughter1) .and. &
	associated (node%daughter2)) then
	call tree_merge (tree, node%daughter1%subtree, &
	node%daughter2%subtree, node%bincode, &
	node%particle%pdg, node%mapping)
	else
	call tree_add_entry_from_numbers (tree, node%bincode, &
	node%particle%pdg, node%mapping)
	end if
	call tree%sort ()
	end subroutine tree_add_entry_from_node

	@ %def tree_add_entry_from_node
	@ For a well-defined order of the elements of the arrays in [[tree_t]],
	the elements can be sorted. The bincodes (entries of [[bc]]) are
	simply ordered by size, the [[pdg]] and [[mapping]] entries go to the
	positions of the corresponding [[bc]] values.
	<<Cascades2: tree: TBP>>=
	procedure :: sort => tree_sort
	<<Cascades2: sub interfaces>>=
	module subroutine tree_sort (tree)
	class(tree_t), intent(inout) :: tree
	end subroutine tree_sort
	<<Cascades2: procedures>>=
	module subroutine tree_sort (tree)
	class(tree_t), intent(inout) :: tree
	integer(TC), dimension(size(tree%bc)) :: bc_tmp
	integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp
	integer, dimension(1) :: pos
	integer :: i
	bc_tmp = tree%bc
	pdg_tmp = tree%pdg
	mapping_tmp = tree%mapping
	do i = size(tree%bc),1,-1
	pos = maxloc (bc_tmp)
	tree%bc(i) = bc_tmp (pos(1))
	tree%pdg(i) = pdg_tmp (pos(1))
	tree%mapping(i) = mapping_tmp (pos(1))
	bc_tmp(pos(1)) = 0
	end do
	end subroutine tree_sort

	@ %def tree_sort
	@
	\subsection{Graph types}
	We define an abstract type which will give rise to two different types:
	The type [[feyngraph_t]] contains the pure information of the
	corresponding Feynman diagram, but also a list of objects of the
	[[kingraph]] type which contain the kinematically relevant data for the
	mapping calculation as well as the mappings themselves. Every graph
	should have an index which is unique. Graphs which are not needed any
	more can be disabled by setting the [[keep]] variable to [[false]].
	<<Cascades2: types>>=
	type, abstract :: graph_t
	integer :: index = 0
	integer :: n_nodes = 0
	logical :: keep = .true.
	end type graph_t

	@ %def graph_t
	@ This is the type representing the Feynman diagrams which are read from
	an input file created by O'Mega. It is a tree of nodes, which we call
	[[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of
	this tree, and each node can have two daughter nodes. The case of only
	one associated daughter should never appear, because in the method of
	phase space parametrization which is used here, we combine always two
	particle momenta to a third one. The [[feyngraphs]] will be arranged in
	a linked list. This is why we have a pointer to the next graph. The
	[[kingraphs]] on the other hand are arranged in linked lists which are
	attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]]
	can give rise to more than one [[kingraph]] because we make a copy
	every time a particle can be resonant, so that in the copy we keep
	the particle nonresonant.
	<<Cascades2: types>>=
	type, extends (graph_t) :: feyngraph_t
	type(string_t) :: omega_feyngraph_output
	type(f_node_t), pointer :: root => null ()
	type(feyngraph_t), pointer :: next => null()
	type(kingraph_t), pointer :: kin_first => null ()
	type(kingraph_t), pointer :: kin_last => null ()
	contains
	<<Cascades2: feyngraph: TBP>>
	end type feyngraph_t

	@ %def feyngraph_t
	@ A container for a pointer of type [[feyngraph_t]]. This is used to
	realize arrays of these pointers.
	<<Cascades2: types>>=
	type :: feyngraph_ptr_t
	type(feyngraph_t), pointer :: graph => null ()
	end type feyngraph_ptr_t

	@ %def feyngraph_ptr_t
	@
	The length of a string describing a Feynman diagram which is produced by
	O'Mega is fixed by the parameter
	<<Cascades2: parameters>>=
	integer, parameter :: FEYNGRAPH_LEN=300
	@ %def feyngraph_len
	<<Cascades2: feyngraph: TBP>>=
	procedure :: final => feyngraph_final
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_final (graph)
	class(feyngraph_t), intent(inout) :: graph
	end subroutine feyngraph_final
	<<Cascades2: procedures>>=
	module subroutine feyngraph_final (graph)
	class(feyngraph_t), intent(inout) :: graph
	type(kingraph_t), pointer :: current
	graph%root => null ()
	graph%kin_last => null ()
	do while (associated (graph%kin_first))
	current => graph%kin_first
	graph%kin_first => graph%kin_first%next
	call current%final ()
	deallocate (current)
	end do
	end subroutine feyngraph_final

	@ %def feyngraph_final
	This is the type of graph which is used to find the phase space channels,
	or in other words, each kingraph could correspond to a channel, if it is
	not eliminated for kinematical reasons or due to an equivalence. For the
	linked list which is attached to the corresponding [[feyngraph]], we
	need the [[next]] pointer, whereas [[grove_next]] points to the next
	[[kingraph]] within a grove. The information which is relevant for the
	specification of a channel is stored in [[tree]]. We use [[grove_prop]]
	to sort the [[kingraph]] in a grove in which all [[kingraphs]] are
	characterized by the numbers contained in [[grove_prop]]. Later these
	groves are further subdevided using the resonance hash. A [[kingraph]]
	which is constructed directly from the output of O'Mega, is not
	[[inverse]]. In this case the first incoming particle is the root ofthe
	tree. In a scattering process, we can also construct a [[kingraph]]
	where the root of the tree is the second incoming particle. In this
	case the value of [[inverse]] is [[.true.]].
	<<Cascades2: types>>=
	type, extends (graph_t) :: kingraph_t
	type(k_node_t), pointer :: root => null ()
	type(kingraph_t), pointer :: next => null()
	type(kingraph_t), pointer :: grove_next => null ()
	type(tree_t) :: tree
	type(grove_prop_t) :: grove_prop
	logical :: inverse = .false.
	integer :: prc_component = 0
	contains
	<<Cascades2: kingraph: TBP>>
	end type kingraph_t

	@ %def kingraph_t
	@ Another container for a pointer to emulate arrays of pointers:
	<<Cascades2: types>>=
	type :: kingraph_ptr_t
	type(kingraph_t), pointer :: graph => null ()
	end type kingraph_ptr_t

	@ %def kingraph_ptr_t
	@
	<<Cascades2: kingraph: TBP>>=
	procedure :: final => kingraph_final
	<<Cascades2: sub interfaces>>=
	module subroutine kingraph_final (graph)
	class(kingraph_t), intent(inout) :: graph
	end subroutine kingraph_final
	<<Cascades2: procedures>>=
	module subroutine kingraph_final (graph)
	class(kingraph_t), intent(inout) :: graph
	graph%root => null ()
	graph%next => null ()
	graph%grove_next => null ()
	call graph%tree%final ()
	end subroutine kingraph_final

	@ %def kingraph_final
	@
	\subsection{The node types}
	We define an abstract type containing variables which are needed for
	[[f_node_t]] as well as [[k_node_t]]. We say that a node is on the
	t-line if it lies between the two nodes which correspond to the two
	incoming particles. [[incoming]] and [[tline]] are used only for
	scattering processes and remain [[.false.]] in decay processes. The
	variable [[n_subtree_nodes]] holds the number of nodes (including the
	node itself) of the subtree of which the node is the root.
	<<Cascades2: types>>=
	type, abstract :: node_t
	type(part_prop_t), pointer :: particle => null ()
	logical :: incoming = .false.
	logical :: t_line = .false.
	integer :: index = 0
	logical :: keep = .true.
	integer :: n_subtree_nodes = 1
	end type node_t

	@ %def node_t
	@ We use two different list types for the different kinds of nodes. We
	therefore start with an abstract type:
	<<Cascades2: types>>=
	type, abstract :: list_t
	integer :: n_entries = 0
	end type list_t

	@ %def list_t
	@ Since the contents of the lists are different, we introduce two
	different entry types. Since the trees of nodes use pointers, the nodes
	should only be allocated by a type-bound procedure of the corresponding
	list type, such that we can keep track of all nodes, eventually reuse
	and in the end deallocate nodes correctly, without forgetting any nodes.
	Here is the type for the [[k_nodes]]. The list is a linked list. We want
	to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore
	[[t_line]].
	<<Cascades2: types>>=
	type :: k_node_entry_t
	type(k_node_t), pointer :: node => null ()
	type(k_node_entry_t), pointer :: next => null ()
	logical :: recycle = .false.
	contains
	<<Cascades2: k node entry: TBP>>
	end type k_node_entry_t

	@ %def k_node_entry_t
	<<Cascades2: k node entry: TBP>>=
	procedure :: final => k_node_entry_final
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_entry_final (entry)
	class(k_node_entry_t), intent(inout) :: entry
	end subroutine k_node_entry_final
	<<Cascades2: procedures>>=
	module subroutine k_node_entry_final (entry)
	class(k_node_entry_t), intent(inout) :: entry
	if (associated (entry%node)) then
	call entry%node%final
	deallocate (entry%node)
	end if
	entry%next => null ()
	end subroutine k_node_entry_final

	@ %def k_node_entry_final
	<<Cascades2: k node entry: TBP>>=
	procedure :: write => k_node_entry_write
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_entry_write (k_node_entry, u)
	class(k_node_entry_t), intent(in) :: k_node_entry
	integer, intent(in) :: u
	end subroutine k_node_entry_write
	<<Cascades2: procedures>>=
	module subroutine k_node_entry_write (k_node_entry, u)
	class(k_node_entry_t), intent(in) :: k_node_entry
	integer, intent(in) :: u
	end subroutine k_node_entry_write

	@ %def k_node_entry_write
	@ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be
	declared to be an observer. In this case it does not create any nodes by
	itself, but the entries set their pointers to existing nodes. In this
	way we can use the list structure and the type bound procedures for
	existing nodes.
	<<Cascades2: types>>=
	type, extends (list_t) :: k_node_list_t
	type(k_node_entry_t), pointer :: first => null ()
	type(k_node_entry_t), pointer :: last => null ()
	integer :: n_recycle
	logical :: observer = .false.
	contains
	<<Cascades2: k node list: TBP>>
	end type k_node_list_t

	@ %def k_node_list_t
	<<Cascades2: k node list: TBP>>=
	procedure :: final => k_node_list_final
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_list_final (list)
	class(k_node_list_t), intent(inout) :: list
	end subroutine k_node_list_final
	<<Cascades2: procedures>>=
	module subroutine k_node_list_final (list)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_entry_t), pointer :: current
	do while (associated (list%first))
	current => list%first
	list%first => list%first%next
	if (list%observer) current%node => null ()
	call current%final ()
	deallocate (current)
	end do
	end subroutine k_node_list_final

	@ %def k_node_list_final
	@ The [[f_node_t]] type contains the [[particle_label]] variable which is
	extracted from the input file. It consists not only of the particle
	name, but also of some numbers in brackets. These numbers indicate which
	external particles are part of the subtree of this node. The [[f_node]]
	contains also a list of [[k_nodes]]. Therefore, if the nodes are not
	[[incoming]] or [[t_line]], the mapping calculations for these
	[[k_nodes]] which can appear in several [[kingraphs]] have to be
	performed only once.
	<<Cascades2: types>>=
	type, extends (node_t) :: f_node_t
	type(f_node_t), pointer :: daughter1 => null ()
	type(f_node_t), pointer :: daughter2 => null ()
	character(len=LABEL_LEN) :: particle_label
	type(k_node_list_t) :: k_node_list
	contains
	<<Cascades2: f node: TBP>>
	end type f_node_t

	@ %def f_node_t
	@ The finalizer nullifies the daughter pointers, since they are
	deallocated, like the [[f_node]] itself, with the finalizer of the
	[[f_node_list]].
	<<Cascades2: f node: TBP>>=
	procedure :: final => f_node_final
	<<Cascades2: sub interfaces>>=
	recursive module subroutine f_node_final (node)
	class(f_node_t), intent(inout) :: node
	end subroutine f_node_final
	<<Cascades2: procedures>>=
	recursive module subroutine f_node_final (node)
	class(f_node_t), intent(inout) :: node
	call node%k_node_list%final ()
	node%daughter1 => null ()
	node%daughter2 => null ()
	end subroutine f_node_final

	@ %def f_node_final
	@ Finaliser for [[f_node_entry]].
	<<Cascades2: f node entry: TBP>>=
	procedure :: final => f_node_entry_final
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_entry_final (entry)
	class(f_node_entry_t), intent(inout) :: entry
	end subroutine f_node_entry_final
	<<Cascades2: procedures>>=
	module subroutine f_node_entry_final (entry)
	class(f_node_entry_t), intent(inout) :: entry
	if (associated (entry%node)) then
	call entry%node%final ()
	deallocate (entry%node)
	end if
	entry%next => null ()
	end subroutine f_node_entry_final

	@ %def f_node_entry_final
	@ Set index if not yet done, i.e. if it is zero.
	<<Cascades2: f node: TBP>>=
	procedure :: set_index => f_node_set_index
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_set_index (f_node)
	class(f_node_t), intent(inout) :: f_node
	end subroutine f_node_set_index
	<<Cascades2: procedures>>=
	module subroutine f_node_set_index (f_node)
	class(f_node_t), intent(inout) :: f_node
	integer, save :: counter = 0
	if (f_node%index == 0) then
	counter = counter + 1
	f_node%index = counter
	end if
	end subroutine f_node_set_index

	@ %def f_node_set_index
	@
	Type for the nodes of the tree (lines of the Feynman diagrams). We
	also need a type containing a pointer to a node, which is needed for
	creating arrays of pointers. This will be used for scattering
	processes where we can take either the first or the second particle to
	be the root of the tree. Since we need both cases for the calculations
	and O'Mega only gives us one of these, we have to perform a
	transformation of the graph in which some nodes (on the line which we
	hereafter call t-line) need to know their mother and sister nodes,
	which become their daughters within this transformation.
	<<Cascades2: types>>=
	type :: f_node_ptr_t
	type(f_node_t), pointer :: node => null ()
	contains
	<<Cascades2: f node ptr: TBP>>
	end type f_node_ptr_t

	@ %def f_node_ptr_t
	<<Cascades2: f node ptr: TBP>>=
	procedure :: final => f_node_ptr_final
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_ptr_final (f_node_ptr)
	class(f_node_ptr_t), intent(inout) :: f_node_ptr
	end subroutine f_node_ptr_final
	<<Cascades2: procedures>>=
	module subroutine f_node_ptr_final (f_node_ptr)
	class(f_node_ptr_t), intent(inout) :: f_node_ptr
	f_node_ptr%node => null ()
	end subroutine f_node_ptr_final

	@ %def f_node_ptr_final
	<<Cascades2: interfaces>>=
	interface assignment (=)
	module procedure f_node_ptr_assign
	end interface assignment (=)
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_ptr_assign (ptr1, ptr2)
	type(f_node_ptr_t), intent(out) :: ptr1
	type(f_node_ptr_t), intent(in) :: ptr2
	end subroutine f_node_ptr_assign
	<<Cascades2: procedures>>=
	module subroutine f_node_ptr_assign (ptr1, ptr2)
	type(f_node_ptr_t), intent(out) :: ptr1
	type(f_node_ptr_t), intent(in) :: ptr2
	ptr1%node => ptr2%node
	end subroutine f_node_ptr_assign

	@ %def f_node_ptr_assign
	@
	<<Cascades2: types>>=
	type :: k_node_ptr_t
	type(k_node_t), pointer :: node => null ()
	end type k_node_ptr_t

	@ %def k_node_ptr_t
	@
	<<Cascades2: types>>=
	type, extends (node_t) :: k_node_t
	type(k_node_t), pointer :: daughter1 => null ()
	type(k_node_t), pointer :: daughter2 => null ()
	type(k_node_t), pointer :: inverse_daughter1 => null ()
	type(k_node_t), pointer :: inverse_daughter2 => null ()
	type(f_node_t), pointer :: f_node => null ()
	type(tree_t) :: subtree
	real (default) :: ext_mass_sum = 0.
	real (default) :: effective_mass = 0.
	logical :: resonant = .false.
	logical :: on_shell = .false.
	logical :: log_enhanced = .false.
	integer :: mapping = NO_MAPPING
	integer(TC) :: bincode = 0
	logical :: mapping_assigned = .false.
	logical :: is_nonresonant_copy = .false.
	logical :: subtree_checked = .false.
	integer :: n_off_shell = 0
	integer :: n_log_enhanced = 0
	integer :: n_resonances = 0
	integer :: multiplicity = 0
	integer :: n_t_channel = 0
	integer :: f_node_index = 0
	contains
	<<Cascades2: k node: TBP>>
	end type k_node_t

	@ %def k_node_t
	@
	Subroutine for [[k_node]] assignment.
	<<Cascades2: interfaces>>=
	interface assignment (=)
	module procedure k_node_assign
	end interface assignment (=)
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_assign (k_node1, k_node2)
	type(k_node_t), intent(inout) :: k_node1
	type(k_node_t), intent(in) :: k_node2
	end subroutine k_node_assign
	<<Cascades2: procedures>>=
	module subroutine k_node_assign (k_node1, k_node2)
	type(k_node_t), intent(inout) :: k_node1
	type(k_node_t), intent(in) :: k_node2
	k_node1%f_node => k_node2%f_node
	k_node1%particle => k_node2%particle
	k_node1%incoming = k_node2%incoming
	k_node1%t_line = k_node2%t_line
	k_node1%keep = k_node2%keep
	k_node1%n_subtree_nodes = k_node2%n_subtree_nodes
	k_node1%ext_mass_sum = k_node2%ext_mass_sum
	k_node1%effective_mass = k_node2%effective_mass
	k_node1%resonant = k_node2%resonant
	k_node1%on_shell = k_node2%on_shell
	k_node1%log_enhanced = k_node2%log_enhanced
	k_node1%mapping = k_node2%mapping
	k_node1%bincode = k_node2%bincode
	k_node1%mapping_assigned = k_node2%mapping_assigned
	k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy
	k_node1%n_off_shell = k_node2%n_off_shell
	k_node1%n_log_enhanced = k_node2%n_log_enhanced
	k_node1%n_resonances = k_node2%n_resonances
	k_node1%multiplicity = k_node2%multiplicity
	k_node1%n_t_channel = k_node2%n_t_channel
	k_node1%f_node_index = k_node2%f_node_index
	end subroutine k_node_assign

	@ %def k_node_assign
	@ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the
	deallocation of these nodes takes place in the finalizer of the list by which
	they were created.
	<<Cascades2: k node: TBP>>=
	procedure :: final => k_node_final
	<<Cascades2: sub interfaces>>=
	recursive module subroutine k_node_final (k_node)
	class(k_node_t), intent(inout) :: k_node
	end subroutine k_node_final
	<<Cascades2: procedures>>=
	recursive module subroutine k_node_final (k_node)
	class(k_node_t), intent(inout) :: k_node
	k_node%daughter1 => null ()
	k_node%daughter2 => null ()
	k_node%inverse_daughter1 => null ()
	k_node%inverse_daughter2 => null ()
	k_node%f_node => null ()
	end subroutine k_node_final

	@ %def k_node_final
	@ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The
	indices are simply positive integer numbers starting from 1.
	<<Cascades2: k node: TBP>>=
	procedure :: set_index => k_node_set_index
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_set_index (k_node)
	class(k_node_t), intent(inout) :: k_node
	end subroutine k_node_set_index
	<<Cascades2: procedures>>=
	module subroutine k_node_set_index (k_node)
	class(k_node_t), intent(inout) :: k_node
	integer, save :: counter = 0
	if (k_node%index == 0) then
	counter = counter + 1
	k_node%index = counter
	end if
	end subroutine k_node_set_index

	@ %def k_node_set_index
	@ The process type (decay or scattering) is given by an integer which is
	equal to the number of incoming particles.
	<<Cascades2: public>>=
	public :: DECAY, SCATTERING
	<<Cascades2: parameters>>=
	integer, parameter :: DECAY=1, SCATTERING=2

	@ %def decay scattering
	@ The entries of the [[f_node_list]] contain the substring of the input
	file from which the node's subtree will be constructed (or a modified
	string containing placeholders for substrings). We use the
	length of this string for fast comparison to find the nodes in the
	[[f_node_list]] which we want to reuse.
	<<Cascades2: types>>=
	type :: f_node_entry_t
	character(len=FEYNGRAPH_LEN) :: subtree_string
	integer :: string_len = 0
	type(f_node_t), pointer :: node => null ()
	type(f_node_entry_t), pointer :: next => null ()
	integer :: subtree_size = 0
	contains
	<<Cascades2: f node entry: TBP>>
	end type f_node_entry_t

	@ %def f_node_entry_t
	@ A write method for [[f_node_entry]].
	<<Cascades2: f node entry: TBP>>=
	procedure :: write => f_node_entry_write
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_entry_write (f_node_entry, u)
	class(f_node_entry_t), intent(in) :: f_node_entry
	integer, intent(in) :: u
	end subroutine f_node_entry_write
	<<Cascades2: procedures>>=
	module subroutine f_node_entry_write (f_node_entry, u)
	class(f_node_entry_t), intent(in) :: f_node_entry
	integer, intent(in) :: u
	write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string)
	end subroutine f_node_entry_write

	@ %def f_node_entry_write
	<<Cascades2: interfaces>>=
	interface assignment (=)
	module procedure f_node_entry_assign
	end interface assignment (=)
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_entry_assign (entry1, entry2)
	type(f_node_entry_t), intent(out) :: entry1
	type(f_node_entry_t), intent(in) :: entry2
	end subroutine f_node_entry_assign
	<<Cascades2: procedures>>=
	module subroutine f_node_entry_assign (entry1, entry2)
	type(f_node_entry_t), intent(out) :: entry1
	type(f_node_entry_t), intent(in) :: entry2
	entry1%node => entry2%node
	entry1%subtree_string = entry2%subtree_string
	entry1%string_len = entry2%string_len
	entry1%subtree_size = entry2%subtree_size
	end subroutine f_node_entry_assign

	@ %def f_node_entry_assign
	@ This is the list type for [[f_nodes]]. The variable [[max_tree_size]]
	is the number of nodes which appear in a complete graph.
	<<Cascades2: types>>=
	type, extends (list_t) :: f_node_list_t
	type(f_node_entry_t), pointer :: first => null ()
	type(f_node_entry_t), pointer :: last => null ()
	type(k_node_list_t), pointer :: k_node_list => null ()
	integer :: max_tree_size = 0
	contains
	<<Cascades2: f node list: TBP>>
	end type f_node_list_t

	@ %def f_node_list_t
	@ Add an entry to the [[f_node_list]]. If the node might be reused, we check first
	using the [[subtree_string]] if there is already a node in the list which
	is the root of exactly the same subtree. Otherwise we add an entry to the
	list and allocate the node. In both cases we return a pointer to the node
	which allows to access the node.
	<<Cascades2: f node list: TBP>>=
	procedure :: add_entry => f_node_list_add_entry
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_list_add_entry (list, subtree_string, &
	ptr_to_node, recycle, subtree_size)
	class(f_node_list_t), intent(inout) :: list
	character(len=*), intent(in) :: subtree_string
	type(f_node_t), pointer, intent(out) :: ptr_to_node
	logical, intent(in) :: recycle
	integer, intent(in), optional :: subtree_size
	end subroutine f_node_list_add_entry
	<<Cascades2: procedures>>=
	module subroutine f_node_list_add_entry (list, subtree_string, &
	ptr_to_node, recycle, subtree_size)
	class(f_node_list_t), intent(inout) :: list
	character(len=*), intent(in) :: subtree_string
	type(f_node_t), pointer, intent(out) :: ptr_to_node
	logical, intent(in) :: recycle
	integer, intent(in), optional :: subtree_size
	type(f_node_entry_t), pointer :: current
	type(f_node_entry_t), pointer :: second
	integer :: subtree_len
	ptr_to_node => null ()
	if (recycle) then
	subtree_len = len_trim (subtree_string)
	current => list%first
	do while (associated (current))
	if (present (subtree_size)) then
	if (current%subtree_size /= subtree_size) exit
	end if
	if (current%string_len == subtree_len) then
	if (trim (current%subtree_string) == trim (subtree_string)) then
	ptr_to_node => current%node
	exit
	end if
	end if
	current => current%next
	end do
	end if
	if (.not. associated (ptr_to_node)) then
	if (list%n_entries == 0) then
	allocate (list%first)
	list%last => list%first
	else
	second => list%first
	list%first => null ()
	allocate (list%first)
	list%first%next => second
	end if
	list%n_entries = list%n_entries + 1
	list%first%subtree_string = trim(subtree_string)
	list%first%string_len = subtree_len
	if (present (subtree_size)) list%first%subtree_size = subtree_size
	allocate (list%first%node)
	call list%first%node%set_index ()
	ptr_to_node => list%first%node
	end if
	end subroutine f_node_list_add_entry

	@ %def f_node_list_add_entry
	@ A write method for debugging.
	<<Cascades2: f node list: TBP>>=
	procedure :: write => f_node_list_write
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_list_write (f_node_list, u)
	class(f_node_list_t), intent(in) :: f_node_list
	integer, intent(in) :: u
	end subroutine f_node_list_write
	<<Cascades2: procedures>>=
	module subroutine f_node_list_write (f_node_list, u)
	class(f_node_list_t), intent(in) :: f_node_list
	integer, intent(in) :: u
	type(f_node_entry_t), pointer :: current
	integer :: pos = 0
	current => f_node_list%first
	do while (associated (current))
	pos = pos + 1
	write (unit=u, fmt='(A,I10)') 'entry #: ', pos
	call current%write (u)
	write (unit=u, fmt=*)
	current => current%next
	end do
	end subroutine f_node_list_write

	@ %def f_node_list_write
	<<Cascades2: interfaces>>=
	interface assignment (=)
	module procedure k_node_entry_assign
	end interface assignment (=)
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_entry_assign (entry1, entry2)
	type(k_node_entry_t), intent(out) :: entry1
	type(k_node_entry_t), intent(in) :: entry2
	end subroutine k_node_entry_assign
	<<Cascades2: procedures>>=
	module subroutine k_node_entry_assign (entry1, entry2)
	type(k_node_entry_t), intent(out) :: entry1
	type(k_node_entry_t), intent(in) :: entry2
	entry1%node => entry2%node
	entry1%recycle = entry2%recycle
	end subroutine k_node_entry_assign

	@ %def k_node_entry_assign
	@ Add an entry to the [[k_node_list]]. We have to specify if the
	node can be reused. The check for existing reusable nodes happens with
	[[k_node_list_get_nodes]] (see below).
	<<Cascades2: k node list: TBP>>=
	procedure :: add_entry => k_node_list_add_entry
	<<Cascades2: sub interfaces>>=
	recursive module subroutine k_node_list_add_entry &
	(list, ptr_to_node, recycle)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_t), pointer, intent(out) :: ptr_to_node
	logical, intent(in) :: recycle
	end subroutine k_node_list_add_entry
	<<Cascades2: procedures>>=
	recursive module subroutine k_node_list_add_entry &
	(list, ptr_to_node, recycle)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_t), pointer, intent(out) :: ptr_to_node
	logical, intent(in) :: recycle
	if (list%n_entries == 0) then
	allocate (list%first)
	list%last => list%first
	else
	allocate (list%last%next)
	list%last => list%last%next
	end if
	list%n_entries = list%n_entries + 1
	list%last%recycle = recycle
	allocate (list%last%node)
	call list%last%node%set_index ()
	ptr_to_node => list%last%node
	end subroutine k_node_list_add_entry

	@ %def k_node_list_add_entry
	@ We need a similar subroutine for adding only a pointer to a list. This
	is needed for a [[k_node_list]] which is only an observer, i.e. it does
	not create any nodes by itself.
	<<Cascades2: k node list: TBP>>=
	procedure :: add_pointer => k_node_list_add_pointer
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_t), pointer, intent(in) :: ptr_to_node
	logical, optional, intent(in) :: recycle
	end subroutine k_node_list_add_pointer
	<<Cascades2: procedures>>=
	module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_t), pointer, intent(in) :: ptr_to_node
	logical, optional, intent(in) :: recycle
	logical :: rec
	if (present (recycle)) then
	rec = recycle
	else
	rec = .false.
	end if
	if (list%n_entries == 0) then
	allocate (list%first)
	list%last => list%first
	else
	allocate (list%last%next)
	list%last => list%last%next
	end if
	list%n_entries = list%n_entries + 1
	list%last%recycle = rec
	list%last%node => ptr_to_node
	end subroutine k_node_list_add_pointer

	@ %def k_node_list_add_pointer
	@ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to
	different [[f_nodes]] in order to compare these. This is done only for nodes
	which have the same number of subtree nodes. We compare all nodes of the
	list with each other (as long as the node is not deactivated, i.e. if
	the [[keep]] variable is set to [[.true.]]) using the subroutine
	[[subtree_select]]. If it turns out that two nodes are equivalent, we
	keep only one of them. The term equivalent in this module refers to trees
	or subtrees which differ in the pdg codes at positions where
	the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that
	the mass of the particle does not matter. Depending on the available
	couplings, two equivalent subtrees could eventually lead to the same phase
	space channels, which is why only one of them is kept.
	<<Cascades2: k node list: TBP>>=
	procedure :: check_subtree_equivalences => &
	k_node_list_check_subtree_equivalences
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_list_check_subtree_equivalences (list, model)
	class(k_node_list_t), intent(inout) :: list
	type(model_data_t), intent(in) :: model
	end subroutine k_node_list_check_subtree_equivalences
	<<Cascades2: procedures>>=
	module subroutine k_node_list_check_subtree_equivalences (list, model)
	class(k_node_list_t), intent(inout) :: list
	type(model_data_t), intent(in) :: model
	type(k_node_ptr_t), dimension (:), allocatable :: set
	type(k_node_entry_t), pointer :: current
	integer :: pos
	integer :: i,j
	if (list%n_entries == 0) return
	allocate (set (list%n_entries))
	current => list%first
	pos = 0
	do while (associated (current))
	pos = pos + 1
	set(pos)%node => current%node
	current => current%next
	end do
	do i=1, list%n_entries
	if (set(i)%node%keep) then
	do j=i+1, list%n_entries
	if (set(j)%node%keep) then
	if (set(i)%node%bincode == set(j)%node%bincode) then
	call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model)
	if (.not. set(i)%node%subtree%keep) then
	set(i)%node%keep = .false.
	exit
	else if (.not. set(j)%node%subtree%keep) then
	set(j)%node%keep = .false.
	end if
	end if
	end if
	end do
	end if
	end do
	deallocate (set)
	end subroutine k_node_list_check_subtree_equivalences

	@ %def k_node_list_check_subtree_equivalences
	@ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]]
	which can be recycled and are not disabled for some reason. We pass an
	allocatable array of the type [[k_node_ptr_t]] which will be allocated
	if there are any such nodes in the list and the pointers will be
	associated with these nodes.
	<<Cascades2: k node list: TBP>>=
	procedure :: get_nodes => k_node_list_get_nodes
	<<Cascades2: sub interfaces>>=
	module subroutine k_node_list_get_nodes (list, nodes)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes
	end subroutine k_node_list_get_nodes
	<<Cascades2: procedures>>=
	module subroutine k_node_list_get_nodes (list, nodes)
	class(k_node_list_t), intent(inout) :: list
	type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes
	integer :: n_nodes
	integer :: pos
	type(k_node_entry_t), pointer :: current, garbage
	n_nodes = 0
	current => list%first
	do while (associated (current))
	if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1
	current => current%next
	end do
	if (n_nodes /= 0) then
	pos = 1
	allocate (nodes (n_nodes))
	do while (associated (list%first) .and. .not. list%first%node%keep)
	garbage => list%first
	list%first => list%first%next
	call garbage%final ()
	deallocate (garbage)
	end do
	current => list%first
	do while (associated (current))
	do while (associated (current%next))
	if (.not. current%next%node%keep) then
	garbage => current%next
	current%next => current%next%next
	call garbage%final
	deallocate (garbage)
	else
	exit
	end if
	end do
	if (current%recycle .and. current%node%keep) then
	nodes(pos)%node => current%node
	pos = pos + 1
	end if
	current => current%next
	end do
	end if
	end subroutine k_node_list_get_nodes

	@ %def k_node_list_get_nodes
	Gfortran 7/8/9 bug, has to remain in the main module:
	<<Cascades2: f node list: TBP>>=
	procedure :: final => f_node_list_final
	<<Cascades2: main procedures>>=
	subroutine f_node_list_final (list)
	class(f_node_list_t) :: list
	type(f_node_entry_t), pointer :: current
	list%k_node_list => null ()
	do while (associated (list%first))
	current => list%first
	list%first => list%first%next
	call current%final ()
	deallocate (current)
	end do
	end subroutine f_node_list_final

	@ %def f_node_list_final
	@
	\subsection{The grove list}
	First a type is introduced in order to speed up the comparison of kingraphs
	with the purpose to quickly find the graphs that might be equivalent.
	This is done solely on the basis of a number (which is given
	by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are
	the highest ones that do not belong to external particles.
	The highest such value determines the index of the element in the [[entry]]
	array of the [[compare_tree]]. The next lower such value determines
	the index of the element in the [[entry]] array of this [[entry]], and so
	on and so forth. This results in a tree structure where the number of
	levels is given by [[depth]] and should not be too large for reasons of
	memory.
	This is the entry type.
	<<Cascades2: types>>=
	type :: compare_tree_entry_t
	type(compare_tree_entry_t), dimension(:), pointer :: entry => null ()
	type(kingraph_ptr_t), dimension(:), allocatable :: graph_entry
	contains
	<<Cascades2: compare tree entry: TBP>>
	end type compare_tree_entry_t

	@ %def compare_tree_entry_t
	@ This is the tree type.
	<<Cascades2: types>>=
	type :: compare_tree_t
	integer :: depth = 3
	type(compare_tree_entry_t), dimension(:), pointer :: entry => null ()
	contains
	<<Cascades2: compare tree: TBP>>
	end type compare_tree_t

	@ %def compare_tree_t
	@ Finalizers for both types. The one for the entry type has to be recursive.
	<<Cascades2: compare tree: TBP>>=
	procedure :: final => compare_tree_final
	<<Cascades2: sub interfaces>>=
	module subroutine compare_tree_final (ctree)
	class(compare_tree_t), intent(inout) :: ctree
	end subroutine compare_tree_final
	<<Cascades2: procedures>>=
	module subroutine compare_tree_final (ctree)
	class(compare_tree_t), intent(inout) :: ctree
	integer :: i
	if (associated (ctree%entry)) then
	do i=1, size (ctree%entry)
	call ctree%entry(i)%final ()
	deallocate (ctree%entry)
	end do
	end if
	end subroutine compare_tree_final

	@ %def compare_tree_final
	<<Cascades2: compare tree entry: TBP>>=
	procedure :: final => compare_tree_entry_final
	<<Cascades2: sub interfaces>>=
	recursive module subroutine compare_tree_entry_final (ct_entry)
	class(compare_tree_entry_t), intent(inout) :: ct_entry
	end subroutine compare_tree_entry_final
	<<Cascades2: procedures>>=
	recursive module subroutine compare_tree_entry_final (ct_entry)
	class(compare_tree_entry_t), intent(inout) :: ct_entry
	integer :: i
	if (associated (ct_entry%entry)) then
	do i=1, size (ct_entry%entry)
	call ct_entry%entry(i)%final ()
	end do
	deallocate (ct_entry%entry)
	else
	deallocate (ct_entry%graph_entry)
	end if
	end subroutine compare_tree_entry_final

	@ %def compare_tree_entry_final
	@ Check the presence of a graph which is considered as equivalent and
	select between the two. If there is no such graph, the current one
	is added to the list. First the entry has to be found:
	<<Cascades2: compare tree: TBP>>=
	procedure :: check_kingraph => compare_tree_check_kingraph
	<<Cascades2: sub interfaces>>=
	module subroutine compare_tree_check_kingraph &
	(ctree, kingraph, model, preliminary)
	class(compare_tree_t), intent(inout) :: ctree
	type(kingraph_t), intent(inout), pointer :: kingraph
	type(model_data_t), intent(in) :: model
	logical, intent(in) :: preliminary
	end subroutine compare_tree_check_kingraph
	<<Cascades2: procedures>>=
	module subroutine compare_tree_check_kingraph &
	(ctree, kingraph, model, preliminary)
	class(compare_tree_t), intent(inout) :: ctree
	type(kingraph_t), intent(inout), pointer :: kingraph
	type(model_data_t), intent(in) :: model
	logical, intent(in) :: preliminary
	integer :: i
	integer :: pos
	integer(TC) :: sz
	integer(TC), dimension(:), allocatable :: identifier
	if (.not. associated (ctree%entry)) then
	sz = 0_TC
	do i = size(kingraph%tree%bc), 1, -1
	sz = ior (sz, kingraph%tree%bc(i))
	end do
	if (sz > 0) then
	allocate (ctree%entry (sz))
	else
	call msg_bug ("Compare tree could not be created")
	end if
	end if
	allocate (identifier (ctree%depth))
	pos = 0
	do i = size(kingraph%tree%bc), 1, -1
	if (popcnt (kingraph%tree%bc(i)) /= 1) then
	pos = pos + 1
	identifier(pos) = kingraph%tree%bc(i)
	if (pos == ctree%depth) exit
	end if
	end do
	if (size (identifier) > 1) then
	call ctree%entry(identifier(1))%check_kingraph (kingraph, model, &
	preliminary, identifier(1), identifier(2:))
	else if (size (identifier) == 1) then
	call ctree%entry(identifier(1))%check_kingraph &
	(kingraph, model, preliminary)
	end if
	deallocate (identifier)
	end subroutine compare_tree_check_kingraph

	@ %def compare_tree_check_kingraph
	@ Then the graphs of the entry are checked.
	<<Cascades2: compare tree entry: TBP>>=
	procedure :: check_kingraph => compare_tree_entry_check_kingraph
	<<Cascades2: sub interfaces>>=
	recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, &
	kingraph, model, preliminary, subtree_size, identifier)
	class(compare_tree_entry_t), intent(inout) :: ct_entry
	type(kingraph_t), pointer, intent(inout) :: kingraph
	type(model_data_t), intent(in) :: model
	logical, intent(in) :: preliminary
	integer, intent(in), optional :: subtree_size
	integer, dimension (:), intent(in), optional :: identifier
	end subroutine compare_tree_entry_check_kingraph
	<<Cascades2: procedures>>=
	recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, &
	kingraph, model, preliminary, subtree_size, identifier)
	class(compare_tree_entry_t), intent(inout) :: ct_entry
	type(kingraph_t), pointer, intent(inout) :: kingraph
	type(model_data_t), intent(in) :: model
	logical, intent(in) :: preliminary
	integer, intent(in), optional :: subtree_size
	integer, dimension (:), intent(in), optional :: identifier
	if (present (identifier)) then
	if (.not. associated (ct_entry%entry)) &
	allocate (ct_entry%entry(subtree_size))
	if (size (identifier) > 1) then
	call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
	model, preliminary, identifier(1), identifier(2:))
	else if (size (identifier) == 1) then
	call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
	model, preliminary)
	end if
	else
	if (allocated (ct_entry%graph_entry)) then
	call perform_check
	else
	allocate (ct_entry%graph_entry(1))
	ct_entry%graph_entry(1)%graph => kingraph
	end if
	end if

	contains

	subroutine perform_check
	integer :: i
	logical :: rebuild
	rebuild = .true.
	do i=1, size(ct_entry%graph_entry)
	if (ct_entry%graph_entry(i)%graph%keep) then
	if (preliminary .or. &
	ct_entry%graph_entry(i)%graph%prc_component /= &
	kingraph%prc_component) then
	call kingraph_select (ct_entry%graph_entry(i)%graph, &
	kingraph, model, preliminary)
	if (.not. kingraph%keep) then
	return
	else if (rebuild .and. .not. &
	ct_entry%graph_entry(i)%graph%keep) then
	ct_entry%graph_entry(i)%graph => kingraph
	rebuild = .false.
	end if
	end if
	end if
	end do
	if (rebuild) call rebuild_graph_entry
	end subroutine perform_check

	subroutine rebuild_graph_entry
	type(kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr
	integer :: i
	integer :: pos
	allocate (tmp_ptr(size(ct_entry%graph_entry)+1))
	pos = 0
	do i=1, size(ct_entry%graph_entry)
	pos = pos + 1
	tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph
	end do
	pos = pos + 1
	tmp_ptr(pos)%graph => kingraph
	deallocate (ct_entry%graph_entry)
	allocate (ct_entry%graph_entry (pos))
	do i=1, pos
	ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph
	end do
	deallocate (tmp_ptr)
	end subroutine rebuild_graph_entry
	end subroutine compare_tree_entry_check_kingraph

	@ %def compare_tree_entry_check_kingraph
	@ The grove to which a completed [[kingraph]] will be added is determined by the
	entries of [[grove_prop]]. We use another list type (linked list) to
	arrange the groves. Each [[grove]] contains again a linked list of
	[[kingraphs]].
	<<Cascades2: types>>=
	type :: grove_t
	type(grove_prop_t) :: grove_prop
	type(grove_t), pointer :: next => null ()
	type(kingraph_t), pointer :: first => null ()
	type(kingraph_t), pointer :: last => null ()
	type(compare_tree_t) :: compare_tree
	contains
	<<Cascades2: grove: TBP>>
	end type grove_t

	@ %def grove_t
	@ Container for a pointer of type [[grove_t]]:
	<<Cascades2: types>>=
	type :: grove_ptr_t
	type(grove_t), pointer :: grove => null ()
	end type grove_ptr_t

	@ %def grove_ptr_t
	<<Cascades2: grove: TBP>>=
	procedure :: final => grove_final
	<<Cascades2: sub interfaces>>=
	module subroutine grove_final (grove)
	class(grove_t), intent(inout) :: grove
	end subroutine grove_final
	<<Cascades2: procedures>>=
	module subroutine grove_final (grove)
	class(grove_t), intent(inout) :: grove
	grove%first => null ()
	grove%last => null ()
	grove%next => null ()
	end subroutine grove_final

	@ %def grove_final
	@ This is the list type:
	<<Cascades2: types>>=
	type :: grove_list_t
	type(grove_t), pointer :: first => null ()
	contains
	<<Cascades2: grove list: TBP>>
	end type grove_list_t

	@ %def grove_list_t
	Gfortran 7/8/9 bug, has to remain in the main module:
	<<Cascades2: grove list: TBP>>=
	procedure :: final => grove_list_final
	<<Cascades2: main procedures>>=
	subroutine grove_list_final (list)
	class(grove_list_t), intent(inout) :: list
	class(grove_t), pointer :: current
	do while (associated (list%first))
	current => list%first
	list%first => list%first%next
	call current%final ()
	deallocate (current)
	end do
	end subroutine grove_list_final

	@ %def grove_list_final
	@
	\subsection{The feyngraph set}
	The fundament of the module is the public type [[feyngraph_set_t]]. It
	is not only a linked list of all [[feyngraphs]] but contains an array
	of all particle properties ([[particle]]), an [[f_node_list]] and a
	pointer of the type [[grove_list_t]], since several [[feyngraph_sets]]
	can share a common [[grove_list]]. In addition it keeps the data which
	unambiguously specifies the process, as well as the model which
	provides information which allows us to choose between equivalent
	subtrees or complete [[kingraphs]].
	<<Cascades2: public>>=
	public :: feyngraph_set_t
	<<Cascades2: types>>=
	type :: feyngraph_set_t
	type(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(:,:), allocatable :: flv
	integer :: n_in = 0
	integer :: n_out = 0
	integer :: process_type = DECAY
	type(phs_parameters_t) :: phs_par
	logical :: fatal_beam_decay = .true.
	type(part_prop_t), dimension (:), pointer :: particle => null ()
	type(f_node_list_t) :: f_node_list
	type(feyngraph_t), pointer :: first => null ()
	type(feyngraph_t), pointer :: last => null ()
	integer :: n_graphs = 0
	type(grove_list_t), pointer :: grove_list => null ()
	logical :: use_dag = .true.
	type(dag_t), pointer :: dag => null ()
	type(feyngraph_set_t), dimension (:), pointer :: fset => null ()
	contains
	<<Cascades2: feyngraph set: TBP>>
	end type feyngraph_set_t

	@ %def feyngraph_set_t
	@ This final procedure contains calls to all other necessary final
	procedures. Gfortran 7/8/9 bug, has to remain in the main module:
	<<Cascades2: feyngraph set: TBP>>=
	procedure :: final => feyngraph_set_final
	<<Cascades2: main procedures>>=
	recursive subroutine feyngraph_set_final (set)
	class(feyngraph_set_t), intent(inout) :: set
	class(feyngraph_t), pointer :: current
	integer :: i
	if (associated (set%fset)) then
	do i=1, size (set%fset)
	call set%fset(i)%final ()
	end do
	deallocate (set%fset)
	else
	set%particle => null ()
	set%grove_list => null ()
	end if
	set%model => null ()
	if (allocated (set%flv)) deallocate (set%flv)
	set%last => null ()
	do while (associated (set%first))
	current => set%first
	set%first => set%first%next
	call current%final ()
	deallocate (current)
	end do
	if (associated (set%particle)) then
	do i = 1, size (set%particle)
	call set%particle(i)%final ()
	end do
	deallocate (set%particle)
	end if
	if (associated (set%grove_list)) then
	if (debug_on) call msg_debug (D_PHASESPACE, "grove_list: final")
	call set%grove_list%final ()
	deallocate (set%grove_list)
	end if
	if (debug_on) call msg_debug (D_PHASESPACE, "f_node_list: final")
	call set%f_node_list%final ()
	if (associated (set%dag)) then
	if (debug_on) call msg_debug (D_PHASESPACE, "dag: final")
	if (associated (set%dag)) then
	call set%dag%final ()
	deallocate (set%dag)
	end if
	end if
	end subroutine feyngraph_set_final

	@ %def feyngraph_set_final
	@
	\subsection{Construct the feyngraph set}
	We construct the [[feyngraph_set]] from an input file. Therefore we pass
	a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen
	depending on the value of [[use_dag]]. In the DAG output, which is the one
	that is produced by default, we have to work on a string of one line,
	where the lenght of this string becomes larger the more particles are
	involved in the process. The other output (which is now only used in a
	unit test) contains one Feynman diagram per line and each line starts with an open
	parenthesis so that we read the file line per line and create a
	[[feyngraph]] for every line. Only after this, nodes are created. In both
	decay and scattering processes the diagrams are represented like in a decay
	process, i.e. in a scattering process one of the incoming particles appears
	as an outgoing particle.
	<<Cascades2: feyngraph set: TBP>>=
	procedure :: build => feyngraph_set_build
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_build (feyngraph_set, u_in)
	class(feyngraph_set_t), intent(inout) :: feyngraph_set
	integer, intent(in) :: u_in
	end subroutine feyngraph_set_build
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_build (feyngraph_set, u_in)
	class(feyngraph_set_t), intent(inout) :: feyngraph_set
	integer, intent(in) :: u_in
	integer :: stat = 0
	character(len=FEYNGRAPH_LEN) :: omega_feyngraph_output
	type(feyngraph_t), pointer :: current_graph
	type(feyngraph_t), pointer :: compare_graph
	logical :: present
	if (feyngraph_set%use_dag) then
	allocate (feyngraph_set%dag)
	if (.not. associated (feyngraph_set%first)) then
	call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1))
	call feyngraph_set%dag%construct (feyngraph_set)
	call feyngraph_set%dag%make_feyngraphs (feyngraph_set)
	end if
	else
	if (.not. associated (feyngraph_set%first)) then
	read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
	omega_feyngraph_output
	if (omega_feyngraph_output(1:1) == '(') then
	allocate (feyngraph_set%first)
	feyngraph_set%first%omega_feyngraph_output = &
	trim(omega_feyngraph_output)
	feyngraph_set%last => feyngraph_set%first
	feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
	else
	call msg_fatal ("Invalid input file")
	end if
	read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
	omega_feyngraph_output
	do while (stat == 0)
	if (omega_feyngraph_output(1:1) == '(') then
	compare_graph => feyngraph_set%first
	present = .false.
	do while (associated (compare_graph))
	if (len_trim(compare_graph%omega_feyngraph_output) &
	== len_trim(omega_feyngraph_output)) then
	if (compare_graph%omega_feyngraph_output == &
	omega_feyngraph_output) then
	present = .true.
	exit
	end if
	end if
	compare_graph => compare_graph%next
	end do
	if (.not. present) then
	allocate (feyngraph_set%last%next)
	feyngraph_set%last => feyngraph_set%last%next
	feyngraph_set%last%omega_feyngraph_output = &
	trim(omega_feyngraph_output)
	feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
	end if
	read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
	omega_feyngraph_output
	else
	exit
	end if
	end do
	current_graph => feyngraph_set%first
	do while (associated (current_graph))
	call feyngraph_construct (feyngraph_set, current_graph)
	current_graph => current_graph%next
	end do
	feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
	end if
	end if
	end subroutine feyngraph_set_build

	@ %def feyngraph_set_build
	@ Read the string from the file. The output which is produced by O'Mega
	contains the DAG in a factorised form as a long string, distributed over
	several lines (in addition, in the case of a scattering process, it
	contains a similar string for the same process, but with the other
	incoming particle as the root of the tree structure). In general, such a
	file can contain many of these strings, belonging to different process
	components. Therefore we first have to find the correct position of the
	string for the process in question. Therefore we look for a line
	containing a pair of colons, in which case the line contains a process
	string. Then we check if the process string describes the correct
	process, which is done by checking for all the incoming and outgoing
	particle names. If the process is correct, the dag output should start
	in the following line. As long as we do not find the correct process
	string, we continue searching. If we reach the end of the file, we
	rewind the unit once, and repeat searching. If the process is still not
	found, there must be some sort of error.
	<<Cascades2: dag: TBP>>=
	procedure :: read_string => dag_read_string
	<<Cascades2: sub interfaces>>=
	module subroutine dag_read_string (dag, u_in, flv)
	class(dag_t), intent(inout) :: dag
	integer, intent(in) :: u_in
	type(flavor_t), dimension(:), intent(in) :: flv
	end subroutine dag_read_string
	<<Cascades2: procedures>>=
	module subroutine dag_read_string (dag, u_in, flv)
	class(dag_t), intent(inout) :: dag
	integer, intent(in) :: u_in
	type(flavor_t), dimension(:), intent(in) :: flv
	character(len=BUFFER_LEN) :: process_string
	logical :: process_found
	logical :: rewound
	!!! Find process string in file
	process_found = .false.
	rewound = .false.
	do while (.not. process_found)
	process_string = ""
	read (unit=u_in, fmt='(A)') process_string
	if (len_trim(process_string) /= 0) then
	if (index (process_string, "::") > 0) then
	process_found = process_string_match (trim (process_string), flv)
	end if
	else if (.not. rewound) then
	rewind (u_in)
	rewound = .true.
	else
	call msg_bug ("Process string not found in O'Mega input file.")
	end if
	end do
	call fds_file_get_line (u_in, dag%string)
	call dag%string%clean ()
	if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) &
	call msg_bug ("Process string not found in O'Mega input file.")
	end subroutine dag_read_string

	@ %def dag_read_string
	@ The output of factorized Feynman diagrams which is created by O'Mega
	for a given process could in principle be written to a single line in
	the file. This can however lead to different problems with different
	compilers as soon as such lines become too long. This is the reason why
	the line is cut into smaller pieces. This means that a new line starts
	after each vertical bar. For this long string the type [[dag_string_t]]
	has been introduced. In order to read the file quickly into such a
	[[dag_string]] we use another type, [[dag_chain_t]] which is a linked
	list of such [[dag_strings]]. This has the advantage that we do not
	have to recreate a new [[dag_string]] for every line which has been
	read from file. Only in the end of this operation we compress the
	list of strings to a single string, removing useless [[dag_tokens]],
	such as blanc space tokens. This subroutine reads all lines starting
	from the position in the file the unit is connected to, until no
	backslash character is found at the end of a line (the backslash
	means that the next line also belongs to the current string).
	<<Cascades2: parameters>>=
	integer, parameter :: BUFFER_LEN = 1000
	integer, parameter :: STACK_SIZE = 100
	@ %def BUFFER_LEN STACK_SIZE
	<<Cascades2: procedures>>=
	subroutine fds_file_get_line (u, string)
	integer, intent(in) :: u
	type(dag_string_t), intent(out) :: string
	type(dag_chain_t) :: chain
	integer :: string_size, current_len
	character(len=BUFFER_LEN) :: buffer
	integer :: fragment_len
	integer :: stat
	current_len = 0
	stat = 0
	string_size = 0
	do while (stat == 0)
	read (unit=u, fmt='(A)', iostat=stat) buffer
	if (stat /= 0) exit
	fragment_len = len_trim (buffer)
	if (fragment_len == 0) then
	exit
	else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then
	fragment_len = fragment_len - 1
	end if
	call chain%append (buffer(:fragment_len))
	if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit
	end do
	if (associated (chain%first)) then
	call chain%compress ()
	string = chain%first
	call chain%final ()
	end if
	end subroutine fds_file_get_line

	@ %def fds_file_get_line
	@ We check, if the process string which has been read from file
	corresponds to the process for which we want to extract the Feynman
	diagrams.
	<<Cascades2: procedures>>=
	function process_string_match (string, flv) result (match)
	character(len=*), intent(in) :: string
	type(flavor_t), dimension(:), intent(in) :: flv
	logical :: match
	integer :: pos
	integer :: occurence
	integer :: i
	pos = 1
	match = .false.
	do i=1, size (flv)
	occurence = index (string(pos:), char(flv(i)%get_name()))
	if (occurence > 0) then
	pos = pos + occurence
	match = .true.
	else
	match = .false.
	exit
	end if
	end do
	end function process_string_match

	@ %def process_string_match
	@
	\subsection{Particle properties}
	This subroutine initializes a model instance with the Standard Model
	data. It is only relevant for a unit test.
	We do not have to care about the model initialization in this module
	because the [[model]] is passed to [[feyngraph_set_generate]] when
	it is called.
	<<Cascades2: public>>=
	public :: init_sm_full_test
	<<Cascades2: sub interfaces>>=
	module subroutine init_sm_full_test (model)
	class(model_data_t), intent(out) :: model
	end subroutine init_sm_full_test
	<<Cascades2: procedures>>=
	module subroutine init_sm_full_test (model)
	class(model_data_t), intent(out) :: model
	type(field_data_t), pointer :: field
	integer, parameter :: n_real = 17
	integer, parameter :: n_field = 21
	integer, parameter :: n_vtx = 56
	integer :: i
	call model%init (var_str ("SM_vertex_test"), &
	n_real, 0, n_field, n_vtx)
	call model%init_par (1, var_str ("mZ"), 91.1882_default)
	call model%init_par (2, var_str ("mW"), 80.419_default)
	call model%init_par (3, var_str ("mH"), 125._default)
	call model%init_par (4, var_str ("me"), 0.000510997_default)
	call model%init_par (5, var_str ("mmu"), 0.105658389_default)
	call model%init_par (6, var_str ("mtau"), 1.77705_default)
	call model%init_par (7, var_str ("ms"), 0.095_default)
	call model%init_par (8, var_str ("mc"), 1.2_default)
	call model%init_par (9, var_str ("mb"), 4.2_default)
	call model%init_par (10, var_str ("mtop"), 173.1_default)
	call model%init_par (11, var_str ("wtop"), 1.523_default)
	call model%init_par (12, var_str ("wZ"), 2.443_default)
	call model%init_par (13, var_str ("wW"), 2.049_default)
	call model%init_par (14, var_str ("wH"), 0.004143_default)
	call model%init_par (15, var_str ("ee"), 0.3079561542961_default)
	call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default)
	call model%init_par (17, 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 (mass_data=model%get_par_real_ptr (7))
	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 (mass_data=model%get_par_real_ptr (8))
	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 (9))
	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 (10))
	call field%set (width_data=model%get_par_real_ptr (11))
	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 (4))
	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 (5))
	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 ("TAU_LEPTON"), 15)
	call field%set (spin_type=2)
	call field%set (mass_data=model%get_par_real_ptr (6))
	call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")])
	i = i + 1
	field => model%get_field_ptr_by_index (i)
	call field%init (var_str ("TAU_NEUTRINO"), 16)
	call field%set (spin_type=2, is_left_handed=.true.)
	call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")])
	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 (12))
	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 (13))
	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 (3))
	call field%set (width_data=model%get_par_real_ptr (14))
	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
	!!! QED
	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 ("sbar"), var_str ("s"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")])
	i = i + 1
	!!!
	call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")])
	i = i + 1
	!!! QCD
	call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("gl"), 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 ("sbar"), var_str ("s"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")])
	i = i + 1
	!!! Neutral currents
	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 ("sbar"), var_str ("s"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")])
	i = i + 1
	!!!
	call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), &
	var_str ("Z")])
	i = i + 1
	!!! Charged currents
	call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")])
	i = i + 1
	!!!
	call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")])
	i = i + 1
	call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")])
	i = i + 1
	!!! Yukawa
	!!! keeping only 3rd generation for the moment
	! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")])
	! i = i + 1
	! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")])
	! i = i + 1
	call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")])
	i = i + 1
	call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")])
	i = i + 1
	! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")])
	! i = i + 1
	call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")])
	i = i + 1
	!!! Vector-boson self-interactions
	call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")])
	i = i + 1
	!!!
	call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")])
	i = i + 1
	call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")])
	i = i + 1
	!!! Higgs - vector boson
	! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")])
	! i = i + 1
	! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")])
	! i = i + 1
	! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")])
	! i = i + 1
	!!!
	call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")])
	i = i + 1
	call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")])
	i = i + 1
	call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")])
	i = i + 1
	!!! Higgs self-interactions
	call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")])
	i = i + 1
	call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")])
	i = i + 1
	call model%freeze_vertices ()
	end subroutine init_sm_full_test

	@ %def init_sm_full_test
	@ Initialize a [[part_prop]] object by passing a [[particle_label]],
	which is simply the particle name. [[part_prop]] should be part of the
	[[particle]] array of [[feyngraph_set]]. We use the [[model]] of
	[[feyngraph_set]] to obtain the relevant data of the particle which is
	needed to find [[phase_space]] parametrizations. When a [[part_prop]]
	is initialized, we add and initialize also the corresponding anti-
	particle [[part_prop]] if it is not yet in the array.
	<<Cascades2: part prop: TBP>>=
	procedure :: init => part_prop_init
	<<Cascades2: sub interfaces>>=
	recursive module subroutine part_prop_init &
	(part_prop, feyngraph_set, particle_label)
	class(part_prop_t), intent(out), target :: part_prop
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	character(len=*), intent(in) :: particle_label
	end subroutine part_prop_init
	<<Cascades2: procedures>>=
	recursive module subroutine part_prop_init &
	(part_prop, feyngraph_set, particle_label)
	class(part_prop_t), intent(out), target :: part_prop
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	character(len=*), intent(in) :: particle_label
	type(flavor_t) :: flv, anti
	type(string_t) :: name
	integer :: i
	name = particle_label
	call flv%init (name, feyngraph_set%model)
	part_prop%particle_label = particle_label
	part_prop%pdg = flv%get_pdg ()
	part_prop%mass = flv%get_mass ()
	part_prop%width = flv%get_width()
	part_prop%spin_type = flv%get_spin_type ()
	part_prop%is_vector = flv%get_spin_type () == VECTOR
	part_prop%empty = .false.
	part_prop%tex_name = flv%get_tex_name ()
	anti = flv%anti ()
	if (flv%get_pdg() == anti%get_pdg()) then
	select type (part_prop)
	type is (part_prop_t)
	part_prop%anti => part_prop
	end select
	else
	do i=1, size (feyngraph_set%particle)
	if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then
	part_prop%anti => feyngraph_set%particle(i)
	exit
	else if (feyngraph_set%particle(i)%empty) then
	part_prop%anti => feyngraph_set%particle(i)
	call feyngraph_set%particle(i)%init &
	(feyngraph_set, char(anti%get_name()))
	exit
	end if
	end do
	end if
	end subroutine part_prop_init

	@ %def part_prop_init
	@ This subroutine assigns to a node the particle properties. Since these
	properties do not change and are simply read from the model file, we
	use pointers to the elements of the [[particle]] array of the
	[[feyngraph_set]]. If there is no corresponding array element, we
	have to initialize the first empty element of the array.
	<<Cascades2: parameters>>=
	integer, parameter :: PRT_ARRAY_SIZE = 200
	<<Cascades2: f node: TBP>>=
	procedure :: assign_particle_properties => f_node_assign_particle_properties
	<<Cascades2: sub interfaces>>=
	module subroutine f_node_assign_particle_properties (node, feyngraph_set)
	class(f_node_t), intent(inout ) :: node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	end subroutine f_node_assign_particle_properties
	<<Cascades2: procedures>>=
	module subroutine f_node_assign_particle_properties (node, feyngraph_set)
	class(f_node_t), intent(inout ) :: node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	character(len=LABEL_LEN) :: particle_label
	integer :: i
	particle_label = node%particle_label(1:index (node%particle_label, '[')-1)
	if (.not. associated (feyngraph_set%particle)) then
	allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
	end if
	do i = 1, size (feyngraph_set%particle)
	if (particle_label == feyngraph_set%particle(i)%particle_label) then
	node%particle => feyngraph_set%particle(i)
	exit
	else if (feyngraph_set%particle(i)%empty) then
	call feyngraph_set%particle(i)%init (feyngraph_set, particle_label)
	node%particle => feyngraph_set%particle(i)
	exit
	end if
	end do
	!!! Since the O'Mega output uses the anti-particles instead of the
	!!! particles specified in the process definition, we revert this
	!!! here. An exception is the first particle in the parsable DAG output
	node%particle => node%particle%anti
	end subroutine f_node_assign_particle_properties

	@ %def f_node_assign_particle_properties
	@ From the output of a Feynman diagram (in the non-factorized output)
	we need to find out how many daughter nodes would be required to
	reconstruct it correctly, to make sure that we keep
	only those [[feyngraphs]] which are constructed solely on the basis of
	the 3-vertices which are provided by the model. The number of daughter
	particles can easily be determined from the syntax of O'Mega's output:
	The particle which appears before the colon ':' is the mother particle.
	The particles or subtrees (i.e. whole parentheses) follow after the
	colon and are separated by commas.
	<<Cascades2: procedures>>=
	function get_n_daughters (subtree_string, pos_first_colon) &
	result (n_daughters)
	character(len=*), intent(in) :: subtree_string
	integer, intent(in) :: pos_first_colon
	integer :: n_daughters
	integer :: n_open_par
	integer :: i
	n_open_par = 1
	n_daughters = 0
	if (len_trim(subtree_string) > 0) then
	if (pos_first_colon > 0) then
	do i=pos_first_colon, len_trim(subtree_string)
	if (subtree_string(i:i) == ',') then
	if (n_open_par == 1) n_daughters = n_daughters + 1
	else if (subtree_string(i:i) == '(') then
	n_open_par = n_open_par + 1
	else if (subtree_string(i:i) == ')') then
	n_open_par = n_open_par - 1
	end if
	end do
	if (n_open_par == 0) then
	n_daughters = n_daughters + 1
	end if
	end if
	end if
	end function get_n_daughters

	@ %def get_n_daughters
	@
	\subsection{Reconstruction of trees}
	The reconstruction of a tree or subtree with the non-factorized input can
	be done recursively, i.e. we first find the root of the tree in the
	string and create an [[f_node]]. Then we look for daughters, which in the
	string appear either as single particles or subtrees (which are of the
	same form as the tree which we want to reconstruct. Therefore the
	subroutine can simply be called again and again until there are no more
	daughter nodes to create. When we meet a vertex which requires more than
	two daughter particles, we stop the recursion and disable the node using
	its [[keep]] variable. Whenever a daughter node is not kept, we do not
	keep the mother node as well.
	<<Cascades2: procedures>>=
	recursive subroutine node_construct_subtree_rec (feyngraph_set, &
	feyngraph, subtree_string, mother_node)
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(feyngraph_t), intent(inout) :: feyngraph
	character(len=*), intent(in) :: subtree_string
	type(f_node_t), pointer, intent(inout) :: mother_node
	integer :: n_daughters
	integer :: pos_first_colon
	integer :: current_daughter
	integer :: pos_subtree_begin, pos_subtree_end
	integer :: i
	integer :: n_open_par
	if (.not. associated (mother_node)) then
	call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.)
	current_daughter = 1
	n_open_par = 1
	pos_first_colon = index (subtree_string, ':')
	n_daughters = get_n_daughters (subtree_string, pos_first_colon)
	if (pos_first_colon == 0) then
	mother_node%particle_label = subtree_string
	else
	mother_node%particle_label = subtree_string(2:pos_first_colon-1)
	end if
	if (.not. associated (mother_node%particle)) then
	call mother_node%assign_particle_properties (feyngraph_set)
	end if
	if (n_daughters /= 2 .and. n_daughters /= 0) then
	mother_node%keep = .false.
	feyngraph%keep = .false.
	return
	end if
	pos_subtree_begin = pos_first_colon + 1
	do i = pos_first_colon + 1, len(trim(subtree_string))
	if (current_daughter == 2) then
	pos_subtree_end = len(trim(subtree_string)) - 1
	call node_construct_subtree_rec (feyngraph_set, feyngraph, &
	subtree_string(pos_subtree_begin:pos_subtree_end), &
	mother_node%daughter2)
	exit
	else if (subtree_string(i:i) == ',') then
	if (n_open_par == 1) then
	pos_subtree_end = i - 1
	call node_construct_subtree_rec (feyngraph_set, feyngraph, &
	subtree_string(pos_subtree_begin:pos_subtree_end), &
	mother_node%daughter1)
	current_daughter = 2
	pos_subtree_begin = i + 1
	end if
	else if (subtree_string(i:i) == '(') then
	n_open_par = n_open_par + 1
	else if (subtree_string(i:i) == ')') then
	n_open_par = n_open_par - 1
	end if
	end do
	end if
	if (associated (mother_node%daughter1)) then
	if (.not. mother_node%daughter1%keep) then
	mother_node%keep = .false.
	end if
	end if
	if (associated (mother_node%daughter2)) then
	if (.not. mother_node%daughter2%keep) then
	mother_node%keep = .false.
	end if
	end if
	if (associated (mother_node%daughter1) .and. &
	associated (mother_node%daughter2)) then
	mother_node%n_subtree_nodes = &
	mother_node%daughter1%n_subtree_nodes &
	+ mother_node%daughter2%n_subtree_nodes + 1
	end if
	if (.not. mother_node%keep) then
	feyngraph%keep = .false.
	end if
	end subroutine node_construct_subtree_rec

	@ %def node_construct_subtree_rec
	@ When the non-factorized version of the O'Mega output is used, the
	[[feyngraph]] is reconstructed from the contents of its [[string_t]]
	variable [[omega_feyngraph_output]]. This can be used for the recursive
	reconstruction of the tree of [[k_nodes]] with
	[[node_construct_subtree_rec]].
	<<Cascades2: procedures>>=
	subroutine feyngraph_construct (feyngraph_set, feyngraph)
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(feyngraph_t), pointer, intent(inout) :: feyngraph
	call node_construct_subtree_rec (feyngraph_set, feyngraph, &
	char(feyngraph%omega_feyngraph_output), feyngraph%root)
	feyngraph%n_nodes = feyngraph%root%n_subtree_nodes
	end subroutine feyngraph_construct

	@ %def feyngraph_construct
	@ We introduce another node type, which is called [[dag_node_t]] and
	is used to reproduce the dag structure which is represented by the input.
	The [[dag_nodes]] can have several combinations of daughters 1 and 2.
	The [[dag]] type contains an array of [[dag_nodes]] and is only used
	for the reconstruction of [[feyngraphs]] which are factorized as well, but
	in the other direction as the original output. This means in particular
	that the outgoing particles in the output file (which there can appear
	many times) exist only once as [[f_nodes]]. To represent combinations of
	daughters and alternatives (options), we further use the types
	[[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]],
	[[dag_options]] and [[dag_combinations]] correspond to a substring of
	the string which has been read from file (and transformed into an object
	of type [[dag_string_t]], which is simply another compact representation
	of this string), or a modified version of this substring. The aim is to
	create only one object for a given substring, even if it appears several
	times in the original string and then create trees of [[f_nodes]], which
	build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused.
	An outgoing particle (always interpreting the input as a decay) is
	called a [[leaf]] in the context of a [[dag]].
	<<Cascades2: types>>=
	type :: dag_node_t
	integer :: string_len
	type(dag_string_t) :: string
	logical :: leaf = .false.
	type(f_node_ptr_t), dimension (:), allocatable :: f_node
	integer :: subtree_size = 0
	contains
	<<Cascades2: dag node: TBP>>
	end type dag_node_t

	@ %def dag_node_t
	<<Cascades2: dag node: TBP>>=
	procedure :: final => dag_node_final
	<<Cascades2: sub interfaces>>=
	module subroutine dag_node_final (dag_node)
	class(dag_node_t), intent(inout) :: dag_node
	end subroutine dag_node_final
	<<Cascades2: procedures>>=
	module subroutine dag_node_final (dag_node)
	class(dag_node_t), intent(inout) :: dag_node
	integer :: i
	call dag_node%string%final ()
	if (allocated (dag_node%f_node)) then
	do i=1, size (dag_node%f_node)
	if (associated (dag_node%f_node(i)%node)) then
	call dag_node%f_node(i)%node%final ()
	deallocate (dag_node%f_node(i)%node)
	end if
	end do
	deallocate (dag_node%f_node)
	end if
	end subroutine dag_node_final

	@ %def dag_node_final
	@ Whenever there are more than one possible subtrees (represented by
	a [[dag_node]]) or combinations of subtrees to daughters (represented
	by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the
	syntax of the factorized output, options are listed within curly
	braces, separated by horizontal bars.
	<<Cascades2: types>>=
	type :: dag_options_t
	integer :: string_len
	type(dag_string_t) :: string
	type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
	type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
	contains
	<<Cascades2: dag options: TBP>>
	end type dag_options_t

	@ %def dag_node_options_t
	<<Cascades2: dag options: TBP>>=
	procedure :: final => dag_options_final
	<<Cascades2: sub interfaces>>=
	module subroutine dag_options_final (dag_options)
	class(dag_options_t), intent(inout) :: dag_options
	end subroutine dag_options_final
	<<Cascades2: procedures>>=
	module subroutine dag_options_final (dag_options)
	class(dag_options_t), intent(inout) :: dag_options
	integer :: i
	call dag_options%string%final ()
	if (allocated (dag_options%f_node_ptr1)) then
	do i=1, size (dag_options%f_node_ptr1)
	dag_options%f_node_ptr1(i)%node => null ()
	end do
	deallocate (dag_options%f_node_ptr1)
	end if
	if (allocated (dag_options%f_node_ptr2)) then
	do i=1, size (dag_options%f_node_ptr2)
	dag_options%f_node_ptr2(i)%node => null ()
	end do
	deallocate (dag_options%f_node_ptr2)
	end if
	end subroutine dag_options_final

	@ %def dag_options_final
	@ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]])
	is represented by the type [[dag_combination_t]]. In the original string,
	a [[dag_combination]] appears between parentheses, which contain a comma,
	but not a colon. If we find a colon between these parentheses, it is a
	a [[dag_node]] instead.
	<<Cascades2: types>>=
	type :: dag_combination_t
	integer :: string_len
	type(dag_string_t) :: string
	integer, dimension (2) :: combination
	type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
	type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
	contains
	<<Cascades2: dag combination: TBP>>
	end type dag_combination_t

	@ %def dag_combination_t
	<<Cascades2: dag combination: TBP>>=
	procedure :: final => dag_combination_final
	<<Cascades2: sub interfaces>>=
	module subroutine dag_combination_final (dag_combination)
	class(dag_combination_t), intent(inout) :: dag_combination
	end subroutine dag_combination_final
	<<Cascades2: procedures>>=
	module subroutine dag_combination_final (dag_combination)
	class(dag_combination_t), intent(inout) :: dag_combination
	integer :: i
	call dag_combination%string%final ()
	if (allocated (dag_combination%f_node_ptr1)) then
	do i=1, size (dag_combination%f_node_ptr1)
	dag_combination%f_node_ptr1(i)%node => null ()
	end do
	deallocate (dag_combination%f_node_ptr1)
	end if
	if (allocated (dag_combination%f_node_ptr2)) then
	do i=1, size (dag_combination%f_node_ptr2)
	dag_combination%f_node_ptr2(i)%node => null ()
	end do
	deallocate (dag_combination%f_node_ptr2)
	end if
	end subroutine dag_combination_final

	@ %def dag_combination_final
	@ Here is the type representing the DAG, i.e. it holds arrays of the
	[[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node
	of the [[dag]] is the last filled element of the [[node]] array.
	<<Cascades2: types>>=
	type :: dag_t
	type(dag_string_t) :: string
	type(dag_node_t), dimension (:), allocatable :: node
	type(dag_options_t), dimension (:), allocatable :: options
	type(dag_combination_t), dimension (:), allocatable :: combination
	integer :: n_nodes = 0
	integer :: n_options = 0
	integer :: n_combinations = 0
	contains
	<<Cascades2: dag: TBP>>
	end type dag_t

	@ %def dag_t
	<<Cascades2: dag: TBP>>=
	procedure :: final => dag_final
	<<Cascades2: sub interfaces>>=
	module subroutine dag_final (dag)
	class(dag_t), intent(inout) :: dag
	end subroutine dag_final
	<<Cascades2: procedures>>=
	module subroutine dag_final (dag)
	class(dag_t), intent(inout) :: dag
	integer :: i
	call dag%string%final ()
	if (allocated (dag%node)) then
	do i=1, size (dag%node)
	call dag%node(i)%final ()
	end do
	deallocate (dag%node)
	end if
	if (allocated (dag%options)) then
	do i=1, size (dag%options)
	call dag%options(i)%final ()
	end do
	deallocate (dag%options)
	end if
	if (allocated (dag%combination)) then
	do i=1, size (dag%combination)
	call dag%combination(i)%final ()
	end do
	deallocate (dag%combination)
	end if
	end subroutine dag_final

	@ %def dag_final
	@ We construct the DAG from the given [[dag_string]] which is modified
	several times so that in the end the remaining string corresponds to a
	simple [[dag_node]], the root of the factorized tree. This means that
	we first identify the leaves, i.e. outgoing particles. Then we identify
	[[dag_nodes]], [[dag_combinations]] and [[options]] until the number of
	these objects does not change any more. Identifying means that we add
	a corresponding object to the array (if not yet present), which can be
	identified with the corresponding substring, and replace the substring
	in the original [[dag_string]] by a [[dag_token]] of the corresponding
	type (in the char output of this token, this corresponds to a place
	holder like e.g. '<O23>' which in this particular case corresponds to
	an option and can be found at the position 23 in the array). The
	character output of the substrings turns out to be very useful for
	debugging.
	<<Cascades2: dag: TBP>>=
	procedure :: construct => dag_construct
	<<Cascades2: sub interfaces>>=
	module subroutine dag_construct (dag, feyngraph_set)
	class(dag_t), intent(inout) :: dag
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	end subroutine dag_construct
	<<Cascades2: procedures>>=
	module subroutine dag_construct (dag, feyngraph_set)
	class(dag_t), intent(inout) :: dag
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	integer :: n_nodes
	integer :: n_options
	integer :: n_combinations
	logical :: continue_loop
	integer :: subtree_size
	integer :: i,j
	subtree_size = 1
	call dag%get_nodes_and_combinations (leaves = .true.)
	do i=1, dag%n_nodes
	call dag%node(i)%make_f_nodes (feyngraph_set, dag)
	end do
	continue_loop = .true.
	subtree_size = subtree_size + 2
	do while (continue_loop)
	n_nodes = dag%n_nodes
	n_options = dag%n_options
	n_combinations = dag%n_combinations
	call dag%get_nodes_and_combinations (leaves = .false.)
	if (n_nodes /= dag%n_nodes) then
	dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size
	do i = n_nodes+1, dag%n_nodes
	call dag%node(i)%make_f_nodes (feyngraph_set, dag)
	end do
	subtree_size = subtree_size + 2
	end if
	if (n_combinations /= dag%n_combinations) then
	!$OMP PARALLEL DO
	do i = n_combinations+1, dag%n_combinations
	call dag%combination(i)%make_f_nodes (feyngraph_set, dag)
	end do
	!$OMP END PARALLEL DO
	end if
	call dag%get_options ()
	if (n_options /= dag%n_options) then
	!$OMP PARALLEL DO
	do i = n_options+1, dag%n_options
	call dag%options(i)%make_f_nodes (feyngraph_set, dag)
	end do
	!$OMP END PARALLEL DO
	end if
	if (n_nodes == dag%n_nodes .and. n_options == dag%n_options &
	.and. n_combinations == dag%n_combinations) then
	continue_loop = .false.
	end if
	end do
	!!! add root node to dag
	call dag%add_node (dag%string%t, leaf = .false.)
	dag%node(dag%n_nodes)%subtree_size = subtree_size
	call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag)
	if (debug2_active (D_PHASESPACE)) then
	call dag%write (output_unit)
	end if
	!!! set indices for all f_nodes
	do i=1, dag%n_nodes
	if (allocated (dag%node(i)%f_node)) then
	do j=1, size (dag%node(i)%f_node)
	if (associated (dag%node(i)%f_node(j)%node)) &
	call dag%node(i)%f_node(j)%node%set_index ()
	end do
	end if
	end do
	end subroutine dag_construct

	@ %def dag_construct
	@ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply
	nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is
	set. The [[dag_nodes]] and [[dag_combinations]] have in common that they
	are surrounded by parentheses. There is however a way to distinguish
	between them because the corresponding substring contains a colon (or
	[[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise
	it is a [[dag_combination]]. The string of the [[dag_node]] or
	[[dag_combination]] should not contain curly braces, because these
	correspond to [[dag_options]] and should be identified before.
	<<Cascades2: dag: TBP>>=
	procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations
	<<Cascades2: sub interfaces>>=
	module subroutine dag_get_nodes_and_combinations (dag, leaves)
	class(dag_t), intent(inout) :: dag
	logical, intent(in) :: leaves
	end subroutine dag_get_nodes_and_combinations
	<<Cascades2: procedures>>=
	module subroutine dag_get_nodes_and_combinations (dag, leaves)
	class(dag_t), intent(inout) :: dag
	logical, intent(in) :: leaves
	type(dag_string_t) :: new_string
	integer :: i, j, k
	integer :: i_node
	integer :: new_size
	integer :: first_colon
	logical :: combination
	!!! Create nodes also for external particles, except for the incoming one
	!!! which appears as the root of the tree. These can easily be identified
	!!! by their bincodes, since they should contain only one bit which is set.
	if (leaves) then
	first_colon = &
	minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK)
	do i = first_colon + 1, size (dag%string%t)
	if (dag%string%t(i)%type == NODE_TK) then
	if (popcnt(dag%string%t(i)%bincode) == 1) then
	call dag%add_node (dag%string%t(i:i), .true., i_node)
	call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node)
	end if
	end if
	end do
	call dag%string%update_char_len ()
	else
	!!! Create a node or combination for every closed pair of parentheses
	!!! which do not contain any other parentheses or curly braces.
	!!! A node (not outgoing) contains a colon. This is not the case
	!!! for combinations, which we use as the criteria to distinguish
	!!! between both.
	allocate (new_string%t (size (dag%string%t)))
	i = 1
	new_size = 0
	do while (i <= size(dag%string%t))
	if (dag%string%t(i)%type == OPEN_PAR_TK) then
	combination = .true.
	do j = i+1, size (dag%string%t)
	select case (dag%string%t(j)%type)
	case (CLOSED_PAR_TK)
	new_size = new_size + 1
	if (combination) then
	call dag%add_combination (dag%string%t(i:j), i_node)
	call new_string%t(new_size)%init_dag_object_token &
	(DAG_COMBINATION_TK, i_node)
	else
	call dag%add_node (dag%string%t(i:j), leaves, i_node)
	call new_string%t(new_size)%init_dag_object_token &
	(DAG_NODE_TK, i_node)
	end if
	i = j + 1
	exit
	case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK)
	new_size = new_size + 1
	new_string%t(new_size) = dag%string%t(i)
	i = i + 1
	exit
	case (COLON_TK)
	combination = .false.
	end select
	end do
	else
	new_size = new_size + 1
	new_string%t(new_size) = dag%string%t(i)
	i = i + 1
	end if
	end do
	dag%string = new_string%t(:new_size)
	call dag%string%update_char_len ()
	end if
	end subroutine dag_get_nodes_and_combinations

	@ %def dag_get_nodes_and_combinations
	@ Identify [[dag_options]], i.e. lists of rival nodes or combinations
	of nodes. These are identified by the surrounding curly braces. They
	should not contain any parentheses any more, because these correspond
	either to nodes or to combinations and should be identified before.
	<<Cascades2: dag: TBP>>=
	procedure :: get_options => dag_get_options
	<<Cascades2: sub interfaces>>=
	module subroutine dag_get_options (dag)
	class(dag_t), intent(inout) :: dag
	end subroutine dag_get_options
	<<Cascades2: procedures>>=
	module subroutine dag_get_options (dag)
	class(dag_t), intent(inout) :: dag
	type(dag_string_t) :: new_string
	integer :: i, j, k
	integer :: new_size
	integer :: i_options
	character(len=10) :: index_char
	integer :: index_start, index_end
	!!! Create a node or combination for every closed pair of parentheses
	!!! which do not contain any other parentheses or curly braces.
	!!! A node (not outgoing) contains a colon. This is not the case
	!!! for combinations, which we use as the criteria to distinguish
	!!! between both.
	allocate (new_string%t (size (dag%string%t)))
	i = 1
	new_size = 0
	do while (i <= size(dag%string%t))
	if (dag%string%t(i)%type == OPEN_CURLY_TK) then
	do j = i+1, size (dag%string%t)
	select case (dag%string%t(j)%type)
	case (CLOSED_CURLY_TK)
	new_size = new_size + 1
	call dag%add_options (dag%string%t(i:j), i_options)
	call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options)
	i = j + 1
	exit
	case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK)
	new_size = new_size + 1
	new_string%t(new_size) = dag%string%t(i)
	i = i + 1
	exit
	end select
	end do
	else
	new_size = new_size + 1
	new_string%t(new_size) = dag%string%t(i)
	i = i + 1
	end if
	end do
	dag%string = new_string%t(:new_size)
	call dag%string%update_char_len ()
	end subroutine dag_get_options

	@ %def dag_get_options
	@ Add a [[dag_node]] to the list. The optional argument returns the index
	of the node. The node might already exist. In this case we only return
	the index.
	<<Cascades2: dag: TBP>>=
	procedure :: add_node => dag_add_node
	<<Cascades2: parameters>>=
	integer, parameter :: DAG_STACK_SIZE = 1000
	<<Cascades2: sub interfaces>>=
	module subroutine dag_add_node (dag, string, leaf, i_node)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	logical, intent(in) :: leaf
	integer, intent(out), optional :: i_node
	end subroutine dag_add_node
	<<Cascades2: procedures>>=
	module subroutine dag_add_node (dag, string, leaf, i_node)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	logical, intent(in) :: leaf
	integer, intent(out), optional :: i_node
	type(dag_node_t), dimension (:), allocatable :: tmp_node
	integer :: string_len
	integer :: i
	string_len = sum (string%char_len)
	if (.not. allocated (dag%node)) then
	allocate (dag%node (DAG_STACK_SIZE))
	else if (dag%n_nodes == size (dag%node)) then
	allocate (tmp_node (dag%n_nodes))
	tmp_node = dag%node
	deallocate (dag%node)
	allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE))
	dag%node(:dag%n_nodes) = tmp_node
	deallocate (tmp_node)
	end if
	do i = 1, dag%n_nodes
	if (dag%node(i)%string_len == string_len) then
	if (size (dag%node(i)%string%t) == size (string)) then
	if (all(dag%node(i)%string%t == string)) then
	if (present (i_node)) i_node = i
	return
	end if
	end if
	end if
	end do
	dag%n_nodes = dag%n_nodes + 1
	dag%node(dag%n_nodes)%string = string
	dag%node(dag%n_nodes)%string_len = string_len
	if (present (i_node)) i_node = dag%n_nodes
	dag%node(dag%n_nodes)%leaf = leaf
	end subroutine dag_add_node

	@ %def dag_add_node
	@ A similar subroutine for options.
	<<Cascades2: dag: TBP>>=
	procedure :: add_options => dag_add_options
	<<Cascades2: sub interfaces>>=
	module subroutine dag_add_options (dag, string, i_options)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	integer, intent(out), optional :: i_options
	end subroutine dag_add_options
	<<Cascades2: procedures>>=
	module subroutine dag_add_options (dag, string, i_options)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	integer, intent(out), optional :: i_options
	type(dag_options_t), dimension (:), allocatable :: tmp_options
	integer :: string_len
	integer :: i
	string_len = sum (string%char_len)
	if (.not. allocated (dag%options)) then
	allocate (dag%options (DAG_STACK_SIZE))
	else if (dag%n_options == size (dag%options)) then
	allocate (tmp_options (dag%n_options))
	tmp_options = dag%options
	deallocate (dag%options)
	allocate (dag%options (dag%n_options+DAG_STACK_SIZE))
	dag%options(:dag%n_options) = tmp_options
	deallocate (tmp_options)
	end if
	do i = 1, dag%n_options
	if (dag%options(i)%string_len == string_len) then
	if (size (dag%options(i)%string%t) == size (string)) then
	if (all(dag%options(i)%string%t == string)) then
	if (present (i_options)) i_options = i
	return
	end if
	end if
	end if
	end do
	dag%n_options = dag%n_options + 1
	dag%options(dag%n_options)%string = string
	dag%options(dag%n_options)%string_len = string_len
	if (present (i_options)) i_options = dag%n_options
	end subroutine dag_add_options

	@ %def dag_add_options
	@ A similar subroutine for combinations.
	<<Cascades2: dag: TBP>>=
	procedure :: add_combination => dag_add_combination
	<<Cascades2: sub interfaces>>=
	module subroutine dag_add_combination (dag, string, i_combination)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	integer, intent(out), optional :: i_combination
	end subroutine dag_add_combination
	<<Cascades2: procedures>>=
	module subroutine dag_add_combination (dag, string, i_combination)
	class(dag_t), intent(inout) :: dag
	type(dag_token_t), dimension (:), intent(in) :: string
	integer, intent(out), optional :: i_combination
	type(dag_combination_t), dimension (:), allocatable :: tmp_combination
	integer :: string_len
	integer :: i
	string_len = sum (string%char_len)
	if (.not. allocated (dag%combination)) then
	allocate (dag%combination (DAG_STACK_SIZE))
	else if (dag%n_combinations == size (dag%combination)) then
	allocate (tmp_combination (dag%n_combinations))
	tmp_combination = dag%combination
	deallocate (dag%combination)
	allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE))
	dag%combination(:dag%n_combinations) = tmp_combination
	deallocate (tmp_combination)
	end if
	do i = 1, dag%n_combinations
	if (dag%combination(i)%string_len == string_len) then
	if (size (dag%combination(i)%string%t) == size (string)) then
	if (all(dag%combination(i)%string%t == string)) then
	i_combination = i
	return
	end if
	end if
	end if
	end do
	dag%n_combinations = dag%n_combinations + 1
	dag%combination(dag%n_combinations)%string = string
	dag%combination(dag%n_combinations)%string_len = string_len
	if (present (i_combination)) i_combination = dag%n_combinations
	end subroutine dag_add_combination

	@ %def dag_add_combination
	@ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node
	is not a leaf, it contains in its string placeholders for options or
	combinations. For these objects there are similar subroutines which are
	needed here to obtain the sets of daughter nodes. If the [[dag_node]] is
	a leaf, it corresponds to an external particle and the token contains the
	particle name.
	<<Cascades2: dag node: TBP>>=
	procedure :: make_f_nodes => dag_node_make_f_nodes
	<<Cascades2: sub interfaces>>=
	module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag)
	class(dag_node_t), intent(inout) :: dag_node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	end subroutine dag_node_make_f_nodes
	<<Cascades2: procedures>>=
	module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag)
	class(dag_node_t), intent(inout) :: dag_node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	character(len=LABEL_LEN) :: particle_label
	integer :: i, j
	integer, dimension (2) :: obj
	integer, dimension (2) :: i_obj
	integer :: n_obj
	integer :: pos
	integer :: new_size, size1, size2
	integer, dimension(:), allocatable :: match
	if (allocated (dag_node%f_node)) return
	pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK)
	particle_label = char (dag_node%string%t(pos))
	if (dag_node%leaf) then
	!!! construct subtree with procedure similar to the one for the old output
	allocate (dag_node%f_node(1))
	allocate (dag_node%f_node(1)%node)
	dag_node%f_node(1)%node%particle_label = particle_label
	call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set)
	if (.not. dag_node%f_node(1)%node%keep) then
	deallocate (dag_node%f_node)
	return
	end if
	else
	n_obj = 0
	do i = 1, size (dag_node%string%t)
	select case (dag_node%string%t(i)%type)
	case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
	n_obj = n_obj + 1
	if (n_obj > 2) return
	obj(n_obj) = dag_node%string%t(i)%type
	i_obj(n_obj) = dag_node%string%t(i)%index
	end select
	end do
	if (n_obj == 1) then
	if (obj(1) == DAG_OPTIONS_TK) then
	if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
	size1 = size(dag%options(i_obj(1))%f_node_ptr1)
	allocate (dag_node%f_node(size1))
	do i=1, size1
	allocate (dag_node%f_node(i)%node)
	dag_node%f_node(i)%node%particle_label = particle_label
	call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
	dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node
	dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node
	dag_node%f_node(i)%node%n_subtree_nodes = &
	dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
	+ dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
	end do
	end if
	else if (obj(1) == DAG_COMBINATION_TK) then
	if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then
	size1 = size(dag%combination(i_obj(1))%f_node_ptr1)
	allocate (dag_node%f_node(size1))
	do i=1, size1
	allocate (dag_node%f_node(i)%node)
	dag_node%f_node(i)%node%particle_label = particle_label
	call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
	dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node
	dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node
	dag_node%f_node(i)%node%n_subtree_nodes = &
	dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
	+ dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
	end do
	end if
	end if
	!!! simply set daughter pointers, daughters are already combined correctly
	else if (n_obj == 2) then
	size1 = 0
	size2 = 0
	if (obj(1) == DAG_NODE_TK) then
	if (allocated (dag%node(i_obj(1))%f_node)) then
	do i=1, size (dag%node(i_obj(1))%f_node)
	if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1
	end do
	end if
	else if (obj(1) == DAG_OPTIONS_TK) then
	if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
	do i=1, size (dag%options(i_obj(1))%f_node_ptr1)
	if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1
	end do
	end if
	end if
	if (obj(2) == DAG_NODE_TK) then
	if (allocated (dag%node(i_obj(2))%f_node)) then
	do i=1, size (dag%node(i_obj(2))%f_node)
	if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1
	end do
	end if
	else if (obj(2) == DAG_OPTIONS_TK) then
	if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then
	do i=1, size (dag%options(i_obj(2))%f_node_ptr1)
	if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1
	end do
	end if
	end if
	!!! make all combinations of daughters
	select case (obj(1))
	case (DAG_NODE_TK)
	select case (obj(2))
	case (DAG_NODE_TK)
	call combine_all_daughters(dag%node(i_obj(1))%f_node, &
	dag%node(i_obj(2))%f_node)
	case (DAG_OPTIONS_TK)
	call combine_all_daughters(dag%node(i_obj(1))%f_node, &
	dag%options(i_obj(2))%f_node_ptr1)
	end select
	case (DAG_OPTIONS_TK)
	select case (obj(2))
	case (DAG_NODE_TK)
	call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
	dag%node(i_obj(2))%f_node)
	case (DAG_OPTIONS_TK)
	call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
	dag%options(i_obj(2))%f_node_ptr1)
	end select
	end select
	end if
	end if

	contains

	subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr)
	type(f_node_ptr_t), dimension (:), intent(in) :: daughter1_ptr
	type(f_node_ptr_t), dimension (:), intent(in) :: daughter2_ptr
	integer :: i, j
	integer :: pos
	new_size = size1*size2
	allocate (dag_node%f_node(new_size))
	pos = 0
	do i = 1, size (daughter1_ptr)
	if (daughter1_ptr(i)%node%keep) then
	do j = 1, size (daughter2_ptr)
	if (daughter2_ptr(j)%node%keep) then
	pos = pos + 1
	allocate (dag_node%f_node(pos)%node)
	dag_node%f_node(pos)%node%particle_label = particle_label
	call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set)
	dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node
	dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node
	dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes &
	+ daughter2_ptr(j)%node%n_subtree_nodes + 1
	call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, &
	daughter2_ptr(j)%node%particle%pdg, match)
	if (allocated (match)) then
	if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then
	dag_node%f_node(pos)%node%keep = .true.
	else
	dag_node%f_node(pos)%node%keep = .false.
	end if
	deallocate (match)
	else
	dag_node%f_node(pos)%node%keep = .false.
	end if
	end if
	end do
	end if
	end do
	end subroutine combine_all_daughters
	end subroutine dag_node_make_f_nodes

	@ %def dag_node_make_f_nodes
	@ In [[dag_options_make_f_nodes_single]]
	we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a
	set of rival subtrees or nodes, which is the first possibility for
	which [[dag_options]] can appear.
	In [[dag_options_make_f_nodes_pair]]
	the options are rival pairs ([[daughter1]], [[daughter2]]).
	Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]]
	to the subroutine.
	<<Cascades2: dag options: TBP>>=
	procedure :: make_f_nodes => dag_options_make_f_nodes
	<<Cascades2: sub interfaces>>=
	module subroutine dag_options_make_f_nodes (dag_options, &
	feyngraph_set, dag)
	class(dag_options_t), intent(inout) :: dag_options
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	end subroutine dag_options_make_f_nodes
	<<Cascades2: procedures>>=
	module subroutine dag_options_make_f_nodes (dag_options, &
	feyngraph_set, dag)
	class(dag_options_t), intent(inout) :: dag_options
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	integer, dimension (:), allocatable :: obj, i_obj
	integer :: n_obj
	integer :: i
	integer :: pos
	!!! read options
	if (allocated (dag_options%f_node_ptr1)) return
	n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. &
	(dag_options%string%t%type == DAG_OPTIONS_TK) .or. &
	(dag_options%string%t%type == DAG_COMBINATION_TK), 1)
	allocate (obj(n_obj)); allocate (i_obj(n_obj))
	pos = 0
	do i = 1, size (dag_options%string%t)
	select case (dag_options%string%t(i)%type)
	case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
	pos = pos + 1
	obj(pos) = dag_options%string%t(i)%type
	i_obj(pos) = dag_options%string%t(i)%index
	end select
	end do
	if (any (dag_options%string%t%type == DAG_NODE_TK)) then
	call dag_options_make_f_nodes_single
	else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then
	call dag_options_make_f_nodes_pair
	end if
	deallocate (obj, i_obj)

	contains

	subroutine dag_options_make_f_nodes_single
	integer :: i_start, i_end
	integer :: n_nodes
	n_nodes = 0
	do i=1, n_obj
	if (allocated (dag%node(i_obj(i))%f_node)) then
	n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node)
	end if
	end do
	if (n_nodes /= 0) then
	allocate (dag_options%f_node_ptr1 (n_nodes))
	i_end = 0
	do i = 1, n_obj
	if (allocated (dag%node(i_obj(i))%f_node)) then
	i_start = i_end + 1
	i_end = i_end + size (dag%node(i_obj(i))%f_node)
	dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node
	end if
	end do
	end if
	end subroutine dag_options_make_f_nodes_single

	subroutine dag_options_make_f_nodes_pair
	integer :: i_start, i_end
	integer :: n_nodes
	!!! get f_nodes from each combination
	n_nodes = 0
	do i=1, n_obj
	if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
	n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1)
	end if
	end do
	if (n_nodes /= 0) then
	allocate (dag_options%f_node_ptr1 (n_nodes))
	allocate (dag_options%f_node_ptr2 (n_nodes))
	i_end = 0
	do i=1, n_obj
	if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
	i_start = i_end + 1
	i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1)
	dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1
	dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2
	end if
	end do
	end if
	end subroutine dag_options_make_f_nodes_pair
	end subroutine dag_options_make_f_nodes

	@ %def dag_options_make_f_nodes
	@ We create all combinations of daughter [[f_nodes]] for a combination.
	In the combination each daughter can be either a single [[dag_node]] or
	[[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we
	first create all possible [[f_nodes]] for daughter1, then all possible
	[[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes
	with all [[daughter2]] nodes.
	<<Cascades2: dag combination: TBP>>=
	procedure :: make_f_nodes => dag_combination_make_f_nodes
	<<Cascades2: sub interfaces>>=
	module subroutine dag_combination_make_f_nodes (dag_combination, &
	feyngraph_set, dag)
	class(dag_combination_t), intent(inout) :: dag_combination
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	end subroutine dag_combination_make_f_nodes
	<<Cascades2: procedures>>=
	module subroutine dag_combination_make_f_nodes (dag_combination, &
	feyngraph_set, dag)
	class(dag_combination_t), intent(inout) :: dag_combination
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(dag_t), intent(inout) :: dag
	integer, dimension (2) :: obj, i_obj
	integer :: n_obj
	integer :: new_size, size1, size2
	integer :: i, j, pos
	if (allocated (dag_combination%f_node_ptr1)) return
	n_obj = 0
	do i = 1, size (dag_combination%string%t)
	select case (dag_combination%string%t(i)%type)
	case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
	n_obj = n_obj + 1
	if (n_obj > 2) return
	obj(n_obj) = dag_combination%string%t(i)%type
	i_obj(n_obj) = dag_combination%string%t(i)%index
	end select
	end do
	size1 = 0
	size2 = 0
	if (obj(1) == DAG_NODE_TK) then
	if (allocated (dag%node(i_obj(1))%f_node)) &
	size1 = size (dag%node(i_obj(1))%f_node)
	else if (obj(1) == DAG_OPTIONS_TK) then
	if (allocated (dag%options(i_obj(1))%f_node_ptr1)) &
	size1 = size (dag%options(i_obj(1))%f_node_ptr1)
	end if
	if (obj(2) == DAG_NODE_TK) then
	if (allocated (dag%node(i_obj(2))%f_node)) &
	size2 = size (dag%node(i_obj(2))%f_node)
	else if (obj(2) == DAG_OPTIONS_TK) then
	if (allocated (dag%options(i_obj(2))%f_node_ptr1)) &
	size2 = size (dag%options(i_obj(2))%f_node_ptr1)
	end if
	!!! combine the 2 arrays of f_nodes
	new_size = size1*size2
	if (new_size /= 0) then
	allocate (dag_combination%f_node_ptr1 (new_size))
	allocate (dag_combination%f_node_ptr2 (new_size))
	pos = 0
	select case (obj(1))
	case (DAG_NODE_TK)
	select case (obj(2))
	case (DAG_NODE_TK)
	do i = 1, size1
	do j = 1, size2
	pos = pos + 1
	dag_combination%f_node_ptr1(pos) = &
	dag%node(i_obj(1))%f_node(i)
	dag_combination%f_node_ptr2(pos) = &
	dag%node(i_obj(2))%f_node(j)
	end do
	end do
	case (DAG_OPTIONS_TK)
	do i = 1, size1
	do j = 1, size2
	pos = pos + 1
	dag_combination%f_node_ptr1(pos) = &
	dag%node(i_obj(1))%f_node(i)
	dag_combination%f_node_ptr2(pos) = &
	dag%options(i_obj(2))%f_node_ptr1(j)
	end do
	end do
	end select
	case (DAG_OPTIONS_TK)
	select case (obj(2))
	case (DAG_NODE_TK)
	do i = 1, size1
	do j = 1, size2
	pos = pos + 1
	dag_combination%f_node_ptr1(pos) = &
	dag%options(i_obj(1))%f_node_ptr1(i)
	dag_combination%f_node_ptr2(pos) = &
	dag%node(i_obj(2))%f_node(j)
	end do
	end do
	case (DAG_OPTIONS_TK)
	do i = 1, size1
	do j = 1, size2
	pos = pos + 1
	dag_combination%f_node_ptr1(pos) = &
	dag%options(i_obj(1))%f_node_ptr1(i)
	dag_combination%f_node_ptr2(pos) = &
	dag%options(i_obj(2))%f_node_ptr1(j)
	end do
	end do
	end select
	end select
	end if
	end subroutine dag_combination_make_f_nodes

	@ %def dag_combination_make_f_nodes
	@ Here we create the [[feyngraphs]]. After the construction of the
	[[dag]] the remaining [[dag_string]] should contain a token for a
	single [[dag_node]] which corresponds to the roots of the
	[[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]]
	and create a [[feyngraph]] for each [[f_node]]. Note that only
	3-vertices are accepted. All other vertices are rejected. The
	starting point is the last dag node which has been added to the list,
	since this corresponds to the root of the tree.
	Is is important to understand that the structure of feyngraphs is not
	the same as the structure of the dag which is read from file, because
	for the calculations which are performed in this module we want to
	reuse the nodes for the outgoing particles, which means that they
	appear only once. In O'Mega's output, it is the first incoming particle
	which appears only once and the outgoing particles appear many times. This
	transition is incorporated in the subroutines which create [[f_nodes]]
	from the different dag objects.
	<<Cascades2: dag: TBP>>=
	procedure :: make_feyngraphs => dag_make_feyngraphs
	<<Cascades2: sub interfaces>>=
	module subroutine dag_make_feyngraphs (dag, feyngraph_set)
	class(dag_t), intent(inout) :: dag
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	end subroutine dag_make_feyngraphs
	<<Cascades2: procedures>>=
	module subroutine dag_make_feyngraphs (dag, feyngraph_set)
	class(dag_t), intent(inout) :: dag
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	integer :: i
	integer :: max_subtree_size
	max_subtree_size = dag%node(dag%n_nodes)%subtree_size
	if (allocated (dag%node(dag%n_nodes)%f_node)) then
	do i = 1, size (dag%node(dag%n_nodes)%f_node)
	if (.not. associated (feyngraph_set%first)) then
	allocate (feyngraph_set%last)
	feyngraph_set%first => feyngraph_set%last
	else
	allocate (feyngraph_set%last%next)
	feyngraph_set%last => feyngraph_set%last%next
	end if
	feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node
	!!! The first particle was correct in the O'Mega parsable DAG output.
	!!! It was however changed to its anti-particle in
	!!! f_node_assign_particle_properties, which we revert here.
	feyngraph_set%last%root%particle => &
	feyngraph_set%last%root%particle%anti
	feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes
	feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
	end do
	feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
	end if
	end subroutine dag_make_feyngraphs

	@ %def dag_make_feyngraphs
	@ A write procedure of the [[dag]] for debugging.
	<<Cascades2: dag: TBP>>=
	procedure :: write => dag_write
	<<Cascades2: sub interfaces>>=
	module subroutine dag_write (dag, u)
	class(dag_t), intent(in) :: dag
	integer, intent(in) :: u
	end subroutine dag_write
	<<Cascades2: procedures>>=
	module subroutine dag_write (dag, u)
	class(dag_t), intent(in) :: dag
	integer, intent(in) :: u
	integer :: i
	write (u,fmt='(A)') 'nodes'
	do i=1, dag%n_nodes
	write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string)
	end do
	write (u,fmt='(A)') 'options'
	do i=1, dag%n_options
	write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string)
	end do
	write (u,fmt='(A)') 'combination'
	do i=1, dag%n_combinations
	write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string)
	end do
	end subroutine dag_write

	@ %def dag_write
	@ Make a copy of a resonant [[k_node]], where the copy is kept
	nonresonant.
	<<Cascades2: procedures>>=
	subroutine k_node_make_nonresonant_copy (k_node)
	type(k_node_t), intent(in) :: k_node
	type(k_node_t), pointer :: copy
	call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.)
	copy%daughter1 => k_node%daughter1
	copy%daughter2 => k_node%daughter2
	copy = k_node
	copy%mapping = NONRESONANT
	copy%resonant = .false.
	copy%on_shell = .false.
	copy%mapping_assigned = .true.
	copy%is_nonresonant_copy = .true.
	end subroutine k_node_make_nonresonant_copy

	@ %def k_node_make_nonresonant_copy
	@ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here
	we use existing [[k_nodes]] which have already been created when the
	mapping calculations of the pure s-channel subgraphs are performed. The
	nodes for the incoming particles or the nodes on the t-line will have
	to be created in all cases because they are not used in several graphs.
	To obtain the existing [[k_nodes]], we use the subroutine
	[[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]]
	to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]].
	The created [[kingraphs]] are attached to the linked list
	of the [[feyngraph]]. For scattering processes we have to split up the
	t-line, because since all graphs are represented as a decay, different
	nodes can share daughter nodes. This happens also for the t-line or
	the incoming particle which appears as an outgoing particle. For the
	[[t_line]] or [[incoming]] nodes we do not want to recycle nodes but
	rather create a copy of this line for each [[kingraph]].
	<<Cascades2: feyngraph: TBP>>=
	procedure :: make_kingraphs => feyngraph_make_kingraphs
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
	class(feyngraph_t), intent(inout) :: feyngraph
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	end subroutine feyngraph_make_kingraphs
	<<Cascades2: procedures>>=
	module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
	class(feyngraph_t), intent(inout) :: feyngraph
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	type(k_node_ptr_t), dimension (:), allocatable :: kingraph_root
	integer :: i
	if (.not. associated (feyngraph%kin_first)) then
	call k_node_init_from_f_node (feyngraph%root, &
	kingraph_root, feyngraph_set)
	if (.not. feyngraph%root%keep) return
	if (feyngraph_set%process_type == SCATTERING) then
	call split_up_t_lines (kingraph_root)
	end if
	do i=1, size (kingraph_root)
	if (associated (feyngraph%kin_last)) then
	allocate (feyngraph%kin_last%next)
	feyngraph%kin_last => feyngraph%kin_last%next
	else
	allocate (feyngraph%kin_last)
	feyngraph%kin_first => feyngraph%kin_last
	end if
	feyngraph%kin_last%root => kingraph_root(i)%node
	feyngraph%kin_last%n_nodes = feyngraph%n_nodes
	feyngraph%kin_last%keep = feyngraph%keep
	if (feyngraph_set%process_type == SCATTERING) then
	feyngraph%kin_last%root%bincode = &
	f_node_get_external_bincode (feyngraph_set, feyngraph%root)
	end if
	end do
	deallocate (kingraph_root)
	end if
	end subroutine feyngraph_make_kingraphs

	@ %def feyngraph_make_kingraphs
	@ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes
	using [[k_node_ptr]]. If the node is external, we assign also the bincode
	to the [[k_nodes]] because this is determined from substrings of the
	input file which belong to the [[feyngraphs]] and [[f_nodes]].
	<<Cascades2: procedures>>=
	recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set)
	type(f_node_t), target, intent(inout) :: f_node
	type(k_node_ptr_t), allocatable, dimension (:), intent(out) :: k_node_ptr
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	type(k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2
	integer :: n_nodes
	integer :: i, j
	integer :: pos
	integer, save :: counter = 0
	if (.not. (f_node%incoming .or. f_node%t_line)) then
	call f_node%k_node_list%get_nodes (k_node_ptr)
	if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then
	f_node%keep = .false.
	return
	end if
	end if
	if (.not. allocated (k_node_ptr)) then
	if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then
	call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, &
	feyngraph_set)
	call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, &
	feyngraph_set)
	if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then
	f_node%keep = .false.
	return
	end if
	n_nodes = size (daughter_ptr1) * size (daughter_ptr2)
	allocate (k_node_ptr (n_nodes))
	pos = 1
	do i=1, size (daughter_ptr1)
	do j=1, size (daughter_ptr2)
	if (f_node%incoming .or. f_node%t_line) then
	call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.)
	else
	call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.)
	end if
	k_node_ptr(pos)%node%f_node => f_node
	k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node
	k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node
	k_node_ptr(pos)%node%f_node_index = f_node%index
	k_node_ptr(pos)%node%incoming = f_node%incoming
	k_node_ptr(pos)%node%t_line = f_node%t_line
	k_node_ptr(pos)%node%particle => f_node%particle
	pos = pos + 1
	end do
	end do
	deallocate (daughter_ptr1, daughter_ptr2)
	else
	allocate (k_node_ptr(1))
	if (f_node%incoming .or. f_node%t_line) then
	call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.)
	else
	call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.)
	end if
	k_node_ptr(1)%node%f_node => f_node
	k_node_ptr(1)%node%f_node_index = f_node%index
	k_node_ptr(1)%node%incoming = f_node%incoming
	k_node_ptr(1)%node%t_line = f_node%t_line
	k_node_ptr(1)%node%particle => f_node%particle
	k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, &
	f_node)
	end if
	end if
	end subroutine k_node_init_from_f_node

	@ %def k_node_init_from_f_node
	@ The graphs resulting from [[k_node_init_from_f_node]] are fine if they
	are used only in one direction. This is however not the case when one
	wants to invert the graphs, i.e. take the other incoming particle of a
	scattering process as the decaying particle, because the outgoing
	[[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This
	problem is solved here by creating a distinct t-line for each of the
	graphs. The following subroutine disentangles the data structure by
	creating new nodes such that the different t-lines are not connected
	any more.
	<<Cascades2: procedures>>=
	recursive subroutine split_up_t_lines (t_node)
	type(k_node_ptr_t), dimension(:), intent(inout) :: t_node
	type(k_node_t), pointer :: ref_node => null ()
	type(k_node_t), pointer :: ref_daughter => null ()
	type(k_node_t), pointer :: new_daughter => null ()
	type(k_node_ptr_t), dimension(:), allocatable :: t_daughter
	integer :: ref_daughter_index
	integer :: i, j
	allocate (t_daughter (size (t_node)))
	do i=1, size (t_node)
	ref_node => t_node(i)%node
	if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then
	ref_daughter => null ()
	if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then
	ref_daughter => ref_node%daughter1
	ref_daughter_index = 1
	else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then
	ref_daughter => ref_node%daughter2
	ref_daughter_index = 2
	end if
	do j=1, size (t_daughter)
	if (.not. associated (t_daughter(j)%node)) then
	t_daughter(j)%node => ref_daughter
	exit
	else if (t_daughter(j)%node%index == ref_daughter%index) then
	new_daughter => null ()
	call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.)
	new_daughter = ref_daughter
	new_daughter%daughter1 => ref_daughter%daughter1
	new_daughter%daughter2 => ref_daughter%daughter2
	if (ref_daughter_index == 1) then
	ref_node%daughter1 => new_daughter
	else if (ref_daughter_index == 2) then
	ref_node%daughter2 => new_daughter
	end if
	ref_daughter => new_daughter
	end if
	end do
	else
	return
	end if
	end do
	call split_up_t_lines (t_daughter)
	deallocate (t_daughter)
	end subroutine split_up_t_lines

	@ %def split_up_t_lines
	@ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we
	invert a [[kingraph]] such that not the first but the second incoming
	particle appears as the root of the tree, the [[incoming]] and [[t_line]]
	particles obtain other daughters. These are the former mother node and
	the sister node [[s_daughter]]. Here we set only the pointers for
	the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]]
	and [[node_inverse_deep_copy]].
	<<Cascades2: procedures>>=
	subroutine kingraph_set_inverse_daughters (kingraph)
	type(kingraph_t), intent(inout) :: kingraph
	type(k_node_t), pointer :: mother
	type(k_node_t), pointer :: t_daughter
	type(k_node_t), pointer :: s_daughter
	mother => kingraph%root
	do while (associated (mother))
	if (associated (mother%daughter1) .and. &
	associated (mother%daughter2)) then
	if (mother%daughter1%t_line .or. mother%daughter1%incoming) then
	t_daughter => mother%daughter1; s_daughter => mother%daughter2
	else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then
	t_daughter => mother%daughter2; s_daughter => mother%daughter1
	else
	exit
	end if
	t_daughter%inverse_daughter1 => mother
	t_daughter%inverse_daughter2 => s_daughter
	mother => t_daughter
	else
	exit
	end if
	end do
	end subroutine kingraph_set_inverse_daughters

	@ %def kingraph_set_inverse_daughters
	@ Set the bincode of an [[f_node]] which corresponds to an external
	particle. This is done on the basis of the [[particle_label]] which is a
	substring of the input file. Here it is not the particle name which is
	important, but the number(s) in brackets which in general indicate the
	external particles which are connected to the current node. This function
	is however only used for external particles, so there can either be
	one or [[n_out + 1]] particles in the brackets (in the DAG input file
	always one, because also for the root there is only a single number).
	In all cases we check the number of particles (in the DAG input the
	numbers are separated by a slash).
	<<Cascades2: procedures>>=
	function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode)
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	type(f_node_t), intent(in) :: f_node
	integer (TC) :: bincode
	character(len=LABEL_LEN) :: particle_label
	integer :: start_pos, end_pos, n_out_decay
	integer :: n_prt ! for DAG
	integer :: i
	bincode = 0
	if (feyngraph_set%process_type == DECAY) then
	n_out_decay = feyngraph_set%n_out
	else
	n_out_decay = feyngraph_set%n_out + 1
	end if
	particle_label = f_node%particle_label
	start_pos = index (particle_label, '[') + 1
	end_pos = index (particle_label, ']') - 1
	particle_label = particle_label(start_pos:end_pos)
	!!! n_out_decay is the number of outgoing particles in the
	!!! O'Mega output, which is always represented as a decay
	if (feyngraph_set%use_dag) then
	n_prt = 1
	do i=1, len(particle_label)
	if (particle_label(i:i) == '/') n_prt = n_prt + 1
	end do
	else
	n_prt = end_pos - start_pos + 1
	end if
	if (n_prt == 1) then
	bincode = calculate_external_bincode (particle_label, &
	feyngraph_set%process_type, n_out_decay)
	else if (n_prt == n_out_decay) then
	bincode = ibset (0, n_out_decay)
	end if
	end function f_node_get_external_bincode

	@ %def f_node_get_external_bincode
	@ Assign a bincode to an internal node, which is calculated from
	the bincodes of [[daughter1]] and [[daughter2]].
	<<Cascades2: procedures>>=
	subroutine node_assign_bincode (node)
	type(k_node_t), intent(inout) :: node
	if (associated (node%daughter1) .and. associated (node%daughter2) &
	.and. .not. node%incoming) then
	node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode)
	end if
	end subroutine node_assign_bincode

	@ %def node_assign_bincode
	@ Calculate the [[bincode]] from the number in the brackets of the
	[[particle_label]], if the node is external. For the root in the
	non-factorized output, this is calculated directly in
	[[f_node_get_external_bincode]] because in this case all the other
	external particle numbers appear between the brackets.
	<<Cascades2: procedures>>=
	function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode)
	character(len=*), intent(in) :: label_number_string
	integer, intent(in) :: process_type
	integer, intent(in) :: n_out_decay
	character :: number_char
	integer :: number_int
	integer (kind=TC) :: bincode
	bincode = 0
	read (label_number_string, fmt='(A)') number_char
	!!! check if the character is a letter (A,B,C,...) or a number (1...9)
	!!! numbers 1 and 2 are special cases
	select case (number_char)
	case ('1')
	if (process_type == SCATTERING) then
	number_int = n_out_decay + 3
	else
	number_int = n_out_decay + 2
	end if
	case ('2')
	if (process_type == SCATTERING) then
	number_int = n_out_decay + 2
	else
	number_int = 2
	end if
	case ('A')
	number_int = 10
	case ('B')
	number_int = 11
	case ('C')
	number_int = 12
	case ('D')
	number_int = 13
	case default
	read (number_char, fmt='(I1)') number_int
	end select
	bincode = ibset (bincode, number_int - process_type - 1)
	end function calculate_external_bincode

	@ %def calculate_external_bincode
	@
	\subsection{Mapping calculations}
	Once a [[k_node]] and its subtree nodes have been created, we can
	perform the kinematical calculations and assign mappings, depending on
	the particle properties and the results for the subtree nodes. This
	could in principle be done recursively, calling the procedure first
	for the daughter nodes and then perform the calculations for the actual
	node. But for parallization and comparing the nodes, this will be done
	simultaneously for all nodes with the same number of subtree nodes, and the number of
	subtree nodes increases, starting from one, in steps of two. The
	actual mapping calculations are done in complete analogy to cascades.
	<<Cascades2: procedures>>=
	subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set)
	type(feyngraph_t), intent(inout) :: feyngraph
	type(k_node_t), intent(inout) :: node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	real(default) :: eff_mass_sum
	logical :: keep
	if (.not. node%mapping_assigned) then
	if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then
	node%effective_mass = node%particle%mass
	end if
	if (associated (node%daughter1) .and. associated (node%daughter2)) then
	if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
	node%keep = .false.; return
	end if
	node%ext_mass_sum = node%daughter1%ext_mass_sum &
	+ node%daughter2%ext_mass_sum
	keep = .false.
	!!! Potentially resonant cases [sqrts = m_rea for on-shell decay]
	if (node%particle%mass > node%ext_mass_sum &
	.and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then
	if (node%particle%width /= 0) then
	if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
	keep = .true.
	node%mapping = S_CHANNEL
	node%resonant = .true.
	end if
	else
	call warn_decay (node%particle)
	end if
	!!! Collinear and IR singular cases
	else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then
	!!! Massless splitting
	if (node%daughter1%effective_mass == 0 &
	.and. node%daughter2%effective_mass == 0 &
	.and. .not. associated (node%daughter1%daughter1) &
	.and. .not. associated (node%daughter1%daughter2) &
	.and. .not. associated (node%daughter2%daughter1) &
	.and. .not. associated (node%daughter2%daughter2)) then
	keep = .true.
	node%log_enhanced = .true.
	if (node%particle%is_vector) then
	if (node%daughter1%particle%is_vector &
	.and. node%daughter2%particle%is_vector) then
	node%mapping = COLLINEAR !!! three-vector-splitting
	else
	node%mapping = INFRARED !!! vector spliiting into matter
	end if
	else
	if (node%daughter1%particle%is_vector &
	.or. node%daughter2%particle%is_vector) then
	node%mapping = COLLINEAR !!! vector radiation off matter
	else
	node%mapping = INFRARED !!! scalar radiation/splitting
	end if
	end if
	!!! IR radiation off massive particle [cascades]
	else if (node%effective_mass > 0 .and. &
	node%daughter1%effective_mass > 0 .and. &
	node%daughter2%effective_mass == 0 .and. &
	(node%daughter1%on_shell .or. &
	node%daughter1%mapping == RADIATION) .and. &
	abs (node%effective_mass - &
	node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
	then
	keep = .true.
	node%log_enhanced = .true.
	node%mapping = RADIATION
	else if (node%effective_mass > 0 .and. &
	node%daughter2%effective_mass > 0 .and. &
	node%daughter1%effective_mass == 0 .and. &
	(node%daughter2%on_shell .or. &
	node%daughter2%mapping == RADIATION) .and. &
	abs (node%effective_mass - &
	node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
	then
	keep = .true.
	node%log_enhanced = .true.
	node%mapping = RADIATION
	end if
	end if
	!!! Non-singular cases, including failed resonances [from cascades]
	if (.not. keep) then
	!!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2]
	if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
	keep = .true.
	eff_mass_sum = node%daughter1%effective_mass &
	+ node%daughter2%effective_mass
	node%effective_mass = max (node%ext_mass_sum, eff_mass_sum)
	if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then
	node%effective_mass = 0
	end if
	end if
	end if
	!!! Complete and register feyngraph (make copy in case of resonance)
	if (keep) then
	node%on_shell = node%resonant .or. node%log_enhanced
	if (node%resonant) then
	if (feyngraph_set%phs_par%keep_nonresonant) then
	call k_node_make_nonresonant_copy (node)
	end if
	node%ext_mass_sum = node%particle%mass
	end if
	end if
	node%mapping_assigned = .true.
	call node_assign_bincode (node)
	call node%subtree%add_entry (node)
	else !!! external (outgoing) particle
	node%ext_mass_sum = node%particle%mass
	node%mapping = EXTERNAL_PRT
	node%multiplicity = 1
	node%mapping_assigned = .true.
	call node%subtree%add_entry (node)
	node%on_shell = .true.
	if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then
	node%effective_mass = node%particle%mass
	end if
	end if
	else if (node%is_nonresonant_copy) then
	call node_assign_bincode (node)
	call node%subtree%add_entry (node)
	node%is_nonresonant_copy = .false.
	end if
	call node_count_specific_properties (node)
	if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
	node%keep = .false.
	end if
	contains
	subroutine warn_decay (particle)
	type(part_prop_t), intent(in) :: particle
	integer :: i
	integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
	LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
	if (warned_code(i) == 0) then
	warned_code(i) = particle%pdg
	write (msg_buffer, "(A)") &
	& " Intermediate decay of zero-width particle " &
	& // trim(particle%particle_label) &
	& // " may be possible."
	call msg_warning
	exit LOOP_WARNED
	else if (warned_code(i) == particle%pdg) then
	exit LOOP_WARNED
	end if
	end do LOOP_WARNED
	end subroutine warn_decay
	end subroutine node_assign_mapping_s

	@ %def node_assign_mapping_s
	@ We determine the numbers [[n_resonances]], [[multiplicity]],
	[[n_off_shell]] and [[n_log_enhanced]] for a given node.
	<<Cascades2: procedures>>=
	subroutine node_count_specific_properties (node)
	type(k_node_t), intent(inout) :: node
	if (associated (node%daughter1) .and. associated(node%daughter2)) then
	if (node%resonant) then
	node%multiplicity = 1
	node%n_resonances &
	= node%daughter1%n_resonances &
	+ node%daughter2%n_resonances + 1
	else
	node%multiplicity &
	= node%daughter1%multiplicity &
	+ node%daughter2%multiplicity
	node%n_resonances &
	= node%daughter1%n_resonances &
	+ node%daughter2%n_resonances
	end if
	if (node%log_enhanced) then
	node%n_log_enhanced &
	= node%daughter1%n_log_enhanced &
	+ node%daughter2%n_log_enhanced + 1
	else
	node%n_log_enhanced &
	= node%daughter1%n_log_enhanced &
	+ node%daughter2%n_log_enhanced
	end if
	if (node%resonant) then
	node%n_off_shell = 0
	else if (node%log_enhanced) then
	node%n_off_shell &
	= node%daughter1%n_off_shell &
	+ node%daughter2%n_off_shell
	else
	node%n_off_shell &
	= node%daughter1%n_off_shell &
	+ node%daughter2%n_off_shell + 1
	end if
	if (node%t_line) then
	if (node%daughter1%t_line .or. node%daughter1%incoming) then
	node%n_t_channel = node%daughter1%n_t_channel + 1
	else if (node%daughter2%t_line .or. node%daughter2%incoming) then
	node%n_t_channel = node%daughter2%n_t_channel + 1
	end if
	end if
	end if
	end subroutine node_count_specific_properties

	@ %def node_count_specific_properties
	@ The subroutine [[kingraph_assign_mappings_s]] completes kinematical
	calculations for a decay process, considering the [[root]] node.
	<<Cascades2: procedures>>=
	subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set)
	type(feyngraph_t), intent(inout) :: feyngraph
	type(kingraph_t), pointer, intent(inout) :: kingraph
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then
	kingraph%keep = .false.
	call kingraph%tree%final ()
	end if
	if (kingraph%keep) then
	kingraph%root%on_shell = .true.
	kingraph%root%mapping = EXTERNAL_PRT
	kingraph%root%mapping_assigned = .true.
	call node_assign_bincode (kingraph%root)
	kingraph%root%ext_mass_sum = &
	kingraph%root%daughter1%ext_mass_sum + &
	kingraph%root%daughter2%ext_mass_sum
	if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then
	kingraph%root%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	end if
	call kingraph%root%subtree%add_entry (kingraph%root)
	kingraph%root%multiplicity &
	= kingraph%root%daughter1%multiplicity &
	+ kingraph%root%daughter2%multiplicity
	kingraph%root%n_resonances &
	= kingraph%root%daughter1%n_resonances &
	+ kingraph%root%daughter2%n_resonances
	kingraph%root%n_off_shell &
	= kingraph%root%daughter1%n_off_shell &
	+ kingraph%root%daughter2%n_off_shell
	kingraph%root%n_log_enhanced &
	= kingraph%root%daughter1%n_log_enhanced &
	+ kingraph%root%daughter2%n_log_enhanced
	if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then
	kingraph%root%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	else
	kingraph%grove_prop%multiplicity = &
	kingraph%root%multiplicity
	kingraph%grove_prop%n_resonances = &
	kingraph%root%n_resonances
	kingraph%grove_prop%n_off_shell = &
	kingraph%root%n_off_shell
	kingraph%grove_prop%n_log_enhanced = &
	kingraph%root%n_log_enhanced
	end if
	kingraph%tree = kingraph%root%subtree
	end if
	end subroutine kingraph_assign_mappings_s

	@ %def kingraph_assign_mappings_s
	@ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is
	done recursively using [[node_compute_t_line]].
	<<Cascades2: procedures>>=
	subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set)
	type(feyngraph_t), intent(inout) :: feyngraph
	type(kingraph_t), pointer, intent(inout) :: kingraph
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set)
	if (.not. kingraph%root%keep) then
	kingraph%keep = .false.
	call kingraph%tree%final ()
	end if
	if (kingraph%keep) kingraph%tree = kingraph%root%subtree
	end subroutine kingraph_compute_mappings_t_line

	@ %def kingraph_compute_mappings_t_line
	@ Perform the kinematical calculations and mapping assignment for a node
	which is either [[incoming]] or [[t_line]]. This is done recursively,
	going first to the daughter node which has this property. Therefore we
	first set the pointer [[t_node]] to this daughter node and [[s_node]] to
	the other one. The mapping determination happens again in the same way as
	in [[cascades]].
	<<Cascades2: procedures>>=
	recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set)
	type(feyngraph_t), intent(inout) :: feyngraph
	type(kingraph_t), intent(inout) :: kingraph
	type(k_node_t), intent(inout) :: node
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(k_node_t), pointer :: s_node
	type(k_node_t), pointer :: t_node
	type(k_node_t), pointer :: new_s_node
	if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
	node%keep = .false.
	return
	end if
	s_node => null ()
	t_node => null ()
	new_s_node => null ()
	if (associated (node%daughter1) .and. associated (node%daughter2)) then
	if (node%daughter1%t_line .or. node%daughter1%incoming) then
	t_node => node%daughter1; s_node => node%daughter2
	else if (node%daughter2%t_line .or. node%daughter2%incoming) then
	t_node => node%daughter2; s_node => node%daughter1
	end if
	if (t_node%t_line) then
	call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set)
	if (.not. t_node%keep) then
	node%keep = .false.
	return
	end if
	else if (t_node%incoming) then
	t_node%mapping = EXTERNAL_PRT
	t_node%on_shell = .true.
	t_node%ext_mass_sum = t_node%particle%mass
	if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then
	t_node%effective_mass = t_node%particle%mass
	end if
	call t_node%subtree%add_entry (t_node)
	end if
	!!! root:
	if (.not. node%incoming) then
	if (t_node%incoming) then
	node%ext_mass_sum = s_node%ext_mass_sum
	else
	node%ext_mass_sum &
	= node%daughter1%ext_mass_sum &
	+ node%daughter2%ext_mass_sum
	end if
	if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then
	node%effective_mass = max (node%particle%mass, &
	s_node%effective_mass)
	else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then
	node%effective_mass = s_node%effective_mass
	else
	node%effective_mass = 0
	end if
	!!! Allowed decay of beam particle
	if (t_node%incoming &
	.and. t_node%particle%mass > s_node%particle%mass &
	+ node%particle%mass) then
	call beam_decay (feyngraph_set%fatal_beam_decay)
	!!! Massless splitting
	else if (t_node%effective_mass == 0 &
	.and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t &
	.and. node%effective_mass == 0) then
	node%mapping = U_CHANNEL
	node%log_enhanced = .true.
	!!! IR radiation off massive particle
	else if (t_node%effective_mass /= 0 &
	.and. s_node%effective_mass == 0 &
	.and. node%effective_mass /= 0 &
	.and. (t_node%on_shell &
	.or. t_node%mapping == RADIATION) &
	.and. abs (t_node%effective_mass - node%effective_mass) &
	< feyngraph_set%phs_par%m_threshold_t) then
	node%log_enhanced = .true.
	node%mapping = RADIATION
	end if
	node%mapping_assigned = .true.
	call node_assign_bincode (node)
	call node%subtree%add_entry (node)
	call node_count_specific_properties (node)
	if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
	node%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
	node%keep = .false.;
	kingraph%keep = .false.; call kingraph%tree%final (); return
	end if
	else
	node%mapping = EXTERNAL_PRT
	node%on_shell = .true.
	node%ext_mass_sum &
	= t_node%ext_mass_sum &
	+ s_node%ext_mass_sum
	node%effective_mass = node%particle%mass
	if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then
	node%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	end if
	if (kingraph%keep) then
	if (t_node%incoming .and. s_node%log_enhanced) then
	call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
	new_s_node = s_node
	new_s_node%daughter1 => s_node%daughter1
	new_s_node%daughter2 => s_node%daughter2
	if (s_node%index == node%daughter1%index) then
	node%daughter1 => new_s_node
	else if (s_node%index == node%daughter2%index) then
	node%daughter2 => new_s_node
	end if
	new_s_node%subtree = s_node%subtree
	new_s_node%mapping = NO_MAPPING
	new_s_node%log_enhanced = .false.
	new_s_node%n_log_enhanced &
	= new_s_node%n_log_enhanced - 1
	new_s_node%log_enhanced = .false.
	where (new_s_node%subtree%bc == new_s_node%bincode)
	new_s_node%subtree%mapping = NO_MAPPING
	endwhere
	else if ((t_node%t_line .or. t_node%incoming) .and. &
	t_node%mapping == U_CHANNEL) then
	t_node%mapping = T_CHANNEL
	where (t_node%subtree%bc == t_node%bincode)
	t_node%subtree%mapping = T_CHANNEL
	endwhere
	else if (t_node%incoming .and. &
	.not. associated (s_node%daughter1) .and. &
	.not. associated (s_node%daughter2)) then
	call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
	new_s_node = s_node
	new_s_node%mapping = ON_SHELL
	new_s_node%daughter1 => s_node%daughter1
	new_s_node%daughter2 => s_node%daughter2
	new_s_node%subtree = s_node%subtree
	if (s_node%index == node%daughter1%index) then
	node%daughter1 => new_s_node
	else if (s_node%index == node%daughter2%index) then
	node%daughter2 => new_s_node
	end if
	where (new_s_node%subtree%bc == new_s_node%bincode)
	new_s_node%subtree%mapping = ON_SHELL
	endwhere
	end if
	end if
	call node%subtree%add_entry (node)
	node%multiplicity &
	= node%daughter1%multiplicity &
	+ node%daughter2%multiplicity
	node%n_resonances &
	= node%daughter1%n_resonances &
	+ node%daughter2%n_resonances
	node%n_off_shell &
	= node%daughter1%n_off_shell &
	+ node%daughter2%n_off_shell
	node%n_log_enhanced &
	= node%daughter1%n_log_enhanced &
	+ node%daughter2%n_log_enhanced
	node%n_t_channel &
	= node%daughter1%n_t_channel &
	+ node%daughter2%n_t_channel
	if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
	node%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
	node%keep = .false.
	kingraph%keep = .false.; call kingraph%tree%final (); return
	else
	kingraph%grove_prop%multiplicity = node%multiplicity
	kingraph%grove_prop%n_resonances = node%n_resonances
	kingraph%grove_prop%n_off_shell = node%n_off_shell
	kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced
	kingraph%grove_prop%n_t_channel = node%n_t_channel
	end if
	end if
	end if
	contains
	subroutine beam_decay (fatal_beam_decay)
	logical, intent(in) :: fatal_beam_decay
	write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
	t_node%particle%particle_label, &
	node%particle%particle_label, &
	s_node%particle%particle_label
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	t_node%particle%particle_label, t_node%particle%mass
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	node%particle%particle_label, node%particle%mass
	call msg_message
	write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
	s_node%particle%particle_label, s_node%particle%mass
	call msg_message
	if (fatal_beam_decay) then
	call msg_fatal (" Phase space: Initial beam particle can decay")
	else
	call msg_warning (" Phase space: Initial beam particle can decay")
	end if
	end subroutine beam_decay
	end subroutine node_compute_t_line

	@ %def node_compute_t_line
	@ After all pure s-channel subdiagrams have already been created from the
	corresponding [[f_nodes]] and mappings have been determined for their
	nodes, we complete the calculations here. In a first step, the
	[[kingraphs]] have to be created on the basis of the existing
	[[k_nodes]], which means in particular that a [[feyngraph]] can give
	rise to several [[kingraphs]] which will all be attached to the linked
	list of the [[feyngraph]]. The calculations which remain are of different
	kinds for decay and scattering processes. In a decay process the
	kinematical calculations have to be done for the [[root]] node. In a
	scattering process, after the creation of [[kingraphs]] in the first
	step, there will be only [[kingraphs]] with the first incoming particle
	as the [[root]] of the tree. For these graphs the [[inverse]] variable
	has the value [[.false.]]. Before performing any calculations on these
	graphs we make a so-called inverse copy of the graph (see below), which
	will also be attached to the linked list. Since the s-channel subgraph
	calculations have already been completed, only the t-line computations
	remain.
	<<Cascades2: feyngraph: TBP>>=
	procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_make_inverse_kingraphs (feyngraph)
	class(feyngraph_t), intent(inout) :: feyngraph
	end subroutine feyngraph_make_inverse_kingraphs
	<<Cascades2: procedures>>=
	module subroutine feyngraph_make_inverse_kingraphs (feyngraph)
	class(feyngraph_t), intent(inout) :: feyngraph
	type(kingraph_t), pointer :: current
	current => feyngraph%kin_first
	do while (associated (current))
	if (current%inverse) exit
	call current%make_inverse_copy (feyngraph)
	current => current%next
	end do
	end subroutine feyngraph_make_inverse_kingraphs

	@ %def feyngraph_make_inverse_kingraphs
	<<Cascades2: feyngraph: TBP>>=
	procedure :: compute_mappings => feyngraph_compute_mappings
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
	class(feyngraph_t), intent(inout) :: feyngraph
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	end subroutine feyngraph_compute_mappings
	<<Cascades2: procedures>>=
	module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
	class(feyngraph_t), intent(inout) :: feyngraph
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(kingraph_t), pointer :: current
	current => feyngraph%kin_first
	do while (associated (current))
	if (feyngraph_set%process_type == DECAY) then
	call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set)
	else if (feyngraph_set%process_type == SCATTERING) then
	call kingraph_compute_mappings_t_line &
	(feyngraph, current, feyngraph_set)
	end if
	current => current%next
	end do
	end subroutine feyngraph_compute_mappings

	@ %def feyngraph_compute_mappings
	@ Here we control the mapping calculations for the nodes of s-channel
	subgraphs. We start with the nodes with the smallest number of subtree
	nodes and always increase this number by two because nodes have exactly
	zero or two daughter nodes. We create the [[k_nodes]] using the
	[[k_node_list]] of each [[f_node]]. The number of nodes which have to
	be created depends of the number of existing daughter nodes, which means
	that we have to create a node for each combination of existing and
	valid (the ones which we [[keep]]) daughter nodes. If the node
	corresponds to an external particle, we create only one node, since
	there are no daughter nodes. If the particle is not external and
	the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do
	not create a new [[k_nodes]] either. When the calculations for all nodes
	with the same number of subtree nodes have been completed, we compare
	the valid nodes to eliminate equivalences (see below).
	<<Cascades2: procedures>>=
	subroutine f_node_list_compute_mappings_s (feyngraph_set)
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(f_node_ptr_t), dimension(:), allocatable :: set
	type(k_node_ptr_t), dimension(:), allocatable :: k_set
	type(k_node_entry_t), pointer :: k_entry
	type(f_node_entry_t), pointer :: current
	type(k_node_list_t), allocatable :: compare_list
	integer :: n_entries
	integer :: pos
	integer :: i, j, k
	do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2
	!!! Counter number of f_nodes with subtree size i for s channel calculations
	n_entries = 0
	if (feyngraph_set%use_dag) then
	do j=1, feyngraph_set%dag%n_nodes
	if (allocated (feyngraph_set%dag%node(j)%f_node)) then
	do k=1, size(feyngraph_set%dag%node(j)%f_node)
	if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
	if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
	.or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
	.and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
	n_entries = n_entries + 1
	end if
	end if
	end do
	end if
	end do
	else
	current => feyngraph_set%f_node_list%first
	do while (associated (current))
	if (.not. (current%node%incoming .or. current%node%t_line) &
	.and. current%node%n_subtree_nodes == i) then
	n_entries = n_entries + 1
	end if
	current => current%next
	end do
	end if
	if (n_entries == 0) exit
	!!! Create a temporary k node list for comparison
	allocate (set(n_entries))
	pos = 0
	if (feyngraph_set%use_dag) then
	do j=1, feyngraph_set%dag%n_nodes
	if (allocated (feyngraph_set%dag%node(j)%f_node)) then
	do k=1, size(feyngraph_set%dag%node(j)%f_node)
	if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
	if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
	.or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
	.and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
	pos = pos + 1
	set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node
	end if
	end if
	end do
	end if
	end do
	else
	current => feyngraph_set%f_node_list%first
	do while (associated (current))
	if (.not. (current%node%incoming .or. current%node%t_line) &
	.and. current%node%n_subtree_nodes == i) then
	pos = pos + 1
	set(pos)%node => current%node
	end if
	current => current%next
	end do
	end if
	allocate (compare_list)
	compare_list%observer = .true.
	do j = 1, n_entries
	call k_node_init_from_f_node (set(j)%node, k_set, &
	feyngraph_set)
	if (allocated (k_set)) deallocate (k_set)
	end do
	!$OMP PARALLEL DO PRIVATE (k_entry)
	do j = 1, n_entries
	k_entry => set(j)%node%k_node_list%first
	do while (associated (k_entry))
	call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set)
	k_entry => k_entry%next
	end do
	end do
	!$OMP END PARALLEL DO
	do j = 1, size (set)
	k_entry => set(j)%node%k_node_list%first
	do while (associated (k_entry))
	if (k_entry%node%keep) then
	if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then
	call compare_list%add_pointer (k_entry%node)
	end if
	end if
	k_entry => k_entry%next
	end do
	end do
	deallocate (set)
	call compare_list%check_subtree_equivalences(feyngraph_set%model)
	call compare_list%final
	deallocate (compare_list)
	end do
	end subroutine f_node_list_compute_mappings_s

	@ %def f_node_list_compute_mappings_s
	@
	\subsection{Fill the grove list}
	Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for
	which the kinematical calculations and mapping assignments have been completed. The [[groves]]
	are defined by the [[grove_prop]] entries and the value of the resonance
	hash ([[res_hash]]). Whenever a matching grove does not exist, we
	create one. In a first step we consider only part of the grove properties
	(see [[grove_prop_match]]) and the resonance hash is ignored, which leads
	to a preliminary grove list. In the end all numbers in [[grove_prop]] as
	well as the resonance hash are compared, i.e. we create a new
	[[grove_list]].
	<<Cascades2: grove list: TBP>>=
	procedure :: get_grove => grove_list_get_grove
	<<Cascades2: sub interfaces>>=
	module subroutine grove_list_get_grove (grove_list, kingraph, &
	return_grove, preliminary)
	class(grove_list_t), intent(inout) :: grove_list
	type(kingraph_t), intent(in), pointer :: kingraph
	type(grove_t), intent(inout), pointer :: return_grove
	logical, intent(in) :: preliminary
	end subroutine grove_list_get_grove
	<<Cascades2: procedures>>=
	module subroutine grove_list_get_grove (grove_list, kingraph, &
	return_grove, preliminary)
	class(grove_list_t), intent(inout) :: grove_list
	type(kingraph_t), intent(in), pointer :: kingraph
	type(grove_t), intent(inout), pointer :: return_grove
	logical, intent(in) :: preliminary
	type(grove_t), pointer :: current_grove
	return_grove => null ()
	if (.not. associated(grove_list%first)) then
	allocate (grove_list%first)
	grove_list%first%grove_prop = kingraph%grove_prop
	return_grove => grove_list%first
	return
	end if
	current_grove => grove_list%first
	do while (associated (current_grove))
	if ((preliminary .and. &
	(current_grove%grove_prop .match. kingraph%grove_prop)) .or. &
	(.not. preliminary .and. &
	current_grove%grove_prop == kingraph%grove_prop)) then
	return_grove => current_grove
	exit
	else if (.not. associated (current_grove%next)) then
	allocate (current_grove%next)
	current_grove%next%grove_prop = kingraph%grove_prop
	if (size (kingraph%tree%bc) < 9) &
	current_grove%compare_tree%depth = 1
	return_grove => current_grove%next
	exit
	end if
	if (associated (current_grove%next)) then
	current_grove => current_grove%next
	end if
	end do
	end subroutine grove_list_get_grove

	@ %def grove_list_get_grove
	@ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the
	[[grove]] which has the grove properties of the [[kingraph]]. If no such
	[[grove]] exists so far, it is created.
	<<Cascades2: grove list: TBP>>=
	procedure :: add_kingraph => grove_list_add_kingraph
	<<Cascades2: sub interfaces>>=
	module subroutine grove_list_add_kingraph (grove_list, kingraph, &
	preliminary, check, model)
	class(grove_list_t), intent(inout) :: grove_list
	type(kingraph_t), pointer, intent(inout) :: kingraph
	logical, intent(in) :: preliminary
	logical, intent(in) :: check
	type(model_data_t), optional, intent(in) :: model
	end subroutine grove_list_add_kingraph
	<<Cascades2: procedures>>=
	module subroutine grove_list_add_kingraph (grove_list, kingraph, &
	preliminary, check, model)
	class(grove_list_t), intent(inout) :: grove_list
	type(kingraph_t), pointer, intent(inout) :: kingraph
	logical, intent(in) :: preliminary
	logical, intent(in) :: check
	type(model_data_t), optional, intent(in) :: model
	type(grove_t), pointer :: grove
	type(kingraph_t), pointer :: current
	integer, save :: index = 0
	grove => null ()
	current => null ()
	if (preliminary) then
	if (kingraph%index == 0) then
	index = index + 1
	kingraph%index = index
	end if
	end if
	call grove_list%get_grove (kingraph, grove, preliminary)
	if (check) then
	call grove%compare_tree%check_kingraph (kingraph, model, preliminary)
	end if
	if (kingraph%keep) then
	if (associated (grove%first)) then
	grove%last%grove_next => kingraph
	grove%last => kingraph
	else
	grove%first => kingraph
	grove%last => kingraph
	end if
	end if
	end subroutine grove_list_add_kingraph

	@ %ref grove_list_add_kingraph
	@ For a given [[feyngraph]] we store all valid [[kingraphs]] in the
	[[grove_list]].
	<<Cascades2: grove list: TBP>>=
	procedure :: add_feyngraph => grove_list_add_feyngraph
	<<Cascades2: sub interfaces>>=
	module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model)
	class(grove_list_t), intent(inout) :: grove_list
	type(feyngraph_t), intent(inout) :: feyngraph
	type(model_data_t), intent(in) :: model
	end subroutine grove_list_add_feyngraph
	<<Cascades2: procedures>>=
	module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model)
	class(grove_list_t), intent(inout) :: grove_list
	type(feyngraph_t), intent(inout) :: feyngraph
	type(model_data_t), intent(in) :: model
	type(kingraph_t), pointer :: current_kingraph, add_kingraph
	do while (associated (feyngraph%kin_first))
	if (feyngraph%kin_first%keep) then
	add_kingraph => feyngraph%kin_first
	feyngraph%kin_first => feyngraph%kin_first%next
	add_kingraph%next => null ()
	call grove_list%add_kingraph (kingraph=add_kingraph, &
	preliminary=.true., check=.true., model=model)
	else
	exit
	end if
	end do
	if (associated (feyngraph%kin_first)) then
	current_kingraph => feyngraph%kin_first
	do while (associated (current_kingraph%next))
	if (current_kingraph%next%keep) then
	add_kingraph => current_kingraph%next
	current_kingraph%next => current_kingraph%next%next
	add_kingraph%next => null ()
	call grove_list%add_kingraph (kingraph=add_kingraph, &
	preliminary=.true., check=.true., model=model)
	else
	current_kingraph => current_kingraph%next
	end if
	end do
	end if
	end subroutine grove_list_add_feyngraph

	@ %def grove_list_add_feyngraph
	@ Compare two [[grove_prop]] objects. The [[.match.]] operator is used
	for preliminary groves in which the [[kingraphs]] share only the 3
	numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These
	groves are only used for comparing the kingraphs, because only graphs
	within these preliminary groves can be equivalent (the numbers which are
	compared here are unambigously fixed by the combination of mappings in
	these channels).
	<<Cascades2: interfaces>>=
	interface operator (.match.)
	module procedure grove_prop_match
	end interface operator (.match.)
	<<Cascades2: sub interfaces>>=
	module function grove_prop_match (grove_prop1, grove_prop2) &
	result (gp_match)
	type(grove_prop_t), intent(in) :: grove_prop1
	type(grove_prop_t), intent(in) :: grove_prop2
	logical :: gp_match
	end function grove_prop_match
	<<Cascades2: procedures>>=
	module function grove_prop_match (grove_prop1, grove_prop2) result (gp_match)
	type(grove_prop_t), intent(in) :: grove_prop1
	type(grove_prop_t), intent(in) :: grove_prop2
	logical :: gp_match
	gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) &
	.and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
	.and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
	end function grove_prop_match

	@ %def grove_prop_match
	@ The equal operator on the other hand will be used when all valid
	[[kingraphs]] have been created and mappings have been determined, to
	split up the existing (preliminary) grove list, i.e. to create new
	groves which are determined by all entries in [[grove_prop_t]].
	<<Cascades2: interfaces>>=
	interface operator (==)
	module procedure grove_prop_equal
	end interface operator (==)
	<<Cascades2: sub interfaces>>=
	module function grove_prop_equal (grove_prop1, grove_prop2) &
	result (gp_equal)
	type(grove_prop_t), intent(in) :: grove_prop1
	type(grove_prop_t), intent(in) :: grove_prop2
	logical :: gp_equal
	end function grove_prop_equal
	<<Cascades2: procedures>>=
	module function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal)
	type(grove_prop_t), intent(in) :: grove_prop1
	type(grove_prop_t), intent(in) :: grove_prop2
	logical :: gp_equal
	gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) &
	.and. (grove_prop1%n_resonances == grove_prop2%n_resonances) &
	.and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
	.and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) &
	.and. (grove_prop1%multiplicity == grove_prop2%multiplicity) &
	.and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
	end function grove_prop_equal

	@ %def grove_prop_equal
	@
	\subsection{Remove equivalent channels}
	Here we define the equivalence condition for completed [[kingraphs]].
	The aim is to keep those [[kingraphs]] which describe the strongest
	peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be
	the same for an equivalence, but the [[pdgs]] can be different. At
	the same time we check if the trees are exacly the same (up to the
	sign of pdg codes) in which case we do not keep both of them. This
	can be the case when the incoming particles are the same or their
	mutual anti-particles and there are no t-channel lines in the
	Feynman diagram to which the kingraph belongs.
	<<Cascades2: parameters>>=
	integer, parameter :: EMPTY = -999
	<<Cascades2: procedures>>=
	function kingraph_eqv (kingraph1, kingraph2) result (eqv)
	type(kingraph_t), intent(in) :: kingraph1
	type(kingraph_t), intent(inout) :: kingraph2
	logical :: eqv
	integer :: i
	logical :: equal
	eqv = .false.
	do i = kingraph1%tree%n_entries, 1, -1
	if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return
	end do
	do i = kingraph1%tree%n_entries, 1, -1
	if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) &
	.or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. &
	kingraph1%tree%mapping(i) == NONRESONANT) .and. &
	(kingraph2%tree%mapping(i) == NO_MAPPING .or. &
	kingraph2%tree%mapping(i) == NONRESONANT)))) return
	end do
	equal = .true.
	do i = kingraph1%tree%n_entries, 1, -1
	if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
	equal = .false.;
	select case (kingraph1%tree%mapping(i))
	case (S_CHANNEL, RADIATION)
	select case (kingraph2%tree%mapping(i))
	case (S_CHANNEL, RADIATION)
	return
	end select
	end select
	end if
	end do
	if (equal) then
	kingraph2%keep = .false.
	call kingraph2%tree%final ()
	else
	eqv = .true.
	end if
	end function kingraph_eqv

	@ %def kingraph_eqv
	@ Select between two [[kingraphs]] which fulfill the equivalence
	condition above. This is done by comparing the [[pdg]] values of the
	[[tree]] for increasing bincode. If the particles are different at
	some place, we usually choose the one which would be returned first by the
	subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes.
	Since we work here only on the basis of the the [[trees]] of the
	completed [[kingraphs]], we have to use the [[bc]] array to determine
	the positions of the daughter nodes' entries in the array. The graph
	which has to be kept should correspond to the stronger peak at the place
	which is compared.
	<<Cascades2: procedures>>=
	subroutine kingraph_select (kingraph1, kingraph2, model, preliminary)
	type(kingraph_t), intent(inout) :: kingraph1
	type(kingraph_t), intent(inout) :: kingraph2
	type(model_data_t), intent(in) :: model
	logical, intent(in) :: preliminary
	integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
	integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
	integer, dimension (:), allocatable :: pdg_match
	integer :: i, j
	integer :: n_ext1, n_ext2
	if (kingraph_eqv (kingraph1, kingraph2)) then
	if (.not. preliminary) then
	kingraph2%keep = .false.; call kingraph2%tree%final ()
	return
	end if
	do i=1, size (kingraph1%tree%bc)
	if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
	if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then
	n_ext1 = popcnt (kingraph1%tree%bc(i))
	n_ext2 = n_ext1
	do j=i+1, size (kingraph1%tree%bc)
	if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then
	n_ext2 = popcnt (kingraph1%tree%bc(j))
	if (n_ext2 < n_ext1) exit
	end if
	end do
	if (n_ext2 < n_ext1) cycle
	allocate (tmp_bc(i-1))
	tmp_bc = kingraph1%tree%bc(:i-1)
	allocate (tmp_pdg(i-1))
	tmp_pdg = kingraph1%tree%pdg(:i-1)
	do j=i-1, 1, - 1
	where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 &
	.or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0)
	tmp_bc(:j-1) = 0
	tmp_pdg(:j-1) = 0
	endwhere
	end do
	allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0))))
	daughter_bc = pack (tmp_bc, tmp_bc /= 0)
	allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0))))
	daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
	if (size (daughter_pdg) == 2) then
	call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
	end if
	do j=1, size (pdg_match)
	if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then
	kingraph2%keep = .false.; call kingraph2%tree%final ()
	exit
	else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then
	kingraph1%keep = .false.; call kingraph1%tree%final ()
	exit
	end if
	end do
	deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
	if (.not. (kingraph1%keep .and. kingraph2%keep)) exit
	end if
	end if
	end do
	end if
	end subroutine kingraph_select

	@ %def kingraph_select
	@ At the beginning we do not care about the resonance hash, but only
	about part of the grove properties, which is defined in
	[[grove_prop_match]]. In these resulting preliminary groves the kingraphs
	can be equivalent, i.e. we do not have to compare all graphs with each
	other but only all graphs within each of these preliminary groves. In the
	end we create a new grove list where the grove properties of the
	[[kingraphs]] within a [[grove]] have to be exactly the same and in
	addition the groves are distinguished by the resonance hash values. Here
	the kingraphs are not compared any more, which means that the number of
	channels is not reduced any more.
	<<Cascades2: grove list: TBP>>=
	procedure :: merge => grove_list_merge
	<<Cascades2: sub interfaces>>=
	module subroutine grove_list_merge (target_list, grove_list, model, &
	prc_component)
	class(grove_list_t), intent(inout) :: target_list
	type(grove_list_t), intent(inout) :: grove_list
	type(model_data_t), intent(in) :: model
	integer, intent(in) :: prc_component
	end subroutine grove_list_merge
	<<Cascades2: procedures>>=
	module subroutine grove_list_merge (target_list, grove_list, model, &
	prc_component)
	class(grove_list_t), intent(inout) :: target_list
	type(grove_list_t), intent(inout) :: grove_list
	type(model_data_t), intent(in) :: model
	integer, intent(in) :: prc_component
	type(grove_t), pointer :: current_grove
	type(kingraph_t), pointer :: current_graph
	current_grove => grove_list%first
	do while (associated (current_grove))
	do while (associated (current_grove%first))
	current_graph => current_grove%first
	current_grove%first => current_grove%first%grove_next
	current_graph%grove_next => null ()
	if (current_graph%keep) then
	current_graph%prc_component = prc_component
	call target_list%add_kingraph(kingraph=current_graph, &
	preliminary=.false., check=.true., model=model)
	else
	call current_graph%final ()
	deallocate (current_graph)
	end if
	end do
	current_grove => current_grove%next
	end do
	end subroutine grove_list_merge

	@ %def grove_list_merge
	@ Recreate a grove list where we have different groves for different
	resonance hashes.
	<<Cascades2: grove list: TBP>>=
	procedure :: rebuild => grove_list_rebuild
	<<Cascades2: sub interfaces>>=
	module subroutine grove_list_rebuild (grove_list)
	class(grove_list_t), intent(inout) :: grove_list
	end subroutine grove_list_rebuild
	<<Cascades2: procedures>>=
	module subroutine grove_list_rebuild (grove_list)
	class(grove_list_t), intent(inout) :: grove_list
	type(grove_list_t) :: tmp_list
	type(grove_t), pointer :: current_grove
	type(grove_t), pointer :: remove_grove
	type(kingraph_t), pointer :: current_graph
	type(kingraph_t), pointer :: next_graph
	tmp_list%first => grove_list%first
	grove_list%first => null ()
	current_grove => tmp_list%first
	do while (associated (current_grove))
	current_graph => current_grove%first
	do while (associated (current_graph))
	call current_graph%assign_resonance_hash ()
	next_graph => current_graph%grove_next
	current_graph%grove_next => null ()
	if (current_graph%keep) then
	call grove_list%add_kingraph (kingraph=current_graph, &
	preliminary=.false., check=.false.)
	end if
	current_graph => next_graph
	end do
	current_grove => current_grove%next
	end do
	call tmp_list%final
	end subroutine grove_list_rebuild

	@ %def grove_list_rebuild
	@
	\subsection{Write the phase-space file}
	The phase-space file is written from the graphs which survive the
	calculations and equivalence checks and are in the grove list. It is
	written grove by grove. The output should be the same as in the
	corresponding procedure [[cascade_set_write_file_format]] of
	[[cascades]], up to the order of groves and channels.
	<<Cascades2: public>>=
	public :: feyngraph_set_write_file_format
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_write_file_format (feyngraph_set, u)
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: u
	end subroutine feyngraph_set_write_file_format
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_write_file_format (feyngraph_set, u)
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: u
	type(grove_t), pointer :: grove
	integer :: channel_number
	integer :: grove_number
	channel_number = 0
	grove_number = 0
	grove => feyngraph_set%grove_list%first
	do while (associated (grove))
	grove_number = grove_number + 1
	call grove%write_file_format &
	(feyngraph_set, grove_number, channel_number, u)
	grove => grove%next
	end do
	end subroutine feyngraph_set_write_file_format

	@ %def feyngraph_set_write_file_format
	@ Write the relevant information of the [[kingraphs]] of a [[grove]] and
	the grove properties in the file format.
	<<Cascades2: grove: TBP>>=
	procedure :: write_file_format => grove_write_file_format
	<<Cascades2: sub interfaces>>=
	recursive module subroutine grove_write_file_format &
	(grove, feyngraph_set, gr_number, ch_number, u)
	class(grove_t), intent(in) :: grove
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: u
	integer, intent(inout) :: gr_number
	integer, intent(inout) :: ch_number
	end subroutine grove_write_file_format
	<<Cascades2: procedures>>=
	recursive module subroutine grove_write_file_format &
	(grove, feyngraph_set, gr_number, ch_number, u)
	class(grove_t), intent(in) :: grove
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: u
	integer, intent(inout) :: gr_number
	integer, intent(inout) :: ch_number
	type(kingraph_t), pointer :: current
	1 format(3x,A,1x,40(1x,I4))
	write (u, "(A)")
	write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
	'Multiplicity =', grove%grove_prop%multiplicity, ","
	select case (grove%grove_prop%n_resonances)
	case (0)
	write (u, '(1x,A)', advance='no') 'no resonances, '
	case (1)
	write (u, '(1x,A)', advance='no') '1 resonance, '
	case default
	write (u, '(1x,I0,1x,A)', advance='no') &
	grove%grove_prop%n_resonances, 'resonances, '
	end select
	write (u, '(1x,I0,1x,A)', advance='no') &
	grove%grove_prop%n_log_enhanced, 'logs, '
	write (u, '(1x,I0,1x,A)', advance='no') &
	grove%grove_prop%n_off_shell, 'off-shell, '
	select case (grove%grove_prop%n_t_channel)
	case (0); write (u, '(1x,A)') 's-channel graph'
	case (1); write (u, '(1x,A)') '1 t-channel line'
	case default
	write(u,'(1x,I0,1x,A)') &
	grove%grove_prop%n_t_channel, 't-channel lines'
	end select
	write (u, '(1x,A,I0)') 'grove #', gr_number
	current => grove%first
	do while (associated (current))
	if (current%keep) then
	ch_number = ch_number + 1
	call current%write_file_format (feyngraph_set, ch_number, u)
	end if
	current => current%grove_next
	end do
	end subroutine grove_write_file_format

	@ %def grove_write_file_format
	@ Write the relevant information of a valid [[kingraph]] in the file
	format. The information is extracted from the [[tree]].
	<<Cascades2: kingraph: TBP>>=
	procedure :: write_file_format => kingraph_write_file_format
	<<Cascades2: sub interfaces>>=
	module subroutine kingraph_write_file_format &
	(kingraph, feyngraph_set, ch_number, u)
	class(kingraph_t), intent(in) :: kingraph
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: ch_number
	integer, intent(in) :: u
	end subroutine kingraph_write_file_format
	<<Cascades2: procedures>>=
	module subroutine kingraph_write_file_format &
	(kingraph, feyngraph_set, ch_number, u)
	class(kingraph_t), intent(in) :: kingraph
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: ch_number
	integer, intent(in) :: u
	integer :: i
	integer(TC) :: bincode_incoming
	2 format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A)
	!!! determine bincode of incoming particle from tree
	bincode_incoming = maxval (kingraph%tree%bc)
	write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number
	write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree'
	do i=1, size (kingraph%tree%bc)
	if (kingraph%tree%mapping(i) >=0 &
	.or. kingraph%tree%mapping(i) == NONRESONANT &
	.or. (kingraph%tree%bc(i) == bincode_incoming &
	.and. feyngraph_set%process_type == DECAY)) then
	write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i)
	end if
	end do
	write (unit=u, fmt='(A)', advance='yes')
	do i=1, size(kingraph%tree%bc)
	select case (kingraph%tree%mapping(i))
	case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT)
	case (S_CHANNEL)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', &
	kingraph%tree%pdg(i), &
	trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
	case (T_CHANNEL)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', &
	abs (kingraph%tree%pdg(i)), &
	trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
	case (U_CHANNEL)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', &
	abs (kingraph%tree%pdg(i)), &
	trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
	case (RADIATION)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', &
	kingraph%tree%pdg(i), &
	trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
	case (COLLINEAR)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', &
	kingraph%tree%pdg(i), &
	trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
	case (INFRARED)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', &
	kingraph%tree%pdg(i), &
	trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
	case (ON_SHELL)
	write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', &
	kingraph%tree%pdg(i), &
	trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
	case default
	call msg_bug (" Impossible mapping mode encountered")
	end select
	end do
	end subroutine kingraph_write_file_format

	@ %def kingraph_write_file_format
	@ Get the particle name from the [[particle]] array of the
	[[feyngraph_set]]. This is needed for the phs file creation.
	<<Cascades2: procedures>>=
	function get_particle_name (feyngraph_set, pdg) result (particle_name)
	type(feyngraph_set_t), intent(in) :: feyngraph_set
	integer, intent(in) :: pdg
	character(len=LABEL_LEN) :: particle_name
	integer :: i
	do i=1, size (feyngraph_set%particle)
	if (feyngraph_set%particle(i)%pdg == pdg) then
	particle_name = feyngraph_set%particle(i)%particle_label
	exit
	end if
	end do
	end function get_particle_name

	@ %def get_particle_name
	@
	\subsection{Invert a graph}
	All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]]
	which is constructed from this output also looks like a decay, where one
	of the incoming particles is the decaying particle (or the root of the
	tree). The calculations can in principle be done on this data structure.
	However, it is also performed with the other incoming particle as
	the root. The first part of the calculation is the same for both cases.
	For the second part we need to transform/turn the graphs such that the
	other incoming particle becomes the root. This is done by identifying
	the incoming particles from the O'Mega output (the first one is simply
	the root of the existing tree, the second contains [2] in the
	[[particle_label]]) and the nodes/particles which connect both incoming
	particles (here we set [[t_line = .true.]]). At the same time we set the
	pointers [[inverse_daughter1]] and [[inverse_daughter2]] for the
	corresponding node, which point to the mother node and the other daughter
	of the mother node; these will be the daughters of the node in the
	inverted [[feyngraph]].
	<<Cascades2: feyngraph: TBP>>=
	procedure :: make_invertible => feyngraph_make_invertible
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_make_invertible (feyngraph)
	class(feyngraph_t), intent(inout) :: feyngraph
	end subroutine feyngraph_make_invertible
	<<Cascades2: procedures>>=
	module subroutine feyngraph_make_invertible (feyngraph)
	class(feyngraph_t), intent(inout) :: feyngraph
	logical :: t_line_found
	feyngraph%root%incoming = .true.
	t_line_found = .false.
	if (associated (feyngraph%root%daughter1)) then
	call f_node_t_line_check (feyngraph%root%daughter1, t_line_found)
	if (.not. t_line_found) then
	if (associated (feyngraph%root%daughter2)) then
	call f_node_t_line_check (feyngraph%root%daughter2, t_line_found)
	end if
	end if
	end if

	contains

	<<k node t line check>>
	end subroutine feyngraph_make_invertible

	@ %def feyngraph_make_invertible
	@ Check if a node has to be [[t_line]] or [[incoming]] and assign
	inverse daughter pointers.
	<<k node t line check>>=
	recursive subroutine f_node_t_line_check (node, t_line_found)
	type(f_node_t), target, intent(inout) :: node
	integer :: pos
	logical, intent(inout) :: t_line_found
	if (associated (node%daughter1)) then
	call f_node_t_line_check (node%daughter1, t_line_found)
	if (node%daughter1%incoming .or. node%daughter1%t_line) then
	node%t_line = .true.
	else if (associated (node%daughter2)) then
	call f_node_t_line_check (node%daughter2, t_line_found)
	if (node%daughter2%incoming .or. node%daughter2%t_line) then
	node%t_line = .true.
	end if
	end if
	else
	pos = index (node%particle_label, '[') + 1
	if (node%particle_label(pos:pos) == '2') then
	node%incoming = .true.
	t_line_found = .true.
	end if
	end if
	end subroutine f_node_t_line_check

	@ %def k_node_t_line_check
	@ Make an inverted copy of a [[kingraph]] using the inverse daughter
	pointers.
	<<Cascades2: kingraph: TBP>>=
	procedure :: make_inverse_copy => kingraph_make_inverse_copy
	<<Cascades2: sub interfaces>>=
	module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
	class(kingraph_t), intent(inout) :: original_kingraph
	type(feyngraph_t), intent(inout) :: feyngraph
	end subroutine kingraph_make_inverse_copy
	<<Cascades2: procedures>>=
	module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
	class(kingraph_t), intent(inout) :: original_kingraph
	type(feyngraph_t), intent(inout) :: feyngraph
	type(kingraph_t), pointer :: kingraph_copy
	type(k_node_t), pointer :: potential_root
	allocate (kingraph_copy)
	if (associated (feyngraph%kin_last)) then
	allocate (feyngraph%kin_last%next)
	feyngraph%kin_last => feyngraph%kin_last%next
	else
	allocate(feyngraph%kin_first)
	feyngraph%kin_last => feyngraph%kin_first
	end if
	kingraph_copy => feyngraph%kin_last
	call kingraph_set_inverse_daughters (original_kingraph)
	kingraph_copy%inverse = .true.
	kingraph_copy%n_nodes = original_kingraph%n_nodes
	kingraph_copy%keep = original_kingraph%keep
	potential_root => original_kingraph%root
	do while (.not. potential_root%incoming .or. &
	(associated (potential_root%daughter1) .and. &
	associated (potential_root%daughter2)))
	if (potential_root%daughter1%incoming .or. &
	potential_root%daughter1%t_line) then
	potential_root => potential_root%daughter1
	else if (potential_root%daughter2%incoming .or. &
	potential_root%daughter2%t_line) then
	potential_root => potential_root%daughter2
	end if
	end do
	call node_inverse_deep_copy (potential_root, kingraph_copy%root)
	end subroutine kingraph_make_inverse_copy

	@ %def kingraph_make_inverse_copy
	@ Recursively deep-copy nodes, but along the t-line the inverse daughters
	become the new daughters. We need a deep copy only for the [[incoming]]
	or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set
	only pointers to the existing nodes of the non-inverted graph.
	<<Cascades2: procedures>>=
	recursive subroutine node_inverse_deep_copy (original_node, node_copy)
	type(k_node_t), intent(in) :: original_node
	type(k_node_t), pointer, intent(out) :: node_copy
	call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.)
	node_copy = original_node
	if (node_copy%t_line .or. node_copy%incoming) then
	node_copy%particle => original_node%particle%anti
	else
	node_copy%particle => original_node%particle
	end if
	if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then
	if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then
	node_copy%daughter2 => original_node%inverse_daughter2
	call node_inverse_deep_copy (original_node%inverse_daughter1, &
	node_copy%daughter1)
	else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then
	node_copy%daughter1 => original_node%inverse_daughter1
	call node_inverse_deep_copy (original_node%inverse_daughter2, &
	node_copy%daughter2)
	end if
	end if
	end subroutine node_inverse_deep_copy

	@ %def node_inverse_deep_copy
	@
	\subsection{Find phase-space parametrizations}
	Perform all mapping calculations for a single process and store valid
	[[kingraphs]] (channels) into the grove list, without caring for instance
	about the resonance hash values.
	<<Cascades2: public>>=
	public :: feyngraph_set_generate_single
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_generate_single (feyngraph_set, model, &
	n_in, n_out, phs_par, fatal_beam_decay, u_in)
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(model_data_t), target, intent(in) :: model
	integer, intent(in) :: n_in, n_out
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	integer, intent(in) :: u_in
	end subroutine feyngraph_set_generate_single
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_generate_single (feyngraph_set, model, &
	n_in, n_out, phs_par, fatal_beam_decay, u_in)
	type(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(model_data_t), target, intent(in) :: model
	integer, intent(in) :: n_in, n_out
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	integer, intent(in) :: u_in
	feyngraph_set%n_in = n_in
	feyngraph_set%n_out = n_out
	feyngraph_set%process_type = n_in
	feyngraph_set%phs_par = phs_par
	feyngraph_set%model => model
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output")
	call feyngraph_set%build (u_in)
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "Find phase-space parametrizations")
	call feyngraph_set_find_phs_parametrizations(feyngraph_set)
	end subroutine feyngraph_set_generate_single

	@ %def feyngraph_set_generate_single
	@ Find the phase space parametrizations. We start with the computation
	of pure s-channel subtrees, i.e. we determine mappings and compare
	subtrees in order to reduce the number of channels. This can be
	parallelized easily. When all s-channel [[k_nodes]] exist, the possible
	[[kingraphs]] are created using these nodes and we determine mappings for
	t-channel nodes.
	<<Cascades2: procedures>>=
	subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set)
	class(feyngraph_set_t), intent(inout) :: feyngraph_set
	type(feyngraph_t), pointer :: current => null ()
	type(feyngraph_ptr_t), dimension (:), allocatable :: set
	integer :: pos
	integer :: i
	allocate (set (feyngraph_set%n_graphs))
	pos = 0
	current => feyngraph_set%first
	do while (associated (current))
	pos = pos + 1
	set(pos)%graph => current
	current => current%next
	end do
	if (feyngraph_set%process_type == SCATTERING) then
	!$OMP PARALLEL DO
	do i=1, feyngraph_set%n_graphs
	if (set(i)%graph%keep) then
	call set(i)%graph%make_invertible ()
	end if
	end do
	!$OMP END PARALLEL DO
	end if
	call f_node_list_compute_mappings_s (feyngraph_set)
	do i=1, feyngraph_set%n_graphs
	if (set(i)%graph%keep) then
	call set(i)%graph%make_kingraphs (feyngraph_set)
	end if
	end do
	if (feyngraph_set%process_type == SCATTERING) then
	do i=1, feyngraph_set%n_graphs
	if (set(i)%graph%keep) then
	call set(i)%graph%make_inverse_kingraphs ()
	end if
	end do
	end if
	do i=1, feyngraph_set%n_graphs
	if (set(i)%graph%keep) then
	call set(i)%graph%compute_mappings (feyngraph_set)
	end if
	end do
	do i=1, feyngraph_set%n_graphs
	if (set(i)%graph%keep) then
	call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, &
	feyngraph_set%model)
	end if
	end do
	end subroutine feyngraph_set_find_phs_parametrizations

	@ %def feyngraph_set_find_phs_parametrizations
	@ Compare objects of type [[tree_t]].
	<<Cascades2: interfaces>>=
	interface operator (==)
	module procedure tree_equal
	end interface operator (==)
	<<Cascades2: sub interfaces>>=
	elemental module function tree_equal (tree1, tree2) result (flag)
	type(tree_t), intent(in) :: tree1, tree2
	logical :: flag
	end function tree_equal
	<<Cascades2: procedures>>=
	elemental module function tree_equal (tree1, tree2) result (flag)
	type(tree_t), intent(in) :: tree1, tree2
	logical :: flag
	if (tree1%n_entries == tree2%n_entries) then
	if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then
	flag = all (tree1%mapping == tree2%mapping) .and. &
	all (tree1%bc == tree2%bc) .and. &
	all (abs(tree1%pdg) == abs(tree2%pdg))
	else
	flag = .false.
	end if
	else
	flag = .false.
	end if
	end function tree_equal

	@ %def tree_equal
	@ Select between equivalent subtrees (type [[tree_t]]). This is similar
	to [[kingraph_select]], but we compare only positions with mappings
	[[NONRESONANT]] and [[NO_MAPPING]].
	<<Cascades2: interfaces>>=
	interface operator (.eqv.)
	module procedure subtree_eqv
	end interface operator (.eqv.)
	<<Cascades2: sub interfaces>>=
	pure module function subtree_eqv (subtree1, subtree2) result (eqv)
	type(tree_t), intent(in) :: subtree1, subtree2
	logical :: eqv
	end function subtree_eqv
	<<Cascades2: procedures>>=
	pure module function subtree_eqv (subtree1, subtree2) result (eqv)
	type(tree_t), intent(in) :: subtree1, subtree2
	logical :: eqv
	integer :: root_pos
	integer :: i
	logical :: equal
	eqv = .false.
	if (subtree1%n_entries /= subtree2%n_entries) return
	root_pos = subtree1%n_entries
	if (subtree1%mapping(root_pos) == NONRESONANT .or. &
	subtree2%mapping(root_pos) == NONRESONANT .or. &
	(subtree1%mapping(root_pos) == NO_MAPPING .and. &
	subtree2%mapping(root_pos) == NO_MAPPING .and. &
	abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then
	do i = subtree1%n_entries, 1, -1
	if (subtree1%bc(i) /= subtree2%bc(i)) return
	end do
	equal = .true.
	do i = subtree1%n_entries, 1, -1
	if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then
	select case (subtree1%mapping(i))
	case (NO_MAPPING, NONRESONANT)
	select case (subtree2%mapping(i))
	case (NO_MAPPING, NONRESONANT)
	equal = .false.
	case default
	return
	end select
	case default
	return
	end select
	end if
	end do
	do i = subtree1%n_entries, 1, -1
	if (subtree1%mapping(i) /= subtree2%mapping(i)) then
	select case (subtree1%mapping(i))
	case (NO_MAPPING, NONRESONANT)
	select case (subtree2%mapping(i))
	case (NO_MAPPING, NONRESONANT)
	case default
	return
	end select
	case default
	return
	end select
	end if
	end do
	if (.not. equal) eqv = .true.
	end if
	end function subtree_eqv

	@ %def subtree_eqv
	<<Cascades2: procedures>>=
	subroutine subtree_select (subtree1, subtree2, model)
	type(tree_t), intent(inout) :: subtree1, subtree2
	type(model_data_t), intent(in) :: model
	integer :: j, k
	integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
	integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
	integer, dimension (:), allocatable :: pdg_match
	if (subtree1 .eqv. subtree2) then
	do j=1, subtree1%n_entries
	if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then
	tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1)
	do k=j-1, 1, - 1
	where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 &
	.or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0)
	tmp_bc(:k-1) = 0
	tmp_pdg(:k-1) = 0
	endwhere
	end do
	daughter_bc = pack (tmp_bc, tmp_bc /= 0)
	daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
	if (size (daughter_pdg) == 2) then
	call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
	if (.not. allocated (pdg_match)) then
	!!! Relevant if tree contains only abs (pdg). In this case, changing the
	!!! sign of one of the pdg codes should give a result.
	call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match)
	end if
	end if
	do k=1, size (pdg_match)
	if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then
	if (subtree1%keep) subtree2%keep = .false.
	exit
	else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then
	if (subtree2%keep) subtree1%keep = .false.
	exit
	end if
	end do
	deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
	if (.not. (subtree1%keep .and. subtree2%keep)) exit
	end if
	end do
	end if
	end subroutine subtree_select

	@ %def subtree_select
	@ Assign a resonance hash value to a [[kingraph]], like in [[cascades]],
	but here without the array [[tree_resonant]].
	<<Cascades2: kingraph: TBP>>=
	procedure :: assign_resonance_hash => kingraph_assign_resonance_hash
	<<Cascades2: sub interfaces>>=
	module subroutine kingraph_assign_resonance_hash (kingraph)
	class(kingraph_t), intent(inout) :: kingraph
	end subroutine kingraph_assign_resonance_hash
	<<Cascades2: procedures>>=
	module subroutine kingraph_assign_resonance_hash (kingraph)
	class(kingraph_t), intent(inout) :: kingraph
	logical, dimension (:), allocatable :: tree_resonant
	integer(i8), dimension(1) :: mold
	allocate (tree_resonant (kingraph%tree%n_entries))
	tree_resonant = (kingraph%tree%mapping == S_CHANNEL)
	kingraph%grove_prop%res_hash = hash (transfer &
	([sort (pack (kingraph%tree%pdg, tree_resonant)), &
	sort (pack (abs (kingraph%tree%pdg), &
	kingraph%tree%mapping == T_CHANNEL .or. &
	kingraph%tree%mapping == U_CHANNEL))], mold))
	deallocate (tree_resonant)
	end subroutine kingraph_assign_resonance_hash

	@ %def kingraph_assign_resonance_hash
	@ Write the process in the bincode format. This is again a copy of the
	corresponding procedure in [[cascades]], using [[feyngraph_set]] instead
	of [[cascade_set]] as an argument.
	<<Cascades2: public>>=
	public :: feyngraph_set_write_process_bincode_format
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_write_process_bincode_format &
	(feyngraph_set, unit)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	integer, intent(in), optional :: unit
	end subroutine feyngraph_set_write_process_bincode_format
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_write_process_bincode_format &
	(feyngraph_set, unit)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	integer, intent(in), optional :: unit
	integer, dimension(:), allocatable :: bincode, field_width
	integer :: n_in, n_out, n_tot, n_flv
	integer :: u, f, i, bc
	character(20) :: str
	type(string_t) :: fmt_head
	type(string_t), dimension(:), allocatable :: fmt_proc
	u = given_output_unit (unit); if (u < 0) return
	if (.not. allocated (feyngraph_set%flv)) return
	write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:"
	n_in = feyngraph_set%n_in
	n_out = feyngraph_set%n_out
	n_tot = n_in + n_out
	n_flv = size (feyngraph_set%flv, 2)
	allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
	bc = 1
	do i = 1, n_out
	bincode(n_in + i) = bc
	bc = 2 * bc
	end do
	do i = n_in, 1, -1
	bincode(i) = bc
	bc = 2 * bc
	end do
	do i = 1, n_tot
	write (str, "(I0)") bincode(i)
	field_width(i) = len_trim (str)
	do f = 1, n_flv
	field_width(i) = max (field_width(i), &
	len (feyngraph_set%flv(i,f)%get_name ()))
	end do
	end do
	fmt_head = "('!'"
	do i = 1, n_tot
	fmt_head = fmt_head // ",1x,"
	fmt_proc(i) = "(1x,"
	write (str, "(I0)") field_width(i)
	fmt_head = fmt_head // "I" // trim(str)
	fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
	if (i == n_in) then
	fmt_head = fmt_head // ",1x,' '"
	end if
	end do
	do i = 1, n_tot
	fmt_proc(i) = fmt_proc(i) // ")"
	end do
	fmt_head = fmt_head // ")"
	write (u, char (fmt_head)) bincode
	do f = 1, n_flv
	write (u, "('!')", advance="no")
	do i = 1, n_tot
	write (u, char (fmt_proc(i)), advance="no") &
	char (feyngraph_set%flv(i,f)%get_name ())
	if (i == n_in) write (u, "(1x,'=>')", advance="no")
	end do
	write (u, *)
	end do
	write (u, char (fmt_head)) bincode
	end subroutine feyngraph_set_write_process_bincode_format

	@ %def feyngraph_set_write_process_bincode_format
	@ Write tex file for graphical display of channels.
	<<Cascades2: public>>=
	public :: feyngraph_set_write_graph_format
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_write_graph_format &
	(feyngraph_set, filename, process_id, unit)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	type(string_t), intent(in) :: filename, process_id
	integer, intent(in), optional :: unit
	end subroutine feyngraph_set_write_graph_format
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_write_graph_format &
	(feyngraph_set, filename, process_id, unit)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	type(string_t), intent(in) :: filename, process_id
	integer, intent(in), optional :: unit
	type(kingraph_t), pointer :: kingraph
	type(grove_t), pointer :: grove
	integer :: u, n_grove, count, pgcount
	logical :: first_in_grove
	u = given_output_unit (unit); if (u < 0) return
	write (u, '(A)') "\documentclass[10pt]{article}"
	write (u, '(A)') "\usepackage{amsmath}"
	write (u, '(A)') "\usepackage{feynmp}"
	write (u, '(A)') "\usepackage{url}"
	write (u, '(A)') "\usepackage{color}"
	write (u, *)
	write (u, '(A)') "\textwidth 18.5cm"
	write (u, '(A)') "\evensidemargin -1.5cm"
	write (u, '(A)') "\oddsidemargin -1.5cm"
	write (u, *)
	write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
	write (u, '(A)') "\newcommand{\green}{\color{green}}"
	write (u, '(A)') "\newcommand{\red}{\color{red}}"
	write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
	write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
	write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
	write (u, '(A)') "\setlength{\parindent}{0pt}"
	write (u, '(A)') "\setlength{\parsep}{20pt}"
	write (u, *)
	write (u, '(A)') "\begin{document}"
	write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
	write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
	write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
	write (u, '(A)') "\begin{fmfshrink}{0.5}"
	write (u, '(A)') "\begin{flushleft}"
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
	& "\hfill\today"
	write (u, *)
	write (u, '(A)') "\vspace{10pt}"
	write (u, '(A)') "\noindent" // &
	& "\textbf{Process:} \url{" // char (process_id) // "}"
	call feyngraph_set_write_process_tex_format (feyngraph_set, u)
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{Note:} These are pseudo Feynman graphs that "
	write (u, '(A)') "visualize phase-space parameterizations " // &
	& "(``integration channels''). "
	write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
	& "matrix element."
	write (u, *)
	write (u, '(A)') "\textbf{Color code:} " // &
	& "{\blue resonance,} " // &
	& "{\cyan t-channel,} " // &
	& "{\green radiation,} "
	write (u, '(A)') "{\red infrared,} " // &
	& "{\magenta collinear,} " // &
	& "external/off-shell"
	write (u, *)
	write (u, '(A)') "\noindent" // &
	& "\textbf{Black square:} Keystone, indicates ordering of " // &
	& "phase space parameters."
	write (u, *)
	write (u, '(A)') "\vspace{-20pt}"
	count = 0
	pgcount = 0
	n_grove = 0
	grove => feyngraph_set%grove_list%first
	do while (associated (grove))
	n_grove = n_grove + 1
	write (u, *)
	write (u, '(A)') "\vspace{20pt}"
	write (u, '(A)') "\begin{tabular}{l}"
	write (u, '(A,I5,A)') &
	& "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]"
	write (u, '(A,I1,A)') "Multiplicity: ", &
	grove%grove_prop%multiplicity, "\\"
	write (u, '(A,I1,A)') "Resonances: ", &
	grove%grove_prop%n_resonances, "\\"
	write (u, '(A,I1,A)') "Log-enhanced: ", &
	grove%grove_prop%n_log_enhanced, "\\"
	write (u, '(A,I1,A)') "Off-shell: ", &
	grove%grove_prop%n_off_shell, "\\"
	write (u, '(A,I1,A)') "t-channel: ", &
	grove%grove_prop%n_t_channel, ""
	write (u, '(A)') "\end{tabular}"
	kingraph => grove%first
	do while (associated (kingraph))
	count = count + 1
	call kingraph_write_graph_format (kingraph, count, unit)
	kingraph => kingraph%grove_next
	end do
	grove => grove%next
	end do
	write (u, '(A)') "\end{flushleft}"
	write (u, '(A)') "\end{fmfshrink}"
	write (u, '(A)') "\end{fmffile}"
	write (u, '(A)') "\end{document}"
	end subroutine feyngraph_set_write_graph_format

	@ %def feyngraph_set_write_graph_format
	@ Write the process as a \LaTeX\ expression. This is a slightly modified
	copy of [[cascade_set_write_process_tex_format]] which has only been
	adapted to the types which are used here.
	<<Cascades2: procedures>>=
	subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	integer, intent(in), optional :: unit
	integer :: n_tot
	integer :: u, f, i
	n_tot = feyngraph_set%n_in + feyngraph_set%n_out
	u = given_output_unit (unit); if (u < 0) return
	if (.not. allocated (feyngraph_set%flv)) return
	write (u, "(A)") "\begin{align*}"
	do f = 1, size (feyngraph_set%flv, 2)
	do i = 1, feyngraph_set%n_in
	if (i > 1) write (u, "(A)", advance="no") "\quad "
	write (u, "(A)", advance="no") &
	char (feyngraph_set%flv(i,f)%get_tex_name ())
	end do
	write (u, "(A)", advance="no") "\quad &\to\quad "
	do i = feyngraph_set%n_in + 1, n_tot
	if (i > feyngraph_set%n_in + 1) write (u, "(A)", advance="no") "\quad "
	write (u, "(A)", advance="no") &
	char (feyngraph_set%flv(i,f)%get_tex_name ())
	end do
	if (f < size (feyngraph_set%flv, 2)) then
	write (u, "(A)") "\\"
	else
	write (u, "(A)") ""
	end if
	end do
	write (u, "(A)") "\end{align*}"
	end subroutine feyngraph_set_write_process_tex_format

	@ %def feyngraph_set_write_process_tex_format
	@ This creates metapost source for graphical display for a given [[kingraph]].
	It is the analogon to [[cascade_write_graph_format]] (a modified copy).
	<<Cascades2: procedures>>=
	subroutine kingraph_write_graph_format (kingraph, count, unit)
	type(kingraph_t), intent(in) :: kingraph
	integer, intent(in) :: count
	integer, intent(in), optional :: unit
	integer :: u
	type(string_t) :: left_str, right_str
	u = given_output_unit (unit); if (u < 0) return
	left_str = ""
	right_str = ""
	write (u, '(A)') "\begin{minipage}{105pt}"
	write (u, '(A)') "\vspace{30pt}"
	write (u, '(A)') "\begin{center}"
	write (u, '(A)') "\begin{fmfgraph*}(55,55)"
	call graph_write_node (kingraph%root)
	write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
	write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
	write (u, '(A)') "\end{fmfgraph*}\\"
	write (u, '(A,I5,A)') "\fbox{$", count, "$}"
	write (u, '(A)') "\end{center}"
	write (u, '(A)') "\end{minipage}"
	write (u, '(A)') "%"
	contains
	recursive subroutine graph_write_node (node)
	type(k_node_t), intent(in) :: node
	if (associated (node%daughter1) .or. associated (node%daughter2)) then
	if (node%daughter2%t_line .or. node%daughter2%incoming) then
	call vertex_write (node, node%daughter2)
	call vertex_write (node, node%daughter1)
	else
	call vertex_write (node, node%daughter1)
	call vertex_write (node, node%daughter2)
	end if
	if (node%mapping == EXTERNAL_PRT) then
	call line_write (node%bincode, 0, node%particle)
	call external_write (node%bincode, node%particle%tex_name, &
	left_str)
	write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
	end if
	else
	if (node%incoming) then
	call external_write (node%bincode, node%particle%anti%tex_name, &
	left_str)
	else
	call external_write (node%bincode, node%particle%tex_name, &
	right_str)
	end if
	end if
	end subroutine graph_write_node
	recursive subroutine vertex_write (node, daughter)
	type(k_node_t), intent(in) :: node, daughter
	integer :: bincode
	if (associated (node%daughter1) .and. associated (node%daughter2) &
	.and. node%mapping == EXTERNAL_PRT) then
	bincode = 0
	else
	bincode = node%bincode
	end if
	call graph_write_node (daughter)
	if (associated (node%daughter1) .or. associated (node%daughter2)) then
	call line_write (bincode, daughter%bincode, daughter%particle, &
	mapping=daughter%mapping)
	else
	call line_write (bincode, daughter%bincode, daughter%particle)
	end if
	end subroutine vertex_write
	subroutine line_write (i1, i2, particle, mapping)
	integer(TC), intent(in) :: i1, i2
	type(part_prop_t), intent(in) :: particle
	integer, intent(in), optional :: mapping
	integer :: k1, k2
	type(string_t) :: prt_type
	select case (particle%spin_type)
	case (SCALAR); prt_type = "plain"
	case (SPINOR); prt_type = "fermion"
	case (VECTOR); prt_type = "boson"
	case (VECTORSPINOR); prt_type = "fermion"
	case (TENSOR); prt_type = "dbl_wiggly"
	case default; prt_type = "dashes"
	end select
	if (particle%pdg < 0) then
	!!! anti-particle
	k1 = i2; k2 = i1
	else
	k1 = i1; k2 = i2
	end if
	if (present (mapping)) then
	select case (mapping)
	case (S_CHANNEL)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=blue,lab=\sm\blue$" // &
	& char (particle%tex_name) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (T_CHANNEL, U_CHANNEL)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=cyan,lab=\sm\cyan$" // &
	& char (particle%tex_name) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (RADIATION)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=green,lab=\sm\green$" // &
	& char (particle%tex_name) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (COLLINEAR)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=magenta,lab=\sm\magenta$" // &
	& char (particle%tex_name) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case (INFRARED)
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=red,lab=\sm\red$" // &
	& char (particle%tex_name) // "$}" // &
	& "{v", k1, ",v", k2, "}"
	case default
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& ",f=black}" // &
	& "{v", k1, ",v", k2, "}"
	end select
	else
	write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
	& "}" // &
	& "{v", k1, ",v", k2, "}"
	end if
	end subroutine line_write
	subroutine external_write (bincode, name, ext_str)
	integer(TC), intent(in) :: bincode
	type(string_t), intent(in) :: name
	type(string_t), intent(inout) :: ext_str
	character(len=20) :: str
	write (str, '(A2,I0)') ",v", bincode
	ext_str = ext_str // trim (str)
	write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
	// char (name) &
	// "\,(", bincode, ")" &
	// "$}{v", bincode, "}"
	end subroutine external_write
	end subroutine kingraph_write_graph_format

	@ %def kingraph_write_graph_format
	@ Generate a [[feyngraph_set]] for several subprocesses. Mapping
	calculations are performed separately, but the final grove list is shared
	between the subsets [[fset]] of the [[feyngraph_set]].
	<<Cascades2: public>>=
	public :: feyngraph_set_generate
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_generate &
	(feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, &
	u_in, vis_channels, use_dag)
	type(feyngraph_set_t), intent(out) :: feyngraph_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(flavor_t), dimension(:,:), intent(in) :: flv
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	integer, intent(in) :: u_in
	logical, intent(in) :: vis_channels
	logical, optional, intent(in) :: use_dag
	end subroutine feyngraph_set_generate
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_generate &
	(feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, &
	u_in, vis_channels, use_dag)
	type(feyngraph_set_t), intent(out) :: feyngraph_set
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_in, n_out
	type(flavor_t), dimension(:,:), intent(in) :: flv
	type(phs_parameters_t), intent(in) :: phs_par
	logical, intent(in) :: fatal_beam_decay
	integer, intent(in) :: u_in
	logical, intent(in) :: vis_channels
	logical, optional, intent(in) :: use_dag
	type(grove_t), pointer :: grove
	integer :: i, j
	type(kingraph_t), pointer :: kingraph
	if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return
	if (present (use_dag)) feyngraph_set%use_dag = use_dag
	feyngraph_set%process_type = n_in
	feyngraph_set%n_in = n_in
	feyngraph_set%n_out = n_out
	allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2)))
	do i = 1, size (flv, 2)
	do j = 1, size (flv, 1)
	call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
	end do
	end do
	allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
	allocate (feyngraph_set%grove_list)
	allocate (feyngraph_set%fset (size (flv, 2)))
	do i = 1, size (feyngraph_set%fset)
	feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag
	allocate (feyngraph_set%fset(i)%flv(size (flv,1),1))
	feyngraph_set%fset(i)%flv(:,1) = flv(:,i)
	feyngraph_set%fset(i)%particle => feyngraph_set%particle
	allocate (feyngraph_set%fset(i)%grove_list)
	call feyngraph_set_generate_single (feyngraph_set%fset(i), &
	model, n_in, n_out, phs_par, fatal_beam_decay, u_in)
	call feyngraph_set%grove_list%merge &
	(feyngraph_set%fset(i)%grove_list, model, i)
	if (.not. vis_channels) call feyngraph_set%fset(i)%final()
	end do
	call feyngraph_set%grove_list%rebuild ()
	end subroutine feyngraph_set_generate

	@ %def feyngraph_set_generate
	@ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any
	[[kingraphs]] which are valid, i.e. where the [[keep]] variable has the
	value [[.true.]]. This is necessary to write a non-empty phase-space
	file. The function is the pendant to [[cascade_set_is_valid]].
	<<Cascades2: public>>=
	public :: feyngraph_set_is_valid
	<<Cascades2: sub interfaces>>=
	module function feyngraph_set_is_valid (feyngraph_set) result (flag)
	class(feyngraph_set_t), intent(in) :: feyngraph_set
	logical :: flag
	end function feyngraph_set_is_valid
	<<Cascades2: procedures>>=
	module function feyngraph_set_is_valid (feyngraph_set) result (flag)
	class(feyngraph_set_t), intent(in) :: feyngraph_set
	type(kingraph_t), pointer :: kingraph
	type(grove_t), pointer :: grove
	logical :: flag
	flag = .false.
	if (associated (feyngraph_set%grove_list)) then
	grove => feyngraph_set%grove_list%first
	do while (associated (grove))
	kingraph => grove%first
	do while (associated (kingraph))
	if (kingraph%keep) then
	flag = .true.
	return
	end if
	kingraph => kingraph%next
	end do
	grove => grove%next
	end do
	end if
	end function feyngraph_set_is_valid

	@ %def feyngraph_set_is_valid
	@
	\subsection{Return the resonance histories for subtraction}
	The following procedures are copies of corresponding procedures in
	[[cascades]], which only have been adapted to the new types used in
	this module.

	Extract the resonance set from a valid [[kingraph]] which is kept in the
	final grove list.
	<<Cascades2: kingraph: TBP>>=
	procedure :: extract_resonance_history => kingraph_extract_resonance_history
	<<Cascades2: sub interfaces>>=
	module subroutine kingraph_extract_resonance_history &
	(kingraph, res_hist, model, n_out)
	class(kingraph_t), intent(in), target :: kingraph
	type(resonance_history_t), intent(out) :: res_hist
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_out
	end subroutine kingraph_extract_resonance_history
	<<Cascades2: procedures>>=
	module subroutine kingraph_extract_resonance_history &
	(kingraph, res_hist, model, n_out)
	class(kingraph_t), intent(in), target :: kingraph
	type(resonance_history_t), intent(out) :: res_hist
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: n_out
	type(resonance_info_t) :: resonance
	integer :: i, mom_id, pdg
	if (debug_on) call msg_debug2 &
	(D_PHASESPACE, "kingraph_extract_resonance_history")
	if (kingraph%grove_prop%n_resonances > 0) then
	if (associated (kingraph%root%daughter1) .or. &
	associated (kingraph%root%daughter2)) then
	if (debug_on) call msg_debug2 &
	(D_PHASESPACE, "kingraph has resonances, root has children")
	do i = 1, kingraph%tree%n_entries
	if (kingraph%tree%mapping(i) == S_CHANNEL) then
	mom_id = kingraph%tree%bc (i)
	pdg = kingraph%tree%pdg (i)
	call resonance%init (mom_id, pdg, model, n_out)
	if (debug2_active (D_PHASESPACE)) then
	print *, 'D: Adding resonance'
	call resonance%write ()
	end if
	call res_hist%add_resonance (resonance)
	end if
	end do
	end if
	end if
	end subroutine kingraph_extract_resonance_history

	@ %def kingraph_extract_resonance_history
	@ Determine the number of valid [[kingraphs]] in [[grove_list]].
	<<Cascades2: public>>=
	public :: grove_list_get_n_trees
	<<Cascades2: sub interfaces>>=
	module function grove_list_get_n_trees (grove_list) result (n)
	class(grove_list_t), intent(in) :: grove_list
	integer :: n
	end function grove_list_get_n_trees
	<<Cascades2: procedures>>=
	module function grove_list_get_n_trees (grove_list) result (n)
	class(grove_list_t), intent(in) :: grove_list
	integer :: n
	type(kingraph_t), pointer :: kingraph
	type(grove_t), pointer :: grove
	if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_n_trees")
	n = 0
	grove => grove_list%first
	do while (associated (grove))
	kingraph => grove%first
	do while (associated (kingraph))
	if (kingraph%keep) n = n + 1
	kingraph => kingraph%grove_next
	end do
	grove => grove%next
	end do
	if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
	end function grove_list_get_n_trees

	@ %def grove_list_get_n_trees
	@ Extract the resonance histories from the [[feyngraph_set]], in complete
	analogy to [[cascade_set_get_resonance_histories]]
	<<Cascades2: public>>=
	public :: feyngraph_set_get_resonance_histories
	<<Cascades2: sub interfaces>>=
	module subroutine feyngraph_set_get_resonance_histories &
	(feyngraph_set, n_filter, res_hists)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	integer, intent(in), optional :: n_filter
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_hists
	end subroutine feyngraph_set_get_resonance_histories
	<<Cascades2: procedures>>=
	module subroutine feyngraph_set_get_resonance_histories &
	(feyngraph_set, n_filter, res_hists)
	type(feyngraph_set_t), intent(in), target :: feyngraph_set
	integer, intent(in), optional :: n_filter
	type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
	res_hists
	type(kingraph_t), pointer :: kingraph
	type(grove_t), pointer :: grove
	type(resonance_history_t) :: res_hist
	type(resonance_history_set_t) :: res_hist_set
	integer :: i_grove
	if (debug_on) call msg_debug &
	(D_PHASESPACE, "grove_list_get_resonance_histories")
	call res_hist_set%init (n_filter = n_filter)
	grove => feyngraph_set%grove_list%first
	i_grove = 0
	do while (associated (grove))
	i_grove = i_grove + 1
	kingraph => grove%first
	do while (associated (kingraph))
	if (kingraph%keep) then
	if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", i_grove)
	call kingraph%extract_resonance_history &
	(res_hist, feyngraph_set%model, feyngraph_set%n_out)
	call res_hist_set%enter (res_hist)
	end if
	kingraph => kingraph%grove_next
	end do
	end do
	call res_hist_set%freeze ()
	call res_hist_set%to_array (res_hists)
	end subroutine feyngraph_set_get_resonance_histories

	@ %def feyngraph_set_get_resonance_histories
	@
	<<[[cascades2_ut.f90]]>>=
	<<File header>>

	module cascades2_ut
	use unit_tests
	use cascades2_uti

	<<Standard module head>>

	<<Cascades2: public test>>

	contains

	<<Cascades2: test driver>>

	end module cascades2_ut
	@ %def cascades2_ut
	@
	<<[[cascades2_uti.f90]]>>=
	<<File header>>

	module cascades2_uti

	<<Use kinds>>
	<<Use strings>>
	use numeric_utils

	use cascades2
	use flavors
	use phs_forests, only: phs_parameters_t
	use model_data

	<<Standard module head>>

	<<Cascades2: test declarations>>

	contains

	<<Cascades2: tests>>

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

	@ %def cascades2_test

	@
	<<Cascades2: execute tests>>=
	call test (cascades2_1, "cascades2_1", &
	"make phase-space", u, results)
	call test (cascades2_2, "cascades2_2", &
	"make phase-space (scattering)", u, results)
	<<Cascades2: test declarations>>=
	public :: cascades2_1
	<<Cascades2: tests>>=
	subroutine cascades2_1 (u)
	integer, intent(in) :: u
	type(feyngraph_set_t) :: feyngraph_set
	type(model_data_t) :: model
	integer :: n_in = 1
	integer :: n_out = 6
	type(flavor_t), dimension(7,1) :: flv
	type(phs_parameters_t) :: phs_par
	logical :: fatal_beam_decay = .true.
	integer :: u_in = 8

	write (u, "(A)") "* Test output: cascades2_1"
	write (u, "(A)") "* Purpose: create a test phs file (decay) with the forest"
	write (u, "(A)") "* output of O'Mega"
	write (u, "(A)")

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

	call init_sm_full_test (model)

	call flv(1,1)%init (6, model)
	call flv(2,1)%init (5, model)
	call flv(3,1)%init (-11, model)
	call flv(4,1)%init (12, model)
	call flv(5,1)%init (21, model)
	call flv(6,1)%init (22, model)
	call flv(7,1)%init (21, model)

	phs_par%sqrts = 173.1_default
	phs_par%m_threshold_s = 50._default
	phs_par%m_threshold_t = 100._default
	phs_par%keep_nonresonant = .true.
	phs_par%off_shell = 2

	open (unit=u_in, file="cascades2_1.fds", status='old', action='read')

	write (u, "(A)")
	write (u, "(A)") "* Generating phase-space parametrizations"
	write (u, "(A)")

	call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
	flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., &
	vis_channels = .false.)
	call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
	call feyngraph_set_write_file_format (feyngraph_set, u)

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

	close (u_in)
	call feyngraph_set%final ()
	call model%final ()

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

	@ %def cascades2_1
	@
	<<Cascades2: test declarations>>=
	public :: cascades2_2
	<<Cascades2: tests>>=
	subroutine cascades2_2 (u)
	integer, intent(in) :: u
	type(feyngraph_set_t) :: feyngraph_set
	type(model_data_t) :: model
	integer :: n_in = 2
	integer :: n_out = 5
	type(flavor_t), dimension(7,1) :: flv
	type(phs_parameters_t) :: phs_par
	logical :: fatal_beam_decay = .true.
	integer :: u_in = 8

	write (u, "(A)") "* Test output: cascades2_2"
	write (u, "(A)") "* Purpose: create a test phs file (scattering) with the"
	write (u, "(A)") "* parsable DAG output of O'Mega"
	write (u, "(A)")

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

	call init_sm_full_test (model)

	call flv(1,1)%init (-11, model)
	call flv(2,1)%init (11, model)
	call flv(3,1)%init (-11, model)
	call flv(4,1)%init (12, model)
	call flv(5,1)%init (1, model)
	call flv(6,1)%init (-2, model)
	call flv(7,1)%init (22, model)

	phs_par%sqrts = 500._default
	phs_par%m_threshold_s = 50._default
	phs_par%m_threshold_t = 100._default
	phs_par%keep_nonresonant = .true.
	phs_par%off_shell = 2
	phs_par%t_channel = 6

	open (unit=u_in, file="cascades2_2.fds", &
	status='old', action='read')

	write (u, "(A)")
	write (u, "(A)") "* Generating phase-space parametrizations"
	write (u, "(A)")

	call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
	flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., &
	vis_channels = .false.)
	call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
	call feyngraph_set_write_file_format (feyngraph_set, u)

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

	close (u_in)
	call feyngraph_set%final ()
	call model%final ()

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

	@ %def cascades2_2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{WOOD phase space}

	This is the module that interfaces the [[phs_forests]] phase-space
	treatment and the [[cascades]] module for generating phase-space
	channels. As an extension of the [[phs_base]] abstract type,
	the phase-space configuration and instance implement the standard API.

	(Currently, this is the only generic phase-space implementation of
	\whizard. For trivial two-particle phase space, there is
	[[phs_wood]] as an alternative.)
	<<[[phs_wood.f90]]>>=
	<<File header>>

	module phs_wood

	<<Use kinds>>
	<<Use strings>>
	use os_interface
	use lorentz
	use model_data
	use flavors
	use phs_base
	use mappings
	use resonances, only: resonance_history_set_t
	use phs_forests
	use cascades
	use cascades2

	<<Standard module head>>

	<<PHS wood: public>>

	<<PHS wood: types>>

	interface
	<<PHS wood: sub interfaces>>
	end interface

	contains

	<<PHS wood: main procedures>>

	end module phs_wood
	@ %def phs_wood
	@
	<<[[phs_wood_sub.f90]]>>=
	<<File header>>

	submodule (phs_wood) phs_wood_s

	use io_units
	use constants
	use numeric_utils
	use diagnostics
	use physics_defs
	use md5
	use process_constants
	use sf_mappings
	use sf_base
	!!! Intel oneAPI 2022/23 regression workaround
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t

	implicit none

	contains

	<<PHS wood: procedures>>

	end submodule phs_wood_s

	@ %def phs_wood_s
	@
	\subsection{Configuration}
	<<PHS wood: public>>=
	public :: phs_wood_config_t
	<<PHS wood: types>>=
	type, extends (phs_config_t) :: phs_wood_config_t
	character(32) :: md5sum_forest = ""
	type(string_t) :: phs_path
	integer :: io_unit = 0
	logical :: io_unit_keep_open = .false.
	logical :: use_equivalences = .false.
	logical :: fatal_beam_decay = .true.
	type(mapping_defaults_t) :: mapping_defaults
	type(phs_parameters_t) :: par
	type(string_t) :: run_id
	type(cascade_set_t), allocatable :: cascade_set
	logical :: use_cascades2 = .false.
	type(feyngraph_set_t), allocatable :: feyngraph_set
	type(phs_forest_t) :: forest
	type(os_data_t) :: os_data
	logical :: is_combined_integration = .false.
	contains
	<<PHS wood: phs wood config: TBP>>
	end type phs_wood_config_t

	@ %def phs_wood_config_t
	@ Finalizer. We should delete the cascade set and the forest subobject.

	Also close the I/O unit, just in case. (We assume that [[io_unit]] is
	not standard input/output.)
	<<PHS wood: phs wood config: TBP>>=
	procedure :: final => phs_wood_config_final
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_final (object)
	class(phs_wood_config_t), intent(inout) :: object
	end subroutine phs_wood_config_final
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_final (object)
	class(phs_wood_config_t), intent(inout) :: object
	logical :: opened
	if (object%io_unit /= 0) then
	inquire (unit = object%io_unit, opened = opened)
	if (opened) close (object%io_unit)
	end if
	call object%clear_phase_space ()
	call object%forest%final ()
	end subroutine phs_wood_config_final

	@ %def phs_wood_config_final
	@
	<<PHS wood: phs wood config: TBP>>=
	procedure :: increase_n_par => phs_wood_config_increase_n_par
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_increase_n_par (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_increase_n_par
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_increase_n_par (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	if (phs_config%is_combined_integration) then
	phs_config%n_par = phs_config%n_par + 3
	end if
	end subroutine phs_wood_config_increase_n_par

	@ %def phs_wood_config_increase_n_par
	@ Output. The contents of the PHS forest are not printed explicitly.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: write => phs_wood_config_write
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_write (object, unit, include_id)
	class(phs_wood_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_wood_config_write
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_write (object, unit, include_id)
	class(phs_wood_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") &
	"Partonic phase-space configuration (phase-space forest):"
	call object%base_write (unit)
	write (u, "(1x,A)") "Phase-space configuration parameters:"
	call object%par%write (u)
	call object%mapping_defaults%write (u)
	write (u, "(3x,A,A,A)") "Run ID: '", char (object%run_id), "'"
	end subroutine phs_wood_config_write

	@ %def phs_wood_config_write
	@ Print the PHS forest contents.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: write_forest => phs_wood_config_write_forest
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_write_forest (object, unit)
	class(phs_wood_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_wood_config_write_forest
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_write_forest (object, unit)
	class(phs_wood_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call object%forest%write (u)
	end subroutine phs_wood_config_write_forest

	@ %def phs_wood_config_write_forest
	@ Set the phase-space parameters that the configuration generator requests.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: set_parameters => phs_wood_config_set_parameters
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_set_parameters (phs_config, par)
	class(phs_wood_config_t), intent(inout) :: phs_config
	type(phs_parameters_t), intent(in) :: par
	end subroutine phs_wood_config_set_parameters
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_set_parameters (phs_config, par)
	class(phs_wood_config_t), intent(inout) :: phs_config
	type(phs_parameters_t), intent(in) :: par
	phs_config%par = par
	end subroutine phs_wood_config_set_parameters

	@ %def phs_wood_config_set_parameters
	@ Enable the generation of channel equivalences (when calling [[configure]]).
	<<PHS wood: phs wood config: TBP>>=
	procedure :: enable_equivalences => phs_wood_config_enable_equivalences
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_enable_equivalences (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_enable_equivalences
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_enable_equivalences (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	phs_config%use_equivalences = .true.
	end subroutine phs_wood_config_enable_equivalences

	@ %def phs_wood_config_enable_equivalences
	@ Set the phase-space mapping parameters that the configuration generator
	requests.g
	<<PHS wood: phs wood config: TBP>>=
	procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_set_mapping_defaults &
	(phs_config, mapping_defaults)
	class(phs_wood_config_t), intent(inout) :: phs_config
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	end subroutine phs_wood_config_set_mapping_defaults
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_set_mapping_defaults &
	(phs_config, mapping_defaults)
	class(phs_wood_config_t), intent(inout) :: phs_config
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	phs_config%mapping_defaults = mapping_defaults
	end subroutine phs_wood_config_set_mapping_defaults

	@ %def phs_wood_config_set_mapping_defaults
	@ Define the input stream for the phase-space file as an open logical unit.
	The unit must be connected.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: set_input => phs_wood_config_set_input
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_set_input (phs_config, unit)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in) :: unit
	end subroutine phs_wood_config_set_input
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_set_input (phs_config, unit)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in) :: unit
	phs_config%io_unit = unit
	rewind (unit)
	end subroutine phs_wood_config_set_input

	@ %def phs_wood_config_set_input
	@
	\subsection{Phase-space generation}
	This subroutine generates a phase space configuration using the
	[[cascades]] module. Note that this may take time, and the
	[[cascade_set]] subobject may consume a large amount of memory.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: generate_phase_space => phs_wood_config_generate_phase_space
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_generate_phase_space (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_generate_phase_space
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_generate_phase_space (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer :: off_shell, extra_off_shell
	logical :: valid
	integer :: unit_fds
	type(string_t) :: file_name
	logical :: file_exists
	call msg_message ("Phase space: generating configuration ...")
	off_shell = phs_config%par%off_shell
	if (phs_config%use_cascades2) then
	file_name = char (phs_config%id) // ".fds"
	inquire (file=char (file_name), exist=file_exists)
	if (.not. file_exists) call msg_fatal &
	("The O'Mega input file " // char (file_name) // &
	" does not exist. " // "Please make sure that the " // &
	"variable ?omega_write_phs_output has been set correctly.")
	unit_fds = free_unit ()
	open (unit=unit_fds, file=char(file_name), status='old', action='read')
	do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
	phs_config%par%off_shell = off_shell + extra_off_shell
	allocate (phs_config%feyngraph_set)
	call feyngraph_set_generate (phs_config%feyngraph_set, &
	phs_config%model, phs_config%n_in, phs_config%n_out, &
	phs_config%flv, &
	phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
	phs_config%vis_channels)
	if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then
	exit
	else
	call msg_message ("Phase space: ... failed. &
	&Increasing phs_off_shell ...")
	call phs_config%feyngraph_set%final ()
	deallocate (phs_config%feyngraph_set)
	end if
	end do
	close (unit_fds)
	else
	allocate (phs_config%cascade_set)
	do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
	phs_config%par%off_shell = off_shell + extra_off_shell
	call cascade_set_generate (phs_config%cascade_set, &
	phs_config%model, phs_config%n_in, phs_config%n_out, &
	phs_config%flv, &
	phs_config%par, phs_config%fatal_beam_decay)
	if (cascade_set_is_valid (phs_config%cascade_set)) then
	exit
	else
	call msg_message ("Phase space: ... failed. &
	&Increasing phs_off_shell ...")
	end if
	end do
	end if
	if (phs_config%use_cascades2) then
	valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
	else
	valid = cascade_set_is_valid (phs_config%cascade_set)
	end if
	if (valid) then
	call msg_message ("Phase space: ... success.")
	else
	call msg_fatal ("Phase-space: generation failed")
	end if
	end subroutine phs_wood_config_generate_phase_space

	@ %def phs_wood_config_generate_phase_space
	@ Using the generated phase-space configuration, write an appropriate
	phase-space file to the stored (or explicitly specified) I/O unit.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: write_phase_space => phs_wood_config_write_phase_space
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_write_phase_space (phs_config, &
	filename_vis, unit)
	class(phs_wood_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	type(string_t), intent(in), optional :: filename_vis
	end subroutine phs_wood_config_write_phase_space
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_write_phase_space (phs_config, &
	filename_vis, unit)
	class(phs_wood_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	type(string_t), intent(in), optional :: filename_vis
	type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi
	integer :: u, unit_tex, unit_dev, status
	if (allocated (phs_config%cascade_set) .or. &
	allocated (phs_config%feyngraph_set)) then
	if (present (unit)) then
	u = unit
	else
	u = phs_config%io_unit
	end if
	write (u, "(1x,A,A)") "process ", char (phs_config%id)
	write (u, "(A)")
	if (phs_config%use_cascades2) then
	call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u)
	else
	call cascade_set_write_process_bincode_format (phs_config%cascade_set, u)
	end if
	write (u, "(A)")
	write (u, "(3x,A,A,A32,A)") "md5sum_process = ", &
	'"', phs_config%md5sum_process, '"'
	write (u, "(3x,A,A,A32,A)") "md5sum_model_par = ", &
	'"', phs_config%md5sum_model_par, '"'
	write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", &
	'"', phs_config%md5sum_phs_config, '"'
	call phs_config%par%write (u)
	if (phs_config%use_cascades2) then
	call feyngraph_set_write_file_format (phs_config%feyngraph_set, u)
	else
	call cascade_set_write_file_format (phs_config%cascade_set, u)
	end if
	if (phs_config%vis_channels) then
	unit_tex = free_unit ()
	open (unit=unit_tex, file=char(filename_vis // ".tex"), &
	action="write", status="replace")
	if (phs_config%use_cascades2) then
	call feyngraph_set_write_graph_format (phs_config%feyngraph_set, &
	filename_vis // "-graphs", phs_config%id, unit_tex)
	else
	call cascade_set_write_graph_format (phs_config%cascade_set, &
	filename_vis // "-graphs", phs_config%id, unit_tex)
	end if
	close (unit_tex)
	call msg_message ("Phase space: visualizing channels in file " &
	// char(trim(filename_vis)) // "...")
	if (phs_config%os_data%event_analysis_ps) then
	BLOCK: do
	unit_dev = free_unit ()
	open (file = "/dev/null", unit = unit_dev, &
	action = "write", iostat = status)
	if (status /= 0) then
	pipe = ""
	pipe_dvi = ""
	else
	pipe = " > /dev/null"
	pipe_dvi = " 2>/dev/null 1>/dev/null"
	end if
	close (unit_dev)
	if (phs_config%os_data%whizard_texpath /= "") then
	setenv_tex = "TEXINPUTS=" // &
	phs_config%os_data%whizard_texpath // ":$TEXINPUTS "
	setenv_mp = "MPINPUTS=" // &
	phs_config%os_data%whizard_texpath // ":$MPINPUTS "
	else
	setenv_tex = ""
	setenv_mp = ""
	end if
	call os_system_call (setenv_tex // &
	phs_config%os_data%latex // " " // &
	filename_vis // ".tex " // pipe, status)
	if (status /= 0) exit BLOCK
	if (phs_config%os_data%mpost /= "") then
	call os_system_call (setenv_mp // &
	phs_config%os_data%mpost // " " // &
	filename_vis // "-graphs.mp" // pipe, status)
	else
	call msg_fatal ("Could not use MetaPOST.")
	end if
	if (status /= 0) exit BLOCK
	call os_system_call (setenv_tex // &
	phs_config%os_data%latex // " " // &
	filename_vis // ".tex" // pipe, status)
	if (status /= 0) exit BLOCK
	call os_system_call &
	(phs_config%os_data%dvips // " -o " // filename_vis &
	// ".ps " // filename_vis // ".dvi" // pipe_dvi, status)
	if (status /= 0) exit BLOCK
	if (phs_config%os_data%event_analysis_pdf) then
	call os_system_call (phs_config%os_data%ps2pdf // " " // &
	filename_vis // ".ps", status)
	if (status /= 0) exit BLOCK
	end if
	exit BLOCK
	end do BLOCK
	if (status /= 0) then
	call msg_error ("Unable to compile analysis output file")
	end if
	end if
	end if
	else
	call msg_fatal ("Phase-space configuration: &
	&no phase space object generated")
	end if
	end subroutine phs_wood_config_write_phase_space

	@ %def phs_config_write_phase_space
	@ Clear the phase-space configuration. This is useful since the
	object may become \emph{really} large.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: clear_phase_space => phs_wood_config_clear_phase_space
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_clear_phase_space (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_clear_phase_space
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_clear_phase_space (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	if (allocated (phs_config%cascade_set)) then
	call cascade_set_final (phs_config%cascade_set)
	deallocate (phs_config%cascade_set)
	end if
	if (allocated (phs_config%feyngraph_set)) then
	call phs_config%feyngraph_set%final ()
	deallocate (phs_config%feyngraph_set)
	end if
	end subroutine phs_wood_config_clear_phase_space

	@ %def phs_wood_config_clear_phase_space
	@
	Extract the set of resonance histories
	<<PHS wood: phs wood config: TBP>>=
	procedure :: extract_resonance_history_set &
	=> phs_wood_config_extract_resonance_history_set
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_extract_resonance_history_set &
	(phs_config, res_set, include_trivial)
	class(phs_wood_config_t), intent(in) :: phs_config
	type(resonance_history_set_t), intent(out) :: res_set
	logical, intent(in), optional :: include_trivial
	end subroutine phs_wood_config_extract_resonance_history_set
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_extract_resonance_history_set &
	(phs_config, res_set, include_trivial)
	class(phs_wood_config_t), intent(in) :: phs_config
	type(resonance_history_set_t), intent(out) :: res_set
	logical, intent(in), optional :: include_trivial
	call phs_config%forest%extract_resonance_history_set &
	(res_set, include_trivial)
	end subroutine phs_wood_config_extract_resonance_history_set

	@ %def phs_wood_config_extract_resonance_history_set
	@
	\subsection{Phase-space configuration}
	We read the phase-space configuration from the stored I/O unit. If
	this is not set, we assume that we have to generate a phase space
	configuration. When done, we open a scratch file and write the
	configuration.

	If [[rebuild]] is set, we should trash any existing phase space file
	and build a new one. Otherwise, we try to use an old one, which we
	check for existence and integrity. If [[ignore_mismatch]] is set, we
	reuse an existing file even if it does not match the current setup.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: configure => phs_wood_config_configure
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_wood_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_wood_config_configure
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_wood_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	type(string_t) :: filename, filename_vis
	logical :: variable_limits
	logical :: ok, exist, found, check, match, rebuild_phs
	integer :: g, c0, c1, n
	if (present (nlo_type)) then
	phs_config%nlo_type = nlo_type
	else
	phs_config%nlo_type = BORN
	end if
	phs_config%sqrts = sqrts
	phs_config%par%sqrts = sqrts
	if (present (sqrts_fixed)) &
	phs_config%sqrts_fixed = sqrts_fixed
	if (present (lab_is_cm)) &
	phs_config%lab_is_cm = lab_is_cm
	if (present (azimuthal_dependence)) &
	phs_config%azimuthal_dependence = azimuthal_dependence
	if (present (rebuild)) then
	rebuild_phs = rebuild
	else
	rebuild_phs = .true.
	end if
	if (present (ignore_mismatch)) then
	check = .not. ignore_mismatch
	if (ignore_mismatch) &
	call msg_warning ("Reading phs file: MD5 sum check disabled")
	else
	check = .true.
	end if
	phs_config%md5sum_forest = ""
	call phs_config%compute_md5sum (include_id = .false.)
	if (phs_config%io_unit == 0) then
	filename = phs_config%make_phs_filename (subdir)
	filename_vis = phs_config%make_phs_filename (subdir) // "-vis"
	if (.not. rebuild_phs) then
	if (check) then
	call phs_config%read_phs_file (exist, found, match, subdir=subdir)
	rebuild_phs = .not. (exist .and. found .and. match)
	else
	call phs_config%read_phs_file (exist, found, subdir=subdir)
	rebuild_phs = .not. (exist .and. found)
	end if
	end if
	if (.not. mpi_is_comm_master ()) then
	rebuild_phs = .false.
	call msg_message ("MPI: Workers do not build phase space configuration.")
	end if
	if (rebuild_phs) then
	call phs_config%generate_phase_space ()
	phs_config%io_unit = free_unit ()
	if (phs_config%id /= "") then
	call msg_message ("Phase space: writing configuration file '" &
	// char (filename) // "'")
	open (phs_config%io_unit, file = char (filename), &
	status = "replace", action = "readwrite")
	else
	open (phs_config%io_unit, status = "scratch", action = "readwrite")
	end if
	call phs_config%write_phase_space (filename_vis)
	rewind (phs_config%io_unit)
	else
	call msg_message ("Phase space: keeping configuration file '" &
	// char (filename) // "'")
	end if
	end if
	if (phs_config%io_unit == 0) then
	ok = .true.
	else
	call phs_config%forest%read (phs_config%io_unit, phs_config%id, &
	phs_config%n_in, phs_config%n_out, phs_config%model, ok)
	if (.not. phs_config%io_unit_keep_open) then
	close (phs_config%io_unit)
	phs_config%io_unit = 0
	end if
	end if
	if (ok) then
	call phs_config%forest%set_flavors (phs_config%flv(:,1))
	variable_limits = .not. phs_config%lab_is_cm
	call phs_config%forest%set_parameters (phs_config%mapping_defaults, &
	variable_limits)
	call phs_config%forest%setup_prt_combinations ()
	phs_config%n_channel = phs_config%forest%get_n_channels ()
	phs_config%n_par = phs_config%forest%get_n_parameters ()
	allocate (phs_config%channel (phs_config%n_channel))
	if (phs_config%use_equivalences) then
	call phs_config%forest%set_equivalences ()
	call phs_config%forest%get_equivalences (phs_config%channel, &
	phs_config%azimuthal_dependence)
	phs_config%provides_equivalences = .true.
	end if
	call phs_config%forest%set_s_mappings ()
	call phs_config%record_on_shell ()
	if (phs_config%mapping_defaults%enable_s_mapping) then
	call phs_config%record_s_mappings ()
	end if
	allocate (phs_config%chain (phs_config%n_channel), source = 0)
	do g = 1, phs_config%forest%get_n_groves ()
	call phs_config%forest%get_grove_bounds (g, c0, c1, n)
	phs_config%chain (c0:c1) = g
	end do
	phs_config%provides_chains = .true.
	call phs_config%compute_md5sum_forest ()
	else
	write (msg_buffer, "(A,A,A)") &
	"Phase space: process '", &
	char (phs_config%id), "' not found in configuration file"
	call msg_fatal ()
	end if
	end subroutine phs_wood_config_configure

	@ %def phs_wood_config_configure
	@ The MD5 sum of the forest is computed in addition to the MD5 sum of
	the configuration. The reason is that the forest may depend on a
	user-provided external file. On the other hand, this MD5 sum encodes
	all information that is relevant for further processing. Therefore,
	the [[get_md5sum]] method returns this result, once it is available.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_compute_md5sum_forest (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_compute_md5sum_forest
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_compute_md5sum_forest (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer :: u
	u = free_unit ()
	open (u, status = "scratch", action = "readwrite")
	call phs_config%write_forest (u)
	rewind (u)
	phs_config%md5sum_forest = md5sum (u)
	close (u)
	end subroutine phs_wood_config_compute_md5sum_forest

	@ %def phs_wood_config_compute_md5sum_forest
	@ Create filenames according to standard conventions. The [[id]] is the
	process name including the suffix [[_iX]] where [[X]] stands for the component
	identifier (an integer). The [[run_id]] may be set or unset.

	The convention for file names that include the run ID is to separate prefix, run
	ID, and any extensions by dots. We construct the file name by concatenating
	the individual elements accordingly. If there is no run ID, we nevertheless
	replace [[_iX]] by [[.iX]].
	<<PHS wood: phs wood config: TBP>>=
	procedure :: make_phs_filename => phs_wood_make_phs_filename
	<<PHS wood: sub interfaces>>=
	module function phs_wood_make_phs_filename &
	(phs_config, subdir) result (filename)
	class(phs_wood_config_t), intent(in) :: phs_config
	type(string_t), intent(in), optional :: subdir
	type(string_t) :: filename
	end function phs_wood_make_phs_filename
	<<PHS wood: procedures>>=
	module function phs_wood_make_phs_filename &
	(phs_config, subdir) result (filename)
	class(phs_wood_config_t), intent(in) :: phs_config
	type(string_t), intent(in), optional :: subdir
	type(string_t) :: filename
	type(string_t) :: basename, suffix, comp_code, comp_index
	basename = phs_config%id
	call split (basename, suffix, "_", back=.true.)
	comp_code = extract (suffix, 1, 1)
	comp_index = extract (suffix, 2)
	if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then
	suffix = "." // comp_code // comp_index
	else
	basename = phs_config%id
	suffix = ""
	end if
	if (phs_config%run_id /= "") then
	filename = basename // "." // phs_config%run_id // suffix // ".phs"
	else
	filename = basename // suffix // ".phs"
	end if
	if (present (subdir)) then
	filename = subdir // "/" // filename
	end if
	end function phs_wood_make_phs_filename

	@ %def phs_wood_make_phs_filename
	@
	<<PHS wood: phs wood config: TBP>>=
	procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_reshuffle_flavors &
	(phs_config, reshuffle, flv_extra)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in), dimension(:), allocatable :: reshuffle
	type(flavor_t), intent(in) :: flv_extra
	end subroutine phs_wood_config_reshuffle_flavors
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_reshuffle_flavors &
	(phs_config, reshuffle, flv_extra)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in), dimension(:), allocatable :: reshuffle
	type(flavor_t), intent(in) :: flv_extra
	call phs_config%forest%set_flavors (phs_config%flv(:,1), reshuffle, &
	flv_extra)
	end subroutine phs_wood_config_reshuffle_flavors

	@ %def phs_wood_config_reshuffle_flavors
	@
	<<PHS wood: phs wood config: TBP>>=
	procedure :: set_momentum_links => phs_wood_config_set_momentum_links
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in), dimension(:), allocatable :: reshuffle
	end subroutine phs_wood_config_set_momentum_links
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle)
	class(phs_wood_config_t), intent(inout) :: phs_config
	integer, intent(in), dimension(:), allocatable :: reshuffle
	call phs_config%forest%set_momentum_links (reshuffle)
	end subroutine phs_wood_config_set_momentum_links

	@ %def phs_wood_config_set_momentum_links
	@ Identify resonances which are marked by s-channel mappings for the
	whole phase space and report them to the channel array.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: record_s_mappings => phs_wood_config_record_s_mappings
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_record_s_mappings (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_record_s_mappings
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_record_s_mappings (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	logical :: flag
	real(default) :: mass, width
	integer :: c
	do c = 1, phs_config%n_channel
	call phs_config%forest%get_s_mapping (c, flag, mass, width)
	if (flag) then
	if (mass == 0) then
	call msg_fatal ("Phase space: s-channel resonance " &
	// " has zero mass")
	end if
	if (width == 0) then
	call msg_fatal ("Phase space: s-channel resonance " &
	// " has zero width")
	end if
	call phs_config%channel(c)%set_resonant (mass, width)
	end if
	end do
	end subroutine phs_wood_config_record_s_mappings

	@ %def phs_wood_config_record_s_mappings
	@ Identify on-shell mappings for the whole phase space and report them
	to the channel array.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: record_on_shell => phs_wood_config_record_on_shell
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_record_on_shell (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	end subroutine phs_wood_config_record_on_shell
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_record_on_shell (phs_config)
	class(phs_wood_config_t), intent(inout) :: phs_config
	logical :: flag
	real(default) :: mass
	integer :: c
	do c = 1, phs_config%n_channel
	call phs_config%forest%get_on_shell (c, flag, mass)
	if (flag) then
	call phs_config%channel(c)%set_on_shell (mass)
	end if
	end do
	end subroutine phs_wood_config_record_on_shell

	@ %def phs_wood_config_record_on_shell
	@ Return the most relevant MD5 sum. This overrides the method of the
	base type.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: get_md5sum => phs_wood_config_get_md5sum
	<<PHS wood: sub interfaces>>=
	module function phs_wood_config_get_md5sum (phs_config) result (md5sum)
	class(phs_wood_config_t), intent(in) :: phs_config
	character(32) :: md5sum
	end function phs_wood_config_get_md5sum
	<<PHS wood: procedures>>=
	module function phs_wood_config_get_md5sum (phs_config) result (md5sum)
	class(phs_wood_config_t), intent(in) :: phs_config
	character(32) :: md5sum
	if (phs_config%md5sum_forest /= "") then
	md5sum = phs_config%md5sum_forest
	else
	md5sum = phs_config%md5sum_phs_config
	end if
	end function phs_wood_config_get_md5sum

	@ %def phs_wood_config_get_md5sum
	@ Check whether a phase-space configuration for the current process exists.
	We look for the phase-space file that should correspond to the current
	process. If we find it, we check the MD5 sums stored in the file against the
	MD5 sums in the current configuration (if required).

	If successful, read the PHS file.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: read_phs_file => phs_wood_read_phs_file
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_read_phs_file &
	(phs_config, exist, found, match, subdir)
	class(phs_wood_config_t), intent(inout) :: phs_config
	logical, intent(out) :: exist
	logical, intent(out) :: found
	logical, intent(out), optional :: match
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_wood_read_phs_file
	<<PHS wood: procedures>>=
	module subroutine phs_wood_read_phs_file &
	(phs_config, exist, found, match, subdir)
	class(phs_wood_config_t), intent(inout) :: phs_config
	logical, intent(out) :: exist
	logical, intent(out) :: found
	logical, intent(out), optional :: match
	type(string_t), intent(in), optional :: subdir
	type(string_t) :: filename
	integer :: u
	filename = phs_config%make_phs_filename (subdir)
	inquire (file = char (filename), exist = exist)
	if (exist) then
	u = free_unit ()
	open (u, file = char (filename), action = "read", status = "old")
	call phs_config%forest%read (u, phs_config%id, phs_config%n_in, &
	phs_config%n_out, phs_config%model, found, &
	phs_config%md5sum_process, phs_config%md5sum_model_par, &
	phs_config%md5sum_phs_config, match = match)
	close (u)
	else
	found = .false.
	if (present (match)) match = .false.
	end if
	end subroutine phs_wood_read_phs_file

	@ %def phs_wood_read_phs_file
	@ Startup message, after configuration is complete.
	<<PHS wood: phs wood config: TBP>>=
	procedure :: startup_message => phs_wood_config_startup_message
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_config_startup_message (phs_config, unit)
	class(phs_wood_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_wood_config_startup_message
	<<PHS wood: procedures>>=
	module subroutine phs_wood_config_startup_message (phs_config, unit)
	class(phs_wood_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	integer :: n_groves, n_eq
	n_groves = phs_config%forest%get_n_groves ()
	n_eq = phs_config%forest%get_n_equivalences ()
	call phs_config%base_startup_message (unit)
	if (phs_config%n_channel == 1) then
	write (msg_buffer, "(A,2(I0,A))") &
	"Phase space: found ", phs_config%n_channel, &
	" channel, collected in ", n_groves, &
	" grove."
	else if (n_groves == 1) then
	write (msg_buffer, "(A,2(I0,A))") &
	"Phase space: found ", phs_config%n_channel, &
	" channels, collected in ", n_groves, &
	" grove."
	else
	write (msg_buffer, "(A,2(I0,A))") &
	"Phase space: found ", phs_config%n_channel, &
	" channels, collected in ", n_groves, &
	" groves."
	end if
	call msg_message (unit = unit)
	if (phs_config%use_equivalences) then
	if (n_eq == 1) then
	write (msg_buffer, "(A,I0,A)") &
	"Phase space: Using ", n_eq, &
	" equivalence between channels."
	else
	write (msg_buffer, "(A,I0,A)") &
	"Phase space: Using ", n_eq, &
	" equivalences between channels."
	end if
	else
	write (msg_buffer, "(A)") &
	"Phase space: no equivalences between channels used."
	end if
	call msg_message (unit = unit)
	write (msg_buffer, "(A,2(1x,I0,1x,A))") &
	"Phase space: wood"
	call msg_message (unit = unit)
	end subroutine phs_wood_config_startup_message

	@ %def phs_wood_config_startup_message
	@ Allocate an instance: the actual phase-space object.
	Gfortran 7/8/9 bug, has to remain in the main module.
	<<PHS wood: phs wood config: TBP>>=
	procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance
	<<PHS wood: main procedures>>=
	subroutine phs_wood_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_wood_t :: phs)
	end subroutine phs_wood_config_allocate_instance

	@ %def phs_wood_config_allocate_instance
	@
	\subsection{Kinematics implementation}
	We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.
	<<PHS wood: public>>=
	public :: phs_wood_t
	<<PHS wood: types>>=
	type, extends (phs_t) :: phs_wood_t
	real(default) :: sqrts = 0
	type(phs_forest_t) :: forest
	real(default), dimension(3) :: r_real
	integer :: n_r_born = 0
	contains
	<<PHS wood: phs wood: TBP>>
	end type phs_wood_t

	@ %def phs_wood_t
	@ Output. The [[verbose]] setting is irrelevant, we just display the contents
	of the base object.
	<<PHS wood: phs wood: TBP>>=
	procedure :: write => phs_wood_write
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_write (object, unit, verbose)
	class(phs_wood_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_wood_write
	<<PHS wood: procedures>>=
	module subroutine phs_wood_write (object, unit, verbose)
	class(phs_wood_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (u)
	end subroutine phs_wood_write

	@ %def phs_wood_write
	@ Write the forest separately.
	<<PHS wood: phs wood: TBP>>=
	procedure :: write_forest => phs_wood_write_forest
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_write_forest (object, unit)
	class(phs_wood_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine phs_wood_write_forest
	<<PHS wood: procedures>>=
	module subroutine phs_wood_write_forest (object, unit)
	class(phs_wood_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call object%forest%write (u)
	end subroutine phs_wood_write_forest

	@ %def phs_wood_write_forest
	@ Finalizer.
	<<PHS wood: phs wood: TBP>>=
	procedure :: final => phs_wood_final
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_final (object)
	class(phs_wood_t), intent(inout) :: object
	end subroutine phs_wood_final
	<<PHS wood: procedures>>=
	module subroutine phs_wood_final (object)
	class(phs_wood_t), intent(inout) :: object
	call object%forest%final ()
	end subroutine phs_wood_final

	@ %def phs_wood_final
	@ Initialization. We allocate arrays ([[base_init]]) and adjust the
	phase-space volume. The two-particle phase space volume is
	\begin{equation}
	\Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
	\end{equation}
	independent of the particle masses.
	<<PHS wood: phs wood: TBP>>=
	procedure :: init => phs_wood_init
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_init (phs, phs_config)
	class(phs_wood_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_wood_init
	<<PHS wood: procedures>>=
	module subroutine phs_wood_init (phs, phs_config)
	class(phs_wood_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	call phs%base_init (phs_config)
	select type(phs_config)
	type is (phs_wood_config_t)
	phs%forest = phs_config%forest
	if (phs_config%is_combined_integration) then
	phs%n_r_born = phs_config%n_par - 3
	end if
	end select
	end subroutine phs_wood_init

	@ %def phs_wood_init
	@
	\subsection{Evaluation}
	We compute the outgoing momenta from the incoming momenta and
	the input parameter set [[r_in]] in channel [[r_in]]. We also compute the
	[[r]] parameters and Jacobians [[f]] for all other channels.

	We do \emph{not} need to a apply a transformation from/to the c.m.\ frame,
	because in [[phs_base]] the momenta are already boosted to the c.m.\ frame
	before assigning them in the [[phs]] object, and inversely boosted when
	extracting them.
	<<PHS wood: phs wood: TBP>>=
	procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel
	procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_wood_t), intent(inout) :: phs
	real(default), intent(in), dimension(:) :: r_in
	integer, intent(in) :: c_in
	end subroutine phs_wood_evaluate_selected_channel
	module subroutine phs_wood_evaluate_other_channels (phs, c_in)
	class(phs_wood_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_wood_evaluate_other_channels
	<<PHS wood: procedures>>=
	module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_wood_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	logical :: ok
	phs%q_defined = .false.
	if (phs%p_defined) then
	call phs%forest%set_prt_in (phs%p)
	phs%r(:,c_in) = r_in
	call phs%forest%evaluate_selected_channel (c_in, phs%active_channel, &
	phs%sqrts_hat, phs%r, phs%f, phs%volume, ok)
	select type (config => phs%config)
	type is (phs_wood_config_t)
	if (config%is_combined_integration) then
	if (phs%n_r_born >= 0) then
	phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3)
	else
	call msg_fatal ("n_r_born should be larger than 0!")
	end if
	end if
	end select
	if (ok) then
	phs%q = phs%forest%get_momenta_out ()
	phs%q_defined = .true.
	end if
	end if
	end subroutine phs_wood_evaluate_selected_channel

	module subroutine phs_wood_evaluate_other_channels (phs, c_in)
	class(phs_wood_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	integer :: c
	if (phs%q_defined) then
	call phs%forest%evaluate_other_channels (c_in, phs%active_channel, &
	phs%sqrts_hat, phs%r, phs%f, combine=.true.)
	select type (config => phs%config)
	type is (phs_wood_config_t)
	if (config%is_combined_integration) then
	if (phs%n_r_born >= 0) then
	do c = 1, size (phs%r, 2)
	phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real
	end do
	else
	phs%r_defined = .false.
	end if
	end if
	end select
	phs%r_defined = .true.
	end if
	end subroutine phs_wood_evaluate_other_channels

	@ %def phs_wood_evaluate_selected_channel
	@ %def phs_wood_evaluate_other_channels
	@ Inverse evaluation.
	<<PHS wood: phs wood: TBP>>=
	procedure :: inverse => phs_wood_inverse
	<<PHS wood: sub interfaces>>=
	module subroutine phs_wood_inverse (phs)
	class(phs_wood_t), intent(inout) :: phs
	end subroutine phs_wood_inverse
	<<PHS wood: procedures>>=
	module subroutine phs_wood_inverse (phs)
	class(phs_wood_t), intent(inout) :: phs
	if (phs%p_defined .and. phs%q_defined) then
	call phs%forest%set_prt_in (phs%p)
	call phs%forest%set_prt_out (phs%q)
	call phs%forest%recover_channel (1, phs%sqrts_hat, phs%r, &
	phs%f, phs%volume)
	call phs%forest%evaluate_other_channels (1, phs%active_channel, &
	phs%sqrts_hat, phs%r, phs%f, combine=.false.)
	phs%r_defined = .true.
	end if
	end subroutine phs_wood_inverse

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

	module phs_wood_ut
	use unit_tests
	use phs_wood_uti

	<<Standard module head>>

	<<PHS wood: public test>>

	<<PHS wood: public test auxiliary>>

	contains

	<<PHS wood: test driver>>

	end module phs_wood_ut
	@ %def phs_wood_ut
	@
	<<[[phs_wood_uti.f90]]>>=
	<<File header>>

	module phs_wood_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use os_interface
	use lorentz
	use flavors
	use model_data
	use process_constants
	use mappings
	use phs_base
	use phs_forests

	use phs_wood

	use phs_base_ut, only: init_test_process_data, init_test_decay_data

	<<Standard module head>>

	<<PHS wood: public test auxiliary>>

	<<PHS wood: test declarations>>

	contains

	<<PHS wood: tests>>

	<<PHS wood: test auxiliary>>

	end module phs_wood_uti
	@ %def phs_wood_ut
	@ API: driver for the unit tests below.
	<<PHS wood: public test>>=
	public :: phs_wood_test
	<<PHS wood: test driver>>=
	subroutine phs_wood_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS wood: execute tests>>
	end subroutine phs_wood_test

	@ %def phs_wood_test
	<<PHS wood: public test>>=
	public :: phs_wood_vis_test
	<<PHS wood: test driver>>=
	subroutine phs_wood_vis_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<PHS wood: execute vis tests>>
	end subroutine phs_wood_vis_test

	@ %def phs_wood_vis_test
	@
	\subsubsection{Phase-space configuration data}
	Construct and display a test phase-space configuration object. Also
	check the [[azimuthal_dependence]] flag.

	This auxiliary routine writes a phase-space configuration file to unit
	[[u_phs]].
	<<PHS wood: public test auxiliary>>=
	public :: write_test_phs_file
	<<PHS wood: test auxiliary>>=
	subroutine write_test_phs_file (u_phs, procname)
	integer, intent(in) :: u_phs
	type(string_t), intent(in), optional :: procname
	if (present (procname)) then
	write (u_phs, "(A,A)") "process ", char (procname)
	else
	write (u_phs, "(A)") "process testproc"
	end if
	write (u_phs, "(A,A)") " md5sum_process = ", '""'
	write (u_phs, "(A,A)") " md5sum_model_par = ", '""'
	write (u_phs, "(A,A)") " md5sum_phs_config = ", '""'
	write (u_phs, "(A)") " sqrts = 1000"
	write (u_phs, "(A)") " m_threshold_s = 50"
	write (u_phs, "(A)") " m_threshold_t = 100"
	write (u_phs, "(A)") " off_shell = 2"
	write (u_phs, "(A)") " t_channel = 6"
	write (u_phs, "(A)") " keep_nonresonant = T"
	write (u_phs, "(A)") " grove #1"
	write (u_phs, "(A)") " tree 3"
	end subroutine write_test_phs_file

	@ %def write_test_phs_file
	@
	<<PHS wood: execute tests>>=
	call test (phs_wood_1, "phs_wood_1", &
	"phase-space configuration", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_1
	<<PHS wood: tests>>=
	subroutine phs_wood_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data
	type(mapping_defaults_t) :: mapping_defaults
	real(default) :: sqrts
	integer :: u_phs, iostat
	character(32) :: buffer

	write (u, "(A)") "* Test output: phs_wood_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&phase-space configuration data"
	write (u, "(A)")

	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_1"), process_data)

	write (u, "(A)") "* Create a scratch phase-space file"
	write (u, "(A)")

	u_phs = free_unit ()
	open (u_phs, status = "scratch", action = "readwrite")
	call write_test_phs_file (u_phs, var_str ("phs_wood_1"))
	rewind (u_phs)
	do
	read (u_phs, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Setup phase-space configuration object"
	write (u, "(A)")

	mapping_defaults%step_mapping = .false.

	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_input (u_phs)
	call phs_data%set_mapping_defaults (mapping_defaults)
	end select

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)
	write (u, "(A)")

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%write_forest (u)
	end select

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

	close (u_phs)
	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_1

	@ %def phs_wood_1
	@
	\subsubsection{Phase space evaluation}
	Compute kinematics for given parameters, also invert the calculation.
	<<PHS wood: execute tests>>=
	call test (phs_wood_2, "phs_wood_2", &
	"phase-space evaluation", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_2
	<<PHS wood: tests>>=
	subroutine phs_wood_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(process_constants_t) :: process_data
	real(default) :: sqrts, E
	class(phs_config_t), allocatable, target :: phs_data
	class(phs_t), pointer :: phs => null ()
	type(vector4_t), dimension(2) :: p, q
	integer :: u_phs

	write (u, "(A)") "* Test output: phs_wood_2"
	write (u, "(A)") "* Purpose: test simple single-channel phase space"
	write (u, "(A)")

	call model%init_test ()
	call flv%init (25, model)

	write (u, "(A)") "* Initialize a process and a matching &
	&phase-space configuration"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_2"), process_data)
	u_phs = free_unit ()
	open (u_phs, status = "scratch", action = "readwrite")
	call write_test_phs_file (u_phs, var_str ("phs_wood_2"))
	rewind (u_phs)

	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_input (u_phs)
	end select

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%write (u, verbose=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	E = sqrts / 2
	p(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	p(2) = vector4_moving (E,-sqrt (E2 - flv%get_mass ()2), 3)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.125, 0.5"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)
	write (u, "(A)")
	select type (phs)
	type is (phs_wood_t)
	call phs%write_forest (u)
	end select

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	call phs%final ()
	deallocate (phs)

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)
	write (u, "(A)")
	select type (phs)
	type is (phs_wood_t)
	call phs%write_forest (u)
	end select

	call phs%final ()
	deallocate (phs)

	close (u_phs)
	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_2

	@ %def phs_wood_2
	@
	\subsubsection{Phase-space generation}
	Generate phase space for a simple process.
	<<PHS wood: execute tests>>=
	call test (phs_wood_3, "phs_wood_3", &
	"phase-space generation", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_3
	<<PHS wood: tests>>=
	subroutine phs_wood_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	type(phs_parameters_t) :: phs_par
	class(phs_config_t), allocatable :: phs_data
	integer :: iostat
	character(80) :: buffer

	write (u, "(A)") "* Test output: phs_wood_3"
	write (u, "(A)") "* Purpose: generate a phase-space configuration"
	write (u, "(A)")

	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process and phase-space parameters"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_3"), process_data)
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)

	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%io_unit_keep_open = .true.
	end select

	write (u, "(A)")
	write (u, "(A)") "* Generate a scratch phase-space file"
	write (u, "(A)")

	call phs_data%configure (phs_par%sqrts)

	select type (phs_data)
	type is (phs_wood_config_t)
	rewind (phs_data%io_unit)
	do
	read (phs_data%io_unit, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do
	end select

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

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_3

	@ %def phs_wood_3
	@
	\subsubsection{Nontrivial process}
	Generate phase space for a $2\to 3$ process.
	<<PHS wood: execute tests>>=
	call test (phs_wood_4, "phs_wood_4", &
	"nontrivial process", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_4
	<<PHS wood: tests>>=
	subroutine phs_wood_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	type(phs_parameters_t) :: phs_par
	class(phs_config_t), allocatable, target :: phs_data
	integer :: iostat
	character(80) :: buffer
	class(phs_t), pointer :: phs => null ()
	real(default) :: E, pL
	type(vector4_t), dimension(2) :: p
	type(vector4_t), dimension(3) :: q

	write (u, "(A)") "* Test output: phs_wood_4"
	write (u, "(A)") "* Purpose: generate a phase-space configuration"
	write (u, "(A)")

	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process and phase-space parameters"
	write (u, "(A)")

	process_data%id = "phs_wood_4"
	process_data%model_name = "Test"
	process_data%n_in = 2
	process_data%n_out = 3
	process_data%n_flv = 1
	allocate (process_data%flv_state (process_data%n_in + process_data%n_out, &
	process_data%n_flv))
	process_data%flv_state(:,1) = [25, 25, 25, 6, -6]

	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)

	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%io_unit_keep_open = .true.
	end select

	write (u, "(A)")
	write (u, "(A)") "* Generate a scratch phase-space file"
	write (u, "(A)")

	call phs_data%configure (phs_par%sqrts)

	select type (phs_data)
	type is (phs_wood_config_t)
	rewind (phs_data%io_unit)
	do
	read (phs_data%io_unit, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do
	end select

	write (u, "(A)")
	write (u, "(A)") "* Initialize the phase-space instance"
	write (u, "(A)")

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	write (u, "(A)") "* Set incoming momenta"
	write (u, "(A)")

	select type (phs_data)
	type is (phs_wood_config_t)
	E = phs_data%sqrts / 2
	pL = sqrt (E2 - phs_data%flv(1,1)%get_mass ()2)
	end select
	p(1) = vector4_moving (E, pL, 3)
	p(2) = vector4_moving (E, -pL, 3)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()

	write (u, "(A)") "* Compute phase-space point &
	&for x = 0.1, 0.2, 0.3, 0.4, 0.5"
	write (u, "(A)")

	call phs%evaluate_selected_channel (1, &
	[0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default])
	call phs%evaluate_other_channels (1)
	call phs%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inverse kinematics"
	write (u, "(A)")

	call phs%get_outgoing_momenta (q)
	call phs%final ()
	deallocate (phs)

	call phs_data%allocate_instance (phs)
	call phs%init (phs_data)

	call phs%set_incoming_momenta (p)
	call phs%compute_flux ()
	call phs%set_outgoing_momenta (q)

	call phs%inverse ()
	call phs%write (u)

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

	call phs%final ()
	deallocate (phs)

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_4

	@ %def phs_wood_4
	@
	\subsubsection{Equivalences}
	Generate phase space for a simple process, including channel equivalences.
	<<PHS wood: execute tests>>=
	call test (phs_wood_5, "phs_wood_5", &
	"equivalences", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_5
	<<PHS wood: tests>>=
	subroutine phs_wood_5 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	type(phs_parameters_t) :: phs_par
	class(phs_config_t), allocatable :: phs_data

	write (u, "(A)") "* Test output: phs_wood_5"
	write (u, "(A)") "* Purpose: generate a phase-space configuration"
	write (u, "(A)")

	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process and phase-space parameters"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_5"), process_data)
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)

	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	call phs_data%enable_equivalences ()
	end select

	write (u, "(A)")
	write (u, "(A)") "* Generate a scratch phase-space file"
	write (u, "(A)")

	call phs_data%configure (phs_par%sqrts)
	call phs_data%write (u)
	write (u, "(A)")

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%write_forest (u)
	end select

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

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_5

	@ %def phs_wood_5
	@
	\subsubsection{MD5 sum checks}
	Generate phase space for a simple process. Repeat this with and without
	parameter change.
	<<PHS wood: execute tests>>=
	call test (phs_wood_6, "phs_wood_6", &
	"phase-space generation", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_6
	<<PHS wood: tests>>=
	subroutine phs_wood_6 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	type(phs_parameters_t) :: phs_par
	class(phs_config_t), allocatable :: phs_data
	logical :: exist, found, match
	integer :: u_phs
	character(*), parameter :: filename = "phs_wood_6_p.phs"

	write (u, "(A)") "* Test output: phs_wood_6"
	write (u, "(A)") "* Purpose: generate and check phase-space file"
	write (u, "(A)")

	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process and phase-space parameters"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_6"), process_data)
	process_data%id = "phs_wood_6_p"
	process_data%md5sum = "1234567890abcdef1234567890abcdef"
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)

	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	end select

	write (u, "(A)") "* Remove previous phs file, if any"
	write (u, "(A)")

	inquire (file = filename, exist = exist)
	if (exist) then
	u_phs = free_unit ()
	open (u_phs, file = filename, action = "write")
	close (u_phs, status = "delete")
	end if

	write (u, "(A)") "* Check phase-space file (should fail)"
	write (u, "(A)")

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

	write (u, "(A)")
	write (u, "(A)") "* Generate a phase-space file"
	write (u, "(A)")

	call phs_data%configure (phs_par%sqrts)

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	write (u, "(A)")
	write (u, "(A)") "* Check MD5 sum"
	write (u, "(A)")

	call phs_data%final ()
	deallocate (phs_data)
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%sqrts = phs_par%sqrts
	phs_data%par%sqrts = phs_par%sqrts
	end select
	call phs_data%compute_md5sum ()

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

	write (u, "(A)")
	write (u, "(A)") "* Modify sqrts and check MD5 sum"
	write (u, "(A)")

	call phs_data%final ()
	deallocate (phs_data)
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	phs_par%sqrts = 500
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%sqrts = phs_par%sqrts
	phs_data%par%sqrts = phs_par%sqrts
	end select
	call phs_data%compute_md5sum ()

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

	write (u, "(A)")
	write (u, "(A)") "* Modify process and check MD5 sum"
	write (u, "(A)")

	call phs_data%final ()
	deallocate (phs_data)
	process_data%md5sum = "77777777777777777777777777777777"
	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	phs_par%sqrts = 1000
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%sqrts = phs_par%sqrts
	phs_data%par%sqrts = phs_par%sqrts
	end select
	call phs_data%compute_md5sum ()

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

	write (u, "(A)")
	write (u, "(A)") "* Modify phs parameter and check MD5 sum"
	write (u, "(A)")

	call phs_data%final ()
	deallocate (phs_data)
	allocate (phs_wood_config_t :: phs_data)
	process_data%md5sum = "1234567890abcdef1234567890abcdef"
	call phs_data%init (process_data, model)
	phs_par%sqrts = 1000
	phs_par%off_shell = 17
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%sqrts = phs_par%sqrts
	phs_data%par%sqrts = phs_par%sqrts
	end select
	call phs_data%compute_md5sum ()

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

	write (u, "(A)")
	write (u, "(A)") "* Modify model parameter and check MD5 sum"
	write (u, "(A)")

	call phs_data%final ()
	deallocate (phs_data)
	allocate (phs_wood_config_t :: phs_data)
	call model%set_par (var_str ("ms"), 100._default)
	call phs_data%init (process_data, model)
	phs_par%sqrts = 1000
	phs_par%off_shell = 1
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_parameters (phs_par)
	phs_data%sqrts = phs_par%sqrts
	phs_data%par%sqrts = phs_par%sqrts
	end select
	call phs_data%compute_md5sum ()

	write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
	phs_data%md5sum_process, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
	phs_data%md5sum_model_par, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
	phs_data%md5sum_phs_config, "'"

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%read_phs_file (exist, found, match)
	write (u, "(1x,A,L1)") "exist = ", exist
	write (u, "(1x,A,L1)") "found = ", found
	write (u, "(1x,A,L1)") "match = ", match
	end select

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

	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_6

	@ %def phs_wood_6
	@
	<<PHS wood: execute vis tests>>=
	call test (phs_wood_vis_1, "phs_wood_vis_1", &
	"visualizing phase space channels", &
	u, results)
	<<PHS wood: test declarations>>=
	public :: phs_wood_vis_1
	<<PHS wood: tests>>=
	subroutine phs_wood_vis_1 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(process_constants_t) :: process_data
	class(phs_config_t), allocatable :: phs_data
	type(mapping_defaults_t) :: mapping_defaults
	type(string_t) :: vis_file, pdf_file, ps_file
	real(default) :: sqrts
	logical :: exist, exist_pdf, exist_ps
	integer :: u_phs, iostat, u_vis
	character(95) :: buffer

	write (u, "(A)") "* Test output: phs_wood_vis_1"
	write (u, "(A)") "* Purpose: visualizing the &
	&phase-space configuration"
	write (u, "(A)")

	call os_data%init ()
	call model%init_test ()

	call syntax_phs_forest_init ()

	write (u, "(A)") "* Initialize a process"
	write (u, "(A)")

	call init_test_process_data (var_str ("phs_wood_vis_1"), process_data)

	write (u, "(A)") "* Create a scratch phase-space file"
	write (u, "(A)")

	u_phs = free_unit ()
	open (u_phs, status = "scratch", action = "readwrite")
	call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1"))
	rewind (u_phs)
	do
	read (u_phs, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Setup phase-space configuration object"
	write (u, "(A)")

	mapping_defaults%step_mapping = .false.

	allocate (phs_wood_config_t :: phs_data)
	call phs_data%init (process_data, model)
	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%set_input (u_phs)
	call phs_data%set_mapping_defaults (mapping_defaults)
	phs_data%os_data = os_data
	phs_data%io_unit = 0
	phs_data%io_unit_keep_open = .true.
	phs_data%vis_channels = .true.
	end select

	sqrts = 1000._default
	call phs_data%configure (sqrts)

	call phs_data%write (u)
	write (u, "(A)")

	select type (phs_data)
	type is (phs_wood_config_t)
	call phs_data%write_forest (u)
	end select

	vis_file = "phs_wood_vis_1.phs-vis.tex"
	ps_file = "phs_wood_vis_1.phs-vis.ps"
	pdf_file = "phs_wood_vis_1.phs-vis.pdf"
	inquire (file = char (vis_file), exist = exist)
	if (exist) then
	u_vis = free_unit ()
	open (u_vis, file = char (vis_file), action = "read", status = "old")
	iostat = 0
	do while (iostat == 0)
	read (u_vis, "(A)", iostat = iostat) buffer
	if (iostat == 0) write (u, "(A)") trim (buffer)
	end do
	close (u_vis)
	else
	write (u, "(A)") "[Visualize LaTeX file is missing]"
	end if
	inquire (file = char (ps_file), exist = exist_ps)
	if (exist_ps) then
	write (u, "(A)") "[Visualize Postscript file exists and is nonempty]"
	else
	write (u, "(A)") "[Visualize Postscript file is missing/non-regular]"
	end if
	inquire (file = char (pdf_file), exist = exist_pdf)
	if (exist_pdf) then
	write (u, "(A)") "[Visualize PDF file exists and is nonempty]"
	else
	write (u, "(A)") "[Visualize PDF file is missing/non-regular]"
	end if

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

	close (u_phs)
	call phs_data%final ()
	call model%final ()

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

	end subroutine phs_wood_vis_1

	@ %def phs_wood_vis_1
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{The FKS phase space}
	<<[[phs_fks.f90]]>>=
	<<File header>>

	module phs_fks

	<<Use kinds>>
	<<Use strings>>
	use constants
	use lorentz
	use phs_points
	use models, only: model_t
	use phs_base
	use resonances, only: resonance_contributors_t, resonance_history_t
	use phs_wood

	<<Standard module head>>

	<<PHS fks: public>>

	<<PHS fks: parameters>>

	<<PHS fks: types>>

	interface
	<<PHS fks: sub interfaces>>
	end interface

	contains

	<<PHS fks: main procedures>>

	end module phs_fks

	@ %def phs_fks
	@
	<<[[phs_fks_sub.f90]]>>=
	<<File header>>

	submodule (phs_fks) phs_fks_s

	<<Use debug>>
	use diagnostics
	use io_units, only: given_output_unit, free_unit
	use format_defs, only: FMT_17
	use format_utils, only: write_separator
	use physics_defs
	use flavors
	use pdg_arrays, only: is_colored
	use cascades
	use cascades2
	use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole
	!!! Intel oneAPI 2022/23 regression workaround
	use resonances, only: resonance_history_t
	use resonances, only: resonance_contributors_t

	implicit none

	<<PHS fks: interfaces>>

	contains

	<<PHS fks: procedures>>

	end submodule phs_fks_s

	@ %def phs_fks_s
	@ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state
	phase spaces.
	<<PHS fks: public>>=
	public :: isr_kinematics_t
	<<PHS fks: types>>=
	type :: isr_kinematics_t
	integer :: n_in
	real(default), dimension(2) :: x = one
	real(default), dimension(2) :: z = zero
	real(default) :: sqrts_born = zero
	real(default), dimension(:), allocatable :: beam_energy
	real(default) :: fac_scale = zero
	real(default), dimension(2) :: jacobian = one
	integer :: isr_mode = SQRTS_FIXED
	contains
	<<PHS fks: isr kinematics: TBP>>
	end type isr_kinematics_t

	@ %def type isr_kinematics_t
	@
	<<PHS fks: isr kinematics: TBP>>=
	procedure :: write => isr_kinematics_write
	<<PHS fks: sub interfaces>>=
	module subroutine isr_kinematics_write (isr, unit)
	class(isr_kinematics_t), intent(in) :: isr
	integer, intent(in), optional :: unit
	end subroutine isr_kinematics_write
	<<PHS fks: procedures>>=
	module subroutine isr_kinematics_write (isr, unit)
	class(isr_kinematics_t), intent(in) :: isr
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u,"(A)") "ISR kinematics: "
	write (u,"(A," // FMT_17 // ",1X)") "x(+): ", isr%x(1)
	write (u,"(A," // FMT_17 // ",1X)") "x(-): ", isr%x(2)
	write (u,"(A," // FMT_17 // ",1X)") "z(+): ", isr%z(1)
	write (u,"(A," // FMT_17 // ",1X)") "z(-): ", isr%z(2)
	write (u,"(A," // FMT_17 // ",1X)") "sqrts (Born): ", isr%sqrts_born
	if (allocated (isr%beam_energy)) then
	do i = 1, size (isr%beam_energy)
	write (u,"(A," // FMT_17 // ",1X)") "Beam energy: ", &
	isr%beam_energy(i)
	end do
	end if
	write (u,"(A," // FMT_17 // ",1X)") "Fac. scale: ", isr%fac_scale
	do i = 1, 2
	write (u,"(A," // FMT_17 // ",1X)") "Jacobian: ", isr%jacobian(i)
	end do
	write (u,"(A,I0,1X)") "ISR mode: ", isr%isr_mode
	end subroutine isr_kinematics_write

	@ %def isr_kinematics_write
	@
	<<PHS fks: public>>=
	public :: phs_point_set_t
	<<PHS fks: types>>=
	type :: phs_point_set_t
	type(phs_point_t), dimension(:), allocatable :: phs_point
	logical :: initialized = .false.
	contains
	<<PHS fks: phs point set: TBP>>
	end type phs_point_set_t

	@ %def phs_point_set_t
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: init => phs_point_set_init
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs)
	class(phs_point_set_t), intent(out) :: phs_point_set
	integer, intent(in) :: n_particles, n_phs
	end subroutine phs_point_set_init
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs)
	class(phs_point_set_t), intent(out) :: phs_point_set
	integer, intent(in) :: n_particles, n_phs
	integer :: i_phs
	allocate (phs_point_set%phs_point (n_phs))
	do i_phs = 1, n_phs
	phs_point_set%phs_point(i_phs) = n_particles
	end do
	phs_point_set%initialized = .true.
	end subroutine phs_point_set_init

	@ %def phs_point_set_init
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: write => phs_point_set_write
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, &
	unit, show_mass, testflag, check_conservation, ultra, n_in)
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in), optional :: i_phs
	integer, intent(in), dimension(:), optional :: contributors
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_mass
	logical, intent(in), optional :: testflag, ultra
	logical, intent(in), optional :: check_conservation
	integer, intent(in), optional :: n_in
	end subroutine phs_point_set_write
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, &
	unit, show_mass, testflag, check_conservation, ultra, n_in)
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in), optional :: i_phs
	integer, intent(in), dimension(:), optional :: contributors
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_mass
	logical, intent(in), optional :: testflag, ultra
	logical, intent(in), optional :: check_conservation
	integer, intent(in), optional :: n_in
	integer :: i, u
	type(vector4_t) :: p_sum
	u = given_output_unit (unit); if (u < 0) return
	if (present (i_phs)) then
	call phs_point_set%phs_point(i_phs)%write &
	(unit = u, show_mass = show_mass, testflag = testflag, &
	check_conservation = check_conservation, ultra = ultra, n_in = n_in)
	else
	do i = 1, size(phs_point_set%phs_point)
	call phs_point_set%phs_point(i)%write &
	(unit = u, show_mass = show_mass, testflag = testflag, &
	check_conservation = check_conservation, ultra = ultra,&
	n_in = n_in)
	end do
	end if
	if (present (contributors)) then
	if (debug_on) call msg_debug &
	(D_SUBTRACTION, "Invariant masses for real emission: ")
	associate (pp => phs_point_set%phs_point(i_phs))
	p_sum = sum (pp, [contributors, size (pp)])
	end associate
	if (debug_active (D_SUBTRACTION)) &
	call vector4_write (p_sum, unit = unit, show_mass = show_mass, &
	testflag = testflag, ultra = ultra)
	end if
	end subroutine phs_point_set_write

	@ %def phs_point_set_write
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_n_momenta => phs_point_set_get_n_momenta
	<<PHS fks: sub interfaces>>=
	elemental module function phs_point_set_get_n_momenta &
	(phs_point_set, i_res) result (n)
	integer :: n
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_res
	end function phs_point_set_get_n_momenta
	<<PHS fks: procedures>>=
	elemental module function phs_point_set_get_n_momenta &
	(phs_point_set, i_res) result (n)
	integer :: n
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_res
	n = size (phs_point_set%phs_point(i_res))
	end function phs_point_set_get_n_momenta

	@ %def phs_point_set_get_n_momenta
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_momenta => phs_point_set_get_momenta
	<<PHS fks: sub interfaces>>=
	pure module function phs_point_set_get_momenta &
	(phs_point_set, i_phs, n_in) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), optional :: n_in
	end function phs_point_set_get_momenta
	<<PHS fks: procedures>>=
	pure module function phs_point_set_get_momenta &
	(phs_point_set, i_phs, n_in) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), optional :: n_in
	integer :: i
	if (present (n_in)) then
	p = phs_point_set%phs_point(i_phs)%select ([(i, i=1, n_in)])
	else
	p = phs_point_set%phs_point(i_phs)
	end if
	end function phs_point_set_get_momenta

	@ %def phs_point_set_get_momenta
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_momentum => phs_point_set_get_momentum
	<<PHS fks: sub interfaces>>=
	pure module function phs_point_set_get_momentum &
	(phs_point_set, i_phs, i_mom) result (p)
	type(vector4_t) :: p
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs, i_mom
	end function phs_point_set_get_momentum
	<<PHS fks: procedures>>=
	pure module function phs_point_set_get_momentum &
	(phs_point_set, i_phs, i_mom) result (p)
	type(vector4_t) :: p
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs, i_mom
	p = phs_point_set%phs_point(i_phs)%select (i_mom)
	end function phs_point_set_get_momentum

	@ %def phs_point_set_get_momentum
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_energy => phs_point_set_get_energy
	<<PHS fks: sub interfaces>>=
	pure module function phs_point_set_get_energy &
	(phs_point_set, i_phs, i_mom) result (E)
	real(default) :: E
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs, i_mom
	end function phs_point_set_get_energy
	<<PHS fks: procedures>>=
	pure module function phs_point_set_get_energy &
	(phs_point_set, i_phs, i_mom) result (E)
	real(default) :: E
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs, i_mom
	E = energy (phs_point_set%phs_point(i_phs)%select (i_mom))
	end function phs_point_set_get_energy

	@ %def phs_point_set_get_energy
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_sqrts => phs_point_set_get_sqrts
	<<PHS fks: sub interfaces>>=
	module function phs_point_set_get_sqrts &
	(phs_point_set, i_phs) result (sqrts)
	real(default) :: sqrts
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	end function phs_point_set_get_sqrts
	<<PHS fks: procedures>>=
	module function phs_point_set_get_sqrts &
	(phs_point_set, i_phs) result (sqrts)
	real(default) :: sqrts
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	sqrts = sqrt (phs_point_set%phs_point(i_phs)%get_msq ([1,2]))
	end function phs_point_set_get_sqrts

	@ %def phs_point_set_get_sqrts
	@
	<<PHS fks: phs point set: TBP>>=
	generic :: set_momenta => set_momenta_p, set_momenta_phs_point
	procedure :: set_momenta_p => phs_point_set_set_momenta_p
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p
	end subroutine phs_point_set_set_momenta_p
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p
	phs_point_set%phs_point(i_phs) = p
	end subroutine phs_point_set_set_momenta_p

	@ %def phs_point_set_set_momenta_p
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_set_momenta_phs_point &
	(phs_point_set, i_phs, p)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	integer, intent(in) :: i_phs
	type(phs_point_t), intent(in) :: p
	end subroutine phs_point_set_set_momenta_phs_point
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_set_momenta_phs_point &
	(phs_point_set, i_phs, p)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	integer, intent(in) :: i_phs
	type(phs_point_t), intent(in) :: p
	phs_point_set%phs_point(i_phs) = p
	end subroutine phs_point_set_set_momenta_phs_point

	@ %def phs_point_set_set_momenta_phs_point
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_n_particles => phs_point_set_get_n_particles
	<<PHS fks: sub interfaces>>=
	module function phs_point_set_get_n_particles &
	(phs_point_set, i) result (n_particles)
	integer :: n_particles
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in), optional :: i
	end function phs_point_set_get_n_particles
	<<PHS fks: procedures>>=
	module function phs_point_set_get_n_particles &
	(phs_point_set, i) result (n_particles)
	integer :: n_particles
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in), optional :: i
	integer :: j
	j = 1; if (present (i)) j = i
	n_particles = size (phs_point_set%phs_point(j))
	end function phs_point_set_get_n_particles

	@ %def phs_point_set_get_n_particles
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_n_phs => phs_point_set_get_n_phs
	<<PHS fks: sub interfaces>>=
	module function phs_point_set_get_n_phs (phs_point_set) result (n_phs)
	integer :: n_phs
	class(phs_point_set_t), intent(in) :: phs_point_set
	end function phs_point_set_get_n_phs
	<<PHS fks: procedures>>=
	module function phs_point_set_get_n_phs (phs_point_set) result (n_phs)
	integer :: n_phs
	class(phs_point_set_t), intent(in) :: phs_point_set
	n_phs = size (phs_point_set%phs_point)
	end function phs_point_set_get_n_phs

	@ %def phs_point_set_get_n_phs
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: get_invariant_mass => phs_point_set_get_invariant_mass
	<<PHS fks: sub interfaces>>=
	module function phs_point_set_get_invariant_mass &
	(phs_point_set, i_phs, i_part) result (m2)
	real(default) :: m2
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), dimension(:) :: i_part
	end function phs_point_set_get_invariant_mass
	<<PHS fks: procedures>>=
	module function phs_point_set_get_invariant_mass &
	(phs_point_set, i_phs, i_part) result (m2)
	real(default) :: m2
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), dimension(:) :: i_part
	m2 = phs_point_set%phs_point(i_phs)%get_msq (i_part)
	end function phs_point_set_get_invariant_mass

	@ %def phs_point_set_get_invariant_mass
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: write_phs_point => phs_point_set_write_phs_point
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, &
	unit, show_mass, testflag, check_conservation, ultra, n_in)
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_mass
	logical, intent(in), optional :: testflag, ultra
	logical, intent(in), optional :: check_conservation
	integer, intent(in), optional :: n_in
	end subroutine phs_point_set_write_phs_point
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, &
	unit, show_mass, testflag, check_conservation, ultra, n_in)
	class(phs_point_set_t), intent(in) :: phs_point_set
	integer, intent(in) :: i_phs
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_mass
	logical, intent(in), optional :: testflag, ultra
	logical, intent(in), optional :: check_conservation
	integer, intent(in), optional :: n_in
	call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, &
	check_conservation, ultra, n_in)
	end subroutine phs_point_set_write_phs_point

	@ %def phs_point_set_write_phs_point
	@
	<<PHS fks: phs point set: TBP>>=
	procedure :: final => phs_point_set_final
	<<PHS fks: sub interfaces>>=
	module subroutine phs_point_set_final (phs_point_set)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	end subroutine phs_point_set_final
	<<PHS fks: procedures>>=
	module subroutine phs_point_set_final (phs_point_set)
	class(phs_point_set_t), intent(inout) :: phs_point_set
	integer :: i
	deallocate (phs_point_set%phs_point)
	phs_point_set%initialized = .false.
	end subroutine phs_point_set_final

	@ %def phs_point_set_final
	@
	<<PHS fks: public>>=
	public :: real_jacobian_t
	<<PHS fks: types>>=
	type :: real_jacobian_t
	real(default), dimension(4) :: jac = 1._default
	end type real_jacobian_t

	@ %def real_jacobian_t
	@
	<<PHS fks: public>>=
	public :: real_kinematics_t
	<<PHS fks: types>>=
	type :: real_kinematics_t
	logical :: supply_xi_max = .true.
	real(default) :: xi_tilde
	real(default) :: phi
	real(default), dimension(:), allocatable :: xi_max, y
	real(default) :: xi_mismatch, y_mismatch
	type(real_jacobian_t), dimension(:), allocatable :: jac
	real(default) :: jac_mismatch
	type(phs_point_set_t) :: p_born_cms
	type(phs_point_set_t) :: p_born_lab
	type(phs_point_set_t) :: p_real_cms
	type(phs_point_set_t) :: p_real_lab
	type(phs_point_set_t) :: p_born_onshell
	type(phs_point_set_t), dimension(2) :: p_real_onshell
	integer, dimension(:), allocatable :: alr_to_i_phs
	real(default), dimension(3) :: x_rad
	real(default), dimension(:), allocatable :: jac_rand
	real(default), dimension(:), allocatable :: y_soft
	real(default) :: cms_energy2
	type(vector4_t), dimension(:), allocatable :: xi_ref_momenta
	contains
	<<PHS fks: real kinematics: TBP>>
	end type real_kinematics_t

	@ %def real_kinematics_t
	@
	<<PHS fks: real kinematics: TBP>>=
	procedure :: init => real_kinematics_init
	<<PHS fks: sub interfaces>>=
	module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: n_tot, n_phs, n_alr, n_contr
	end subroutine real_kinematics_init
	<<PHS fks: procedures>>=
	module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: n_tot, n_phs, n_alr, n_contr
	allocate (r%xi_max (n_phs))
	allocate (r%y (n_phs))
	allocate (r%y_soft (n_phs))
	call r%p_born_cms%init (n_tot - 1, 1)
	call r%p_born_lab%init (n_tot - 1, 1)
	call r%p_real_cms%init (n_tot, n_phs)
	call r%p_real_lab%init (n_tot, n_phs)
	allocate (r%jac (n_phs), r%jac_rand (n_phs))
	allocate (r%alr_to_i_phs (n_alr))
	allocate (r%xi_ref_momenta (n_contr))
	r%alr_to_i_phs = 0
	r%xi_tilde = zero; r%xi_mismatch = zero
	r%xi_max = zero
	r%y = zero; r%y_mismatch = zero
	r%y_soft = zero
	r%phi = zero
	r%cms_energy2 = zero
	r%xi_ref_momenta = vector4_null
	r%jac_mismatch = one
	r%jac_rand = one
	end subroutine real_kinematics_init

	@ %def real_kinematics_init
	@
	<<PHS fks: real kinematics: TBP>>=
	procedure :: init_onshell => real_kinematics_init_onshell
	<<PHS fks: sub interfaces>>=
	module subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: n_tot, n_phs
	end subroutine real_kinematics_init_onshell
	<<PHS fks: procedures>>=
	module subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: n_tot, n_phs
	call r%p_born_onshell%init (n_tot - 1, 1)
	call r%p_real_onshell(1)%init (n_tot, n_phs)
	call r%p_real_onshell(2)%init (n_tot, n_phs)
	end subroutine real_kinematics_init_onshell

	@ %def real_kinematics_init_onshell
	@
	<<PHS fks: real kinematics: TBP>>=
	procedure :: write => real_kinematics_write
	<<PHS fks: sub interfaces>>=
	module subroutine real_kinematics_write (r, unit)
	class(real_kinematics_t), intent(in) :: r
	integer, intent(in), optional :: unit
	end subroutine real_kinematics_write
	<<PHS fks: procedures>>=
	module subroutine real_kinematics_write (r, unit)
	class(real_kinematics_t), intent(in) :: r
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u,"(A)") "Real kinematics: "
	write (u,"(A," // FMT_17 // ",1X)") "xi_tilde: ", r%xi_tilde
	write (u,"(A," // FMT_17 // ",1X)") "phi: ", r%phi
	do i = 1, size (r%xi_max)
	write (u,"(A,I1,1X)") "i_phs: ", i
	write (u,"(A," // FMT_17 // ",1X)") "xi_max: ", r%xi_max(i)
	write (u,"(A," // FMT_17 // ",1X)") "y: ", r%y(i)
	write (u,"(A," // FMT_17 // ",1X)") "jac_rand: ", r%jac_rand(i)
	write (u,"(A," // FMT_17 // ",1X)") "y_soft: ", r%y_soft(i)
	end do
	write (u, "(A)") "Born Momenta: "
	write (u, "(A)") "CMS: "
	call r%p_born_cms%write (unit = u)
	write (u, "(A)") "Lab: "
	call r%p_born_lab%write (unit = u)
	write (u, "(A)") "Real Momenta: "
	write (u, "(A)") "CMS: "
	call r%p_real_cms%write (unit = u)
	write (u, "(A)") "Lab: "
	call r%p_real_lab%write (unit = u)
	end subroutine real_kinematics_write

	@ %def real_kinematics_write
	@ The boost to the center-of-mass system only has a reasonable meaning
	above the threshold. Below the threshold, we do not apply boost at all, so
	that the top quarks stay in the rest frame. However, with top quarks exactly
	at rest, problems arise in the matrix elements (e.g. in the computation
	of angles). Therefore, we apply a boost which is not exactly 1, but has a
	tiny value differing from that.
	<<PHS fks: public>>=
	public :: get_boost_for_threshold_projection
	<<PHS fks: sub interfaces>>=
	module function get_boost_for_threshold_projection &
	(p, sqrts, mtop) result (L)
	type(lorentz_transformation_t) :: L
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(in) :: sqrts, mtop
	end function get_boost_for_threshold_projection
	<<PHS fks: procedures>>=
	module function get_boost_for_threshold_projection &
	(p, sqrts, mtop) result (L)
	type(lorentz_transformation_t) :: L
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(in) :: sqrts, mtop
	type(vector4_t) :: p_tmp
	type(vector3_t) :: dir
	real(default) :: scale_factor, arg
	p_tmp = p(THR_POS_WP) + p(THR_POS_B)
	arg = sqrts*2 - four mtop**2
	if (arg > zero) then
	scale_factor = sqrt (arg) / two
	else
	scale_factor = tiny_07*1000
	end if
	dir = scale_factor * create_unit_vector (p_tmp)
	p_tmp = [sqrts / two, dir%p]
	L = boost (p_tmp, mtop)
	end function get_boost_for_threshold_projection

	@ %def get_boost_for_threshold_projection
	-@ This routine recomputes the value of $\phi$ used to generate the real phase space.
	-<<PHS fks: procedures>>=
	- function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi)
	- real(default) :: phi
	- type(vector4_t), intent(in), dimension(:) :: p_born, p_real
	- integer, intent(in) :: emitter, i_gluon
	- type(vector4_t) :: p1, p2, pp
	- type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z
	- type(vector3_t) :: dir, z
	- real(default) :: cpsi
	- pp = p_real(emitter) + p_real(i_gluon)
	- cpsi = (space_part_norm (pp)2 - space_part_norm (p_real(emitter))2 &
	- + space_part_norm (p_real(i_gluon))**2) / &
	- (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon)))
	- dir = create_orthogonal (space_part (p_born(emitter)))
	- rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir)
	- pp = rot_to_gluon * p_born(emitter)
	- z%p = [0._default, 0._default, 1._default]
	- rot_to_z = rotation_to_2nd &
	- (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z)
	- p1 = rot_to_z * pp / space_part_norm (pp)
	- p2 = rot_to_z * p_real(i_gluon)
	- phi = azimuthal_distance (p1, p2)
	- if (phi < zero) phi = twopi - abs(phi)
	- end function get_generation_phi
	-
	-@ %def get_generation_phi
	@
	<<PHS fks: real kinematics: TBP>>=
	procedure :: apply_threshold_projection_real => &
	real_kinematics_apply_threshold_projection_real
	<<PHS fks: sub interfaces>>=
	module subroutine real_kinematics_apply_threshold_projection_real &
	(r, i_phs, mtop, L_to_cms, invert)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: i_phs
	real(default), intent(in) :: mtop
	type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms
	logical, intent(in) :: invert
	end subroutine real_kinematics_apply_threshold_projection_real
	<<PHS fks: procedures>>=
	module subroutine real_kinematics_apply_threshold_projection_real &
	(r, i_phs, mtop, L_to_cms, invert)
	class(real_kinematics_t), intent(inout) :: r
	integer, intent(in) :: i_phs
	real(default), intent(in) :: mtop
	type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms
	logical, intent(in) :: invert
	integer :: leg, other_leg
	type(vector4_t), dimension(:), allocatable :: p_real
	type(vector4_t), dimension(:), allocatable :: p_real_onshell
	type(vector4_t), dimension(4) :: k_tmp
	type(vector4_t), dimension(4) :: k_decay_onshell_real
	type(vector4_t), dimension(3) :: k_decay_onshell_born
	do leg = 1, 2
	other_leg = 3 - leg
	p_real = r%p_real_cms%phs_point(i_phs)
	allocate (p_real_onshell (size (p_real)))
	p_real_onshell(1:2) = p_real(1:2)
	k_tmp(1) = p_real(7)
	k_tmp(2) = p_real(ass_quark(leg))
	k_tmp(3) = p_real(ass_boson(leg))
	k_tmp(4) = [mtop, zero, zero, zero]
	call generate_on_shell_decay_threshold (k_tmp(1:3), &
	k_tmp(4), k_decay_onshell_real (2:4))
	k_decay_onshell_real (1) = k_tmp(4)
	k_tmp(1) = p_real(ass_quark(other_leg))
	k_tmp(2) = p_real(ass_boson(other_leg))
	k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2))
	p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2)
	p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3)
	p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4)
	p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2)
	p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3)
	if (invert) then
	call vector4_invert_direction (p_real_onshell (ass_quark(other_leg)))
	call vector4_invert_direction (p_real_onshell (ass_boson(other_leg)))
	end if
	r%p_real_onshell(leg)%phs_point(i_phs) = p_real_onshell
	deallocate (p_real_onshell)
	end do
	end subroutine real_kinematics_apply_threshold_projection_real

	@ %def real_kinematics_apply_threshold_projection_real
	@
	<<PHS fks: public>>=
	public :: threshold_projection_born
	<<PHS fks: sub interfaces>>=
	module subroutine threshold_projection_born &
	(mtop, L_to_cms, p_in, p_onshell)
	real(default), intent(in) :: mtop
	type(lorentz_transformation_t), intent(in) :: L_to_cms
	type(vector4_t), intent(in), dimension(:) :: p_in
	type(vector4_t), intent(out), dimension(:) :: p_onshell
	end subroutine threshold_projection_born
	<<PHS fks: procedures>>=
	module subroutine threshold_projection_born &
	(mtop, L_to_cms, p_in, p_onshell)
	real(default), intent(in) :: mtop
	type(lorentz_transformation_t), intent(in) :: L_to_cms
	type(vector4_t), intent(in), dimension(:) :: p_in
	type(vector4_t), intent(out), dimension(:) :: p_onshell
	type(vector4_t), dimension(3) :: k_decay_onshell
	type(vector4_t) :: p_tmp_1, p_tmp_2
	type(lorentz_transformation_t) :: L_to_cms_inv
	p_onshell(1:2) = p_in(1:2)
	L_to_cms_inv = inverse (L_to_cms)
	p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B)
	p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP)
	k_decay_onshell = create_two_particle_decay (mtop**2, &
	p_tmp_1, p_tmp_2)
	p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3])
	p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR)
	p_tmp_2 = L_to_cms * p_in(THR_POS_WM)
	k_decay_onshell = create_two_particle_decay (mtop**2, &
	p_tmp_1, p_tmp_2)
	p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3])
	p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B])
	p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR])
	end subroutine threshold_projection_born

	@ %def threshold_projection_born
	@ This routine computes the bounds of the Dalitz region for massive emitters.
	The corresponding derivation can be found in [[1202.0465]], App. A.
	It is also used for the POWHEG matching so the routine is public.
	The input parameter [[m2]] corresponds to the squared mass of the emitter.
	<<PHS fks: public>>=
	public :: compute_dalitz_bounds
	<<PHS fks: sub interfaces>>=
	pure module subroutine compute_dalitz_bounds &
	(q0, m2, mrec2, z1, z2, k0_rec_max)
	real(default), intent(in) :: q0, m2, mrec2
	real(default), intent(out) :: z1, z2, k0_rec_max
	end subroutine compute_dalitz_bounds
	<<PHS fks: procedures>>=
	pure module subroutine compute_dalitz_bounds &
	(q0, m2, mrec2, z1, z2, k0_rec_max)
	real(default), intent(in) :: q0, m2, mrec2
	real(default), intent(out) :: z1, z2, k0_rec_max
	k0_rec_max = (q0*2 - m2 + mrec2) / (two q0)
	z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0
	z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0
	end subroutine compute_dalitz_bounds

	@ %def compute_dalitz_bounds
	@ Compute the [[kt2]] of a given emitter
	<<PHS fks: real kinematics: TBP>>=
	procedure :: kt2 => real_kinematics_kt2
	<<PHS fks: sub interfaces>>=
	module function real_kinematics_kt2 &
	(real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2)
	real(default) :: kt2
	class(real_kinematics_t), intent(in) :: real_kinematics
	integer, intent(in) :: emitter, i_phs, kt2_type
	real(default), intent(in), optional :: xi, y
	end function real_kinematics_kt2
	<<PHS fks: procedures>>=
	module function real_kinematics_kt2 &
	(real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2)
	real(default) :: kt2
	class(real_kinematics_t), intent(in) :: real_kinematics
	integer, intent(in) :: emitter, i_phs, kt2_type
	real(default), intent(in), optional :: xi, y
	real(default) :: xii, yy
	real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max
	type(vector4_t) :: p_emitter
	if (present (y)) then
	yy = y
	else
	yy = real_kinematics%y (i_phs)
	end if
	if (present (xi)) then
	xii = xi
	else
	xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs)
	end if
	select case (kt2_type)
	case (UBF_FSR_SIMPLE)
	kt2 = real_kinematics%cms_energy2 / two * xii*2 (1 - yy)
	case (UBF_FSR_MASSIVE)
	q = sqrt (real_kinematics%cms_energy2)
	p_emitter = real_kinematics%p_born_cms%phs_point(1)%select (emitter)
	mrec2 = (q - p_emitter%p(0))2 - sum (p_emitter%p(1:3)2)
	m2 = p_emitter**2
	E_em = energy (p_emitter)
	call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max)
	z = z2 - (z2 - z1) * (one + yy) / two
	kt2 = xii*2 q*3 (one - z) / &
	(two * E_em - z * xii * q)
	case (UBF_FSR_MASSLESS_RECOIL)
	kt2 = real_kinematics%cms_energy2 / two * xii*2 (1 - yy**2) / two
	case (UBF_ISR)
	kt2 = real_kinematics%cms_energy2 / four * xii*2 (1 - yy**2) / (1 - xii)
	case default
	kt2 = zero
	call msg_bug ("kt2_type must be set to a known value")
	end select
	end function real_kinematics_kt2

	@ %def real_kinematics_kt2
	@ These are the possible values for [[upper_bound_func_type]] and will be
	used to decide which UBF object is allocated and which $K_T$ scale for the
	matching is computed.
	<<PHS fks: parameters>>=
	integer, parameter, public :: UBF_FSR_SIMPLE = 1
	integer, parameter, public :: UBF_FSR_MASSIVE = 2
	integer, parameter, public :: UBF_FSR_MASSLESS_RECOIL = 3
	integer, parameter, public :: UBF_ISR = 4
	@ %def UBF_FSR_SIMPLE UBF_FSR_MASSIVE UBF_FSR_MASSLESS_RECOIL UBF_ISR
	@
	<<PHS fks: real kinematics: TBP>>=
	procedure :: final => real_kinematics_final
	<<PHS fks: sub interfaces>>=
	module subroutine real_kinematics_final (real_kin)
	class(real_kinematics_t), intent(inout) :: real_kin
	end subroutine real_kinematics_final
	<<PHS fks: procedures>>=
	module subroutine real_kinematics_final (real_kin)
	class(real_kinematics_t), intent(inout) :: real_kin
	if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max)
	if (allocated (real_kin%y)) deallocate (real_kin%y)
	if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs)
	if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand)
	if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft)
	if (allocated (real_kin%xi_ref_momenta)) &
	deallocate (real_kin%xi_ref_momenta)
	call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final ()
	call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final ()
	end subroutine real_kinematics_final

	@ %def real_kinematics_final
	@
	<<PHS fks: parameters>>=
	integer, parameter, public :: I_XI = 1
	integer, parameter, public :: I_Y = 2
	integer, parameter, public :: I_PHI = 3

	integer, parameter, public :: PHS_MODE_UNDEFINED = 0
	integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1
	integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2

	@ %def parameters
	@
	<<PHS fks: public>>=
	public :: phs_fks_config_t
	<<PHS fks: types>>=
	type, extends (phs_wood_config_t) :: phs_fks_config_t
	integer :: mode = PHS_MODE_UNDEFINED
	character(32) :: md5sum_born_config
	logical :: born_2_to_1 = .false.
	logical :: make_dalitz_plot = .false.
	contains
	<<PHS fks: fks config: TBP>>
	end type phs_fks_config_t

	@ %def phs_fks_config_t
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: clear_phase_space => fks_config_clear_phase_space
	<<PHS fks: sub interfaces>>=
	module subroutine fks_config_clear_phase_space (phs_config)
	class(phs_fks_config_t), intent(inout) :: phs_config
	end subroutine fks_config_clear_phase_space
	<<PHS fks: procedures>>=
	module subroutine fks_config_clear_phase_space (phs_config)
	class(phs_fks_config_t), intent(inout) :: phs_config
	end subroutine fks_config_clear_phase_space

	@ %def fks_config_clear_phase_space
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: write => phs_fks_config_write
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_write (object, unit, include_id)
	class(phs_fks_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	end subroutine phs_fks_config_write
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_write (object, unit, include_id)
	class(phs_fks_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: include_id
	integer :: u
	u = given_output_unit (unit)
	call object%phs_wood_config_t%write (u)
	write (u, "(3x,A,I0)") "NLO mode = ", object%mode
	write (u, "(3x,A,L1)") "2->1 proc = ", object%born_2_to_1
	write (u, "(3x,A,L1)") "Dalitz = ", object%make_dalitz_plot
	write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config
	end subroutine phs_fks_config_write

	@ %def phs_fks_config_write
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: set_mode => phs_fks_config_set_mode
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_set_mode (phs_config, mode)
	class(phs_fks_config_t), intent(inout) :: phs_config
	integer, intent(in) :: mode
	end subroutine phs_fks_config_set_mode
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_set_mode (phs_config, mode)
	class(phs_fks_config_t), intent(inout) :: phs_config
	integer, intent(in) :: mode
	select case (mode)
	case (NLO_REAL, NLO_MISMATCH)
	phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE
	case (NLO_DGLAP)
	phs_config%mode = PHS_MODE_COLLINEAR_REMNANT
	end select
	end subroutine phs_fks_config_set_mode

	@ %def phs_fks_config_set_mod
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: configure => phs_fks_config_configure
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_fks_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	end subroutine phs_fks_config_configure
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_configure (phs_config, sqrts, &
	sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
	ignore_mismatch, nlo_type, subdir)
	class(phs_fks_config_t), intent(inout) :: phs_config
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: sqrts_fixed
	logical, intent(in), optional :: lab_is_cm
	logical, intent(in), optional :: azimuthal_dependence
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: subdir
	if (present (nlo_type)) phs_config%nlo_type = nlo_type
	if (.not. phs_config%is_combined_integration) then
	select case (phs_config%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	phs_config%n_par = phs_config%n_par + 3
	if (phs_config%nlo_type == NLO_REAL .and. phs_config%n_out == 2) then
	phs_config%born_2_to_1 = .true.
	end if
	case (PHS_MODE_COLLINEAR_REMNANT)
	phs_config%n_par = phs_config%n_par + 1
	end select
	end if
	call phs_config%compute_md5sum ()
	end subroutine phs_fks_config_configure

	@ %def phs_fks_config_configure
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: startup_message => phs_fks_config_startup_message
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_startup_message (phs_config, unit)
	class(phs_fks_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	end subroutine phs_fks_config_startup_message
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_startup_message (phs_config, unit)
	class(phs_fks_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	call phs_config%phs_wood_config_t%startup_message (unit)
	end subroutine phs_fks_config_startup_message

	@ %def phs_fks_config_startup_message
	@ Gfortran 7/8/9 bug, has to remain in the main module:
	<<PHS fks: fks config: TBP>>=
	procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance
	<<PHS fks: main procedures>>=
	subroutine phs_fks_config_allocate_instance (phs)
	class(phs_t), intent(inout), pointer :: phs
	allocate (phs_fks_t :: phs)
	end subroutine phs_fks_config_allocate_instance

	@ %def phs_fks_config_allocate_instance
	@ If the phase space is generated from file, but we want to have resonance
	histories, we must force the cascade sets to be generated. However, it must
	be assured that Born flavors are used for this.
	<<PHS fks: fks config: TBP>>=
	procedure :: generate_phase_space_extra => &
	phs_fks_config_generate_phase_space_extra
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_generate_phase_space_extra (phs_config)
	class(phs_fks_config_t), intent(inout) :: phs_config
	end subroutine phs_fks_config_generate_phase_space_extra
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_generate_phase_space_extra (phs_config)
	class(phs_fks_config_t), intent(inout) :: phs_config
	integer :: off_shell, extra_off_shell
	type(flavor_t), dimension(:,:), allocatable :: flv_born
	integer :: i, j
	integer :: n_state, n_flv_born
	integer :: unit_fds
	logical :: valid
	type(string_t) :: file_name
	logical :: file_exists
	if (phs_config%use_cascades2) then
	allocate (phs_config%feyngraph_set)
	else
	allocate (phs_config%cascade_set)
	end if
	n_flv_born = size (phs_config%flv, 1) - 1
	n_state = size (phs_config%flv, 2)
	allocate (flv_born (n_flv_born, n_state))
	do i = 1, n_flv_born
	do j = 1, n_state
	flv_born(i, j) = phs_config%flv(i, j)
	end do
	end do
	if (phs_config%use_cascades2) then
	file_name = char (phs_config%id) // ".fds"
	inquire (file=char (file_name), exist=file_exists)
	if (.not. file_exists) call msg_fatal &
	("The O'Mega input file " // char (file_name) // &
	" does not exist. " // "Please make sure that the " // &
	"variable ?omega_write_phs_output has been set correctly.")
	unit_fds = free_unit ()
	open (unit=unit_fds, file=char(file_name), status='old', action='read')
	end if
	off_shell = phs_config%par%off_shell
	do extra_off_shell = 0, max (n_flv_born - 2, 0)
	phs_config%par%off_shell = off_shell + extra_off_shell
	if (phs_config%use_cascades2) then
	call feyngraph_set_generate (phs_config%feyngraph_set, &
	phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
	flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
	phs_config%vis_channels)
	if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit
	else
	call cascade_set_generate (phs_config%cascade_set, &
	phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
	flv_born, phs_config%par, phs_config%fatal_beam_decay)
	if (cascade_set_is_valid (phs_config%cascade_set)) exit
	end if
	end do
	if (phs_config%use_cascades2) then
	close (unit_fds)
	valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
	else
	valid = cascade_set_is_valid (phs_config%cascade_set)
	end if
	if (.not. valid) &
	call msg_fatal ("Resonance extraction: Phase space generation failed")
	end subroutine phs_fks_config_generate_phase_space_extra

	@ %def phs_fks_config_generate_phase_space_extra
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: set_born_config => phs_fks_config_set_born_config
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born)
	class(phs_fks_config_t), intent(inout) :: phs_config
	type(phs_wood_config_t), intent(in), target :: phs_cfg_born
	end subroutine phs_fks_config_set_born_config
	<<PHS fks: procedures>>=
	module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born)
	class(phs_fks_config_t), intent(inout) :: phs_config
	type(phs_wood_config_t), intent(in), target :: phs_cfg_born
	if (debug_on) &
	call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config")
	phs_config%forest = phs_cfg_born%forest
	phs_config%n_channel = phs_cfg_born%n_channel
	allocate (phs_config%channel (phs_config%n_channel))
	phs_config%channel = phs_cfg_born%channel
	phs_config%n_par = phs_cfg_born%n_par
	phs_config%n_state = phs_cfg_born%n_state
	phs_config%sqrts = phs_cfg_born%sqrts
	phs_config%par = phs_cfg_born%par
	phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed
	phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence
	phs_config%provides_chains = phs_cfg_born%provides_chains
	phs_config%lab_is_cm = phs_cfg_born%lab_is_cm
	phs_config%vis_channels = phs_cfg_born%vis_channels
	phs_config%provides_equivalences = phs_cfg_born%provides_equivalences
	allocate (phs_config%chain (size (phs_cfg_born%chain)))
	phs_config%chain = phs_cfg_born%chain
	phs_config%model => phs_cfg_born%model
	phs_config%use_cascades2 = phs_cfg_born%use_cascades2
	if (allocated (phs_cfg_born%cascade_set)) then
	allocate (phs_config%cascade_set)
	phs_config%cascade_set = phs_cfg_born%cascade_set
	end if
	if (allocated (phs_cfg_born%feyngraph_set)) then
	allocate (phs_config%feyngraph_set)
	phs_config%feyngraph_set = phs_cfg_born%feyngraph_set
	end if
	phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config
	end subroutine phs_fks_config_set_born_config

	@ %def phs_fks_config_set_born_config
	@
	<<PHS fks: fks config: TBP>>=
	procedure :: get_resonance_histories => &
	phs_fks_config_get_resonance_histories
	<<PHS fks: sub interfaces>>=
	module function phs_fks_config_get_resonance_histories &
	(phs_config) result (resonance_histories)
	type(resonance_history_t), dimension(:), allocatable :: &
	resonance_histories
	class(phs_fks_config_t), intent(inout) :: phs_config
	end function phs_fks_config_get_resonance_histories
	<<PHS fks: procedures>>=
	module function phs_fks_config_get_resonance_histories &
	(phs_config) result (resonance_histories)
	type(resonance_history_t), dimension(:), allocatable :: resonance_histories
	class(phs_fks_config_t), intent(inout) :: phs_config
	if (allocated (phs_config%cascade_set)) then
	call cascade_set_get_resonance_histories (phs_config%cascade_set, &
	n_filter = 2, res_hists = resonance_histories)
	else if (allocated (phs_config%feyngraph_set)) then
	call feyngraph_set_get_resonance_histories (phs_config%feyngraph_set, &
	n_filter = 2, res_hists = resonance_histories)
	else
	if (debug_on) call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories")
	call phs_config%generate_phase_space_extra ()
	if (phs_config%use_cascades2) then
	call feyngraph_set_get_resonance_histories &
	(phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories)
	else
	call cascade_set_get_resonance_histories &
	(phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories)
	end if
	end if
	end function phs_fks_config_get_resonance_histories

	@ %def phs_fks_config_get_resonance_histories
	@
	<<PHS fks: public>>=
	public :: dalitz_plot_t
	<<PHS fks: types>>=
	type :: dalitz_plot_t
	integer :: unit = -1
	type(string_t) :: filename
	logical :: active = .false.
	logical :: inverse = .false.
	contains
	<<PHS fks: dalitz plot: TBP>>
	end type dalitz_plot_t

	@ %def dalitz_plot_t
	@
	<<PHS fks: dalitz plot: TBP>>=
	procedure :: init => dalitz_plot_init
	<<PHS fks: sub interfaces>>=
	module subroutine dalitz_plot_init (plot, unit, filename, inverse)
	class(dalitz_plot_t), intent(inout) :: plot
	integer, intent(in) :: unit
	type(string_t), intent(in) :: filename
	logical, intent(in) :: inverse
	end subroutine dalitz_plot_init
	<<PHS fks: procedures>>=
	module subroutine dalitz_plot_init (plot, unit, filename, inverse)
	class(dalitz_plot_t), intent(inout) :: plot
	integer, intent(in) :: unit
	type(string_t), intent(in) :: filename
	logical, intent(in) :: inverse
	plot%active = .true.
	plot%unit = unit
	plot%inverse = inverse
	open (plot%unit, file = char (filename), action = "write")
	end subroutine dalitz_plot_init

	@ %def daltiz_plot_init
	@
	<<PHS fks: dalitz plot: TBP>>=
	procedure :: write_header => dalitz_plot_write_header
	<<PHS fks: sub interfaces>>=
	module subroutine dalitz_plot_write_header (plot)
	class(dalitz_plot_t), intent(in) :: plot
	end subroutine dalitz_plot_write_header
	<<PHS fks: procedures>>=
	module subroutine dalitz_plot_write_header (plot)
	class(dalitz_plot_t), intent(in) :: plot
	write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD"
	if (plot%inverse) then
	write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n"
	else
	write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1"
	end if
	end subroutine dalitz_plot_write_header

	@ %def dalitz_plot_write_header
	@
	<<PHS fks: dalitz plot: TBP>>=
	procedure :: register => dalitz_plot_register
	<<PHS fks: sub interfaces>>=
	module subroutine dalitz_plot_register (plot, k0_n, k0_np1)
	class(dalitz_plot_t), intent(in) :: plot
	real(default), intent(in) :: k0_n, k0_np1
	end subroutine dalitz_plot_register
	<<PHS fks: procedures>>=
	module subroutine dalitz_plot_register (plot, k0_n, k0_np1)
	class(dalitz_plot_t), intent(in) :: plot
	real(default), intent(in) :: k0_n, k0_np1
	if (plot%inverse) then
	write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
	else
	write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
	end if
	end subroutine dalitz_plot_register

	@ %def dalitz_plot_register
	@
	<<PHS fks: dalitz plot: TBP>>=
	procedure :: final => dalitz_plot_final
	<<PHS fks: sub interfaces>>=
	module subroutine dalitz_plot_final (plot)
	class(dalitz_plot_t), intent(inout) :: plot
	end subroutine dalitz_plot_final
	<<PHS fks: procedures>>=
	module subroutine dalitz_plot_final (plot)
	class(dalitz_plot_t), intent(inout) :: plot
	logical :: opened
	plot%active = .false.
	plot%inverse = .false.
	if (plot%unit >= 0) then
	inquire (unit = plot%unit, opened = opened)
	if (opened) close (plot%unit)
	end if
	plot%filename = var_str ('')
	plot%unit = -1
	end subroutine dalitz_plot_final

	@ %def dalitz_plot_final
	@
	<<PHS fks: parameters>>=
	integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1
	integer, parameter, public :: GEN_SOFT_MISMATCH = 2
	integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3
	integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4
	integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5
	integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6
	integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7

	integer, parameter, public :: SQRTS_FIXED = 1
	integer, parameter, public :: SQRTS_VAR = 2

	real(default), parameter :: xi_tilde_test_soft = 0.00001_default
	real(default), parameter :: xi_tilde_test_coll = 0.5_default
	real(default), parameter :: y_test_soft = 0.5_default
	real(default), parameter :: y_test_coll = 0.9999999_default
	!!! for testing EW singularities: y_test_coll = 0.99999999_default

	@
	@ Very soft or collinear phase-space points can become a problem for
	matrix elements providers, as some scalar products cannot be evaluated
	properly. Here, a nonsensical result can spoil the whole integration.
	We therefore check the scalar products appearing to be below a certain
	tolerance.\\
	Naturally, this happens very rarely but for some processes,
	setting [[?test_coll_limit = true]] and/or [[?test_soft_limit = true]]
	leads to all phase space points beeing discarded by this routine.
	<<PHS fks: public>>=
	public :: check_scalar_products
	<<PHS fks: sub interfaces>>=
	module function check_scalar_products (p) result (valid)
	logical :: valid
	type(vector4_t), intent(in), dimension(:) :: p
	end function check_scalar_products
	<<PHS fks: procedures>>=
	module function check_scalar_products (p) result (valid)
	logical :: valid
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), parameter :: tolerance = 1E-7_default
	!!! for testing EW singularities: tolerance = 5E-9_default
	integer :: i, j
	valid = .true.
	do i = 1, size (p)
	do j = i, size (p)
	if (i /= j) then
	if (abs(p(i) * p(j)) < tolerance) then
	valid = .false.
	exit
	end if
	end if
	end do
	end do
	end function check_scalar_products

	@ %def check_scalar_products
	@ [[xi_min]] should be set to a non-zero value in order to avoid
	phase-space points with [[p_real(emitter) = 0]].
	<<PHS fks: public>>=
	public :: phs_fks_generator_t
	<<PHS fks: types>>=
	type :: phs_fks_generator_t
	integer, dimension(:), allocatable :: emitters
	type(real_kinematics_t), pointer :: real_kinematics => null()
	type(isr_kinematics_t), pointer :: isr_kinematics => null()
	integer :: n_in
	real(default) :: xi_min
	real(default) :: y_max
	real(default) :: sqrts
	real(default) :: E_gluon
	real(default) :: mrec2
	real(default), dimension(:), allocatable :: m2
	logical :: massive_phsp = .false.
	logical, dimension(:), allocatable :: is_massive
	logical :: singular_jacobian = .false.
	integer :: i_fsr_first = -1
	type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else?
	integer :: mode = GEN_REAL_PHASE_SPACE
	contains
	<<PHS fks: phs fks generator: TBP>>
	end type phs_fks_generator_t

	@ %def phs_fks_generator_t
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: connect_kinematics => phs_fks_generator_connect_kinematics
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_connect_kinematics &
	(generator, isr_kinematics, real_kinematics, massive_phsp)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(isr_kinematics_t), intent(in), pointer :: isr_kinematics
	type(real_kinematics_t), intent(in), pointer :: real_kinematics
	logical, intent(in) :: massive_phsp
	end subroutine phs_fks_generator_connect_kinematics
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_connect_kinematics &
	(generator, isr_kinematics, real_kinematics, massive_phsp)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(isr_kinematics_t), intent(in), pointer :: isr_kinematics
	type(real_kinematics_t), intent(in), pointer :: real_kinematics
	logical, intent(in) :: massive_phsp
	generator%real_kinematics => real_kinematics
	generator%isr_kinematics => isr_kinematics
	generator%massive_phsp = massive_phsp
	end subroutine phs_fks_generator_connect_kinematics

	@ %def phs_fks_generator_connect_kinematics
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_isr_kinematics => &
	phs_fks_generator_compute_isr_kinematics
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_isr_kinematics &
	(generator, r, p_in)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r
	type(vector4_t), dimension(2), intent(in), optional :: p_in
	end subroutine phs_fks_generator_compute_isr_kinematics
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_isr_kinematics &
	(generator, r, p_in)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r
	type(vector4_t), dimension(2), intent(in), optional :: p_in
	integer :: em
	type(vector4_t), dimension(2) :: p

	if (present (p_in)) then
	p = p_in
	else
	p = generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2])
	end if

	associate (isr_kinematics => generator%isr_kinematics)
	do em = 1, 2
	isr_kinematics%x(em) = p(em)%p(0) / isr_kinematics%beam_energy(em)
	isr_kinematics%z(em) = one - (one - isr_kinematics%x(em)) * r
	isr_kinematics%jacobian(em) = one - isr_kinematics%x(em)
	end do
	isr_kinematics%sqrts_born = (p(1) + p(2))**1
	end associate
	end subroutine phs_fks_generator_compute_isr_kinematics

	@ %def phs_fks_generator_compute_isr_kinematics
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: final => phs_fks_generator_final
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_final (generator)
	class(phs_fks_generator_t), intent(inout) :: generator
	end subroutine phs_fks_generator_final
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_final (generator)
	class(phs_fks_generator_t), intent(inout) :: generator
	if (allocated (generator%emitters)) deallocate (generator%emitters)
	if (associated (generator%real_kinematics)) &
	nullify (generator%real_kinematics)
	if (associated (generator%isr_kinematics)) &
	nullify (generator%isr_kinematics)
	if (allocated (generator%m2)) deallocate (generator%m2)
	generator%massive_phsp = .false.
	if (allocated (generator%is_massive)) deallocate (generator%is_massive)
	generator%singular_jacobian = .false.
	generator%i_fsr_first = -1
	if (allocated (generator%resonance_contributors)) &
	deallocate (generator%resonance_contributors)
	generator%mode = GEN_REAL_PHASE_SPACE
	end subroutine phs_fks_generator_final

	@ %def phs_fks_generator_final
	@ A resonance phase space is uniquely specified via the resonance contributors and the
	corresponding emitters. The [[phs_identifier]] type also checks whether
	the given contributor-emitter configuration has already been evaluated to
	avoid duplicate computations.
	<<PHS fks: public>>=
	public :: phs_identifier_t
	<<PHS fks: types>>=
	type :: phs_identifier_t
	integer, dimension(:), allocatable :: contributors
	integer :: emitter = -1
	logical :: evaluated = .false.
	contains
	<<PHS fks: phs identifier: TBP>>
	end type phs_identifier_t

	@ %def phs_identifier_t
	@
	<<PHS fks: phs identifier: TBP>>=
	generic :: init => init_from_emitter, init_from_emitter_and_contributors
	procedure :: init_from_emitter => phs_identifier_init_from_emitter
	procedure :: init_from_emitter_and_contributors &
	=> phs_identifier_init_from_emitter_and_contributors
	<<PHS fks: sub interfaces>>=
	module subroutine phs_identifier_init_from_emitter (phs_id, emitter)
	class(phs_identifier_t), intent(out) :: phs_id
	integer, intent(in) :: emitter
	end subroutine phs_identifier_init_from_emitter
	module subroutine phs_identifier_init_from_emitter_and_contributors &
	(phs_id, emitter, contributors)
	class(phs_identifier_t), intent(out) :: phs_id
	integer, intent(in) :: emitter
	integer, intent(in), dimension(:) :: contributors
	end subroutine phs_identifier_init_from_emitter_and_contributors
	<<PHS fks: procedures>>=
	module subroutine phs_identifier_init_from_emitter (phs_id, emitter)
	class(phs_identifier_t), intent(out) :: phs_id
	integer, intent(in) :: emitter
	phs_id%emitter = emitter
	end subroutine phs_identifier_init_from_emitter

	module subroutine phs_identifier_init_from_emitter_and_contributors &
	(phs_id, emitter, contributors)
	class(phs_identifier_t), intent(out) :: phs_id
	integer, intent(in) :: emitter
	integer, intent(in), dimension(:) :: contributors
	allocate (phs_id%contributors (size (contributors)))
	phs_id%contributors = contributors
	phs_id%emitter = emitter
	end subroutine phs_identifier_init_from_emitter_and_contributors

	@ %def phs_identifier_init_from_emitter
	@ %def phs_identifier_init_from_emitter_and_contributors
	@
	<<PHS fks: phs identifier: TBP>>=
	procedure :: check => phs_identifier_check
	<<PHS fks: sub interfaces>>=
	module function phs_identifier_check &
	(phs_id, emitter, contributors) result (check)
	logical :: check
	class(phs_identifier_t), intent(in) :: phs_id
	integer, intent(in) :: emitter
	integer, intent(in), dimension(:), optional :: contributors
	end function phs_identifier_check
	<<PHS fks: procedures>>=
	module function phs_identifier_check &
	(phs_id, emitter, contributors) result (check)
	logical :: check
	class(phs_identifier_t), intent(in) :: phs_id
	integer, intent(in) :: emitter
	integer, intent(in), dimension(:), optional :: contributors
	check = phs_id%emitter == emitter
	if (present (contributors)) then
	if (.not. allocated (phs_id%contributors)) &
	call msg_fatal ("Phs identifier: contributors not allocated!")
	check = check .and. all (phs_id%contributors == contributors)
	end if
	end function phs_identifier_check

	@ %def phs_identifier_check
	@
	<<PHS fks: phs identifier: TBP>>=
	procedure :: write => phs_identifier_write
	<<PHS fks: sub interfaces>>=
	module subroutine phs_identifier_write (phs_id, unit)
	class(phs_identifier_t), intent(in) :: phs_id
	integer, intent(in), optional :: unit
	end subroutine phs_identifier_write
	<<PHS fks: procedures>>=
	module subroutine phs_identifier_write (phs_id, unit)
	class(phs_identifier_t), intent(in) :: phs_id
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, '(A)') 'phs_identifier: '
	write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter
	if (allocated (phs_id%contributors)) then
	write (u, '(A)', advance = 'no') 'Resonance contributors: '
	do i = 1, size (phs_id%contributors)
	write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i)
	end do
	else
	write (u, '(A)') 'No Contributors allocated'
	end if
	end subroutine phs_identifier_write

	@ %def phs_identifier_write
	@
	<<PHS fks: public>>=
	public :: check_for_phs_identifier
	<<PHS fks: sub interfaces>>=
	module subroutine check_for_phs_identifier &
	(phs_id, n_in, emitter, contributors, phs_exist, i_phs)
	type(phs_identifier_t), intent(in), dimension(:) :: phs_id
	integer, intent(in) :: n_in, emitter
	integer, intent(in), dimension(:), optional :: contributors
	logical, intent(out) :: phs_exist
	integer, intent(out) :: i_phs
	end subroutine check_for_phs_identifier
	<<PHS fks: procedures>>=
	module subroutine check_for_phs_identifier &
	(phs_id, n_in, emitter, contributors, phs_exist, i_phs)
	type(phs_identifier_t), intent(in), dimension(:) :: phs_id
	integer, intent(in) :: n_in, emitter
	integer, intent(in), dimension(:), optional :: contributors
	logical, intent(out) :: phs_exist
	integer, intent(out) :: i_phs
	integer :: i
	phs_exist = .false.
	i_phs = -1
	do i = 1, size (phs_id)
	if (phs_id(i)%emitter < 0) then
	i_phs = i
	exit
	end if
	phs_exist = phs_id(i)%emitter == emitter
	if (present (contributors)) &
	phs_exist = phs_exist .and. &
	all (phs_id(i)%contributors == contributors)
	if (phs_exist) then
	i_phs = i
	exit
	end if
	end do
	end subroutine check_for_phs_identifier

	@ %def check_for_phs_identifier
	@
	@ The fks phase space type contains the wood phase space and
	separately the in- and outcoming momenta for the real process and the
	corresponding Born momenta. Additionally, there are the variables
	$\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real
	phase space, as well as the jacobian and its corresponding soft and
	collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each
	channel with an emitter.
	<<PHS fks: public>>=
	public :: phs_fks_t
	<<PHS fks: types>>=
	type, extends (phs_wood_t) :: phs_fks_t
	integer :: mode = PHS_MODE_UNDEFINED
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: q_born
	type(vector4_t), dimension(:), allocatable :: p_real
	type(vector4_t), dimension(:), allocatable :: q_real
	type(vector4_t), dimension(:), allocatable :: p_born_tot
	type(phs_fks_generator_t) :: generator
	real(default) :: r_isr
	type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
	contains
	<<PHS fks: phs fks: TBP>>
	end type phs_fks_t

	@ %def phs_fks_t
	@
	<<PHS fks: interfaces>>=

	interface compute_beta
	module procedure compute_beta_massless
	module procedure compute_beta_massive
	end interface

	interface get_xi_max_fsr
	module procedure get_xi_max_fsr_massless
	module procedure get_xi_max_fsr_massive
	end interface

	@ %def interfaces
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: write => phs_fks_write
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_write (object, unit, verbose)
	class(phs_fks_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine phs_fks_write
	<<PHS fks: procedures>>=
	module subroutine phs_fks_write (object, unit, verbose)
	class(phs_fks_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i, n_id
	u = given_output_unit (unit)
	call object%base_write ()
	n_id = size (object%phs_identifiers)
	if (n_id == 0) then
	write (u, "(A)") "No phs identifiers allocated! "
	else
	do i = 1, n_id
	call object%phs_identifiers(i)%write (u)
	end do
	end if
	end subroutine phs_fks_write

	@ %def phs_fks_write
	@ Initializer for the phase space. Calls the initialization of the
	corresponding Born phase space, sets up the
	channel-emitter-association and allocates space for the momenta.
	<<PHS fks: phs fks: TBP>>=
	procedure :: init => phs_fks_init
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_init (phs, phs_config)
	class(phs_fks_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config
	end subroutine phs_fks_init
	<<PHS fks: procedures>>=
	module subroutine phs_fks_init (phs, phs_config)
	class(phs_fks_t), intent(out) :: phs
	class(phs_config_t), intent(in), target :: phs_config

	call phs%base_init (phs_config)
	select type (phs_config)
	type is (phs_fks_config_t)
	phs%config => phs_config
	phs%forest = phs_config%forest
	end select

	select type (phs)
	type is (phs_fks_t)
	select type (phs_config)
	type is (phs_fks_config_t)
	phs%mode = phs_config%mode
	end select

	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	phs%n_r_born = phs%config%n_par - 3
	case (PHS_MODE_COLLINEAR_REMNANT)
	phs%n_r_born = phs%config%n_par - 1
	end select
	end select
	end subroutine phs_fks_init

	@ %def phs_fks_init
	@ For real components of $2\to 1$ NLO processes we have to recompute the
	flux factor as this has to be the one of the underlying Born.
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_flux => phs_fks_compute_flux
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_flux (phs)
	class(phs_fks_t), intent(inout) :: phs
	end subroutine phs_fks_compute_flux
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_flux (phs)
	class(phs_fks_t), intent(inout) :: phs
	call phs%compute_base_flux ()
	select type (config => phs%config)
	type is (phs_fks_config_t)
	if (config%born_2_to_1) then
	phs%flux = conv * twopi &
	/ (2 * config%sqrts ** 2 * phs%m_out(1) ** 2)
	end if
	end select
	end subroutine phs_fks_compute_flux

	@ %def phs_fks_compute_flux
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: allocate_momenta => phs_fks_allocate_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born)
	class(phs_fks_t), intent(inout) :: phs
	class(phs_config_t), intent(in) :: phs_config
	logical, intent(in) :: data_is_born
	end subroutine phs_fks_allocate_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born)
	class(phs_fks_t), intent(inout) :: phs
	class(phs_config_t), intent(in) :: phs_config
	logical, intent(in) :: data_is_born
	integer :: n_out_born
	allocate (phs%p_born (phs_config%n_in))
	allocate (phs%p_real (phs_config%n_in))
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	if (data_is_born) then
	n_out_born = phs_config%n_out
	else
	n_out_born = phs_config%n_out - 1
	end if
	allocate (phs%q_born (n_out_born))
	allocate (phs%q_real (n_out_born + 1))
	allocate (phs%p_born_tot (phs_config%n_in + n_out_born))
	end select
	end subroutine phs_fks_allocate_momenta

	@ %def phs_fks_allocate_momenta
	@ Evaluate selected channel. First, the subroutine calls the
	evaluation procedure of the underlying Born phase space, using $n_r -
	3$ random numbers. Then, the remaining three random numbers are used
	to create $\xi$, $y$ and $\phi$, from which the real momenta are
	calculated from the Born momenta.
	<<PHS fks: phs fks: TBP>>=
	procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	end subroutine phs_fks_evaluate_selected_channel
	<<PHS fks: procedures>>=
	module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	real(default), intent(in), dimension(:) :: r_in
	integer :: n_in

	call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in)
	phs%r(:,c_in) = r_in

	phs%q_defined = phs%phs_wood_t%q_defined
	if (.not. phs%q_defined) return

	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	n_in = phs%config%n_in
	phs%p_born = phs%phs_wood_t%p
	phs%q_born = phs%phs_wood_t%q
	phs%p_born_tot (1: n_in) = phs%p_born
	phs%p_born_tot (n_in + 1 :) = phs%q_born
	call phs%set_reference_frames (.true.)
	call phs%set_isr_kinematics (.true.)
	case (PHS_MODE_COLLINEAR_REMNANT)
	call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1))
	phs%r_isr = r_in(phs%n_r_born + 1)
	end select
	end subroutine phs_fks_evaluate_selected_channel

	@ %def phs_fks_evaluate_selected_channel
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_evaluate_other_channels (phs, c_in)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	end subroutine phs_fks_evaluate_other_channels
	<<PHS fks: procedures>>=
	module subroutine phs_fks_evaluate_other_channels (phs, c_in)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: c_in
	call phs%phs_wood_t%evaluate_other_channels (c_in)
	phs%r_defined = .true.
	end subroutine phs_fks_evaluate_other_channels

	@ %def phs_fks_evaluate_other_channels
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: get_mcpar => phs_fks_get_mcpar
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_get_mcpar (phs, c, r)
	class(phs_fks_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default), dimension(:), intent(out) :: r
	end subroutine phs_fks_get_mcpar
	<<PHS fks: procedures>>=
	module subroutine phs_fks_get_mcpar (phs, c, r)
	class(phs_fks_t), intent(in) :: phs
	integer, intent(in) :: c
	real(default), dimension(:), intent(out) :: r
	r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c)
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	r(phs%n_r_born + 1 :) = phs%r_real
	case (PHS_MODE_COLLINEAR_REMNANT)
	r(phs%n_r_born + 1 :) = phs%r_isr
	end select
	end subroutine phs_fks_get_mcpar

	@ %def phs_fks_get_mcpar
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: set_beam_energy => phs_fks_set_beam_energy
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_set_beam_energy (phs)
	class(phs_fks_t), intent(inout) :: phs
	end subroutine phs_fks_set_beam_energy
	<<PHS fks: procedures>>=
	module subroutine phs_fks_set_beam_energy (phs)
	class(phs_fks_t), intent(inout) :: phs
	call phs%generator%set_sqrts_hat (phs%config%sqrts)
	end subroutine phs_fks_set_beam_energy

	@ %def phs_fks_set_beam_energy
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: set_emitters => phs_fks_set_emitters
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_set_emitters (phs, emitters)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in), dimension(:), allocatable :: emitters
	end subroutine phs_fks_set_emitters
	<<PHS fks: procedures>>=
	module subroutine phs_fks_set_emitters (phs, emitters)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in), dimension(:), allocatable :: emitters
	call phs%generator%set_emitters (emitters)
	end subroutine phs_fks_set_emitters

	@ %def phs_fks_set_emitters
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: set_momenta => phs_fks_set_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_set_momenta (phs, p)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:) :: p
	end subroutine phs_fks_set_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_set_momenta (phs, p)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:) :: p
	integer :: n_in, n_tot_born
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1
	phs%p_born = p(1 : n_in)
	phs%q_born = p(n_in + 1 : n_tot_born)
	phs%p_born_tot = p
	end select
	end subroutine phs_fks_set_momenta

	@ %def phs_fks_set_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: setup_masses => phs_fks_setup_masses
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_setup_masses (phs, n_tot)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: n_tot
	end subroutine phs_fks_setup_masses
	<<PHS fks: procedures>>=
	module subroutine phs_fks_setup_masses (phs, n_tot)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: n_tot
	call phs%generator%setup_masses (n_tot)
	end subroutine phs_fks_setup_masses

	@ %def phs_fks_setup_masses
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: get_born_momenta => phs_fks_get_born_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_get_born_momenta (phs, p)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(out), dimension(:) :: p
	end subroutine phs_fks_get_born_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_get_born_momenta (phs, p)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(out), dimension(:) :: p
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	p(1 : phs%config%n_in) = phs%p_born
	p(phs%config%n_in + 1 :) = phs%q_born
	case (PHS_MODE_COLLINEAR_REMNANT)
	p(1:phs%config%n_in) = phs%phs_wood_t%p
	p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q
	end select
	if (.not. phs%config%lab_is_cm) p = phs%lt_cm_to_lab * p
	end subroutine phs_fks_get_born_momenta

	@ %def phs_fks_get_born_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_get_outgoing_momenta (phs, q)
	class(phs_fks_t), intent(in) :: phs
	type(vector4_t), intent(out), dimension(:) :: q
	end subroutine phs_fks_get_outgoing_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_get_outgoing_momenta (phs, q)
	class(phs_fks_t), intent(in) :: phs
	type(vector4_t), intent(out), dimension(:) :: q
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	q = phs%q_real
	case (PHS_MODE_COLLINEAR_REMNANT)
	q = phs%phs_wood_t%q
	end select
	end subroutine phs_fks_get_outgoing_momenta

	@ %def phs_fks_get_outgoing_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_get_incoming_momenta (phs, p)
	class(phs_fks_t), intent(in) :: phs
	type(vector4_t), intent(inout), dimension(:), allocatable :: p
	end subroutine phs_fks_get_incoming_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_get_incoming_momenta (phs, p)
	class(phs_fks_t), intent(in) :: phs
	type(vector4_t), intent(inout), dimension(:), allocatable :: p
	p = phs%p_real
	end subroutine phs_fks_get_incoming_momenta

	@ %def phs_fks_get_incoming_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
	class(phs_fks_t), intent(inout) :: phs
	logical, intent(in) :: requires_boost
	end subroutine phs_fks_set_isr_kinematics
	<<PHS fks: procedures>>=
	module subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
	class(phs_fks_t), intent(inout) :: phs
	logical, intent(in) :: requires_boost
	type(vector4_t), dimension(2) :: p
	if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then
	if (requires_boost) then
	p = phs%lt_cm_to_lab &
	* phs%generator%real_kinematics%p_born_cms%phs_point(1)%select ([1,2])
	else
	p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2])
	end if
	call phs%generator%set_isr_kinematics (p)
	end if
	end subroutine phs_fks_set_isr_kinematics

	@ %def phs_fks_set_isr_kinematics
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: generate_radiation_variables => &
	phs_fks_generate_radiation_variables
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generate_radiation_variables &
	(phs, r_in, threshold)
	class(phs_fks_t), intent(inout) :: phs
	real(default), intent(in), dimension(:) :: r_in
	logical, intent(in) :: threshold
	end subroutine phs_fks_generate_radiation_variables
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generate_radiation_variables &
	(phs, r_in, threshold)
	class(phs_fks_t), intent(inout) :: phs
	real(default), intent(in), dimension(:) :: r_in
	logical, intent(in) :: threshold
	type(vector4_t), dimension(:), allocatable :: p_born
	if (size (r_in) /= 3) call msg_fatal &
	("Real kinematics need to be generated using three random numbers!")
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	allocate (p_born (size (phs%p_born_tot)))
	if (threshold) then
	p_born = phs%get_onshell_projected_momenta ()
	else
	p_born = phs%p_born_tot
	if (.not. phs%lab_is_cm ()) &
	p_born = inverse (phs%lt_cm_to_lab) * p_born
	end if
	call phs%generator%generate_radiation_variables &
	(r_in, p_born, phs%phs_identifiers, threshold)
	phs%r_real = r_in
	end select
	end subroutine phs_fks_generate_radiation_variables

	@ %def phs_fks_generate_radiation_variables
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:), optional :: p_in
	type(resonance_contributors_t), intent(in), dimension(:), optional :: &
	contributors
	end subroutine phs_fks_compute_xi_ref_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:), optional :: p_in
	type(resonance_contributors_t), intent(in), dimension(:), optional :: &
	contributors
	if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
	if (present (p_in)) then
	call phs%generator%compute_xi_ref_momenta (p_in, contributors)
	else
	call phs%generator%compute_xi_ref_momenta &
	(phs%p_born_tot, contributors)
	end if
	end if
	end subroutine phs_fks_compute_xi_ref_momenta

	@ %def phs_fks_compute_xi_ref_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_xi_ref_momenta_threshold => &
	phs_fks_compute_xi_ref_momenta_threshold
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
	class(phs_fks_t), intent(inout) :: phs
	end subroutine phs_fks_compute_xi_ref_momenta_threshold
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
	class(phs_fks_t), intent(inout) :: phs
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	call phs%generator%compute_xi_ref_momenta_threshold &
	(phs%get_onshell_projected_momenta ())
	end select
	end subroutine phs_fks_compute_xi_ref_momenta_threshold

	@ %def phs_fks_compute_xi_ref_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_cms_energy => phs_fks_compute_cms_energy
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_cms_energy (phs)
	class(phs_fks_t), intent(inout) :: phs
	end subroutine phs_fks_compute_cms_energy
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_cms_energy (phs)
	class(phs_fks_t), intent(inout) :: phs
	if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
	call phs%generator%compute_cms_energy (phs%p_born_tot)
	end subroutine phs_fks_compute_cms_energy

	@ %def phs_fks_compute_cms_energy
	@ When initial-state radiation is involved, either due to beamstrahlung or
	QCD/QED corrections, it is important to have access to both the phase
	space points in the center-of-mass and lab frame.
	<<PHS fks: phs fks: TBP>>=
	procedure :: set_reference_frames => phs_fks_set_reference_frames
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_set_reference_frames (phs, is_cms)
	class(phs_fks_t), intent(inout) :: phs
	logical, intent(in) :: is_cms
	end subroutine phs_fks_set_reference_frames
	<<PHS fks: procedures>>=
	module subroutine phs_fks_set_reference_frames (phs, is_cms)
	class(phs_fks_t), intent(inout) :: phs
	logical, intent(in) :: is_cms
	associate (real_kinematics => phs%generator%real_kinematics)
	if (phs%config%lab_is_cm) then
	real_kinematics%p_born_cms%phs_point(1) = phs%p_born_tot
	real_kinematics%p_born_lab%phs_point(1) = phs%p_born_tot
	else
	if (is_cms) then
	real_kinematics%p_born_cms%phs_point(1) &
	= phs%p_born_tot
	real_kinematics%p_born_lab%phs_point(1) &
	= phs%lt_cm_to_lab * phs%p_born_tot
	else
	real_kinematics%p_born_cms%phs_point(1) &
	= inverse (phs%lt_cm_to_lab) * phs%p_born_tot
	real_kinematics%p_born_lab%phs_point(1) &
	= phs%p_born_tot
	end if
	end if
	end associate
	end subroutine phs_fks_set_reference_frames

	@ %def phs_fks_set_reference_frames
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr
	<<PHS fks: sub interfaces>>=
	module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr)
	logical :: is_isr
	class(phs_fks_t), intent(in) :: phs
	integer, intent(in) :: i_phs
	end function phs_fks_i_phs_is_isr
	<<PHS fks: procedures>>=
	module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr)
	logical :: is_isr
	class(phs_fks_t), intent(in) :: phs
	integer, intent(in) :: i_phs
	is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in
	end function phs_fks_i_phs_is_isr

	@ %def phs_fks_i_phs_is_isr
	@
	\subsection{Creation of the real phase space - FSR}
	At this point, the Born phase space has been generated, as well as the
	three random variables $\xi$, $y$ and $\phi$. The question is how the
	real phase space is generated for a final-state emission
	configuration. We work with two different sets of momenta, the Born
	configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ...,
	\bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus},
	k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of
	the emitter to be on the $n$-th position and the momentum of the
	radiated particle to be at position $n+1$. The magnitude of the
	spatial component of k is denoted by $\underline{k}$.

	For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and
	$\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems
	coincide and it is
	\begin{equation}
	q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i,
	\end{equation}
	with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$.

	We want to construct the real phase space from the Born phase space
	using three random numbers. They are defined as follows:
	\begin{itemize}
	\item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where
	$k_{n+1}$ denotes the four-momentum of the radiated particle.
	\item $y = \cos\theta = \frac{\vec{k}_n \cdot
	\vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the
	splitting angle.
	\item The angle between tho two splitting particles in the transversal
	plane, $phi \in [0,2\pi]$.
	\end{itemize}
	Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all
	recoiling momenta.
	<<PHS fks: phs fks generator: TBP>>=
	generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_default &
	(generator, emitter, i_phs, &
	p_born, p_real, xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	end subroutine phs_fks_generator_generate_fsr_default
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_default &
	(generator, emitter, i_phs, &
	p_born, p_real, xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	real(default) :: q0

	call generator%generate_fsr_in (p_born, p_real)
	q0 = sum (p_born(1:generator%n_in))**1
	generator%i_fsr_first = generator%n_in + 1
	call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, &
	xi_y_phi = xi_y_phi, no_jacobians = no_jacobians)
	if (debug_active (D_PHASESPACE)) then
	call vector4_check_momentum_conservation (p_real, generator%n_in, &
	rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
	end if
	end subroutine phs_fks_generator_generate_fsr_default

	@ %def phs_fks_generator_generate_fsr
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_resonances => &
	phs_fks_generator_generate_fsr_resonances
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_resonances (generator, &
	emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	integer, intent(in) :: i_con
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	end subroutine phs_fks_generator_generate_fsr_resonances
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_resonances (generator, &
	emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	integer, intent(in) :: i_con
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	integer, dimension(:), allocatable :: resonance_list
	integer, dimension(size(p_born)) :: inv_resonance_list
	type(vector4_t), dimension(:), allocatable :: p_tmp_born
	type(vector4_t), dimension(:), allocatable :: p_tmp_real
	type(vector4_t) :: p_resonance
	real(default) :: q0
	integer :: i, j, nlegborn, nlegreal
	integer :: i_emitter
	type(lorentz_transformation_t) :: boost_to_resonance
	integer :: n_resonant_particles
	if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
	nlegborn = size (p_born); nlegreal = nlegborn + 1
	allocate (resonance_list (size (generator%resonance_contributors(i_con)%c)))
	resonance_list = generator%resonance_contributors(i_con)%c
	n_resonant_particles = size (resonance_list)

	if (.not. any (resonance_list == emitter)) then
	call msg_fatal ("Emitter must be included in the resonance list!")
	else
	do i = 1, n_resonant_particles
	if (resonance_list (i) == emitter) i_emitter = i
	end do
	end if

	inv_resonance_list = &
	create_inverse_resonance_list (nlegborn, resonance_list)

	allocate (p_tmp_born (n_resonant_particles))
	allocate (p_tmp_real (n_resonant_particles + 1))
	p_tmp_born = vector4_null
	p_tmp_real = vector4_null
	j = 1
	do i = 1, n_resonant_particles
	p_tmp_born(j) = p_born(resonance_list(i))
	j = j + 1
	end do

	call generator%generate_fsr_in (p_born, p_real)

	p_resonance = generator%real_kinematics%xi_ref_momenta(i_con)
	q0 = p_resonance**1

	boost_to_resonance = inverse (boost (p_resonance, q0))
	p_tmp_born = boost_to_resonance * p_tmp_born

	generator%i_fsr_first = 1
	call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, &
	q0, i_emitter, xi_y_phi)
	p_tmp_real = inverse (boost_to_resonance) * p_tmp_real

	do i = generator%n_in + 1, nlegborn
	if (any (resonance_list == i)) then
	p_real(i) = p_tmp_real(inv_resonance_list (i))
	else
	p_real(i) = p_born (i)
	end if
	end do
	p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1)

	if (debug_active (D_PHASESPACE)) then
	call vector4_check_momentum_conservation (p_real, generator%n_in, &
	rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
	end if

	contains

	function create_inverse_resonance_list (nlegborn, resonance_list) &
	result (inv_resonance_list)
	integer, intent(in) :: nlegborn
	integer, intent(in), dimension(:) :: resonance_list
	integer, dimension(nlegborn) :: inv_resonance_list
	integer :: i, j
	inv_resonance_list = 0
	j = 1
	do i = 1, nlegborn
	if (any (i == resonance_list)) then
	inv_resonance_list (i) = j
	j = j + 1
	end if
	end do
	end function create_inverse_resonance_list

	function boosted_energy () result (E)
	real(default) :: E
	type(vector4_t) :: p_boost
	p_boost = boost_to_resonance * p_resonance
	E = p_boost%p(0)
	end function boosted_energy
	end subroutine phs_fks_generator_generate_fsr_resonances

	@ %def phs_fks_generator_generate_fsr_resonances
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_threshold => &
	phs_fks_generator_generate_fsr_threshold
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_threshold (generator, &
	emitter, i_phs, p_born, p_real, xi_y_phi)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	end subroutine phs_fks_generator_generate_fsr_threshold
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_threshold (generator, &
	emitter, i_phs, p_born, p_real, xi_y_phi)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	type(vector4_t), dimension(2) :: p_tmp_born
	type(vector4_t), dimension(3) :: p_tmp_real
	integer :: nlegborn, nlegreal
	type(vector4_t) :: p_top
	real(default) :: q0
	type(lorentz_transformation_t) :: boost_to_top
	integer :: leg, other_leg
	real(default) :: sqrts, mtop
	if (debug_on) call msg_debug2 &
	(D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
	nlegborn = size (p_born); nlegreal = nlegborn + 1

	leg = thr_leg(emitter); other_leg = 3 - leg

	p_tmp_born(1) = p_born (ass_boson(leg))
	p_tmp_born(2) = p_born (ass_quark(leg))

	call generator%generate_fsr_in (p_born, p_real)

	p_top = generator%real_kinematics%xi_ref_momenta(leg)

	q0 = p_top**1
	sqrts = two * p_born(1)%p(0)
	mtop = m1s_to_mpole (sqrts)
	if (sqrts*2 - four mtop**2 > zero) then
	boost_to_top = inverse (boost (p_top, q0))
	else
	boost_to_top = identity
	end if
	p_tmp_born = boost_to_top * p_tmp_born

	generator%i_fsr_first = 1
	call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, &
	p_tmp_real, q0, 2, xi_y_phi)
	p_tmp_real = inverse (boost_to_top) * p_tmp_real

	p_real(ass_boson(leg)) = p_tmp_real(1)
	p_real(ass_quark(leg)) = p_tmp_real(2)
	p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg))
	p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg))
	p_real(THR_POS_GLUON) = p_tmp_real(3)

	end subroutine phs_fks_generator_generate_fsr_threshold

	@ %def phs_fks_generator_generate_fsr_threshold
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_in &
	(generator, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_fsr_in
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_in &
	(generator, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	integer :: i
	do i = 1, generator%n_in
	p_real(i) = p_born(i)
	end do
	end subroutine phs_fks_generator_generate_fsr_in

	@ %def phs_fks_generator_generate_fsr_in
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_out (generator, &
	emitter, i_phs, p_born, p_real, q0, p_emitter_index, &
	xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in) :: q0
	integer, intent(in), optional :: p_emitter_index
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	end subroutine phs_fks_generator_generate_fsr_out
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_out (generator, &
	emitter, i_phs, p_born, p_real, q0, p_emitter_index, &
	xi_y_phi, no_jacobians)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(inout), dimension(:) :: p_real
	real(default), intent(in) :: q0
	integer, intent(in), optional :: p_emitter_index
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	real(default) :: xi, y, phi
	integer :: nlegborn, nlegreal
	real(default) :: uk_np1, uk_n
	real(default) :: uk_rec, k_rec0
	type(vector3_t) :: k_n_born, k
	real(default) :: uk_n_born, uk, k2, k0_n
	real(default) :: cpsi, beta
	type(vector3_t) :: vec, vec_orth
	type(lorentz_transformation_t) :: rot
	integer :: i, p_em
	logical :: compute_jac
	p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index
	compute_jac = .true.
	if (present (no_jacobians)) compute_jac = .not. no_jacobians
	if (generator%i_fsr_first < 0) &
	call msg_fatal ("FSR generator is called for outgoing particles but "&
	&"i_fsr_first is not set!")

	if (present (xi_y_phi)) then
	xi = xi_y_phi(I_XI)
	y = xi_y_phi(I_Y)
	phi = xi_y_phi(I_PHI)
	else
	associate (rad_var => generator%real_kinematics)
	xi = rad_var%xi_tilde
	if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs)
	y = rad_var%y(i_phs)
	phi = rad_var%phi
	end associate
	end if

	nlegborn = size (p_born)
	nlegreal = nlegborn + 1
	generator%E_gluon = q0 * xi / two
	uk_np1 = generator%E_gluon
	k_n_born = p_born(p_em)%p(1:3)
	uk_n_born = k_n_born**1

	generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 &
	- space_part_norm(p_born(p_em))**2
	if (generator%is_massive(emitter)) then
	call generator%compute_emitter_kinematics (y, emitter, &
	i_phs, q0, k0_n, uk_n, uk, compute_jac)
	else
	call generator%compute_emitter_kinematics (y, q0, uk_n, uk)
	generator%real_kinematics%y_soft(i_phs) = y
	k0_n = uk_n
	end if

	if (debug_on) call msg_debug2 &
	(D_PHASESPACE, "phs_fks_generator_generate_fsr_out")
	call debug_input_values ()

	vec = uk_n / uk_n_born * k_n_born
	vec_orth = create_orthogonal (vec)
	p_real(p_em)%p(0) = k0_n
	p_real(p_em)%p(1:3) = vec%p(1:3)
	cpsi = (uk_n2 + uk2 - uk_np1*2) / (two uk_n * uk)
	!!! This is to catch the case where cpsi = 1, but numerically
	!!! turns out to be slightly larger than 1.
	call check_cpsi_bound (cpsi)
	rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth)
	p_real(p_em) = rot * p_real(p_em)
	vec = uk_np1 / uk_n_born * k_n_born
	vec_orth = create_orthogonal (vec)
	p_real(nlegreal)%p(0) = uk_np1
	p_real(nlegreal)%p(1:3) = vec%p(1:3)
	cpsi = (uk_np12 + uk2 - uk_n*2) / (two uk_np1 * uk)
	call check_cpsi_bound (cpsi)
	rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth)
	p_real(nlegreal) = rot * p_real(nlegreal)
	call construct_recoiling_momenta ()
	if (compute_jac) call compute_jacobians ()

	contains

	<<PHS fks: generator generate fsr out procedures>>

	end subroutine phs_fks_generator_generate_fsr_out

	@ %def phs_fks_generator_generate_fsr_out
	@
	<<PHS fks: generator generate fsr out procedures>>=
	subroutine debug_input_values ()
	if (debug2_active (D_PHASESPACE)) then
	call generator%write ()
	print *, 'emitter = ', emitter
	print *, 'p_born:'
	call vector4_write_set (p_born)
	print *, 'p_real:'
	call vector4_write_set (p_real)
	print *, 'q0 = ', q0
	if (present(p_emitter_index)) then
	print *, 'p_emitter_index = ', p_emitter_index
	else
	print *, 'p_emitter_index not given'
	end if
	end if
	end subroutine debug_input_values

	<<PHS fks: generator generate fsr out procedures>>=
	subroutine check_cpsi_bound (cpsi)
	real(default), intent(inout) :: cpsi
	if (cpsi > one) then
	cpsi = one
	else if (cpsi < -one) then
	cpsi = - one
	end if
	end subroutine check_cpsi_bound

	@ Construction of the recoiling momenta. The reshuffling of momenta
	must not change the invariant mass of the recoiling system, which
	means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta
	are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter
	is
	\begin{equation*}
	\beta = \frac{q^2 - (k_{\rm{rec}}^0 +
	\underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 +
	\underline{k}_{\rm{rec}})^2}
	\end{equation*}
	<<PHS fks: generator generate fsr out procedures>>=
	subroutine construct_recoiling_momenta ()
	type(lorentz_transformation_t) :: lambda
	k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0)
	if (k_rec0**2 > generator%mrec2) then
	uk_rec = sqrt (k_rec0**2 - generator%mrec2)
	else
	uk_rec = 0
	end if
	if (generator%is_massive(emitter)) then
	beta = compute_beta (q0**2, k_rec0, uk_rec, &
	p_born(p_em)%p(0), uk_n_born)
	else
	beta = compute_beta (q0**2, k_rec0, uk_rec)
	end if
	k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3)
	vec%p(1:3) = one / uk * k%p(1:3)
	lambda = boost (beta / sqrt(one - beta**2), vec)
	do i = generator%i_fsr_first, nlegborn
	if (i /= p_em) then
	p_real(i) = lambda * p_born(i)
	end if
	end do
	vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born
	rot = rotation (cos(phi), sin(phi), vec)
	p_real(nlegreal) = rot * p_real(nlegreal)
	p_real(p_em) = rot * p_real(p_em)
	end subroutine construct_recoiling_momenta

	@ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is
	supplied during phase space generation. Also, we already divide by
	$\xi$.
	<<PHS fks: generator generate fsr out procedures>>=
	subroutine compute_jacobians ()
	associate (jac => generator%real_kinematics%jac(i_phs))
	if (generator%is_massive(emitter)) then
	jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi
	else
	k2 = two * uk_n * uk_np1* (one - y)
	jac%jac(1) = uk_n*2 / uk_n_born / (uk_n - k2 / (two q0))
	end if
	jac%jac(2) = one
	jac%jac(3) = one - xi / two * q0 / uk_n_born
	end associate
	end subroutine compute_jacobians

	@ %def compute_jacobians
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: generate_fsr_in => phs_fks_generate_fsr_in
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generate_fsr_in (phs)
	class(phs_fks_t), intent(inout) :: phs
	end subroutine phs_fks_generate_fsr_in
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generate_fsr_in (phs)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), dimension(:), allocatable :: p
	p = phs%generator%real_kinematics%p_born_lab%get_momenta &
	(1, phs%generator%n_in)
	end subroutine phs_fks_generate_fsr_in

	@ %def phs_fks_generate_fsr_in
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: generate_fsr => phs_fks_generate_fsr
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, &
	i_con, xi_y_phi, no_jacobians)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(out), dimension(:) :: p_real
	integer, intent(in), optional :: i_con
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	end subroutine phs_fks_generate_fsr
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, &
	i_con, xi_y_phi, no_jacobians)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(out), dimension(:) :: p_real
	integer, intent(in), optional :: i_con
	real(default), intent(in), dimension(3), optional :: xi_y_phi
	logical, intent(in), optional :: no_jacobians
	type(vector4_t), dimension(:), allocatable :: p
	associate (generator => phs%generator)
	p = generator%real_kinematics%p_born_cms%phs_point(1)
	generator%real_kinematics%supply_xi_max = .true.
	if (present (i_con)) then
	call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, &
	xi_y_phi, no_jacobians)
	else
	call generator%generate_fsr (emitter, i_phs, p, p_real, &
	xi_y_phi, no_jacobians)
	end if
	generator%real_kinematics%p_real_cms%phs_point(i_phs) = p_real
	if (.not. phs%config%lab_is_cm) p_real = phs%lt_cm_to_lab * p_real
	generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real
	end associate
	end subroutine phs_fks_generate_fsr

	@ %def phs_fks_generate_fsr
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: get_onshell_projected_momenta => &
	phs_fks_get_onshell_projected_momenta
	<<PHS fks: sub interfaces>>=
	pure module function phs_fks_get_onshell_projected_momenta (phs) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(phs_fks_t), intent(in) :: phs
	end function phs_fks_get_onshell_projected_momenta
	<<PHS fks: procedures>>=
	pure module function phs_fks_get_onshell_projected_momenta (phs) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(phs_fks_t), intent(in) :: phs
	p = phs%generator%real_kinematics%p_born_onshell%phs_point(1)
	end function phs_fks_get_onshell_projected_momenta

	@ %def phs_fks_get_onshell_projected_momenta
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generate_fsr_threshold &
	(phs, emitter, i_phs, p_real)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(inout), dimension(:), optional :: p_real
	end subroutine phs_fks_generate_fsr_threshold
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generate_fsr_threshold &
	(phs, emitter, i_phs, p_real)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(inout), dimension(:), optional :: p_real
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: pp
	integer :: leg
	associate (generator => phs%generator)
	generator%real_kinematics%supply_xi_max = .true.
	allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles()))
	p_born = generator%real_kinematics%p_born_onshell%get_momenta (1)
	allocate (pp (size (p_born) + 1))
	call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp)
	leg = thr_leg (emitter)
	call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp)
	if (present (p_real)) p_real = pp
	end associate
	end subroutine phs_fks_generate_fsr_threshold

	@ %def phs_fks_generate_fsr_threshold
	@
	<<PHS fks: phs fks: TBP>>=
	generic :: compute_xi_max => &
	compute_xi_max_internal, compute_xi_max_with_output
	procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:) :: p
	logical, intent(in) :: threshold
	end subroutine phs_fks_compute_xi_max_internal
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold)
	class(phs_fks_t), intent(inout) :: phs
	type(vector4_t), intent(in), dimension(:) :: p
	logical, intent(in) :: threshold
	integer :: i_phs, i_con, emitter
	do i_phs = 1, size (phs%phs_identifiers)
	associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator)
	emitter = phs_id%emitter
	if (threshold) then
	call generator%compute_xi_max (emitter, i_phs, p, &
	generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
	else if (allocated (phs_id%contributors)) then
	do i_con = 1, size (phs_id%contributors)
	call generator%compute_xi_max (emitter, i_phs, p, &
	generator%real_kinematics%xi_max(i_phs), i_con = 1)
	end do
	else
	call generator%compute_xi_max (emitter, i_phs, p, &
	generator%real_kinematics%xi_max(i_phs))
	end if
	end associate
	end do
	end subroutine phs_fks_compute_xi_max_internal

	@ %def phs_fks_compute_xi_max
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_xi_max_with_output &
	(phs, emitter, i_phs, y, p, xi_max)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: i_phs, emitter
	real(default), intent(in) :: y
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(out) :: xi_max
	end subroutine phs_fks_compute_xi_max_with_output
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_xi_max_with_output &
	(phs, emitter, i_phs, y, p, xi_max)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: i_phs, emitter
	real(default), intent(in) :: y
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(out) :: xi_max
	call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y)
	end subroutine phs_fks_compute_xi_max_with_output

	@ %def phs_fks_compute_xi_max_with_output
	@
	<<PHS fks: phs fks generator: TBP>>=
	generic :: compute_emitter_kinematics => &
	compute_emitter_kinematics_massless, &
	compute_emitter_kinematics_massive
	procedure :: compute_emitter_kinematics_massless => &
	phs_fks_generator_compute_emitter_kinematics_massless
	procedure :: compute_emitter_kinematics_massive => &
	phs_fks_generator_compute_emitter_kinematics_massive
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_emitter_kinematics_massless &
	(generator, y, q0, uk_em, uk)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: y, q0
	real(default), intent(out) :: uk_em, uk
	end subroutine phs_fks_generator_compute_emitter_kinematics_massless
	module subroutine phs_fks_generator_compute_emitter_kinematics_massive &
	(generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: y
	integer, intent(in) :: em, i_phs
	real(default), intent(in) :: q0
	real(default), intent(inout) :: k0_em, uk_em, uk
	logical, intent(in) :: compute_jac
	end subroutine phs_fks_generator_compute_emitter_kinematics_massive
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_emitter_kinematics_massless &
	(generator, y, q0, uk_em, uk)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: y, q0
	real(default), intent(out) :: uk_em, uk
	real(default) :: k0_np1, q2

	k0_np1 = generator%E_gluon
	q2 = q0**2

	uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / &
	(two * (q0 - k0_np1 * (one - y)))
	uk = sqrt (uk_em2 + k0_np12 + two * uk_em * k0_np1 * y)
	end subroutine phs_fks_generator_compute_emitter_kinematics_massless

	module subroutine phs_fks_generator_compute_emitter_kinematics_massive &
	(generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: y
	integer, intent(in) :: em, i_phs
	real(default), intent(in) :: q0
	real(default), intent(inout) :: k0_em, uk_em, uk
	logical, intent(in) :: compute_jac
	real(default) :: k0_np1, q2, mrec2, m2
	real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec
	real(default) :: z, z1, z2

	k0_np1 = generator%E_gluon
	q2 = q0**2
	mrec2 = generator%mrec2
	m2 = generator%m2(em)

	k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
	k0_em_max = (q2 + m2 - mrec2) /(two * q0)
	z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
	z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
	z = z2 - (z2 - z1) * (one + y) / two
	k0_em = k0_em_max - k0_np1 * z
	k0_rec = q0 - k0_np1 - k0_em
	uk_em = sqrt(k0_em**2 - m2)
	uk_rec = sqrt(k0_rec**2 - mrec2)
	uk = uk_rec
	if (compute_jac) &
	generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1
	generator%real_kinematics%y_soft(i_phs) = &
	(two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max*2 - m2) q0) / two
	end subroutine phs_fks_generator_compute_emitter_kinematics_massive

	@ %def phs_fks_generator_compute_emitter_kinematics
	@
	<<PHS fks: procedures>>=
	function recompute_xi_max (q0, mrec2, m2, y) result (xi_max)
	real(default) :: xi_max
	real(default), intent(in) :: q0, mrec2, m2, y
	real(default) :: q2, k0_np1_max, k0_rec_max
	real(default) :: z1, z2, z
	q2 = q0**2
	k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
	z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
	z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
	z = z2 - (z2 - z1) * (one + y) / 2
	k0_np1_max = - (q2 * z*2 - two q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z))
	xi_max = two * k0_np1_max / q0
	end function recompute_xi_max

	@ %def recompute_xi_max
	@
	<<PHS fks: procedures>>=
	function compute_beta_massless (q2, k0_rec, uk_rec) result (beta)
	real(default), intent(in) :: q2, k0_rec, uk_rec
	real(default) :: beta
	beta = (q2 - (k0_rec + uk_rec)2) / (q2 + (k0_rec + uk_rec)2)
	end function compute_beta_massless

	function compute_beta_massive (q2, k0_rec, uk_rec, &
	k0_em_born, uk_em_born) result (beta)
	real(default), intent(in) :: q2, k0_rec, uk_rec
	real(default), intent(in) :: k0_em_born, uk_em_born
	real(default) :: beta
	real(default) :: k0_rec_born, uk_rec_born, alpha
	k0_rec_born = sqrt(q2) - k0_em_born
	uk_rec_born = uk_em_born
	alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born)
	beta = (one - alpha2) / (one + alpha2)
	end function compute_beta_massive

	@ %def compute_beta
	@ The momentum of the radiated particle is computed according to
	\begin{equation}
	\label{eq:phs_fks:compute_k_n}
	\underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 -
	2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))},
	\end{equation}
	with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 =
	\left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel
	\boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 =
	\left(q-\bar{k}_n\right)^2$.
	Equation \ref{eq:phs_fks:compute_k_n} follows from the fact that
	$\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 =
	\boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n
	\cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 +
	\underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\
	$\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first
	setting up vectors parallel to $\boldsymbol{\bar{k}}_n$,
	\begin{equation*}
	\boldsymbol{k}_n' = \underline{k}_n
	\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}'
	= \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n},
	\end{equation*}
	and then rotating these vectors by an amount of $\cos\psi_n =
	\frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$.
	@ The emitted particle cannot have more momentum than the emitter has
	in the Born phase space. Thus, there is an upper bound for $\xi$,
	determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which
	is equal to
	\begin{equation*}
	\xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}.
	\end{equation*}
	<<PHS fks: procedures>>=
	pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max)
	type(vector4_t), intent(in), dimension(:) :: p_born
	real(default), intent(in) :: q0
	integer, intent(in) :: emitter
	real(default) :: xi_max
	real(default) :: uk_n_born
	uk_n_born = space_part_norm (p_born(emitter))
	xi_max = two * uk_n_born / q0
	end function get_xi_max_fsr_massless

	@ %def get_xi_max_fsr_massless
	@ The computation of $\xi_{\rm{max}}$ for massive emitters is described
	in arXiv:1202.0465. Let's recapitulate it here.

	We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and
	$k_{\rm{rec}}^0$ and introduce the parameterization
	\begin{equation*}
	k_n^0 = \bar{k}_n^0 - zk_{n+1}^0
	\end{equation*}
	Then, for each value of $z$, there exists a maximum value of
	$\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via
	$\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition
	\begin{equation*}
	\underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0.
	\end{equation*}
	This can be manipulated to yield
	\begin{equation*}
	\left(\underline{k}_{n+1}^2 + \underline{k}_n^2 -
	\underline{k}_{\rm{rec}}^2\right)^2 =
	4\underline{k}^2_{n+1}\underline{k}_n^2.
	\end{equation*}
	Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and
	$\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 -
	M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to
	obtain
	\begin{equation*}
	4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) +
	q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0.
	\end{equation*}
	Solving for $k_{n+1}^0$ gives
	\begin{equation}
	k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}.
	\label{XiMaxMassive}
	\end{equation}
	It is still open how to compute $z$. For this, consider that the
	right-hand-side of equation (\ref{XiMaxMassive}) vanishes for
	\begin{equation*}
	z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm
	\sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q,
	\end{equation*}
	which corresponds to the borders of the Dalitz-region where the gluon
	momentum vanishes. Thus we define
	\begin{equation*}
	z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y).
	\end{equation*}
	<<PHS fks: procedures>>=
	pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max)
	real(default) :: xi_max
	type(vector4_t), intent(in), dimension(:) :: p_born
	real(default), intent(in) :: q0
	integer, intent(in) :: emitter
	real(default), intent(in) :: m2, y
	real(default) :: mrec2
	real(default) :: k0_rec_max
	real(default) :: z, z1, z2
	real(default) :: k0_np1_max
	associate (p => p_born(emitter)%p)
	mrec2 = (q0 - p(0))2 - p(1)2 - p(2)2 - p(3)2
	end associate
	call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
	z = z2 - (z2 - z1) * (one + y) / two
	k0_np1_max = - (q0*2 z*2 - two q0 * k0_rec_max * z + mrec2) &
	/ (two * q0 * z * (one - z))
	xi_max = two * k0_np1_max / q0
	end function get_xi_max_fsr_massive

	@ %def get_xi_max_fsr_massive
	@
	<<PHS fks: parameters>>=
	integer, parameter, public :: I_PLUS = 1
	integer, parameter, public :: I_MINUS = 2

	@ %def parameters
	@ Computes $\xi_{\text{max}}$ in the case of ISR as documented in eq. \ref{eqn:xi_max_isr}.
	It is also used for the POWHEG matching.
	<<PHS fks: public>>=
	public :: get_xi_max_isr
	<<PHS fks: sub interfaces>>=
	module function get_xi_max_isr (xb, y) result (xi_max)
	real(default) :: xi_max
	real(default), dimension(2), intent(in) :: xb
	real(default), intent(in) :: y
	end function get_xi_max_isr
	<<PHS fks: procedures>>=
	module function get_xi_max_isr (xb, y) result (xi_max)
	real(default) :: xi_max
	real(default), dimension(2), intent(in) :: xb
	real(default), intent(in) :: y
	xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y))
	contains
	function xi_max_isr_plus (x, y)
	real(default) :: xi_max_isr_plus
	real(default), intent(in) :: x, y
	real(default) :: deno
	deno = sqrt ((one + x2)2 * (one - y)*2 + 16 y * x*2) + (one - y) (1 - x**2)
	xi_max_isr_plus = two * (one + y) * x**2 / deno
	end function xi_max_isr_plus

	function xi_max_isr_minus (x, y)
	real(default) :: xi_max_isr_minus
	real(default), intent(in) :: x, y
	real(default) :: deno
	deno = sqrt ((one + x2)2 * (one + y)*2 - 16 y * x*2) + (one + y) (1 - x**2)
	xi_max_isr_minus = two * (one - y) * x**2 / deno
	end function xi_max_isr_minus
	end function get_xi_max_isr

	@ %def get_xi_max_isr
	@
	<<PHS fks: procedures>>=
	recursive function get_xi_max_isr_decay (p) result (xi_max)
	real(default) :: xi_max
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: n_tot
	type(vector4_t), dimension(:), allocatable :: p_dec_new
	n_tot = size (p)
	if (n_tot == 3) then
	xi_max = xi_max_one_to_two (p(1), p(2), p(3))
	else
	allocate (p_dec_new (n_tot - 1))
	p_dec_new(1) = sum (p (3 : ))
	p_dec_new(2 : n_tot - 1) = p (3 : n_tot)
	xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), &
	get_xi_max_isr_decay (p_dec_new))
	end if
	contains
	function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max)
	real(default) :: xi_max
	type(vector4_t), intent(in) :: p_in, p_out1, p_out2
	real(default) :: m_in, m_out1, m_out2
	m_in = p_in**1
	m_out1 = p_out11; m_out2 = p_out21
	xi_max = one - (m_out1 + m_out2)2 / m_in2
	end function xi_max_one_to_two
	end function get_xi_max_isr_decay

	@ %def get_xi_max_isr_decay
	@
	\subsection{Creation of the real phase space - ISR}
	<<PHS fks: phs fks: TBP>>=
	procedure :: generate_isr => phs_fks_generate_isr
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generate_isr (phs, i_phs, p_real)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: i_phs
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generate_isr
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generate_isr (phs, i_phs, p_real)
	class(phs_fks_t), intent(inout) :: phs
	integer, intent(in) :: i_phs
	type(vector4_t), intent(out), dimension(:) :: p_real
	type(vector4_t) :: p0, p1
	type(lorentz_transformation_t) :: lt
	real(default) :: sqrts_hat
	type(vector4_t), dimension(:), allocatable :: p_work

	associate (generator => phs%generator)
	select case (generator%n_in)
	case (1)
	p_work = generator%real_kinematics%p_born_cms%phs_point(1)
	call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
	phs%config%lab_is_cm = .true.
	case (2)
	select case (generator%isr_kinematics%isr_mode)
	case (SQRTS_FIXED)
	p_work = generator%real_kinematics%p_born_cms%phs_point(1)
	call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
	case (SQRTS_VAR)
	p_work = generator%real_kinematics%p_born_lab%phs_point(1)
	call generator%generate_isr (i_phs, p_work, p_real)
	end select
	end select
	generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real
	if (.not. phs%config%lab_is_cm) then
	sqrts_hat = (p_real(1) + p_real(2))**1
	p0 = p_real(1) + p_real(2)
	lt = boost (p0, sqrts_hat)
	p1 = inverse(lt) * p_real(1)
	lt = lt * rotation_to_2nd (3, space_part (p1))
	phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) &
	= inverse (lt) * p_real
	else
	phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) &
	= p_real
	end if
	end associate
	end subroutine phs_fks_generate_isr

	@ %def phs_fks_generate_isr
	@ The real phase space for an inital-state emission involved in a decay
	process is generated by first setting the gluon momentum like in the
	scattering case by using its angular coordinates $y$ and $\phi$ and then
	adjusting the gluon energy with $\xi$. The emitter momentum is kept
	identical to the Born case, i.e. $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so
	that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} -
	p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$. Note that the
	final state momenta have to remain on-shell, so that $p_1^2 =
	\bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be
	the boost from into the rest frame of the emitter after emission, i.e.
	$\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$. In this reference
	frame, the spatial components of the final-state momenta sum up to zero,
	and their magnitude is
	\begin{equation*}
	p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m},
	\end{equation*}
	a fact already used in the evaluation of the phase space trees of
	[[phs_forest]]. Obviously, from this, the final-state energies can be
	deferred via $E_i^2 = m_i^2 - p^2$. In the next step, the $p_{1,2}$ are
	set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated
	about the same azimuthal and polar angles as in the Born system.
	Finally, the momenta are boosted out of the rest frame by multiplying
	with $\Lambda$.
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_isr_fixed_beam_energy => &
	phs_fks_generator_generate_isr_fixed_beam_energy
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_isr_fixed_beam_energy &
	(generator, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_isr_fixed_beam_energy
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_isr_fixed_beam_energy &
	(generator, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	real(default) :: xi_max, xi, y, phi
	integer :: nlegborn, nlegreal, i
	real(default) :: k0_np1
	real(default) :: msq_in
	type(vector4_t) :: p_virt
	real(default) :: jac_real

	associate (rad_var => generator%real_kinematics)
	xi_max = rad_var%xi_max(i_phs)
	xi = rad_var%xi_tilde * xi_max
	y = rad_var%y(i_phs)
	phi = rad_var%phi
	rad_var%y_soft(i_phs) = y
	end associate

	nlegborn = size (p_born)
	nlegreal = nlegborn + 1

	msq_in = sum (p_born(1:generator%n_in))**2
	generator%real_kinematics%jac(i_phs)%jac = one

	p_real(1) = p_born(1)
	if (generator%n_in > 1) p_real(2) = p_born(2)
	k0_np1 = zero
	do i = 1, generator%n_in
	k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two
	end do
	p_real(nlegreal)%p(0) = k0_np1
	p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y*2) sin(phi)
	p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y*2) cos(phi)
	p_real(nlegreal)%p(3) = k0_np1 * y

	p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal)

	jac_real = one
	call generate_on_shell_decay (p_virt, &
	p_born(generator%n_in + 1 : nlegborn), &
	p_real(generator%n_in + 1 : nlegreal - 1), 1, msq_in, jac_real)

	associate (jac => generator%real_kinematics%jac(i_phs))
	jac%jac(1) = jac_real
	jac%jac(2) = one
	end associate

	end subroutine phs_fks_generator_generate_isr_fixed_beam_energy

	@ %def phs_fks_generator_generate_isr_fixed_beam_energy
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_isr_factorized => &
	phs_fks_generator_generate_isr_factorized
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_isr_factorized &
	(generator, i_phs, emitter, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_isr_factorized
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_isr_factorized &
	(generator, i_phs, emitter, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	type(vector4_t), dimension(3) :: p_tmp_born
	type(vector4_t), dimension(4) :: p_tmp_real
	type(vector4_t) :: p_top
	type(lorentz_transformation_t) :: boost_to_rest_frame
	integer, parameter :: nlegreal = 7
	!!! Factorized phase space so far only required for ee -> bwbw

	p_tmp_born = vector4_null; p_tmp_real = vector4_null
	p_real(1:2) = p_born(1:2)
	if (emitter == THR_POS_B) then
	p_top = p_born (THR_POS_WP) + p_born (THR_POS_B)
	p_tmp_born(2) = p_born (THR_POS_WP)
	p_tmp_born(3) = p_born (THR_POS_B)
	else if (emitter == THR_POS_BBAR) then
	p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR)
	p_tmp_born(2) = p_born (THR_POS_WM)
	p_tmp_born(3) = p_born (THR_POS_BBAR)
	else
	call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // &
	"Please check if your process specification fulfills this requirement.")
	end if
	p_tmp_born (1) = p_top
	boost_to_rest_frame = inverse (boost (p_top, p_top**1))
	p_tmp_born = boost_to_rest_frame * p_tmp_born
	call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born)
	call generator%generate_isr_fixed_beam_energy &
	(i_phs, p_tmp_born, p_tmp_real)
	p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real
	if (emitter == THR_POS_B) then
	p_real(THR_POS_WP) = p_tmp_real(2)
	p_real(THR_POS_B) = p_tmp_real(3)
	p_real(THR_POS_WM) = p_born(THR_POS_WM)
	p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR)
	!!! Exception has been handled above
	else
	p_real(THR_POS_WM) = p_tmp_real(2)
	p_real(THR_POS_BBAR) = p_tmp_real(3)
	p_real(THR_POS_WP) = p_born(THR_POS_WP)
	p_real(THR_POS_B) = p_born(THR_POS_B)
	end if
	p_real(nlegreal) = p_tmp_real(4)
	end subroutine phs_fks_generator_generate_isr_factorized

	@ %def phs_fks_generator_generate_isr_factorized
	@ Construction of the real momenta [[p_real]] in case of ISR.
	Follows the discussion in [0709.2092] sec. 5.1.
	The sequence of Lorentz boosts required to construct [[p_real]] from
	[[p_born]] is as follows:
	\begin{enumerate}
	\item[\labelitemii] We construct the IS momenta of [[p_real]] from
	the Born momenta via rescaling:
	[[p_real(1:2)]] $= \frac{x}{\overline{x}} \cdot$ [[p_born(1:2)]].
	If the Born momenta are imported in the lab frame, these will define
	the real lab frame.
	\item[\labelitemii] We construct the momentum of the radiated
	particle in the real CMS:
	$k_{n+1} = \frac{s \xi}{2} \cdot (1, \sin(\theta) \sin(\phi),
	\sin(\theta) \cos(\phi), \cos(\theta))$
	\setcounter{enumi}{-1}
	\item We first boost the momentum of the radiated particle from the
	real CMS to the real lab frame determined from [[p_real(1:2)]].
	\item We initialize the non-radiated real FS momenta by a
	longitudinal boost of [[p_born]] to a system with zero rapidity,
	i.e. zero longitudinal momenum. This is $\mathbb{B}_L$.
	\item We boost these momenta in a transverse direction to compensate
	the transverse momentum of the radiation. This is
	$\mathbb{B}_T$. Note: we switched $\mathbb{B}_T$ and
	$\mathbb{B}^{-1}_T$ in Eq. (5.16) and their definition
	w.r.t. [0709.2092].
	\item We restore longitudinal momentum conservation by applying the
	inverse boost of $\mathbb{B}_L$ to all non-radiated real FS momenta.
	\end{enumerate}
	This way, all components of [[p_real]] are constructed in the real Lab frame.
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_isr => phs_fks_generator_generate_isr
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_isr &
	(generator, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in) , dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_isr
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_isr &
	(generator, i_phs, p_born, p_real)
	!!! Important: Import Born momenta in the lab frame
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in) , dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	real(default) :: xi_max, xi_tilde, xi, y, phi
	integer :: nlegborn, nlegreal
	real(default) :: sqrts_real
	real(default) :: k0_np1
	type(lorentz_transformation_t) :: &
	lambda_transv, lambda_longit, lambda_longit_inv
	real(default) :: x_plus, x_minus, xb_plus, xb_minus
	real(default) :: onemy, onepy
	integer :: i
	real(default) :: xi_plus, xi_minus
	real(default) :: beta_gamma
	type(vector3_t) :: beta_vec

	associate (rad_var => generator%real_kinematics)
	xi_max = rad_var%xi_max(i_phs)
	xi_tilde = rad_var%xi_tilde
	xi = xi_tilde * xi_max
	y = rad_var%y(i_phs)
	onemy = one - y; onepy = one + y
	phi = rad_var%phi
	rad_var%y_soft(i_phs) = y
	end associate

	nlegborn = size (p_born)
	nlegreal = nlegborn + 1
	generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1

	!!! Initial state real momenta
	xb_plus = generator%isr_kinematics%x(I_PLUS)
	xb_minus = generator%isr_kinematics%x(I_MINUS)
	x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / &
	(two - xi * onepy))
	x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / &
	(two - xi * onemy))
	xi_plus = xi_tilde * (one - xb_plus)
	xi_minus = xi_tilde * (one - xb_minus)
	p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS)
	p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS)

	!!! Fraction of momentum fractions in a collinear splitting
	generator%isr_kinematics%z(I_PLUS) = (one - xi_plus)
	generator%isr_kinematics%z(I_MINUS) = (one - xi_minus)

	!!! Create radiation momentum in the real CMS
	sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi)
	k0_np1 = sqrts_real * xi / two
	p_real(nlegreal)%p(0) = k0_np1
	p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y*2) sin(phi)
	p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y*2) cos(phi)
	p_real(nlegreal)%p(3) = k0_np1 * y

	!!! Boosts the radiation from real CMS to the real LAB frame
	call get_boost_parameters (p_real, beta_gamma, beta_vec)
	lambda_longit = create_longitudinal_boost &
	(beta_gamma, beta_vec, inverse = .true.)
	p_real(nlegreal) = lambda_longit * p_real(nlegreal)

	call get_boost_parameters (p_born, beta_gamma, beta_vec)
	lambda_longit = create_longitudinal_boost &
	(beta_gamma, beta_vec, inverse = .false.)
	forall (i = 3 : nlegborn) p_real(i) = lambda_longit * p_born(i)

	lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real)
	forall (i = 3 : nlegborn) p_real(i) = lambda_transv * p_real(i)

	lambda_longit_inv = create_longitudinal_boost &
	(beta_gamma, beta_vec, inverse = .true.)
	forall (i = 3 : nlegborn) p_real(i) = lambda_longit_inv * p_real(i)

	!!! Compute Jacobians
	associate (jac => generator%real_kinematics%jac(i_phs))
	!!! Additional 1 / (1 - xi) factor because in the real jacobian,
	!!! there is s_real in the numerator
	!!! We also have to adapt the flux factor, which is 1/(2s_real) for
	!!! the real component
	!!! The reweighting factor is s_born / s_real, cancelling the
	!!! (1-xi) factor from above
	jac%jac(1) = one / (one - xi)
	jac%jac(2) = one
	jac%jac(3) = one / (one - xi_plus)**2
	jac%jac(4) = one / (one - xi_minus)**2
	end associate
	contains
	subroutine get_boost_parameters (p, beta_gamma, beta_vec)
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(out) :: beta_gamma
	type(vector3_t), intent(out) :: beta_vec
	beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0))
	beta_gamma = beta_vec1 / sqrt (one - beta_vec2)
	beta_vec = beta_vec / beta_vec**1
	end subroutine get_boost_parameters

	function create_longitudinal_boost &
	(beta_gamma, beta_vec, inverse) result (lambda)
	real(default), intent(in) :: beta_gamma
	type(vector3_t), intent(in) :: beta_vec
	logical, intent(in) :: inverse
	type(lorentz_transformation_t) :: lambda
	if (inverse) then
	lambda = boost (beta_gamma, beta_vec)
	else
	lambda = boost (-beta_gamma, beta_vec)
	end if
	end function create_longitudinal_boost

	function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda)
	type(vector4_t), intent(in) :: p_rad
	real(default), intent(in) :: xi, sqrts_real
	type(lorentz_transformation_t) :: lambda
	type(vector3_t) :: vec_transverse
	real(default) :: pt2, beta, beta_gamma
	pt2 = transverse_part (p_rad)**2
	beta = one / sqrt (one + sqrts_real*2 (one - xi) / pt2)
	beta_gamma = beta / sqrt (one - beta**2)
	vec_transverse%p(1:2) = p_rad%p(1:2)
	vec_transverse%p(3) = zero
	vec_transverse = normalize (vec_transverse)
	lambda = boost (-beta_gamma, vec_transverse)
	end function create_transversal_boost
	end subroutine phs_fks_generator_generate_isr

	@ %def phs_fks_generator_generate_isr
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: sqrts
	end subroutine phs_fks_generator_set_sqrts_hat
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: sqrts
	generator%sqrts = sqrts
	end subroutine phs_fks_generator_set_sqrts_hat

	@ %def phs_fks_generator_set_sqrts_hat
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: set_emitters => phs_fks_generator_set_emitters
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_set_emitters (generator, emitters)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in), dimension(:), allocatable :: emitters
	end subroutine phs_fks_generator_set_emitters
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_set_emitters (generator, emitters)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in), dimension(:), allocatable :: emitters
	allocate (generator%emitters (size (emitters)))
	generator%emitters = emitters
	end subroutine phs_fks_generator_set_emitters

	@ %def phs_fks_generator_set_emitters
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: setup_masses => phs_fks_generator_setup_masses
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_setup_masses (generator, n_tot)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: n_tot
	end subroutine phs_fks_generator_setup_masses
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_setup_masses (generator, n_tot)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: n_tot
	if (.not. allocated (generator%m2)) then
	allocate (generator%is_massive (n_tot))
	allocate (generator%m2 (n_tot))
	generator%is_massive = .false.
	generator%m2 = zero
	end if
	end subroutine phs_fks_generator_setup_masses

	@ %def phs_fks_generator_setup_masses
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_set_xi_and_y_bounds &
	(generator, fks_xi_min, fks_y_max)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in), optional :: fks_xi_min, fks_y_max
	end subroutine phs_fks_generator_set_xi_and_y_bounds
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_set_xi_and_y_bounds &
	(generator, fks_xi_min, fks_y_max)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in), optional :: fks_xi_min, fks_y_max
	real(default) :: xi_min, y_max
	xi_min = zero; y_max = one
	if (present (fks_xi_min)) xi_min = fks_xi_min
	if (present (fks_y_max)) y_max = fks_y_max
	generator%xi_min = min (one, max (xi_min, tiny_07))
	generator%y_max = min (abs (y_max), one)
	end subroutine phs_fks_generator_set_xi_and_y_bounds

	@ %def phs_fks_generator_set_xi_and_y_bounds
	@ Sets [[x]] in the [[isr_kinematics]] of the generator.
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_set_isr_kinematics (generator, p)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), dimension(2), intent(in) :: p
	end subroutine phs_fks_generator_set_isr_kinematics
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_set_isr_kinematics (generator, p)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), dimension(2), intent(in) :: p
	if (allocated (generator%isr_kinematics%beam_energy)) then
	select case (size (generator%isr_kinematics%beam_energy))
	case (1)
	generator%isr_kinematics%x = p%p(0) / &
	generator%isr_kinematics%beam_energy(1)
	case (2)
	generator%isr_kinematics%x = p%p(0) / &
	generator%isr_kinematics%beam_energy
	end select
	else
	generator%isr_kinematics%x = 0
	end if
	end subroutine phs_fks_generator_set_isr_kinematics

	@ %def phs_fks_generator_set_isr_kinematics
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_radiation_variables => &
	phs_fks_generator_generate_radiation_variables
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_radiation_variables &
	(generator, r_in, p_born, phs_identifiers, threshold)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in), dimension(:) :: r_in
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	logical, intent(in), optional :: threshold
	end subroutine phs_fks_generator_generate_radiation_variables
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_radiation_variables &
	(generator, r_in, p_born, phs_identifiers, threshold)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in), dimension(:) :: r_in
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	logical, intent(in), optional :: threshold

	associate (rad_var => generator%real_kinematics)
	rad_var%phi = r_in (I_PHI) * twopi
	select case (generator%mode)
	case (GEN_REAL_PHASE_SPACE)
	rad_var%jac_rand = twopi
	call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, &
	rad_var%jac_rand, rad_var%y, threshold)
	case (GEN_SOFT_MISMATCH)
	rad_var%jac_mismatch = twopi
	call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, &
	rad_var%y_mismatch, rad_var%y_soft)
	case default
	call generator%compute_y_test (rad_var%y)
	end select
	call generator%compute_xi_tilde (r_in(I_XI))
	call generator%set_masses (p_born, phs_identifiers)
	end associate
	end subroutine phs_fks_generator_generate_radiation_variables

	@ %def phs_fks_generator_generate_radiation_variables
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_xi_ref_momenta => &
	phs_fks_generator_compute_xi_ref_momenta
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_xi_ref_momenta &
	(generator, p_born, resonance_contributors)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(resonance_contributors_t), intent(in), dimension(:), optional &
	:: resonance_contributors
	end subroutine phs_fks_generator_compute_xi_ref_momenta
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_xi_ref_momenta &
	(generator, p_born, resonance_contributors)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(resonance_contributors_t), intent(in), dimension(:), optional &
	:: resonance_contributors
	integer :: i_con, n_contributors
	if (present (resonance_contributors)) then
	n_contributors = size (resonance_contributors)
	if (.not. allocated (generator%resonance_contributors)) &
	allocate (generator%resonance_contributors (n_contributors))
	do i_con = 1, n_contributors
	generator%real_kinematics%xi_ref_momenta(i_con) = &
	get_resonance_momentum (p_born, resonance_contributors(i_con)%c)
	generator%resonance_contributors(i_con) = &
	resonance_contributors(i_con)
	end do
	else
	generator%real_kinematics%xi_ref_momenta(1) = &
	sum (p_born(1:generator%n_in))
	end if
	end subroutine phs_fks_generator_compute_xi_ref_momenta

	@ %def phs_fks_generator_compute_xi_ref_momenta
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_xi_ref_momenta_threshold &
	=> phs_fks_generator_compute_xi_ref_momenta_threshold
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold &
	(generator, p_born)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold &
	(generator, p_born)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	generator%real_kinematics%xi_ref_momenta(1) = &
	p_born(THR_POS_WP) + p_born(THR_POS_B)
	generator%real_kinematics%xi_ref_momenta(2) = &
	p_born(THR_POS_WM) + p_born(THR_POS_BBAR)
	end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold

	@ %def phs_fks_generator_compute_xi_ref_momenta_threshold
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_cms_energy (generator, p_born)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	end subroutine phs_fks_generator_compute_cms_energy
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_cms_energy (generator, p_born)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t) :: p_sum
	p_sum = sum (p_born (1 : generator%n_in))
	generator%real_kinematics%cms_energy2 = p_sum**2
	end subroutine phs_fks_generator_compute_cms_energy

	@ %def phs_fks_generator_compute_cms_energy
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_xi_max => phs_fks_generator_compute_xi_max
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_xi_max (generator, emitter, &
	i_phs, p, xi_max, i_con, y_in)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(out) :: xi_max
	integer, intent(in), optional :: i_con
	real(default), intent(in), optional :: y_in
	end subroutine phs_fks_generator_compute_xi_max
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_xi_max (generator, emitter, &
	i_phs, p, xi_max, i_con, y_in)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), intent(out) :: xi_max
	integer, intent(in), optional :: i_con
	real(default), intent(in), optional :: y_in
	real(default) :: q0
	type(vector4_t), dimension(:), allocatable :: pp, pp_decay
	type(vector4_t) :: p_res
	type(lorentz_transformation_t) :: L_to_resonance
	real(default) :: y
	if (.not. any (generator%emitters == emitter)) return
	allocate (pp (size (p)))
	associate (rad_var => generator%real_kinematics)
	if (present (i_con)) then
	q0 = rad_var%xi_ref_momenta(i_con)**1
	else
	q0 = energy (sum (p(1:generator%n_in)))
	end if
	if (present (y_in)) then
	y = y_in
	else
	y = rad_var%y(i_phs)
	end if
	if (present (i_con)) then
	p_res = rad_var%xi_ref_momenta(i_con)
	L_to_resonance = inverse (boost (p_res, q0))
	pp = L_to_resonance * p
	else
	pp = p
	end if
	if (emitter <= generator%n_in) then
	select case (generator%isr_kinematics%isr_mode)
	case (SQRTS_FIXED)
	if (generator%n_in > 1) then
	allocate (pp_decay (size (pp) - 1))
	else
	allocate (pp_decay (size (pp)))
	end if
	pp_decay (1) = sum (pp(1:generator%n_in))
	pp_decay (2 : ) = pp (generator%n_in + 1 : )
	xi_max = get_xi_max_isr_decay (pp_decay)
	deallocate (pp_decay)
	case (SQRTS_VAR)
	xi_max = get_xi_max_isr (generator%isr_kinematics%x, y)
	end select
	else
	if (generator%is_massive(emitter)) then
	xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y)
	else
	xi_max = get_xi_max_fsr (pp, q0, emitter)
	end if
	end if
	deallocate (pp)
	end associate
	end subroutine phs_fks_generator_compute_xi_max

	@ %def phs_fks_generator_compute_xi_max
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_xi_max_isr_factorized &
	=> phs_fks_generator_compute_xi_max_isr_factorized
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_xi_max_isr_factorized &
	(generator, i_phs, p)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p
	end subroutine phs_fks_generator_compute_xi_max_isr_factorized
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_xi_max_isr_factorized &
	(generator, i_phs, p)
	class(phs_fks_generator_t), intent(inout) :: generator
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p
	generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p)
	end subroutine phs_fks_generator_compute_xi_max_isr_factorized

	@ %def phs_fks_generator_compute_xi_max_isr_factorized
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: set_masses => phs_fks_generator_set_masses
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_set_masses &
	(generator, p, phs_identifiers)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	type(vector4_t), intent(in), dimension(:) :: p
	end subroutine phs_fks_generator_set_masses
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_set_masses &
	(generator, p, phs_identifiers)
	class(phs_fks_generator_t), intent(inout) :: generator
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	type(vector4_t), intent(in), dimension(:) :: p
	integer :: emitter, i_phs
	do i_phs = 1, size (phs_identifiers)
	emitter = phs_identifiers(i_phs)%emitter
	if (any (generator%emitters == emitter) .and. emitter > 0) then
	if (generator%is_massive (emitter) .and. emitter > generator%n_in) &
	generator%m2(emitter) = p(emitter)**2
	end if
	end do
	end subroutine phs_fks_generator_set_masses

	@ %def phs_fhs_generator_set_masses
	@
	<<PHS fks: public>>=
	public :: compute_y_from_emitter
	<<PHS fks: sub interfaces>>=
	module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, &
	massive, y_max, jac_rand, y, contributors, threshold)
	real(default), intent(in) :: r_y
	type(vector4_t), intent(in), dimension(:) :: p
	integer, intent(in) :: n_in
	integer, intent(in) :: emitter
	logical, intent(in) :: massive
	real(default), intent(in) :: y_max
	real(default), intent(inout) :: jac_rand
	real(default), intent(out) :: y
	integer, intent(in), dimension(:), allocatable, optional :: contributors
	logical, intent(in), optional :: threshold
	end subroutine compute_y_from_emitter
	<<PHS fks: procedures>>=
	module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, &
	massive, y_max, jac_rand, y, contributors, threshold)
	real(default), intent(in) :: r_y
	type(vector4_t), intent(in), dimension(:) :: p
	integer, intent(in) :: n_in
	integer, intent(in) :: emitter
	logical, intent(in) :: massive
	real(default), intent(in) :: y_max
	real(default), intent(inout) :: jac_rand
	real(default), intent(out) :: y
	integer, intent(in), dimension(:), allocatable, optional :: contributors
	logical, intent(in), optional :: threshold
	logical :: thr, resonance
	type(vector4_t) :: p_res, p_em
	real(default) :: q0
	type(lorentz_transformation_t) :: boost_to_resonance
	integer :: i
	real(default) :: beta, one_m_beta, one_p_beta
	thr = .false.; if (present (threshold)) thr = threshold
	p_res = vector4_null
	if (present (contributors)) then
	resonance = allocated (contributors)
	else
	resonance = .false.
	end if
	if (massive) then
	if (resonance) then
	do i = 1, size (contributors)
	p_res = p_res + p(contributors(i))
	end do
	else if (thr) then
	p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter)))
	else
	p_res = sum (p(1:n_in))
	end if
	q0 = p_res**1
	boost_to_resonance = inverse (boost (p_res, q0))
	p_em = boost_to_resonance * p(emitter)
	beta = beta_emitter (q0, p_em)
	one_m_beta = one - beta
	one_p_beta = one + beta
	y = one / beta * (one - one_p_beta * &
	exp ( - r_y * log(one_p_beta / one_m_beta)))
	jac_rand = jac_rand * &
	(one - beta * y) * log(one_p_beta / one_m_beta) / beta
	else
	y = (one - two * r_y) * y_max
	jac_rand = jac_rand * 3 * (one - y*2) y_max
	y = 1.5_default * (y - y**3 / 3)
	end if
	end subroutine compute_y_from_emitter

	@ %def compute_y_from_emitter
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_y_real_phs &
	(generator, r_y, p, phs_identifiers, &
	jac_rand, y, threshold)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r_y
	type(vector4_t), intent(in), dimension(:) :: p
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	real(default), intent(inout), dimension(:) :: jac_rand
	real(default), intent(out), dimension(:) :: y
	logical, intent(in), optional :: threshold
	end subroutine phs_fks_generator_compute_y_real_phs
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_y_real_phs &
	(generator, r_y, p, phs_identifiers, &
	jac_rand, y, threshold)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r_y
	type(vector4_t), intent(in), dimension(:) :: p
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	real(default), intent(inout), dimension(:) :: jac_rand
	real(default), intent(out), dimension(:) :: y
	logical, intent(in), optional :: threshold
	- real(default) :: beta, one_p_beta, one_m_beta
	- type(lorentz_transformation_t) :: boost_to_resonance
	- real(default) :: q0
	- type(vector4_t) :: p_res, p_em
	integer :: i, i_phs, emitter
	logical :: thr
	logical :: construct_massive_fsr
	construct_massive_fsr = .false.
	thr = .false.; if (present (threshold)) thr = threshold
	do i_phs = 1, size (phs_identifiers)
	emitter = phs_identifiers(i_phs)%emitter
	!!! We need this additional check because of decay phase spaces
	!!! t -> bW has a massive emitter at position 1, which should
	!!! not be treated here.
	construct_massive_fsr = emitter > generator%n_in
	if (construct_massive_fsr) construct_massive_fsr = &
	construct_massive_fsr .and. generator%is_massive (emitter)
	call compute_y_from_emitter (r_y, p, generator%n_in, &
	emitter, construct_massive_fsr, &
	generator%y_max, jac_rand(i_phs), y(i_phs), &
	phs_identifiers(i_phs)%contributors, threshold)
	end do
	end subroutine phs_fks_generator_compute_y_real_phs

	@ %def phs_fks_generator_compute_y_real_phs
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_y_mismatch &
	(generator, r_y, jac_rand, y, y_soft)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r_y
	real(default), intent(inout) :: jac_rand
	real(default), intent(out) :: y
	real(default), intent(out), dimension(:) :: y_soft
	end subroutine phs_fks_generator_compute_y_mismatch
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_y_mismatch &
	(generator, r_y, jac_rand, y, y_soft)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r_y
	real(default), intent(inout) :: jac_rand
	real(default), intent(out) :: y
	real(default), intent(out), dimension(:) :: y_soft
	y = (one - two * r_y) * generator%y_max
	jac_rand = jac_rand * 3 * (one - y*2) generator%y_max
	y = 1.5_default * (y - y**3 / 3)
	y_soft = y
	end subroutine phs_fks_generator_compute_y_mismatch

	@ %def phs_fks_generator_compute_y_mismatch
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_y_test => phs_fks_generator_compute_y_test
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_compute_y_test (generator, y)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(out), dimension(:):: y
	end subroutine phs_fks_generator_compute_y_test
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_compute_y_test (generator, y)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(out), dimension(:):: y
	select case (generator%mode)
	case (GEN_SOFT_LIMIT_TEST)
	y = y_test_soft
	case (GEN_COLL_LIMIT_TEST)
	y = y_test_coll
	case (GEN_ANTI_COLL_LIMIT_TEST)
	y = - y_test_coll
	case (GEN_SOFT_COLL_LIMIT_TEST)
	y = y_test_coll
	case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
	y = - y_test_coll
	end select
	end subroutine phs_fks_generator_compute_y_test

	@ %def phs_fks_generator_compute_y_test
	@
	<<PHS fks: public>>=
	public :: beta_emitter
	<<PHS fks: sub interfaces>>=
	pure module function beta_emitter (q0, p) result (beta)
	real(default), intent(in) :: q0
	type(vector4_t), intent(in) :: p
	real(default) :: beta
	end function beta_emitter
	<<PHS fks: procedures>>=
	pure module function beta_emitter (q0, p) result (beta)
	real(default), intent(in) :: q0
	type(vector4_t), intent(in) :: p
	real(default) :: beta
	real(default) :: m2, mrec2, k0_max
	m2 = p**2
	mrec2 = (q0 - p%p(0))2 - p%p(1)2 - p%p(2)2 - p%p(3)2
	k0_max = (q0*2 - mrec2 + m2) / (two q0)
	beta = sqrt(one - m2 / k0_max**2)
	end function beta_emitter

	@ %def beta_emitter
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde
	<<PHS fks: sub interfaces>>=
	pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r
	end subroutine phs_fks_generator_compute_xi_tilde
	<<PHS fks: procedures>>=
	pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: r
	real(default) :: deno
	associate (rad_var => generator%real_kinematics)
	select case (generator%mode)
	case (GEN_REAL_PHASE_SPACE)
	if (generator%singular_jacobian) then
	rad_var%xi_tilde = (one - generator%xi_min) - (one - r)*2 &
	(one - two * generator%xi_min)
	rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * &
	(one - two * generator%xi_min)
	else
	rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min)
	rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min)
	end if
	case (GEN_SOFT_MISMATCH)
	deno = one - r
	if (deno < tiny_13) deno = tiny_13
	rad_var%xi_mismatch = generator%xi_min + r / deno
	rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2
	case (GEN_SOFT_LIMIT_TEST)
	rad_var%xi_tilde = r * two * xi_tilde_test_soft
	rad_var%jac_rand = two * xi_tilde_test_soft
	case (GEN_COLL_LIMIT_TEST)
	rad_var%xi_tilde = xi_tilde_test_coll
	rad_var%jac_rand = xi_tilde_test_coll
	case (GEN_ANTI_COLL_LIMIT_TEST)
	rad_var%xi_tilde = xi_tilde_test_coll
	rad_var%jac_rand = xi_tilde_test_coll
	case (GEN_SOFT_COLL_LIMIT_TEST)
	rad_var%xi_tilde = r * two * xi_tilde_test_soft
	rad_var%jac_rand = two * xi_tilde_test_soft
	case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
	rad_var%xi_tilde = r * two * xi_tilde_test_soft
	rad_var%jac_rand = two * xi_tilde_test_soft
	end select
	end associate
	end subroutine phs_fks_generator_compute_xi_tilde

	@ %def phs_fks_generator_compute_xi_tilde
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: prepare_generation => phs_fks_generator_prepare_generation
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_prepare_generation (generator, &
	r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), dimension(3), intent(in) :: r_in
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	type(resonance_contributors_t), intent(in), dimension(:), optional :: &
	contributors
	integer, intent(in), optional :: i_con
	end subroutine phs_fks_generator_prepare_generation
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_prepare_generation (generator, &
	r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), dimension(3), intent(in) :: r_in
	integer, intent(in) :: i_phs, emitter
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	type(resonance_contributors_t), intent(in), dimension(:), optional :: &
	contributors
	integer, intent(in), optional :: i_con
	call generator%generate_radiation_variables (r_in, p_born, phs_identifiers)
	call generator%compute_xi_ref_momenta &
	(generator%real_kinematics%p_born_lab%phs_point(1)%get (), &
	contributors)
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs), i_con = i_con)
	end subroutine phs_fks_generator_prepare_generation

	@ %def phs_fks_generator_prepare_generation
	@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
	generate an FSR phase space. Note that the flag [[supply_xi_max]] is
	set to [[.false.]] because it is assumed that the upper bound on [[xi]]
	has already been taken into account during its generation.
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_fsr_from_xi_and_y => &
	phs_fks_generator_generate_fsr_from_xi_and_y
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_fsr_from_xi_and_y &
	(generator, xi, y, &
	phi, emitter, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: xi, y, phi
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_fsr_from_xi_and_y
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_fsr_from_xi_and_y &
	(generator, xi, y, &
	phi, emitter, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: xi, y, phi
	integer, intent(in) :: emitter, i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	associate (rad_var => generator%real_kinematics)
	rad_var%supply_xi_max = .false.
	rad_var%xi_tilde = xi
	rad_var%y(i_phs) = y
	rad_var%phi = phi
	end associate
	call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0))
	call generator%generate_fsr (emitter, i_phs, p_born, p_real)
	end subroutine phs_fks_generator_generate_fsr_from_xi_and_y

	@ %def phs_fks_generator_generate_fsr_from_xi_and_y
	@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
	generate the ISR phase space.
	For this, we need to overwrite all variables of the real kinematics
	dependent on $(\xi,y,\phi)$ that we need to compute [[p_real]].
	From the [[isr_kinematics]] we just need [[sqme_born]] and [[x]].
	Both do not depend on the real radiation so we can leave them as they are.
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: generate_isr_from_xi_and_y => &
	phs_fks_generator_generate_isr_from_xi_and_y
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
	(generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: xi, xi_max, y, phi
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	end subroutine phs_fks_generator_generate_isr_from_xi_and_y
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
	(generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
	class(phs_fks_generator_t), intent(inout) :: generator
	real(default), intent(in) :: xi, xi_max, y, phi
	integer, intent(in) :: i_phs
	type(vector4_t), intent(in), dimension(:) :: p_born
	type(vector4_t), intent(out), dimension(:) :: p_real
	associate (rad_var => generator%real_kinematics)
	rad_var%xi_max(i_phs) = xi_max
	rad_var%xi_tilde = xi / xi_max
	rad_var%y(i_phs) = y
	rad_var%phi = phi
	end associate
	call generator%generate_isr (i_phs, p_born, p_real)
	end subroutine phs_fks_generator_generate_isr_from_xi_and_y

	@ %def phs_fks_generator_generate_isr_from_xi_and_y
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: get_radiation_variables => &
	phs_fks_generator_get_radiation_variables
	<<PHS fks: sub interfaces>>=
	pure module subroutine phs_fks_generator_get_radiation_variables &
	(generator, i_phs, xi, y, phi)
	class(phs_fks_generator_t), intent(in) :: generator
	integer, intent(in) :: i_phs
	real(default), intent(out) :: xi, y
	real(default), intent(out), optional :: phi
	end subroutine phs_fks_generator_get_radiation_variables
	<<PHS fks: procedures>>=
	pure module subroutine phs_fks_generator_get_radiation_variables &
	(generator, i_phs, xi, y, phi)
	class(phs_fks_generator_t), intent(in) :: generator
	integer, intent(in) :: i_phs
	real(default), intent(out) :: xi, y
	real(default), intent(out), optional :: phi
	associate (rad_var => generator%real_kinematics)
	xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde
	y = rad_var%y(i_phs)
	if (present (phi)) phi = rad_var%phi
	end associate
	end subroutine phs_fks_generator_get_radiation_variables

	@ %def phs_fks_generator_get_radiation_variables
	@
	<<PHS fks: phs fks generator: TBP>>=
	procedure :: write => phs_fks_generator_write
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_generator_write (generator, unit)
	class(phs_fks_generator_t), intent(in) :: generator
	integer, intent(in), optional :: unit
	end subroutine phs_fks_generator_write
	<<PHS fks: procedures>>=
	module subroutine phs_fks_generator_write (generator, unit)
	class(phs_fks_generator_t), intent(in) :: generator
	integer, intent(in), optional :: unit
	integer :: u
	type(string_t) :: massive_phsp
	u = given_output_unit (unit); if (u < 0) return
	if (generator%massive_phsp) then
	massive_phsp = " massive "
	else
	massive_phsp = " massless "
	end if
	write (u, "(A)") char ("This is a generator for a" &
	// massive_phsp // "phase space")
	if (associated (generator%real_kinematics)) then
	call generator%real_kinematics%write ()
	else
	write (u, "(A)") "Warning: There are no real " // &
	"kinematics associated with this generator"
	end if
	call write_separator (u)
	write (u, "(A," // FMT_17 // ",1X)") "sqrts : ", generator%sqrts
	write (u, "(A," // FMT_17 // ",1X)") "E_gluon : ", generator%E_gluon
	write (u, "(A," // FMT_17 // ",1X)") "mrec2 : ", generator%mrec2
	end subroutine phs_fks_generator_write

	@ %def phs_fks_generator_write
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_compute_isr_kinematics (phs, r)
	class(phs_fks_t), intent(inout) :: phs
	real(default), intent(in) :: r
	end subroutine phs_fks_compute_isr_kinematics
	<<PHS fks: procedures>>=
	module subroutine phs_fks_compute_isr_kinematics (phs, r)
	class(phs_fks_t), intent(inout) :: phs
	real(default), intent(in) :: r
	if (.not. phs%config%lab_is_cm) then
	call phs%generator%compute_isr_kinematics &
	(r, phs%lt_cm_to_lab * phs%phs_wood_t%p)
	else
	call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p)
	end if
	end subroutine phs_fks_compute_isr_kinematics

	@ %def phs_fks_compute_isr_kinematics
	@
	<<PHS fks: phs fks: TBP>>=
	procedure :: final => phs_fks_final
	<<PHS fks: sub interfaces>>=
	module subroutine phs_fks_final (object)
	class(phs_fks_t), intent(inout) :: object
	end subroutine phs_fks_final
	<<PHS fks: procedures>>=
	module subroutine phs_fks_final (object)
	class(phs_fks_t), intent(inout) :: object
	call object%forest%final ()
	call object%generator%final ()
	end subroutine phs_fks_final

	@ %def phs_fks_final
	@
	<<PHS fks: procedures>>=
	subroutine filter_particles_from_resonances &
	(res_hist, exclusion_list, &
	model, res_hist_filtered)
	type(resonance_history_t), intent(in), dimension(:) :: res_hist
	type(string_t), intent(in), dimension(:) :: exclusion_list
	type(model_t), intent(in) :: model
	type(resonance_history_t), intent(out), dimension(:), allocatable :: &
	res_hist_filtered
	integer :: i_hist, i_flv, i_new, n_orig
	logical, dimension(size (res_hist)) :: to_filter
	type(flavor_t) :: flv
	to_filter = .false.
	n_orig = size (res_hist)
	do i_flv = 1, size (exclusion_list)
	call flv%init (exclusion_list (i_flv), model)
	do i_hist = 1, size (res_hist)
	if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true.
	end do
	end do
	allocate (res_hist_filtered (n_orig - count (to_filter)))
	i_new = 1
	do i_hist = 1, size (res_hist)
	if (.not. to_filter (i_hist)) then
	res_hist_filtered (i_new) = res_hist (i_hist)
	i_new = i_new + 1
	end if
	end do
	end subroutine filter_particles_from_resonances

	@ %def filter_particles_from_resonances
	@
	<<PHS fks: procedures>>=
	subroutine clean_resonance_histories &
	(res_hist, n_in, flv, res_hist_clean, success)
	type(resonance_history_t), intent(in), dimension(:) :: res_hist
	integer, intent(in) :: n_in
	integer, intent(in), dimension(:) :: flv
	type(resonance_history_t), intent(out), dimension(:), allocatable :: &
	res_hist_clean
	logical, intent(out) :: success
	integer :: i_hist
	type(resonance_history_t), dimension(:), allocatable :: &
	res_hist_colored, res_hist_contracted

	if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_init")
	if (debug_active (D_SUBTRACTION)) then
	call msg_debug (D_SUBTRACTION, "Original resonances:")
	do i_hist = 1, size(res_hist)
	call res_hist(i_hist)%write ()
	end do
	end if

	call remove_uncolored_resonances ()
	call contract_resonances (res_hist_colored, res_hist_contracted)
	call remove_subresonances (res_hist_contracted, res_hist_clean)
	!!! Here, we are still not sure whether we actually would rather use
	!!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean)
	if (debug_active (D_SUBTRACTION)) then
	call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ")
	do i_hist = 1, size (res_hist_clean)
	call res_hist_clean(i_hist)%write ()
	end do
	end if
	if (size (res_hist_clean) == 0) then
	call msg_warning ("No resonances found. Proceed in usual FKS mode.")
	success = .false.
	else
	success = .true.
	end if

	contains
	subroutine remove_uncolored_resonances ()
	type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp
	integer :: n_hist, nleg_out, n_removed
	integer :: i_res, i_hist
	n_hist = size (res_hist)
	nleg_out = size (flv) - n_in
	allocate (res_hist_tmp (n_hist))
	allocate (res_hist_colored (n_hist))
	do i_hist = 1, n_hist
	res_hist_tmp(i_hist) = res_hist(i_hist)
	call res_hist_tmp(i_hist)%add_offset (n_in)
	n_removed = 0
	do i_res = 1, res_hist_tmp(i_hist)%n_resonances
	associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed))
	if (.not. any (is_colored (flv (resonance%contributors%c))) &
	.or. size (resonance%contributors%c) == nleg_out) then
	call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed)
	n_removed = n_removed + 1
	end if
	end associate
	end do
	if (allocated (res_hist_tmp(i_hist)%resonances)) then
	if (any (res_hist_colored == res_hist_tmp(i_hist))) then
	cycle
	else
	do i_res = 1, res_hist_tmp(i_hist)%n_resonances
	associate (resonance => res_hist_tmp(i_hist)%resonances(i_res))
	call res_hist_colored(i_hist)%add_resonance (resonance)
	end associate
	end do
	end if
	end if
	end do
	end subroutine remove_uncolored_resonances

	subroutine contract_resonances (res_history_in, res_history_out)
	type(resonance_history_t), intent(in), dimension(:) :: res_history_in
	type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
	logical, dimension(:), allocatable :: i_non_zero
	integer :: n_hist_non_zero, n_hist
	integer :: i_hist_new
	n_hist = size (res_history_in); n_hist_non_zero = 0
	allocate (i_non_zero (n_hist))
	i_non_zero = .false.
	do i_hist = 1, n_hist
	if (res_history_in(i_hist)%n_resonances /= 0) then
	n_hist_non_zero = n_hist_non_zero + 1
	i_non_zero(i_hist) = .true.
	end if
	end do
	allocate (res_history_out (n_hist_non_zero))
	i_hist_new = 1
	do i_hist = 1, n_hist
	if (i_non_zero (i_hist)) then
	res_history_out (i_hist_new) = res_history_in (i_hist)
	i_hist_new = i_hist_new + 1
	end if
	end do
	end subroutine contract_resonances

	subroutine remove_subresonances (res_history_in, res_history_out)
	type(resonance_history_t), intent(in), dimension(:) :: res_history_in
	type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
	logical, dimension(:), allocatable :: i_non_sub_res
	integer :: n_hist, n_hist_non_sub_res
	integer :: i_hist1, i_hist2
	logical :: is_not_subres
	n_hist = size (res_history_in); n_hist_non_sub_res = 0
	allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false.
	do i_hist1 = 1, n_hist
	is_not_subres = .true.
	do i_hist2 = 1, n_hist
	if (i_hist1 == i_hist2) cycle
	is_not_subres = is_not_subres .and. &
	.not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1))
	end do
	if (is_not_subres) then
	n_hist_non_sub_res = n_hist_non_sub_res + 1
	i_non_sub_res (i_hist1) = .true.
	end if
	end do

	allocate (res_history_out (n_hist_non_sub_res))
	i_hist2 = 1
	do i_hist1 = 1, n_hist
	if (i_non_sub_res (i_hist1)) then
	res_history_out (i_hist2) = res_history_in (i_hist1)
	i_hist2 = i_hist2 + 1
	end if
	end do
	end subroutine remove_subresonances

	subroutine remove_multiple_resonances (res_history_in, res_history_out)
	type(resonance_history_t), intent(in), dimension(:) :: res_history_in
	type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
	integer :: n_hist, n_hist_single
	logical, dimension(:), allocatable :: i_hist_single
	integer :: i_hist, j
	n_hist = size (res_history_in)
	n_hist_single = 0
	allocate (i_hist_single (n_hist)); i_hist_single = .false.
	do i_hist = 1, n_hist
	if (res_history_in(i_hist)%n_resonances == 1) then
	n_hist_single = n_hist_single + 1
	i_hist_single(i_hist) = .true.
	end if
	end do

	allocate (res_history_out (n_hist_single))
	j = 1
	do i_hist = 1, n_hist
	if (i_hist_single(i_hist)) then
	res_history_out(j) = res_history_in(i_hist)
	j = j + 1
	end if
	end do
	end subroutine remove_multiple_resonances
	end subroutine clean_resonance_histories

	@ %def clean_resonance_histories
	@
	<<PHS fks: public>>=
	public :: get_filtered_resonance_histories
	<<PHS fks: sub interfaces>>=
	module subroutine get_filtered_resonance_histories &
	(phs_config, n_in, flv_state, model, excluded_resonances, &
	resonance_histories_filtered, success)
	type(phs_fks_config_t), intent(inout) :: phs_config
	integer, intent(in) :: n_in
	integer, intent(in), dimension(:,:), allocatable :: flv_state
	type(model_t), intent(in) :: model
	type(string_t), intent(in), dimension(:), allocatable :: &
	excluded_resonances
	type(resonance_history_t), intent(out), dimension(:), &
	allocatable :: resonance_histories_filtered
	logical, intent(out) :: success
	end subroutine get_filtered_resonance_histories
	<<PHS fks: procedures>>=
	module subroutine get_filtered_resonance_histories &
	(phs_config, n_in, flv_state, model, excluded_resonances, &
	resonance_histories_filtered, success)
	type(phs_fks_config_t), intent(inout) :: phs_config
	integer, intent(in) :: n_in
	integer, intent(in), dimension(:,:), allocatable :: flv_state
	type(model_t), intent(in) :: model
	type(string_t), intent(in), dimension(:), allocatable :: &
	excluded_resonances
	type(resonance_history_t), intent(out), dimension(:), &
	allocatable :: resonance_histories_filtered
	logical, intent(out) :: success
	type(resonance_history_t), dimension(:), allocatable :: resonance_histories
	type(resonance_history_t), dimension(:), allocatable :: &
	resonance_histories_clean!, resonance_histories_filtered
	allocate (resonance_histories (size (phs_config%get_resonance_histories ())))
	resonance_histories = phs_config%get_resonance_histories ()
	call clean_resonance_histories (resonance_histories, &
	n_in, flv_state (:,1), resonance_histories_clean, success)
	if (success .and. allocated (excluded_resonances)) then
	call filter_particles_from_resonances (resonance_histories_clean, &
	excluded_resonances, model, resonance_histories_filtered)
	else
	allocate (resonance_histories_filtered (size (resonance_histories_clean)))
	resonance_histories_filtered = resonance_histories_clean
	end if
	end subroutine get_filtered_resonance_histories

	@ %def get_filtered_resonance_histories
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsection{Unit tests}
	Test module for FKS phase space, followed by the corresponding implementation module.
	<<[[phs_fks_ut.f90]]>>=
	<<File header>>

	module phs_fks_ut
	use unit_tests
	use phs_fks_uti

	<<Standard module head>>

	<<PHS fks: public test>>

	contains

	<<PHS fks: test driver>>

	end module phs_fks_ut
	@ %def phs_fks_ut
	@
	<<[[phs_fks_uti.f90]]>>=
	<<File header>>

	module phs_fks_uti

	<<Use kinds>>
	use format_utils, only: write_separator, pac_fmt
	use format_defs, only: FMT_15, FMT_19
	use numeric_utils, only: nearly_equal
	use constants, only: tiny_07, zero, one, two
	use lorentz
	use phs_points, only: assignment(=)

	use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON
	use physics_defs, only: thr_leg

	use resonances, only: resonance_contributors_t
	use phs_fks

	<<Standard module head>>

	<<PHS fks: test declarations>>

	contains

	<<PHS fks: tests>>

	end module phs_fks_uti
	@ %def phs_fks_uti
	@ API: driver for the unit tests below.
	<<PHS fks: public test>>=
	public :: phs_fks_generator_test
	<<PHS fks: test driver>>=
	subroutine phs_fks_generator_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	call test(phs_fks_generator_1, "phs_fks_generator_1", &
	"Test the generation of FKS phase spaces", u, results)
	call test(phs_fks_generator_2, "phs_fks_generator_2", &
	"Test the generation of an ISR FKS phase space", u, results)
	call test(phs_fks_generator_3, "phs_fks_generator_3", &
	"Test the generation of a real phase space for decays", &
	u, results)
	call test(phs_fks_generator_4, "phs_fks_generator_4", &
	"Test the generation of an FSR phase space with "&
	&"conserved invariant resonance masses", u, results)
	call test(phs_fks_generator_5, "phs_fks_generator_5", &
	"Test on-shell projection of a Born phase space and the generation"&
	&" of a real phase-space from that", u, results)
	call test(phs_fks_generator_6, "phs_fks_generator_6", &
	"Test the generation of a real phase space for 1 -> 3 decays", &
	u, results)
	call test(phs_fks_generator_7, "phs_fks_generator_7", &
	"Test the generation of an ISR FKS phase space for fixed beam energy", &
	u, results)
	end subroutine phs_fks_generator_test

	@ %def phs_fks_generator_test
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_1
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_1 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	integer :: emitter, i_phs
	real(default) :: x1, x2, x3
	real(default), parameter :: sqrts = 250.0_default
	type(phs_identifier_t), dimension(2) :: phs_identifiers
	write (u, "(A)") "* Test output: phs_fks_generator_1"
	write (u, "(A)") "* Purpose: Create massless fsr phase space"
	write (u, "(A)")

	allocate (p_born (4))
	p_born(1)%p(0) = 125.0_default
	p_born(1)%p(1:2) = 0.0_default
	p_born(1)%p(3) = 125.0_default
	p_born(2)%p(0) = 125.0_default
	p_born(2)%p(1:2) = 0.0_default
	p_born(2)%p(3) = -125.0_default
	p_born(3)%p(0) = 125.0_default
	p_born(3)%p(1) = -39.5618_default
	p_born(3)%p(2) = -20.0791_default
	p_born(3)%p(3) = -114.6957_default
	p_born(4)%p(0) = 125.0_default
	p_born(4)%p(1:3) = -p_born(3)%p(1:3)

	allocate (generator%isr_kinematics)
	generator%n_in = 2
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()

	call generator%set_sqrts_hat (sqrts)

	write (u, "(A)") "* Use four-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "***********************"
	write (u, "(A)")

	x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
	write (u, "(A)" ) "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (4, 2, 2, 1)

	allocate (generator%emitters (2))
	generator%emitters(1) = 3; generator%emitters(2) = 4
	allocate (generator%m2 (4))
	generator%m2 = zero
	allocate (generator%is_massive (4))
	generator%is_massive(1:2) = .false.
	generator%is_massive(3:4) = .true.
	phs_identifiers(1)%emitter = 3
	phs_identifiers(2)%emitter = 4
	call generator%compute_xi_ref_momenta (p_born)
	call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs))
	end do
	write (u, "(A)") &
	"* With these, the following radiation variables have been produced:"
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
	write (u, "(A,F3.2)") "y: " , rad_var%y(1)
	write (u, "(A,F3.2)") "phi: ", rad_var%phi
	end associate
	call write_separator (u)
	write (u, "(A)") "Produce real momenta: "
	i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter

	allocate (p_real (5))
	call generator%generate_fsr (emitter, i_phs, p_born, p_real)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator (u)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_1"

	end subroutine phs_fks_generator_1

	@ %def phs_fks_generator_1
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_2
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_2 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	integer :: emitter, i_phs
	real(default) :: x1, x2, x3
	real(default), parameter :: sqrts_hadronic = 250.0_default
	type(phs_identifier_t), dimension(2) :: phs_identifiers
	write (u, "(A)") "* Test output: phs_fks_generator_2"
	write (u, "(A)") "* Purpose: Create massless ISR phase space"
	write (u, "(A)")


	allocate (p_born (4))
	p_born(1)%p(0) = 114.661_default
	p_born(1)%p(1:2) = 0.0_default
	p_born(1)%p(3) = 114.661_default
	p_born(2)%p(0) = 121.784_default
	p_born(2)%p(1:2) = 0.0_default
	p_born(2)%p(3) = -121.784_default
	p_born(3)%p(0) = 115.148_default
	p_born(3)%p(1) = -46.250_default
	p_born(3)%p(2) = -37.711_default
	p_born(3)%p(3) = 98.478_default
	p_born(4)%p(0) = 121.296_default
	p_born(4)%p(1:2) = -p_born(3)%p(1:2)
	p_born(4)%p(3) = -105.601_default

	phs_identifiers(1)%emitter = 1
	phs_identifiers(2)%emitter = 2

	allocate (generator%emitters (2))
	allocate (generator%isr_kinematics)
	generator%emitters(1) = 1; generator%emitters(2) = 2
	generator%sqrts = sqrts_hadronic
	allocate (generator%isr_kinematics%beam_energy(2))
	generator%isr_kinematics%beam_energy = sqrts_hadronic / two
	call generator%set_sqrts_hat (sqrts_hadronic)
	call generator%set_isr_kinematics (p_born)
	generator%n_in = 2
	generator%isr_kinematics%isr_mode = SQRTS_VAR
	call generator%set_xi_and_y_bounds ()
	write (u, "(A)") "* Use four-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "***********************"
	write (u, "(A)")

	x1=0.5_default; x2=0.25_default; x3=0.65_default
	write (u, "(A)" ) "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (4, 2, 2, 1)
	call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)

	allocate (generator%m2 (2))
	generator%m2(1) = 0._default; generator%m2(2) = 0._default
	allocate (generator%is_massive (4))
	generator%is_massive = .false.
	call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
	call generator%compute_xi_ref_momenta (p_born)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs))
	end do
	write (u, "(A)") &
	"* With these, the following radiation variables have been produced:"
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
	write (u, "(A,F3.2)") "y: " , rad_var%y(1)
	write (u, "(A,F3.2)") "phi: ", rad_var%phi
	end associate
	write (u, "(A)") "Initial-state momentum fractions: "
	associate (xb => generator%isr_kinematics%x)
	write (u, "(A,F3.2)") "x_born_plus: ", xb(1)
	write (u, "(A,F3.2)") "x_born_minus: ", xb(2)
	end associate
	call write_separator (u)
	write (u, "(A)") "Produce real momenta: "
	i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	allocate (p_real(5))
	call generator%generate_isr (i_phs, p_born, p_real)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator (u)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_2"

	end subroutine phs_fks_generator_2

	@ %def phs_fks_generator_2
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_3
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_3 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	real(default) :: x1, x2, x3
	real(default) :: mB, mW, mT
	integer :: i, emitter, i_phs
	type(phs_identifier_t), dimension(2) :: phs_identifiers

	write (u, "(A)") "* Test output: phs_fks_generator_3"
	write (u, "(A)") "* Puropse: Create real phase space for particle decays"
	write (u, "(A)")

	allocate (p_born(3))
	p_born(1)%p(0) = 172._default
	p_born(1)%p(1) = 0._default
	p_born(1)%p(2) = 0._default
	p_born(1)%p(3) = 0._default
	p_born(2)%p(0) = 104.72866679_default
	p_born(2)%p(1) = 45.028053213_default
	p_born(2)%p(2) = 29.450337581_default
	p_born(2)%p(3) = -5.910229156_default
	p_born(3)%p(0) = 67.271333209_default
	p_born(3)%p(1:3) = -p_born(2)%p(1:3)

	generator%n_in = 1
	allocate (generator%isr_kinematics)
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()

	mB = 4.2_default
	mW = 80.376_default
	mT = 172._default

	generator%sqrts = mT

	write (u, "(A)") "* Use three-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "**********************"
	write (u, "(A)")

	x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
	write (u, "(A)") "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (3, 2, 2, 1)
	call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)

	allocate (generator%emitters(2))
	generator%emitters(1) = 1
	generator%emitters(2) = 3
	allocate (generator%m2 (3), generator%is_massive(3))
	generator%m2(1) = mT**2
	generator%m2(2) = mW**2
	generator%m2(3) = mB**2
	generator%is_massive = .true.
	phs_identifiers(1)%emitter = 1
	phs_identifiers(2)%emitter = 3

	call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
	call generator%compute_xi_ref_momenta (p_born)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs))
	end do

	write (u, "(A)") &
	"* With these, the following radiation variables have been produced: "
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
	do i = 1, 2
	write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
	end do
	write (u, "(A,F4.2)") "phi: ", rad_var%phi
	end associate

	call write_separator (u)
	write (u, "(A)") "Produce real momenta via initial-state emission: "
	i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	allocate (p_real (4))
	call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator(u)
	write (u, "(A)") "Produce real momenta via final-state emisson: "
	i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	call generator%generate_fsr (emitter, i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_3"

	end subroutine phs_fks_generator_3

	@ %def phs_fks_generator_3
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_4
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_4 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	integer, dimension(:), allocatable :: emitters
	integer, dimension(:,:), allocatable :: resonance_lists
	type(resonance_contributors_t), dimension(2) :: alr_contributors
	real(default) :: x1, x2, x3
	real(default), parameter :: sqrts = 250.0_default
	integer, parameter :: nlegborn = 6
	integer :: i_phs, i_con, emitter
	real(default) :: m_inv_born, m_inv_real
	character(len=7) :: fmt
	type(phs_identifier_t), dimension(2) :: phs_identifiers

	call pac_fmt (fmt, FMT_19, FMT_15, .true.)

	write (u, "(A)") "* Test output: phs_fks_generator_4"
	write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances"
	write (u, "(A)")

	allocate (p_born (nlegborn))
	p_born(1)%p(0) = 250._default
	p_born(1)%p(1) = 0._default
	p_born(1)%p(2) = 0._default
	p_born(1)%p(3) = 250._default
	p_born(2)%p(0) = 250._default
	p_born(2)%p(1) = 0._default
	p_born(2)%p(2) = 0._default
	p_born(2)%p(3) = -250._default
	p_born(3)%p(0) = 145.91184486_default
	p_born(3)%p(1) = 50.39727589_default
	p_born(3)%p(2) = 86.74156041_default
	p_born(3)%p(3) = -69.03608748_default
	p_born(4)%p(0) = 208.1064784_default
	p_born(4)%p(1) = -44.07610020_default
	p_born(4)%p(2) = -186.34264578_default
	p_born(4)%p(3) = 13.48038407_default
	p_born(5)%p(0) = 26.25614471_default
	p_born(5)%p(1) = -25.12258068_default
	p_born(5)%p(2) = -1.09540228_default
	p_born(5)%p(3) = -6.27703505_default
	p_born(6)%p(0) = 119.72553196_default
	p_born(6)%p(1) = 18.80140499_default
	p_born(6)%p(2) = 100.69648766_default
	p_born(6)%p(3) = 61.83273846_default

	allocate (generator%isr_kinematics)
	generator%n_in = 2
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()

	call generator%set_sqrts_hat (sqrts)

	write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~"
	write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)"
	write (u, "(A)") "* Use four-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "******************************"
	write (u, "(A)")

	x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
	write (u, "(A)") "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (nlegborn, 2, 2, 2)

	allocate (generator%emitters (2))
	generator%emitters(1) = 5; generator%emitters(2) = 6
	allocate (generator%m2 (nlegborn))
	generator%m2 = p_born**2
	allocate (generator%is_massive (nlegborn))
	generator%is_massive (1:2) = .false.
	generator%is_massive (3:6) = .true.

	phs_identifiers(1)%emitter = 5
	phs_identifiers(2)%emitter = 6
	do i_phs = 1, 2
	allocate (phs_identifiers(i_phs)%contributors (2))
	end do
	allocate (resonance_lists (2, 2))
	resonance_lists (1,:) = [3,5]
	resonance_lists (2,:) = [4,6]
	!!! Here is obviously some redundance. Surely we can improve on this.
	do i_phs = 1, 2
	phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:)
	end do
	do i_con = 1, 2
	allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:))))
	alr_contributors(i_con)%c = resonance_lists(i_con,:)
	end do
	call generator%generate_radiation_variables &
	([x1, x2, x3], p_born, phs_identifiers)

	allocate (p_real(nlegborn + 1))
	call generator%compute_xi_ref_momenta (p_born, alr_contributors)
	!!! Keep the distinction between i_phs and i_con because in general,
	!!! they are not the same.
	do i_phs = 1, 2
	i_con = i_phs
	emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1,1X,A,I1,A,I1,A)") &
	"* Generate FSR phase space for emitter ", emitter, &
	"and resonance pair (", resonance_lists (i_con, 1), ",", &
	resonance_lists (i_con, 2), ")"
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs), i_con = i_con)
	call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator(u)
	write (u, "(A)") "* Check if resonance masses are conserved: "
	m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:))
	m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7)
	write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born
	write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real
	if (abs (m_inv_born - m_inv_real) < tiny_07) then
	write (u, "(A)") " Success! "
	else
	write (u, "(A)") " Failure! "
	end if
	call write_separator(u)
	call write_separator(u)
	end do
	deallocate (p_real)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_4"
	end subroutine phs_fks_generator_4

	@ %def phs_fks_generator_4
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_5
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_5 (u)
	use ttv_formfactors, only: init_parameters
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born, pb1
	type(vector4_t), dimension(:), allocatable :: p_born_onshell, pb1_os
	type(vector4_t), dimension(:), allocatable :: p_real
	real(default) :: x1, x2, x3
	real(default) :: mB, mW, mtop, mcheck
	integer :: i, emitter, i_phs
	type(phs_identifier_t), dimension(2) :: phs_identifiers
	type(lorentz_transformation_t) :: L_to_cms
	real(default), parameter :: sqrts = 360._default
	real(default), parameter :: momentum_tolerance = 1E-10_default
	real(default) :: mpole, gam_out

	write (u, "(A)") "* Test output: phs_fks_generator_5"
	write (u, "(A)") "* Puropse: Perform threshold on-shell projection of "
	write (u, "(A)") "* Born momenta and create a real phase-space "
	write (u, "(A)") "* point from those. "
	write (u, "(A)")

	allocate (p_born(6), p_born_onshell(6))
	p_born(1)%p(0) = sqrts / two
	p_born(1)%p(1:2) = zero
	p_born(1)%p(3) = sqrts / two
	p_born(2)%p(0) = sqrts / two
	p_born(2)%p(1:2) = zero
	p_born(2)%p(3) = -sqrts / two
	p_born(3)%p(0) = 117.1179139230_default
	p_born(3)%p(1) = 56.91215483880_default
	p_born(3)%p(2) = -40.02386013017_default
	p_born(3)%p(3) = -49.07634310496_default
	p_born(4)%p(0) = 98.91904548743_default
	p_born(4)%p(1) = 56.02241403836_default
	p_born(4)%p(2) = -8.302977504723_default
	p_born(4)%p(3) = -10.50293716131_default
	p_born(5)%p(0) = 62.25884689208_default
	p_born(5)%p(1) = -60.00786540278_default
	p_born(5)%p(2) = 4.753602375910_default
	p_born(5)%p(3) = 15.32916731546_default
	p_born(6)%p(0) = 81.70419369751_default
	p_born(6)%p(1) = -52.92670347439_default
	p_born(6)%p(2) = 43.57323525898_default
	p_born(6)%p(3) = 44.25011295081_default

	generator%n_in = 2
	allocate (generator%isr_kinematics)
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()

	mB = 4.2_default
	mW = 80.376_default
	mtop = 172._default

	generator%sqrts = sqrts

	!!! Dummy-initialization of the threshold model because generate_fsr_threshold
	!!! uses m1s_to_mpole to determine if it is above or below threshold.
	call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, &
	0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, &
	one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero)

	write (u, "(A)") "* Use four-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	call vector4_check_momentum_conservation &
	(p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
	write (u, "(A)") "**********************"
	write (u, "(A)")

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (7, 2, 2, 2)
	call generator%real_kinematics%init_onshell (7, 2)
	generator%real_kinematics%p_born_cms%phs_point(1) = p_born

	write (u, "(A)") "Get boost projection system -> CMS: "
	L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop)
	call L_to_cms%write (u, testflag = .true., ultra = .true.)
	write (u, "(A)") "**********************"
	write (u, "(A)")

	write (u, "(A)") "* Perform onshell-projection:"
	pb1 = generator%real_kinematics%p_born_cms%phs_point(1)
	call threshold_projection_born (mtop, L_to_cms, pb1, p_born_onshell)
	generator%real_kinematics%p_born_onshell%phs_point(1) = p_born_onshell

	call generator%real_kinematics%p_born_onshell%write &
	(1, unit = u, testflag = .true., ultra = .true.)

	pb1_os = generator%real_kinematics%p_born_onshell%phs_point(1)
	call check_phsp (pb1_os, 0)

	allocate (generator%emitters (2))
	generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR

	allocate (generator%m2 (6), generator%is_massive(6))
	generator%m2 = p_born**2
	generator%is_massive (1:2) = .false.
	generator%is_massive (3:6) = .true.

	phs_identifiers(1)%emitter = THR_POS_B
	phs_identifiers(2)%emitter = THR_POS_BBAR

	x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
	write (u, "(A)") "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3


	call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_ref_momenta_threshold (p_born_onshell)
	call generator%compute_xi_max (emitter, i_phs, p_born_onshell, &
	generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
	end do
	write (u, "(A)") &
	"* With these, the following radiation variables have been produced: "
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
	write (u, "(A)") "xi_max: "
	write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2)
	write (u, "(A)") "y: "
	write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2)
	write (u, "(A,F4.2)") "phi: ", rad_var%phi
	end associate

	call write_separator (u)
	write (u, "(A)") "* Produce real momenta from on-shell phase space: "
	allocate (p_real(7))
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real)
	call check_phsp (p_real, emitter)
	end do

	call write_separator(u)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_5"

	contains
	subroutine check_phsp (p, emitter)
	type(vector4_t), intent(inout), dimension(:) :: p
	integer, intent(in) :: emitter
	type(vector4_t) :: pp
	real(default) :: E_tot
	logical :: check
	write (u, "(A)") "* Check momentum conservation: "
	call vector4_check_momentum_conservation &
	(p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
	write (u, "(A)") "* Check invariant masses: "
	write (u, "(A)", advance = "no") "inv(W+, b, gl): "
	pp = p(THR_POS_WP) + p(THR_POS_B)
	if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON)
	if (nearly_equal (pp**1, mtop)) then
	write (u, "(A)") "CHECK"
	else
	write (u, "(A,F7.3)") "FAIL: ", pp**1
	end if
	write (u, "(A)", advance = "no") "inv(W-, bbar): "
	pp = p(THR_POS_WM) + p(THR_POS_BBAR)
	if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON)
	if (nearly_equal (pp**1, mtop)) then
	write (u, "(A)") "CHECK"
	else
	write (u, "(A,F7.3)") "FAIL: ", pp**1
	end if
	write (u, "(A)") "* Sum of energies equal to sqrts?"
	E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts)
	write (u, "(A,L1)") "Initial state: ", check
	if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
	if (emitter > 0) then
	E_tot = sum(p(3:7)%p(0))
	else
	E_tot = sum(p(3:6)%p(0))
	end if
	check = nearly_equal (E_tot, sqrts)
	write (u, "(A,L1)") "Final state : ", check
	if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
	call pacify (p, 1E-6_default)
	call vector4_write_set (p, u, testflag = .true., ultra = .true.)

	end subroutine check_phsp
	end subroutine phs_fks_generator_5

	@ %def phs_fks_generator_5
	@

	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_6
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_6 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	real(default) :: x1, x2, x3
	real(default) :: mB, mW, mT
	integer :: i, emitter, i_phs
	type(phs_identifier_t), dimension(2) :: phs_identifiers

	write (u, "(A)") "* Test output: phs_fks_generator_6"
	write (u, "(A)") "* Puropse: Create real phase space for particle decays"
	write (u, "(A)")

	allocate (p_born(4))
	p_born(1)%p(0) = 173.1_default
	p_born(1)%p(1) = zero
	p_born(1)%p(2) = zero
	p_born(1)%p(3) = zero
	p_born(2)%p(0) = 68.17074462929_default
	p_born(2)%p(1) = -37.32578717617_default
	p_born(2)%p(2) = 30.99675959336_default
	p_born(2)%p(3) = -47.70321718398_default
	p_born(3)%p(0) = 65.26639312326_default
	p_born(3)%p(1) = -1.362927648502_default
	p_born(3)%p(2) = -33.25327150840_default
	p_born(3)%p(3) = 56.14324922494_default
	p_born(4)%p(0) = 39.66286224745_default
	p_born(4)%p(1) = 38.68871482467_default
	p_born(4)%p(2) = 2.256511915049_default
	p_born(4)%p(3) = -8.440032040958_default

	generator%n_in = 1
	allocate (generator%isr_kinematics)
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()

	mB = 4.2_default
	mW = 80.376_default
	mT = 173.1_default

	generator%sqrts = mT

	write (u, "(A)") "* Use four-particle phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "**********************"
	write (u, "(A)")

	x1=0.5_default; x2=0.25_default; x3=0.6_default
	write (u, "(A)") "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (3, 2, 2, 1)
	call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)

	allocate (generator%emitters(2))
	generator%emitters(1) = 1
	generator%emitters(2) = 2
	allocate (generator%m2 (4), generator%is_massive(4))
	generator%m2(1) = mT**2
	generator%m2(2) = mB**2
	generator%m2(3) = zero
	generator%m2(4) = zero
	generator%is_massive(1:2) = .true.
	generator%is_massive(3:4) = .false.
	phs_identifiers(1)%emitter = 1
	phs_identifiers(2)%emitter = 2

	call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
	call generator%compute_xi_ref_momenta (p_born)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs))
	end do

	write (u, "(A)") &
	"* With these, the following radiation variables have been produced: "
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
	do i = 1, 2
	write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
	end do
	write (u, "(A,F4.2)") "phi: ", rad_var%phi
	end associate

	call write_separator (u)
	write (u, "(A)") "Produce real momenta via initial-state emission: "
	i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	allocate (p_real(5))
	call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator(u)
	write (u, "(A)") "Produce real momenta via final-state emisson: "
	i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	call generator%generate_fsr (emitter, i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_6"

	end subroutine phs_fks_generator_6

	@ %def phs_fks_generator_6
	@
	<<PHS fks: test declarations>>=
	public :: phs_fks_generator_7
	<<PHS fks: tests>>=
	subroutine phs_fks_generator_7 (u)
	integer, intent(in) :: u
	type(phs_fks_generator_t) :: generator
	type(vector4_t), dimension(:), allocatable :: p_born
	type(vector4_t), dimension(:), allocatable :: p_real
	real(default) :: x1, x2, x3
	integer :: i, emitter, i_phs
	type(phs_identifier_t), dimension(2) :: phs_identifiers
	real(default), parameter :: sqrts = 1000.0_default

	write (u, "(A)") "* Test output: phs_fks_generator_7"
	write (u, "(A)") "* Puropse: Create real phase space for scattering ISR"
	write (u, "(A)") "* keeping the beam energy fixed."
	write (u, "(A)")

	allocate (p_born(4))
	p_born(1)%p(0) = 500._default
	p_born(1)%p(1) = 0._default
	p_born(1)%p(2) = 0._default
	p_born(1)%p(3) = 500._default
	p_born(2)%p(0) = 500._default
	p_born(2)%p(1) = 0._default
	p_born(2)%p(2) = 0._default
	p_born(2)%p(3) = -500._default
	p_born(3)%p(0) = 500._default
	p_born(3)%p(1) = 11.275563070_default
	p_born(3)%p(2) = -13.588797663_default
	p_born(3)%p(3) = 486.93070588_default
	p_born(4)%p(0) = 500._default
	p_born(4)%p(1:3) = -p_born(3)%p(1:3)

	phs_identifiers(1)%emitter = 1
	phs_identifiers(2)%emitter = 2

	allocate (generator%emitters(2))
	generator%n_in = 2
	allocate (generator%isr_kinematics)
	generator%isr_kinematics%isr_mode = SQRTS_FIXED
	call generator%set_xi_and_y_bounds ()
	generator%emitters(1) = 1; generator%emitters(2) = 2
	generator%sqrts = sqrts

	write (u, "(A)") "* Use 2 -> 2 phase space containing: "
	call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
	write (u, "(A)") "**********************"
	write (u, "(A)")

	x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
	write (u, "(A)") "* Use random numbers: "
	write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
	"x1: ", x1, "x2: ", x2, "x3: ", x3

	allocate (generator%real_kinematics)
	call generator%real_kinematics%init (4, 2, 2, 1)
	call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)

	allocate (generator%m2 (4))
	generator%m2 = 0._default
	allocate (generator%is_massive(4))
	generator%is_massive = .false.
	call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
	call generator%compute_xi_ref_momenta (p_born)
	do i_phs = 1, 2
	emitter = phs_identifiers(i_phs)%emitter
	call generator%compute_xi_max (emitter, i_phs, p_born, &
	generator%real_kinematics%xi_max(i_phs))
	end do

	write (u, "(A)") &
	"* With these, the following radiation variables have been produced: "
	associate (rad_var => generator%real_kinematics)
	write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
	do i = 1, 2
	write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
	end do
	write (u, "(A,F4.2)") "phi: ", rad_var%phi
	end associate

	call write_separator (u)
	write (u, "(A)") "Produce real momenta via initial-state emission: "
	i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	allocate (p_real(5))
	call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	call write_separator(u)
	i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
	write (u, "(A,I1)") "emitter: ", emitter
	call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
	call pacify (p_real, 1E-6_default)
	call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
	write (u, "(A)")
	write (u, "(A)") "* Test output end: phs_fks_generator_7"

	end subroutine phs_fks_generator_7

	@ %def phs_fks_generator_3
	@
	\section{Dispatch}
	<<[[dispatch_phase_space.f90]]>>=
	<<File header>>

	module dispatch_phase_space

	<<Use kinds>>
	<<Use strings>>
	use variables, only: var_list_t
	use os_interface, only: os_data_t

	use sf_mappings, only: sf_channel_t
	use beam_structures, only: beam_structure_t
	use dispatch_beams, only: sf_prop_t, strfun_mode

	use mappings
	use phs_forests, only: phs_parameters_t
	use phs_base

	<<Standard module head>>

	<<Dispatch phs: public>>

	interface
	<<Dispatch phs: sub interfaces>>
	end interface

	end module dispatch_phase_space
	@ %def dispatch_phase_space
	@
	<<[[dispatch_phase_space_sub.f90]]>>=
	<<File header>>

	submodule (dispatch_phase_space) dispatch_phase_space_s

	use io_units, only: free_unit
	use diagnostics
	use phs_none
	use phs_single
	use phs_rambo
	use phs_wood
	use phs_fks

	implicit none

	contains

	<<Dispatch phs: procedures>>

	end submodule dispatch_phase_space_s

	@ %def dispatch_phase_space_s
	@
	Allocate a phase-space object according to the variable [[$phs_method]].
	<<Dispatch phs: public>>=
	public :: dispatch_phs
	<<Dispatch phs: sub interfaces>>=
	module subroutine dispatch_phs (phs, var_list, os_data, process_id, &
	mapping_defaults, phs_par, phs_method_in)
	class(phs_config_t), allocatable, intent(inout) :: phs
	type(var_list_t), intent(in) :: var_list
	type(os_data_t), intent(in) :: os_data
	type(string_t), intent(in) :: process_id
	type(mapping_defaults_t), intent(in), optional :: mapping_defaults
	type(phs_parameters_t), intent(in), optional :: phs_par
	type(string_t), intent(in), optional :: phs_method_in
	end subroutine dispatch_phs
	<<Dispatch phs: procedures>>=
	module subroutine dispatch_phs (phs, var_list, os_data, process_id, &
	mapping_defaults, phs_par, phs_method_in)
	class(phs_config_t), allocatable, intent(inout) :: phs
	type(var_list_t), intent(in) :: var_list
	type(os_data_t), intent(in) :: os_data
	type(string_t), intent(in) :: process_id
	type(mapping_defaults_t), intent(in), optional :: mapping_defaults
	type(phs_parameters_t), intent(in), optional :: phs_par
	type(string_t), intent(in), optional :: phs_method_in
	type(string_t) :: phs_method, phs_file, run_id
	logical :: use_equivalences, vis_channels, fatal_beam_decay
	integer :: u_phs
	logical :: exist
	if (present (phs_method_in)) then
	phs_method = phs_method_in
	else
	phs_method = &
	var_list%get_sval (var_str ("$phs_method"))
	end if
	phs_file = &
	var_list%get_sval (var_str ("$phs_file"))
	use_equivalences = &
	var_list%get_lval (var_str ("?use_vamp_equivalences"))
	vis_channels = &
	var_list%get_lval (var_str ("?vis_channels"))
	fatal_beam_decay = &
	var_list%get_lval (var_str ("?fatal_beam_decay"))
	run_id = &
	var_list%get_sval (var_str ("$run_id"))
	select case (char (phs_method))
	case ("none")
	allocate (phs_none_config_t :: phs)
	case ("single")
	allocate (phs_single_config_t :: phs)
	if (vis_channels) then
	call msg_warning ("Visualizing phase space channels not " // &
	"available for method 'single'.")
	end if
	case ("rambo")
	allocate (phs_rambo_config_t :: phs)
	if (vis_channels) &
	call msg_warning ("Visualizing phase space channels not " // &
	"available for method 'rambo'.")
	case ("fks")
	allocate (phs_fks_config_t :: phs)
	if (use_equivalences) then
	select type (phs)
	type is (phs_fks_config_t)
	call phs%enable_equivalences ()
	end select
	end if
	case ("wood", "default", "fast_wood")
	call dispatch_wood ()
	case default
	call msg_fatal ("Phase space: parameterization method '" &
	// char (phs_method) // "' not implemented")
	end select
	contains
	<<Dispatch phs: dispatch phs: procedures>>
	end subroutine dispatch_phs

	@ %def dispatch_phs
	@
	<<Dispatch phs: dispatch phs: procedures>>=
	subroutine dispatch_wood ()
	allocate (phs_wood_config_t :: phs)
	select type (phs)
	type is (phs_wood_config_t)
	if (phs_file /= "") then
	inquire (file = char (phs_file), exist = exist)
	if (exist) then
	call msg_message ("Phase space: reading configuration from '" &
	// char (phs_file) // "'")
	u_phs = free_unit ()
	open (u_phs, file = char (phs_file), &
	action = "read", status = "old")
	call phs%set_input (u_phs)
	else
	call msg_fatal ("Phase space: configuration file '" &
	// char (phs_file) // "' not found")
	end if
	end if
	if (present (phs_par)) &
	call phs%set_parameters (phs_par)
	if (use_equivalences) &
	call phs%enable_equivalences ()
	if (present (mapping_defaults)) &
	call phs%set_mapping_defaults (mapping_defaults)
	if (phs_method == "fast_wood") phs%use_cascades2 = .true.
	phs%vis_channels = vis_channels
	phs%fatal_beam_decay = fatal_beam_decay
	phs%os_data = os_data
	phs%run_id = run_id
	end select
	end subroutine dispatch_wood

	@
	@ Configure channel mappings, using some conditions
	from the phase space configuration. If there are no structure
	functions, we enable a default setup with a single (dummy)
	structure-function channel. Otherwise, we look at the channel
	collection that we got from the phase-space configuration step. Each
	entry should be translated into an independent structure-function
	channel, where typically there is one default entry, which could be
	mapped using a standard s-channel mapping if the structure function
	setup recommends this, and other entries with s-channel resonances.
	The latter need to be translated into global mappings from the
	structure-function chain.
	<<Dispatch phs: public>>=
	public :: dispatch_sf_channels
	<<Dispatch phs: sub interfaces>>=
	module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, &
	coll, var_list, sqrts, beam_structure)
	type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel
	type(string_t), intent(out) :: sf_string
	type(sf_prop_t), intent(in) :: sf_prop
	type(phs_channel_collection_t), intent(in) :: coll
	type(var_list_t), intent(in) :: var_list
	real(default), intent(in) :: sqrts
	type(beam_structure_t), intent(in) :: beam_structure
	end subroutine dispatch_sf_channels
	<<Dispatch phs: procedures>>=
	module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, &
	coll, var_list, sqrts, beam_structure)
	type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel
	type(string_t), intent(out) :: sf_string
	type(sf_prop_t), intent(in) :: sf_prop
	type(phs_channel_collection_t), intent(in) :: coll
	type(var_list_t), intent(in) :: var_list
	real(default), intent(in) :: sqrts
	type(beam_structure_t), intent(in) :: beam_structure
	type(beam_structure_t) :: beam_structure_tmp
	class(channel_prop_t), allocatable :: prop
	integer :: n_strfun, n_sf_channel, i
	logical :: sf_allow_s_mapping, circe1_map, circe1_generate
	logical :: s_mapping_enable, endpoint_mapping, power_mapping
	logical :: single_parameter
	integer, dimension(:), allocatable :: s_mapping, single_mapping
	real(default) :: s_mapping_power
	real(default) :: circe1_mapping_slope, endpoint_mapping_slope
	real(default) :: power_mapping_eps
	beam_structure_tmp = beam_structure
	call beam_structure_tmp%expand (strfun_mode)
	n_strfun = beam_structure_tmp%get_n_record ()
	sf_string = beam_structure_tmp%to_string (sf_only = .true.)
	sf_allow_s_mapping = &
	var_list%get_lval (var_str ("?sf_allow_s_mapping"))
	circe1_generate = &
	var_list%get_lval (var_str ("?circe1_generate"))
	circe1_map = &
	var_list%get_lval (var_str ("?circe1_map"))
	circe1_mapping_slope = &
	var_list%get_rval (var_str ("circe1_mapping_slope"))
	s_mapping_enable = .false.
	s_mapping_power = 1
	endpoint_mapping = .false.
	endpoint_mapping_slope = 1
	power_mapping = .false.
	single_parameter = .false.
	select case (char (sf_string))
	case ("", "[any particles]")
	case ("pdf_builtin, none", &
	"pdf_builtin_photon, none", &
	"none, pdf_builtin", &
	"none, pdf_builtin_photon", &
	"lhapdf, none", &
	"lhapdf_photon, none", &
	"none, lhapdf", &
	"none, lhapdf_photon")
	single_parameter = .true.
	case ("pdf_builtin, none => none, pdf_builtin", &
	"pdf_builtin, none => none, pdf_builtin_photon", &
	"pdf_builtin_photon, none => none, pdf_builtin", &
	"pdf_builtin_photon, none => none, pdf_builtin_photon", &
	"lhapdf, none => none, lhapdf", &
	"lhapdf, none => none, lhapdf_photon", &
	"lhapdf_photon, none => none, lhapdf", &
	"lhapdf_photon, none => none, lhapdf_photon")
	allocate (s_mapping (2), source = [1, 2])
	s_mapping_enable = .true.
	s_mapping_power = 2
	case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", &
	"pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", &
	"pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", &
	"pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa")
	allocate (s_mapping (2), source = [1, 2])
	s_mapping_enable = .true.
	s_mapping_power = 2
	case ("isr, none", &
	"none, isr")
	allocate (single_mapping (1), source = [1])
	single_parameter = .true.
	case ("isr, none => none, isr")
	allocate (s_mapping (2), source = [1, 2])
	power_mapping = .true.
	power_mapping_eps = minval (sf_prop%isr_eps)
	case ("isr, none => none, isr => epa, none => none, epa", &
	"isr, none => none, isr => ewa, none => none, ewa", &
	"isr, none => none, isr => ewa, none => none, epa", &
	"isr, none => none, isr => epa, none => none, ewa")
	allocate (s_mapping (2), source = [1, 2])
	power_mapping = .true.
	power_mapping_eps = minval (sf_prop%isr_eps)
	case ("circe1 => isr, none => none, isr => epa, none => none, epa", &
	"circe1 => isr, none => none, isr => ewa, none => none, ewa", &
	"circe1 => isr, none => none, isr => ewa, none => none, epa", &
	"circe1 => isr, none => none, isr => epa, none => none, ewa")
	if (circe1_generate) then
	allocate (s_mapping (2), source = [2, 3])
	else
	allocate (s_mapping (3), source = [1, 2, 3])
	endpoint_mapping = .true.
	endpoint_mapping_slope = circe1_mapping_slope
	end if
	power_mapping = .true.
	power_mapping_eps = minval (sf_prop%isr_eps)
	case ("pdf_builtin, none => none, isr", &
	"pdf_builtin_photon, none => none, isr", &
	"lhapdf, none => none, isr", &
	"lhapdf_photon, none => none, isr")
	allocate (single_mapping (1), source = [2])
	case ("isr, none => none, pdf_builtin", &
	"isr, none => none, pdf_builtin_photon", &
	"isr, none => none, lhapdf", &
	"isr, none => none, lhapdf_photon")
	allocate (single_mapping (1), source = [1])
	case ("epa, none", &
	"none, epa")
	allocate (single_mapping (1), source = [1])
	single_parameter = .true.
	case ("epa, none => none, epa")
	allocate (single_mapping (2), source = [1, 2])
	case ("epa, none => none, isr", &
	"isr, none => none, epa", &
	"ewa, none => none, isr", &
	"isr, none => none, ewa")
	allocate (single_mapping (2), source = [1, 2])
	case ("pdf_builtin, none => none, epa", &
	"pdf_builtin_photon, none => none, epa", &
	"lhapdf, none => none, epa", &
	"lhapdf_photon, none => none, epa")
	allocate (single_mapping (1), source = [2])
	case ("pdf_builtin, none => none, ewa", &
	"pdf_builtin_photon, none => none, ewa", &
	"lhapdf, none => none, ewa", &
	"lhapdf_photon, none => none, ewa")
	allocate (single_mapping (1), source = [2])
	case ("epa, none => none, pdf_builtin", &
	"epa, none => none, pdf_builtin_photon", &
	"epa, none => none, lhapdf", &
	"epa, none => none, lhapdf_photon")
	allocate (single_mapping (1), source = [1])
	case ("ewa, none => none, pdf_builtin", &
	"ewa, none => none, pdf_builtin_photon", &
	"ewa, none => none, lhapdf", &
	"ewa, none => none, lhapdf_photon")
	allocate (single_mapping (1), source = [1])
	case ("ewa, none", &
	"none, ewa")
	allocate (single_mapping (1), source = [1])
	single_parameter = .true.
	case ("ewa, none => none, ewa")
	allocate (single_mapping (2), source = [1, 2])
	case ("energy_scan, none => none, energy_scan")
	allocate (s_mapping (2), source = [1, 2])
	case ("sf_test_1, none => none, sf_test_1")
	allocate (s_mapping (2), source = [1, 2])
	case ("circe1")
	if (circe1_generate) then
	!!! no mapping
	else if (circe1_map) then
	allocate (s_mapping (1), source = [1])
	endpoint_mapping = .true.
	endpoint_mapping_slope = circe1_mapping_slope
	else
	allocate (s_mapping (1), source = [1])
	s_mapping_enable = .true.
	end if
	case ("circe1 => isr, none => none, isr")
	if (circe1_generate) then
	allocate (s_mapping (2), source = [2, 3])
	else
	allocate (s_mapping (3), source = [1, 2, 3])
	endpoint_mapping = .true.
	endpoint_mapping_slope = circe1_mapping_slope
	end if
	power_mapping = .true.
	power_mapping_eps = minval (sf_prop%isr_eps)
	case ("circe1 => isr, none", &
	"circe1 => none, isr")
	allocate (single_mapping (1), source = [2])
	case ("circe1 => epa, none => none, epa")
	if (circe1_generate) then
	allocate (single_mapping (2), source = [2, 3])
	else
	call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
	&only")
	end if
	case ("circe1 => ewa, none => none, ewa")
	if (circe1_generate) then
	allocate (single_mapping (2), source = [2, 3])
	else
	call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true &
	&only")
	end if
	case ("circe1 => epa, none", &
	"circe1 => none, epa")
	if (circe1_generate) then
	allocate (single_mapping (1), source = [2])
	else
	call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
	&only")
	end if
	case ("circe1 => epa, none => none, isr", &
	"circe1 => isr, none => none, epa", &
	"circe1 => ewa, none => none, isr", &
	"circe1 => isr, none => none, ewa")
	if (circe1_generate) then
	allocate (single_mapping (2), source = [2, 3])
	else
	call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
	&only")
	end if
	case ("circe2", &
	"gaussian", &
	"beam_events")
	!!! no mapping
	case ("circe2 => isr, none => none, isr", &
	"gaussian => isr, none => none, isr", &
	"beam_events => isr, none => none, isr")
	allocate (s_mapping (2), source = [2, 3])
	power_mapping = .true.
	power_mapping_eps = minval (sf_prop%isr_eps)
	case ("circe2 => isr, none", &
	"circe2 => none, isr", &
	"gaussian => isr, none", &
	"gaussian => none, isr", &
	"beam_events => isr, none", &
	"beam_events => none, isr")
	allocate (single_mapping (1), source = [2])
	case ("circe2 => epa, none => none, epa", &
	"gaussian => epa, none => none, epa", &
	"beam_events => epa, none => none, epa")
	allocate (single_mapping (2), source = [2, 3])
	case ("circe2 => epa, none", &
	"circe2 => none, epa", &
	"circe2 => ewa, none", &
	"circe2 => none, ewa", &
	"gaussian => epa, none", &
	"gaussian => none, epa", &
	"gaussian => ewa, none", &
	"gaussian => none, ewa", &
	"beam_events => epa, none", &
	"beam_events => none, epa", &
	"beam_events => ewa, none", &
	"beam_events => none, ewa")
	allocate (single_mapping (1), source = [2])
	case ("circe2 => epa, none => none, isr", &
	"circe2 => isr, none => none, epa", &
	"circe2 => ewa, none => none, isr", &
	"circe2 => isr, none => none, ewa", &
	"gaussian => epa, none => none, isr", &
	"gaussian => isr, none => none, epa", &
	"gaussian => ewa, none => none, isr", &
	"gaussian => isr, none => none, ewa", &
	"beam_events => epa, none => none, isr", &
	"beam_events => isr, none => none, epa", &
	"beam_events => ewa, none => none, isr", &
	"beam_events => isr, none => none, ewa")
	allocate (single_mapping (2), source = [2, 3])
	case ("energy_scan")
	case default
	call msg_fatal ("Beam structure: " &
	// char (sf_string) // " not supported")
	end select
	if (sf_allow_s_mapping .and. coll%n > 0) then
	n_sf_channel = coll%n
	allocate (sf_channel (n_sf_channel))
	do i = 1, n_sf_channel
	call sf_channel(i)%init (n_strfun)
	if (allocated (single_mapping)) then
	call sf_channel(i)%activate_mapping (single_mapping)
	end if
	if (allocated (prop)) deallocate (prop)
	call coll%get_entry (i, prop)
	if (allocated (prop)) then
	if (endpoint_mapping .and. power_mapping) then
	select type (prop)
	type is (resonance_t)
	call sf_channel(i)%set_eir_mapping (s_mapping, &
	a = endpoint_mapping_slope, eps = power_mapping_eps, &
	m = prop%mass / sqrts, w = prop%width / sqrts)
	type is (on_shell_t)
	call sf_channel(i)%set_eio_mapping (s_mapping, &
	a = endpoint_mapping_slope, eps = power_mapping_eps, &
	m = prop%mass / sqrts)
	end select
	else if (endpoint_mapping) then
	select type (prop)
	type is (resonance_t)
	call sf_channel(i)%set_epr_mapping (s_mapping, &
	a = endpoint_mapping_slope, &
	m = prop%mass / sqrts, w = prop%width / sqrts)
	type is (on_shell_t)
	call sf_channel(i)%set_epo_mapping (s_mapping, &
	a = endpoint_mapping_slope, &
	m = prop%mass / sqrts)
	end select
	else if (power_mapping) then
	select type (prop)
	type is (resonance_t)
	call sf_channel(i)%set_ipr_mapping (s_mapping, &
	eps = power_mapping_eps, &
	m = prop%mass / sqrts, w = prop%width / sqrts)
	type is (on_shell_t)
	call sf_channel(i)%set_ipo_mapping (s_mapping, &
	eps = power_mapping_eps, &
	m = prop%mass / sqrts)
	end select
	else if (allocated (s_mapping)) then
	select type (prop)
	type is (resonance_t)
	call sf_channel(i)%set_res_mapping (s_mapping, &
	m = prop%mass / sqrts, w = prop%width / sqrts, &
	single = single_parameter)
	type is (on_shell_t)
	call sf_channel(i)%set_os_mapping (s_mapping, &
	m = prop%mass / sqrts, &
	single = single_parameter)
	end select
	else if (allocated (single_mapping)) then
	select type (prop)
	type is (resonance_t)
	call sf_channel(i)%set_res_mapping (single_mapping, &
	m = prop%mass / sqrts, w = prop%width / sqrts, &
	single = single_parameter)
	type is (on_shell_t)
	call sf_channel(i)%set_os_mapping (single_mapping, &
	m = prop%mass / sqrts, &
	single = single_parameter)
	end select
	end if
	else if (endpoint_mapping .and. power_mapping) then
	call sf_channel(i)%set_ei_mapping (s_mapping, &
	a = endpoint_mapping_slope, eps = power_mapping_eps)
	else if (endpoint_mapping .and. .not. allocated (single_mapping)) then
	call sf_channel(i)%set_ep_mapping (s_mapping, &
	a = endpoint_mapping_slope)
	else if (power_mapping .and. .not. allocated (single_mapping)) then
	call sf_channel(i)%set_ip_mapping (s_mapping, &
	eps = power_mapping_eps)
	else if (s_mapping_enable .and. .not. allocated (single_mapping)) then
	call sf_channel(i)%set_s_mapping (s_mapping, &
	power = s_mapping_power)
	end if
	end do
	else if (sf_allow_s_mapping) then
	allocate (sf_channel (1))
	call sf_channel(1)%init (n_strfun)
	if (allocated (single_mapping)) then
	call sf_channel(1)%activate_mapping (single_mapping)
	else if (endpoint_mapping .and. power_mapping) then
	call sf_channel(i)%set_ei_mapping (s_mapping, &
	a = endpoint_mapping_slope, eps = power_mapping_eps)
	else if (endpoint_mapping) then
	call sf_channel(1)%set_ep_mapping (s_mapping, &
	a = endpoint_mapping_slope)
	else if (power_mapping) then
	call sf_channel(1)%set_ip_mapping (s_mapping, &
	eps = power_mapping_eps)
	else if (s_mapping_enable) then
	call sf_channel(1)%set_s_mapping (s_mapping, &
	power = s_mapping_power)
	end if
	else
	allocate (sf_channel (1))
	call sf_channel(1)%init (n_strfun)
	if (allocated (single_mapping)) then
	call sf_channel(1)%activate_mapping (single_mapping)
	end if
	end if
	end subroutine dispatch_sf_channels

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

	module dispatch_phs_ut
	use unit_tests
	use dispatch_phs_uti

	<<Standard module head>>

	<<Dispatch phs: public test>>

	contains

	<<Dispatch phs: test driver>>

	end module dispatch_phs_ut
	@ %def dispatch_phs_ut
	@
	<<[[dispatch_phs_uti.f90]]>>=
	<<File header>>

	module dispatch_phs_uti

	<<Use kinds>>
	<<Use strings>>
	use variables
	use io_units, only: free_unit
	use os_interface, only: os_data_t
	use process_constants
	use model_data
	use models
	use phs_base
	use phs_none
	use phs_forests
	use phs_wood
	use mappings
	use dispatch_phase_space

	<<Standard module head>>

	<<Dispatch phs: test declarations>>

	contains

	<<Dispatch phs: tests>>

	end module dispatch_phs_uti
	@ %def dispatch_phs_ut
	@ API: driver for the unit tests below.
	<<Dispatch phs: public test>>=
	public ::dispatch_phs_test
	<<Dispatch phs: test driver>>=
	subroutine dispatch_phs_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Dispatch phs: execute tests>>
	end subroutine dispatch_phs_test

	@ %def dispatch_phs_test
	@
	\subsubsection{Select type: phase-space configuration object}
	<<Dispatch phs: execute tests>>=
	call test (dispatch_phs_1, "dispatch_phs_1", &
	"phase-space configuration", &
	u, results)
	<<Dispatch phs: test declarations>>=
	public :: dispatch_phs_1
	<<Dispatch phs: tests>>=
	subroutine dispatch_phs_1 (u)
	integer, intent(in) :: u
	type(var_list_t) :: var_list
	class(phs_config_t), allocatable :: phs
	type(phs_parameters_t) :: phs_par
	type(os_data_t) :: os_data
	type(mapping_defaults_t) :: mapping_defs

	write (u, "(A)") "* Test output: dispatch_phs_1"
	write (u, "(A)") "* Purpose: select phase-space configuration method"
	write (u, "(A)")

	call var_list%init_defaults (0)

	write (u, "(A)") "* Allocate PHS as phs_none_t"
	write (u, "(A)")

	call var_list%set_string (&
	var_str ("$phs_method"), &
	var_str ("none"), is_known = .true.)
	call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	write (u, "(A)")
	write (u, "(A)") "* Allocate PHS as phs_single_t"
	write (u, "(A)")

	call var_list%set_string (&
	var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	write (u, "(A)")
	write (u, "(A)") "* Allocate PHS as phs_wood_t"
	write (u, "(A)")

	call var_list%set_string (&
	var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
	call phs%write (u)

	call phs%final ()
	deallocate (phs)

	write (u, "(A)")
	write (u, "(A)") "* Setting parameters for phs_wood_t"
	write (u, "(A)")

	phs_par%m_threshold_s = 123
	phs_par%m_threshold_t = 456
	phs_par%t_channel = 42
	phs_par%off_shell = 17
	phs_par%keep_nonresonant = .false.
	mapping_defs%energy_scale = 987
	mapping_defs%invariant_mass_scale = 654
	mapping_defs%momentum_transfer_scale = 321
	mapping_defs%step_mapping = .false.
	mapping_defs%step_mapping_exp = .false.
	mapping_defs%enable_s_mapping = .true.
	call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), &
	mapping_defs, phs_par)
	call phs%write (u)

	call phs%final ()

	call var_list%final ()

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

	end subroutine dispatch_phs_1

	@ %def dispatch_phs_1
	@
	\subsubsection{Phase-space configuration with file}
	<<Dispatch phs: execute tests>>=
	call test (dispatch_phs_2, "dispatch_phs_2", &
	"configure phase space using file", &
	u, results)
	<<Dispatch phs: test declarations>>=
	public :: dispatch_phs_2
	<<Dispatch phs: tests>>=
	subroutine dispatch_phs_2 (u)
	use phs_base_ut, only: init_test_process_data
	use phs_wood_ut, only: write_test_phs_file
	use phs_forests
	integer, intent(in) :: u
	type(var_list_t) :: var_list
	type(os_data_t) :: os_data
	type(process_constants_t) :: process_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model
	class(phs_config_t), allocatable :: phs
	integer :: u_phs

	write (u, "(A)") "* Test output: dispatch_phs_2"
	write (u, "(A)") "* Purpose: select 'wood' phase-space &
	&for a test process"
	write (u, "(A)") "* and read phs configuration from file"
	write (u, "(A)")

	write (u, "(A)") "* Initialize a process"
	write (u, "(A)")

	call var_list%init_defaults (0)
	call os_data%init ()
	call syntax_model_file_init ()
	call model_list%read_model &
	(var_str ("Test"), var_str ("Test.mdl"), os_data, model)

	call syntax_phs_forest_init ()

	call init_test_process_data (var_str ("dispatch_phs_2"), process_data)

	write (u, "(A)") "* Write phase-space file"

	u_phs = free_unit ()
	open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace")
	call write_test_phs_file (u_phs, var_str ("dispatch_phs_2"))
	close (u_phs)

	write (u, "(A)")
	write (u, "(A)") "* Allocate PHS as phs_wood_t"
	write (u, "(A)")

	call var_list%set_string (&
	var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call var_list%set_string (&
	var_str ("$phs_file"), &
	var_str ("dispatch_phs_2.phs"), is_known = .true.)
	call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2"))

	call phs%init (process_data, model)
	call phs%configure (sqrts = 1000._default)

	call phs%write (u)
	write (u, "(A)")
	select type (phs)
	type is (phs_wood_config_t)
	call phs%write_forest (u)
	end select

	call phs%final ()

	call var_list%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_phs_2

	@ %def dispatch_phs_2
	@

File Metadata

Mime Type: text/x-diff
Expires: Tue, Nov 19, 4:51 PM (1 d, 12 h)
Storage Engine: local-disk
Storage Format: Raw Data
Storage Handle: c4/78/458c06f4120240ed663ba1eb8363
Default Alt Text: (1 MB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions