No OneTemporary
Actions

Size

4 MB

Subscribers

None

View Options

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

	Index: trunk/src/variables/variables.nw
	===================================================================
	--- trunk/src/variables/variables.nw (revision 8777)
	+++ trunk/src/variables/variables.nw (revision 8778)
	@@ -1,7055 +1,7054 @@
	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: variables for processes
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Variables for Processes}
	\includemodulegraph{variables}

	This part introduces variables as user-controlled objects that
	influence the behavior of objects and calculations. Variables contain
	objects of intrinsic type or of a type as introced above.
	\begin{description}
	\item[variables]
	Store values of various kind, used by expressions and accessed by
	the command interface. This provides an implementation of the [[vars_t]]
	abstract type.
	\item[observables]
	Concrete implementation of observables (functions in the variable tree),
	applicable for \whizard.
	abstract type.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Variables: Implementation}
	The user interface deals with variables that are handled similarly to
	full-flegded programming languages. The system will add a lot of
	predefined variables (model parameters, flags, etc.) that are
	accessible to the user by the same methods.

	Variables can be of various type: logical (boolean/flag), integer,
	real (default precision), subevents (used in cut expressions),
	arrays of PDG codes (aliases for particles), strings. Furthermore, in
	cut expressions we have unary and binary observables, which are used
	like real parameters but behave like functions.
	<<[[variables.f90]]>>=
	<<File header>>

	module variables

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use numeric_utils, only: pacify
	use format_utils, only: pac_fmt
	use format_defs, only: FMT_12, FMT_19
	use constants, only: eps0
	use os_interface, only: paths_t
	use physics_defs, only: LAMBDA_QCD_REF
	use system_dependencies
	use fastjet !NODEP!
	use diagnostics
	use pdg_arrays
	use subevents

	use var_base

	<<Standard module head>>

	<<Variables: public>>

	<<Variables: parameters>>

	<<Variables: types>>

	<<Variables: interfaces>>

	contains

	<<Variables: procedures>>

	end module variables
	@ %def variables
	@
	\subsection{Variable list entries}
	Variable (and constant) values can be of one of the following types:
	<<Variables: parameters>>=
	integer, parameter, public :: V_NONE = 0, V_LOG = 1, V_INT = 2, V_REAL = 3
	integer, parameter, public :: V_CMPLX = 4, V_SEV = 5, V_PDG = 6, V_STR = 7
	integer, parameter, public :: V_OBS1_INT = 11, V_OBS2_INT = 12
	integer, parameter, public :: V_OBS1_REAL = 21, V_OBS2_REAL = 22
	integer, parameter, public :: V_OBSEV_INT = 13, V_OBSEV_REAL = 23
	integer, parameter, public :: V_UOBS1_INT = 31, V_UOBS2_INT = 32
	integer, parameter, public :: V_UOBS1_REAL = 41, V_UOBS2_REAL = 42

	@ %def V_NONE V_LOG V_INT V_REAL V_CMPLX V_PRT V_SEV V_PDG V_OBS1_INT
	@ %def V_OBS2_INT V_OBSEV_INT V_OBS1_REAL V_OBS2_REAL V_OBSEV_REAL
	@ %def V_UOBS1_INT V_UOBS2_INT V_UOBS1_REAL V_UOBS2_REAL
	@
	\subsubsection{The type}
	This is an entry in the variable list. It can be of any type; in
	each case only one value is allocated. It may be physically
	allocated upon creation, in which case [[is_allocated]] is true, or
	it may contain just a pointer to a value somewhere else, in which case
	[[is_allocated]] is false.

	The flag [[is_defined]] is set when the variable is given a value, even the
	undefined value. (Therefore it is distinct from [[is_known]].) This matters
	for variable declaration in the SINDARIN language. The variable is set up in
	the compilation step and initially marked as defined, but after compilation
	all variables are set undefined. Each variable becomes defined when it is
	explicitly set. The difference matters in loops.

	[[is_locked]] means that it cannot be given a value using the interface
	routines [[var_list_set_XXX]] below. It can only be initialized, or change
	automatically due to a side effect.

	[[is_copy]] means that this is a local copy of a global variable. The copy
	has a pointer to the original, which can be used to restore a previous value.

	[[is_intrinsic]] means that this variable is defined by the program, not by
	the user. Intrinsic variables cannot be (re)declared, but their values can be
	reset unless they are locked. [[is_user_var]] means that the variable has
	been declared by the user. It could be a new variable, or a local copy of an
	intrinsic variable.

	The flag [[is_known]] is a pointer which parallels the use of the
	value pointer. For pointer variables, it is set if the value should point to
	a known value. For ordinary variables, it should be true.

	The value is implemented as a set of alternative type-specific pointers. This
	emulates polymorphism, and it allows for actual pointer variables.
	Observable-type variables have function pointers as values, so they behave
	like macros. The functions make use of the particle objects accessible via
	the pointers [[prt1]] and [[prt2]].

	Finally, the [[next]] pointer indicates that we are making lists of
	variables. A more efficient implementation might switch to hashes or
	similar; the current implementation has $O(N)$ lookup.
	<<Variables: public>>=
	public :: var_entry_t
	<<Variables: types>>=
	type :: var_entry_t
	private
	integer :: type = V_NONE
	type(string_t) :: name
	logical :: is_allocated = .false.
	logical :: is_defined = .false.
	logical :: is_locked = .false.
	logical :: is_intrinsic = .false.
	logical :: is_user_var = .false.
	logical, pointer :: is_known => null ()
	logical, pointer :: lval => null ()
	integer, pointer :: ival => null ()
	real(default), pointer :: rval => null ()
	complex(default), pointer :: cval => null ()
	type(subevt_t), pointer :: pval => null ()
	type(pdg_array_t), pointer :: aval => null ()
	type(string_t), pointer :: sval => null ()
	procedure(obs_unary_int), nopass, pointer :: obs1_int => null ()
	procedure(obs_unary_real), nopass, pointer :: obs1_real => null ()
	procedure(obs_binary_int), nopass, pointer :: obs2_int => null ()
	procedure(obs_binary_real), nopass, pointer :: obs2_real => null ()
	procedure(obs_sev_int), nopass, pointer :: obsev_int => null ()
	procedure(obs_sev_real), nopass, pointer :: obsev_real => null ()
	type(prt_t), pointer :: prt1 => null ()
	type(prt_t), pointer :: prt2 => null ()
	type(var_entry_t), pointer :: next => null ()
	type(var_entry_t), pointer :: previous => null ()
	type(string_t) :: description
	end type var_entry_t

	@ %def var_entry_t
	@
	\subsubsection{Interfaces for the observable functions}
	<<Variables: public>>=
	public :: obs_unary_int
	public :: obs_unary_real
	public :: obs_binary_int
	public :: obs_binary_real
	public :: obs_sev_int
	public :: obs_sev_real
	<<Variables: interfaces>>=
	abstract interface
	function obs_unary_int (prt1) result (ival)
	import
	integer :: ival
	type(prt_t), intent(in) :: prt1
	end function obs_unary_int
	end interface
	abstract interface
	function obs_unary_real (prt1) result (rval)
	import
	real(default) :: rval
	type(prt_t), intent(in) :: prt1
	end function obs_unary_real
	end interface
	abstract interface
	function obs_binary_int (prt1, prt2) result (ival)
	import
	integer :: ival
	type(prt_t), intent(in) :: prt1, prt2
	end function obs_binary_int
	end interface
	abstract interface
	function obs_binary_real (prt1, prt2) result (rval)
	import
	real(default) :: rval
	type(prt_t), intent(in) :: prt1, prt2
	end function obs_binary_real
	end interface
	abstract interface
	function obs_sev_int (sev) result (ival)
	import
	integer :: ival
	type(subevt_t), intent(in) :: sev
	end function obs_sev_int
	end interface
	abstract interface
	function obs_sev_real (sev) result (rval)
	import
	real(default) :: rval
	type(subevt_t), intent(in) :: sev
	end function obs_sev_real
	end interface

	@ %def obs_unary_int obs_unary_real
	@ %def obs_binary_int obs_binary_real
	@ %def obs_sev_int obs_sev_real
	@
	\subsubsection{Initialization}
	Initialize an entry, optionally with a physical value. We also
	allocate the [[is_known]] flag and set it if the value is set.
	<<Variables: public>>=
	public :: var_entry_init_int
	<<Variables: procedures>>=
	subroutine var_entry_init_log (var, name, lval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: lval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_LOG
	allocate (var%lval, var%is_known)
	if (present (lval)) then
	var%lval = lval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_log

	subroutine var_entry_init_int (var, name, ival, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: ival
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_INT
	allocate (var%ival, var%is_known)
	if (present (ival)) then
	var%ival = ival
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_int

	subroutine var_entry_init_real (var, name, rval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	real(default), intent(in), optional :: rval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_REAL
	allocate (var%rval, var%is_known)
	if (present (rval)) then
	var%rval = rval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_real

	subroutine var_entry_init_cmplx (var, name, cval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	complex(default), intent(in), optional :: cval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_CMPLX
	allocate (var%cval, var%is_known)
	if (present (cval)) then
	var%cval = cval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_cmplx

	subroutine var_entry_init_subevt (var, name, pval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), optional :: pval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_SEV
	allocate (var%pval, var%is_known)
	if (present (pval)) then
	var%pval = pval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_subevt

	subroutine var_entry_init_pdg_array (var, name, aval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), optional :: aval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_PDG
	allocate (var%aval, var%is_known)
	if (present (aval)) then
	var%aval = aval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_pdg_array

	subroutine var_entry_init_string (var, name, sval, intrinsic, user)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: sval
	logical, intent(in), optional :: intrinsic, user
	var%name = name
	var%type = V_STR
	allocate (var%sval, var%is_known)
	if (present (sval)) then
	var%sval = sval
	var%is_defined = .true.
	var%is_known = .true.
	else
	var%is_known = .false.
	end if
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	if (present (user)) var%is_user_var = user
	var%is_allocated = .true.
	end subroutine var_entry_init_string

	@ %def var_entry_init_log
	@ %def var_entry_init_int
	@ %def var_entry_init_real
	@ %def var_entry_init_cmplx
	@ %def var_entry_init_subevt
	@ %def var_entry_init_pdg_array
	@ %def var_entry_init_string
	@ Initialize an entry with a pointer to the value and, for numeric/logical
	values, a pointer to the [[is_known]] flag.
	<<Variables: procedures>>=
	subroutine var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	logical, intent(in), target :: lval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_LOG
	var%lval => lval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_log_ptr

	subroutine var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	integer, intent(in), target :: ival
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_INT
	var%ival => ival
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_int_ptr

	subroutine var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	real(default), intent(in), target :: rval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_REAL
	var%rval => rval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_real_ptr

	subroutine var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	complex(default), intent(in), target :: cval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_CMPLX
	var%cval => cval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_cmplx_ptr

	subroutine var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), target :: aval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_PDG
	var%aval => aval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_pdg_array_ptr

	subroutine var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), target :: pval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_SEV
	var%pval => pval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_subevt_ptr

	subroutine var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	type(string_t), intent(in), target :: sval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: intrinsic
	var%name = name
	var%type = V_STR
	var%sval => sval
	var%is_known => is_known
	if (present (intrinsic)) var%is_intrinsic = intrinsic
	var%is_defined = .true.
	end subroutine var_entry_init_string_ptr

	@ %def var_entry_init_log_ptr
	@ %def var_entry_init_int_ptr
	@ %def var_entry_init_real_ptr
	@ %def var_entry_init_cmplx_ptr
	@ %def var_entry_init_pdg_array_ptr
	@ %def var_entry_init_subevt_ptr
	@ %def var_entry_init_string_ptr
	@ Initialize an entry with an observable. The procedure pointer is
	not yet set.
	<<Variables: procedures>>=
	subroutine var_entry_init_obs (var, name, type, prt1, prt2)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	integer, intent(in) :: type
	type(prt_t), intent(in), target :: prt1
	type(prt_t), intent(in), optional, target :: prt2
	var%type = type
	var%name = name
	var%prt1 => prt1
	if (present (prt2)) var%prt2 => prt2
	var%is_intrinsic = .true.
	var%is_defined = .true.
	end subroutine var_entry_init_obs

	subroutine var_entry_init_obs_sev (var, name, type, pval)
	type(var_entry_t), intent(out) :: var
	type(string_t), intent(in) :: name
	integer, intent(in) :: type
	type(subevt_t), intent(in), target :: pval
	var%type = type
	var%name = name
	var%pval => pval
	var%is_intrinsic = .true.
	var%is_defined = .true.
	end subroutine var_entry_init_obs_sev

	@ %def var_entry_init_obs var_entry_init_obs_sev
	@ Mark an entry as undefined it it is a user-defined variable object, so force
	re-initialization.
	<<Variables: procedures>>=
	subroutine var_entry_undefine (var)
	type(var_entry_t), intent(inout) :: var
	var%is_defined = .not. var%is_user_var
	var%is_known = var%is_defined .and. var%is_known
	end subroutine var_entry_undefine

	@ %def var_entry_undefine
	@ Clear an entry: mark it as unknown.
	<<Variables: procedures>>=
	subroutine var_entry_clear (var)
	type(var_entry_t), intent(inout) :: var
	var%is_known = .false.
	end subroutine var_entry_clear

	@ %def var_entry_clear
	@ Lock an entry: forbid resetting the entry after initialization.
	<<Variables: procedures>>=
	subroutine var_entry_lock (var, locked)
	type(var_entry_t), intent(inout) :: var
	logical, intent(in), optional :: locked
	if (present (locked)) then
	var%is_locked = locked
	else
	var%is_locked = .true.
	end if
	end subroutine var_entry_lock

	@ %def var_entry_lock
	@
	\subsubsection{Finalizer}
	<<Variables: procedures>>=
	subroutine var_entry_final (var)
	type(var_entry_t), intent(inout) :: var
	if (var%is_allocated) then
	select case (var%type)
	case (V_LOG); deallocate (var%lval)
	case (V_INT); deallocate (var%ival)
	case (V_REAL);deallocate (var%rval)
	case (V_CMPLX);deallocate (var%cval)
	case (V_SEV); deallocate (var%pval)
	case (V_PDG); deallocate (var%aval)
	case (V_STR); deallocate (var%sval)
	end select
	deallocate (var%is_known)
	var%is_allocated = .false.
	var%is_defined = .false.
	end if
	end subroutine var_entry_final

	@ %def var_entry_final
	@
	\subsubsection{Output}
	<<Variables: procedures>>=
	recursive subroutine var_entry_write (var, unit, model_name, &
	intrinsic, pacified, descriptions, ascii_output)
	type(var_entry_t), intent(in) :: var
	integer, intent(in), optional :: unit
	type(string_t), intent(in), optional :: model_name
	logical, intent(in), optional :: intrinsic
	logical, intent(in), optional :: pacified
	logical, intent(in), optional :: descriptions
	logical, intent(in), optional :: ascii_output
	type(string_t) :: col_string
	logical :: show_desc, ao
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	show_desc = .false.; if (present (descriptions)) show_desc = descriptions
	ao = .false.; if (present (ascii_output)) ao = ascii_output
	if (show_desc) then
	if (ao) then
	col_string = create_col_string (COL_BLUE)
	if (var%is_locked) then
	write (u, "(A)", advance="no") char (achar(27) // col_string) // &
	char (var%name) // achar(27) // "[0m" //" fixed-value="
	else
	write (u, "(A)", advance="no") char (achar(27) // col_string) // &
	char (var%name) // achar(27) // "[0m" //" default="
	end if
	col_string = create_col_string (COL_RED)
	write (u, "(A)", advance="no") char (achar(27) // col_string)
	call var_write_val (var, u, "no", pacified=.true.)
	write (u, "(A)") achar(27) // "[0m"
	write (u, "(A)") char (var%description)
	return
	else
	write (u, "(A)") "\item"
	write (u, "(A)", advance="no") "\ttt{" // char ( &
	replace (replace (var%name, "_", "\_", every=.true.), "$", "\$" )) // &
	"} "
	if (var%is_known) then
	if (var%is_locked) then
	write (u, "(A)", advance="no") "\qquad (fixed value: \ttt{"
	else
	write (u, "(A)", advance="no") "\qquad (default: \ttt{"
	end if
	call var_write_val (var, u, "no", pacified=.true., escape_tex=.true.)
	write (u, "(A)", advance="no") "})"
	end if
	write (u, "(A)") " \newline"
	write (u, "(A)") char (var%description)
	write (u, "(A)") "%%%%%"
	return
	end if
	end if
	if (present (intrinsic)) then
	if (var%is_intrinsic .neqv. intrinsic) return
	end if
	if (.not. var%is_defined) then
	write (u, "(A,1x)", advance="no") "[undefined]"
	end if
	if (.not. var%is_intrinsic) then
	write (u, "(A,1x)", advance="no") "[user variable]"
	end if
	if (present (model_name)) then
	write (u, "(A,A)", advance="no") char(model_name), "."
	end if
	write (u, "(A)", advance="no") char (var%name)
	if (var%is_locked) write (u, "(A)", advance="no") "*"
	if (var%is_allocated) then
	write (u, "(A)", advance="no") " = "
	else if (var%type /= V_NONE) then
	write (u, "(A)", advance="no") " => "
	end if
	call var_write_val (var, u, "yes", pacified)
	end subroutine var_entry_write

	@ %def var_entry_write
	@
	<<Variables: procedures>>=
	subroutine var_write_val (var, u, advance, pacified, escape_tex)
	type(var_entry_t), intent(in) :: var
	integer, intent(in) :: u
	character(*), intent(in) :: advance
	logical, intent(in), optional :: pacified, escape_tex
	logical :: num_pac, et
	real(default) :: rval
	complex(default) :: cval
	character(len=7) :: fmt
	call pac_fmt (fmt, FMT_19, FMT_12, pacified)
	num_pac = .false.; if (present (pacified)) num_pac = pacified
	et = .false.; if (present (escape_tex)) et = escape_tex
	select case (var%type)
	case (V_NONE); write (u, '()', advance=advance)
	case (V_LOG)
	if (var%is_known) then
	if (var%lval) then
	write (u, "(A)", advance=advance) "true"
	else
	write (u, "(A)", advance=advance) "false"
	end if
	else
	write (u, "(A)", advance=advance) "[unknown logical]"
	end if
	case (V_INT)
	if (var%is_known) then
	write (u, "(I0)", advance=advance) var%ival
	else
	write (u, "(A)", advance=advance) "[unknown integer]"
	end if
	case (V_REAL)
	if (var%is_known) then
	rval = var%rval
	if (num_pac) then
	call pacify (rval, 10 * eps0)
	end if
	write (u, "(" // fmt // ")", advance=advance) rval
	else
	write (u, "(A)", advance=advance) "[unknown real]"
	end if
	case (V_CMPLX)
	if (var%is_known) then
	cval = var%cval
	if (num_pac) then
	call pacify (cval, 10 * eps0)
	end if
	write (u, "('('," // fmt // ",','," // fmt // ",')')", advance=advance) cval
	else
	write (u, "(A)", advance=advance) "[unknown complex]"
	end if
	case (V_SEV)
	if (var%is_known) then
	- call subevt_write (var%pval, u, prefix=" ", &
	- pacified = pacified)
	+ call var%pval%write (u, prefix=" ", pacified = pacified)
	else
	write (u, "(A)", advance=advance) "[unknown subevent]"
	end if
	case (V_PDG)
	if (var%is_known) then
	- call pdg_array_write (var%aval, u); write (u, *)
	+ call var%aval%write (u); write (u, *)
	else
	write (u, "(A)", advance=advance) "[unknown PDG array]"
	end if
	case (V_STR)
	if (var%is_known) then
	if (et) then
	write (u, "(A)", advance=advance) '"' // char (replace ( &
	replace (var%sval, "_", "\_", every=.true.), "$", "\$" )) // '"'
	else
	write (u, "(A)", advance=advance) '"' // char (var%sval) // '"'
	end if
	else
	write (u, "(A)", advance=advance) "[unknown string]"
	end if
	case (V_OBS1_INT); write (u, "(A)", advance=advance) "[int] = unary observable"
	case (V_OBS2_INT); write (u, "(A)", advance=advance) "[int] = binary observable"
	case (V_OBSEV_INT); write (u, "(A)", advance=advance) "[int] = subeventary observable"
	case (V_OBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary observable"
	case (V_OBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary observable"
	case (V_OBSEV_REAL); write (u, "(A)", advance=advance) "[real] = subeventary observable"
	case (V_UOBS1_INT); write (u, "(A)", advance=advance) "[int] = unary user observable"
	case (V_UOBS2_INT); write (u, "(A)", advance=advance) "[int] = binary user observable"
	case (V_UOBS1_REAL); write (u, "(A)", advance=advance) "[real] = unary user observable"
	case (V_UOBS2_REAL); write (u, "(A)", advance=advance) "[real] = binary user observable"
	end select
	end subroutine var_write_val

	@ %def procedure
	@
	\subsubsection{Accessing contents}
	<<Variables: procedures>>=
	function var_entry_get_name (var) result (name)
	type(string_t) :: name
	type(var_entry_t), intent(in) :: var
	name = var%name
	end function var_entry_get_name

	function var_entry_get_type (var) result (type)
	integer :: type
	type(var_entry_t), intent(in) :: var
	type = var%type
	end function var_entry_get_type

	@ %def var_entry_get_name var_entry_get_type
	@ Return true if the variable is defined. This the case if it is allocated
	and known, or if it is a pointer.
	<<Variables: procedures>>=
	function var_entry_is_defined (var) result (defined)
	logical :: defined
	type(var_entry_t), intent(in) :: var
	defined = var%is_defined
	end function var_entry_is_defined

	@ %def var_entry_is_defined
	@ Return true if the variable is locked. If [[force]] is active,
	always return false.
	<<Variables: procedures>>=
	function var_entry_is_locked (var, force) result (locked)
	logical :: locked
	type(var_entry_t), intent(in) :: var
	logical, intent(in), optional :: force
	if (present (force)) then
	if (force) then
	locked = .false.; return
	end if
	end if
	locked = var%is_locked
	end function var_entry_is_locked

	@ %def var_entry_is_locked
	@ Return true if the variable is intrinsic
	<<Variables: procedures>>=
	function var_entry_is_intrinsic (var) result (flag)
	logical :: flag
	type(var_entry_t), intent(in) :: var
	flag = var%is_intrinsic
	end function var_entry_is_intrinsic

	@ %def var_entry_is_intrinsic
	@ Return components
	<<Variables: procedures>>=
	function var_entry_is_known (var) result (flag)
	logical :: flag
	type(var_entry_t), intent(in) :: var
	flag = var%is_known
	end function var_entry_is_known

	function var_entry_get_lval (var) result (lval)
	logical :: lval
	type(var_entry_t), intent(in) :: var
	lval = var%lval
	end function var_entry_get_lval

	function var_entry_get_ival (var) result (ival)
	integer :: ival
	type(var_entry_t), intent(in) :: var
	ival = var%ival
	end function var_entry_get_ival

	function var_entry_get_rval (var) result (rval)
	real(default) :: rval
	type(var_entry_t), intent(in) :: var
	rval = var%rval
	end function var_entry_get_rval

	function var_entry_get_cval (var) result (cval)
	complex(default) :: cval
	type(var_entry_t), intent(in) :: var
	cval = var%cval
	end function var_entry_get_cval

	function var_entry_get_aval (var) result (aval)
	type(pdg_array_t) :: aval
	type(var_entry_t), intent(in) :: var
	aval = var%aval
	end function var_entry_get_aval

	function var_entry_get_pval (var) result (pval)
	type(subevt_t) :: pval
	type(var_entry_t), intent(in) :: var
	pval = var%pval
	end function var_entry_get_pval

	function var_entry_get_sval (var) result (sval)
	type(string_t) :: sval
	type(var_entry_t), intent(in) :: var
	sval = var%sval
	end function var_entry_get_sval

	@ %def var_entry_get_lval
	@ %def var_entry_get_ival
	@ %def var_entry_get_rval
	@ %def var_entry_get_cval
	@ %def var_entry_get_aval
	@ %def var_entry_get_pval
	@ %def var_entry_get_sval
	@ Return pointers to components.
	<<Variables: procedures>>=
	function var_entry_get_known_ptr (var) result (ptr)
	logical, pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%is_known
	end function var_entry_get_known_ptr

	function var_entry_get_lval_ptr (var) result (ptr)
	logical, pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%lval
	end function var_entry_get_lval_ptr

	function var_entry_get_ival_ptr (var) result (ptr)
	integer, pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%ival
	end function var_entry_get_ival_ptr

	function var_entry_get_rval_ptr (var) result (ptr)
	real(default), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%rval
	end function var_entry_get_rval_ptr

	function var_entry_get_cval_ptr (var) result (ptr)
	complex(default), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%cval
	end function var_entry_get_cval_ptr

	function var_entry_get_pval_ptr (var) result (ptr)
	type(subevt_t), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%pval
	end function var_entry_get_pval_ptr

	function var_entry_get_aval_ptr (var) result (ptr)
	type(pdg_array_t), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%aval
	end function var_entry_get_aval_ptr

	function var_entry_get_sval_ptr (var) result (ptr)
	type(string_t), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%sval
	end function var_entry_get_sval_ptr

	@ %def var_entry_get_known_ptr
	@ %def var_entry_get_lval_ptr var_entry_get_ival_ptr var_entry_get_rval_ptr
	@ %def var_entry_get_cval_ptr var_entry_get_aval_ptr var_entry_get_pval_ptr
	@ %def var_entry_get_sval_ptr
	@ Furthermore,
	<<Variables: procedures>>=
	function var_entry_get_prt1_ptr (var) result (ptr)
	type(prt_t), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%prt1
	end function var_entry_get_prt1_ptr

	function var_entry_get_prt2_ptr (var) result (ptr)
	type(prt_t), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%prt2
	end function var_entry_get_prt2_ptr

	@ %def var_entry_get_prt1_ptr
	@ %def var_entry_get_prt2_ptr
	@ Subroutines might be safer than functions for procedure pointer transfer.
	<<Variables: procedures>>=
	subroutine var_entry_assign_obs1_int_ptr (ptr, var)
	procedure(obs_unary_int), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obs1_int
	end subroutine var_entry_assign_obs1_int_ptr

	subroutine var_entry_assign_obs1_real_ptr (ptr, var)
	procedure(obs_unary_real), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obs1_real
	end subroutine var_entry_assign_obs1_real_ptr

	subroutine var_entry_assign_obs2_int_ptr (ptr, var)
	procedure(obs_binary_int), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obs2_int
	end subroutine var_entry_assign_obs2_int_ptr

	subroutine var_entry_assign_obs2_real_ptr (ptr, var)
	procedure(obs_binary_real), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obs2_real
	end subroutine var_entry_assign_obs2_real_ptr

	subroutine var_entry_assign_obsev_int_ptr (ptr, var)
	procedure(obs_sev_int), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obsev_int
	end subroutine var_entry_assign_obsev_int_ptr

	subroutine var_entry_assign_obsev_real_ptr (ptr, var)
	procedure(obs_sev_real), pointer :: ptr
	type(var_entry_t), intent(in), target :: var
	ptr => var%obsev_real
	end subroutine var_entry_assign_obsev_real_ptr

	@ %def var_entry_assign_obs1_int_ptr var_entry_assign_obs1_real_ptr
	@ %def var_entry_assign_obs2_int_ptr var_entry_assign_obs2_real_ptr
	@ %def var_entry_assigbn_obsev_int_ptr var_entry_assign_obsev_real_ptr
	@
	\subsection{Setting values}
	Undefine the value.
	<<Variables: procedures>>=
	subroutine var_entry_clear_value (var)
	type(var_entry_t), intent(inout) :: var
	var%is_known = .false.
	end subroutine var_entry_clear_value

	@ %def var_entry_clear_value
	<<Variables: procedures>>=
	recursive subroutine var_entry_set_log &
	(var, lval, is_known, verbose, model_name)
	type(var_entry_t), intent(inout) :: var
	logical, intent(in) :: lval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%lval = lval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write (var, model_name=model_name)
	call var_entry_write (var, model_name=model_name, unit=u)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_log

	recursive subroutine var_entry_set_int &
	(var, ival, is_known, verbose, model_name)
	type(var_entry_t), intent(inout) :: var
	integer, intent(in) :: ival
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%ival = ival
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write (var, model_name=model_name)
	call var_entry_write (var, model_name=model_name, unit=u)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_int

	recursive subroutine var_entry_set_real &
	(var, rval, is_known, verbose, model_name, pacified)
	type(var_entry_t), intent(inout) :: var
	real(default), intent(in) :: rval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose, pacified
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%rval = rval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write &
	(var, model_name=model_name, pacified = pacified)
	call var_entry_write &
	(var, model_name=model_name, unit=u, pacified = pacified)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_real

	recursive subroutine var_entry_set_cmplx &
	(var, cval, is_known, verbose, model_name, pacified)
	type(var_entry_t), intent(inout) :: var
	complex(default), intent(in) :: cval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose, pacified
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%cval = cval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write &
	(var, model_name=model_name, pacified = pacified)
	call var_entry_write &
	(var, model_name=model_name, unit=u, pacified = pacified)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_cmplx

	recursive subroutine var_entry_set_pdg_array &
	(var, aval, is_known, verbose, model_name)
	type(var_entry_t), intent(inout) :: var
	type(pdg_array_t), intent(in) :: aval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%aval = aval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write (var, model_name=model_name)
	call var_entry_write (var, model_name=model_name, unit=u)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_pdg_array

	recursive subroutine var_entry_set_subevt &
	(var, pval, is_known, verbose, model_name)
	type(var_entry_t), intent(inout) :: var
	type(subevt_t), intent(in) :: pval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%pval = pval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write (var, model_name=model_name)
	call var_entry_write (var, model_name=model_name, unit=u)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_subevt

	recursive subroutine var_entry_set_string &
	(var, sval, is_known, verbose, model_name)
	type(var_entry_t), intent(inout) :: var
	type(string_t), intent(in) :: sval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	integer :: u
	u = logfile_unit ()
	var%sval = sval
	var%is_known = is_known
	var%is_defined = .true.
	if (present (verbose)) then
	if (verbose) then
	call var_entry_write (var, model_name=model_name)
	call var_entry_write (var, model_name=model_name, unit=u)
	if (u >= 0) flush (u)
	end if
	end if
	end subroutine var_entry_set_string

	@ %def var_entry_set_log
	@ %def var_entry_set_int
	@ %def var_entry_set_real
	@ %def var_entry_set_cmplx
	@ %def var_entry_set_pdg_array
	@ %def var_entry_set_subevt
	@ %def var_entry_set_string
	@
	<<Variables: public>>=
	public :: var_entry_set_description
	<<Variables: procedures>>=
	pure subroutine var_entry_set_description (var_entry, description)
	type(var_entry_t), intent(inout) :: var_entry
	type(string_t), intent(in) :: description
	var_entry%description = description
	end subroutine var_entry_set_description

	@ %def var_entry_set_description
	@
	\subsection{Copies and pointer variables}
	Initialize an entry with a copy of an existing variable entry. The
	copy is physically allocated with the same type as the original.
	<<Variables: procedures>>=
	subroutine var_entry_init_copy (var, original, user)
	type(var_entry_t), intent(out) :: var
	type(var_entry_t), intent(in), target :: original
	logical, intent(in), optional :: user
	type(string_t) :: name
	logical :: intrinsic
	name = var_entry_get_name (original)
	intrinsic = original%is_intrinsic
	select case (original%type)
	case (V_LOG)
	call var_entry_init_log (var, name, intrinsic=intrinsic, user=user)
	case (V_INT)
	call var_entry_init_int (var, name, intrinsic=intrinsic, user=user)
	case (V_REAL)
	call var_entry_init_real (var, name, intrinsic=intrinsic, user=user)
	case (V_CMPLX)
	call var_entry_init_cmplx (var, name, intrinsic=intrinsic, user=user)
	case (V_SEV)
	call var_entry_init_subevt (var, name, intrinsic=intrinsic, user=user)
	case (V_PDG)
	call var_entry_init_pdg_array (var, name, intrinsic=intrinsic, user=user)
	case (V_STR)
	call var_entry_init_string (var, name, intrinsic=intrinsic, user=user)
	end select
	end subroutine var_entry_init_copy

	@ %def var_entry_init_copy
	@ Copy the value of an entry. The target variable entry must be initialized
	correctly.
	<<Variables: procedures>>=
	subroutine var_entry_copy_value (var, original)
	type(var_entry_t), intent(inout) :: var
	type(var_entry_t), intent(in), target :: original
	if (var_entry_is_known (original)) then
	select case (original%type)
	case (V_LOG)
	call var_entry_set_log (var, var_entry_get_lval (original), .true.)
	case (V_INT)
	call var_entry_set_int (var, var_entry_get_ival (original), .true.)
	case (V_REAL)
	call var_entry_set_real (var, var_entry_get_rval (original), .true.)
	case (V_CMPLX)
	call var_entry_set_cmplx (var, var_entry_get_cval (original), .true.)
	case (V_SEV)
	call var_entry_set_subevt (var, var_entry_get_pval (original), .true.)
	case (V_PDG)
	call var_entry_set_pdg_array (var, var_entry_get_aval (original), .true.)
	case (V_STR)
	call var_entry_set_string (var, var_entry_get_sval (original), .true.)
	end select
	else
	call var_entry_clear (var)
	end if
	end subroutine var_entry_copy_value

	@ %def var_entry_copy_value
	@
	\subsection{Variable lists}
	\subsubsection{The type}
	Variable lists can be linked together. No initializer needed.
	They are deleted separately.
	<<Variables: public>>=
	public :: var_list_t
	<<Variables: types>>=
	type, extends (vars_t) :: var_list_t
	private
	type(var_entry_t), pointer :: first => null ()
	type(var_entry_t), pointer :: last => null ()
	type(var_list_t), pointer :: next => null ()
	contains
	<<Variables: var list: TBP>>
	end type var_list_t

	@ %def var_list_t
	@
	\subsubsection{Constructors}
	Implementation of the [[link]] deferred method. The implementation
	restricts itself to var lists of the same type. We might need to
	relax this constraint.
	<<Variables: var list: TBP>>=
	procedure :: link => var_list_link
	<<Variables: procedures>>=
	subroutine var_list_link (vars, target_vars)
	class(var_list_t), intent(inout) :: vars
	class(vars_t), intent(in), target :: target_vars
	select type (target_vars)
	type is (var_list_t)
	vars%next => target_vars
	class default
	call msg_bug ("var_list_link: unsupported target type")
	end select
	end subroutine var_list_link

	@ %def var_list_link
	@ Append a new entry to an existing list.
	<<Variables: procedures>>=
	subroutine var_list_append (var_list, var, verbose)
	type(var_list_t), intent(inout), target :: var_list
	type(var_entry_t), intent(inout), target :: var
	logical, intent(in), optional :: verbose
	if (associated (var_list%last)) then
	var%previous => var_list%last
	var_list%last%next => var
	else
	var%previous => null ()
	var_list%first => var
	end if
	var_list%last => var
	if (present (verbose)) then
	if (verbose) call var_entry_write (var)
	end if
	end subroutine var_list_append

	@ %def var_list_append
	@ Sort a list.
	<<Variables: var list: TBP>>=
	procedure :: sort => var_list_sort
	<<Variables: procedures>>=
	subroutine var_list_sort (var_list)
	class(var_list_t), intent(inout) :: var_list
	type(var_entry_t), pointer :: var, previous
	if (associated (var_list%first)) then
	var => var_list%first
	do while (associated (var))
	previous => var%previous
	do while (associated (previous))
	if (larger_var (previous, var)) then
	call var_list%swap_with_next (previous)
	end if
	previous => previous%previous
	end do
	var => var%next
	end do
	end if
	end subroutine var_list_sort

	@ %def var_list_sort
	@
	<<Variables: procedures>>=
	pure function larger_var (var1, var2) result (larger)
	logical :: larger
	type(var_entry_t), intent(in) :: var1, var2
	type(string_t) :: str1, str2
	str1 = replace (var1%name, "?", "")
	str1 = replace (str1, "$", "")
	str2 = replace (var2%name, "?", "")
	str2 = replace (str2, "$", "")
	larger = str1 > str2
	end function larger_var

	@ %def larger_var
	@
	<<Variables: var list: TBP>>=
	procedure :: get_previous => var_list_get_previous
	<<Variables: procedures>>=
	function var_list_get_previous (var_list, var_entry) result (previous)
	type(var_entry_t), pointer :: previous
	class(var_list_t), intent(in) :: var_list
	type(var_entry_t), intent(in) :: var_entry
	previous => var_list%first
	if (previous%name == var_entry%name) then
	previous => null ()
	else
	do while (associated (previous))
	if (previous%next%name == var_entry%name) exit
	previous => previous%next
	end do
	end if
	end function var_list_get_previous

	@ %def var_list_get_previous
	@
	<<Variables: var list: TBP>>=
	procedure :: swap_with_next => var_list_swap_with_next
	<<Variables: procedures>>=
	subroutine var_list_swap_with_next (var_list, var_entry)
	class(var_list_t), intent(inout) :: var_list
	type(var_entry_t), intent(in) :: var_entry
	type(var_entry_t), pointer :: previous, this, next, next_next
	previous => var_list%get_previous (var_entry)
	if (.not. associated (previous)) then
	this => var_list%first
	else
	this => previous%next
	end if
	next => this%next
	next_next => next%next
	if (associated (previous)) then
	previous%next => next
	next%previous => previous
	else
	var_list%first => next
	next%previous => null ()
	end if
	this%next => next_next
	if (associated (next_next)) then
	next_next%previous => this
	end if
	next%next => this
	this%previous => next
	if (.not. associated (next%next)) then
	var_list%last => next
	end if
	end subroutine var_list_swap_with_next

	@ %def var_list_swap_with_next
	@ Public methods for expanding the variable list (as subroutines)
	<<Variables: var list: TBP>>=
	generic :: append_log => var_list_append_log_s, var_list_append_log_c
	procedure, private :: var_list_append_log_s
	procedure, private :: var_list_append_log_c
	generic :: append_int => var_list_append_int_s, var_list_append_int_c
	procedure, private :: var_list_append_int_s
	procedure, private :: var_list_append_int_c
	generic :: append_real => var_list_append_real_s, var_list_append_real_c
	procedure, private :: var_list_append_real_s
	procedure, private :: var_list_append_real_c
	generic :: append_cmplx => var_list_append_cmplx_s, var_list_append_cmplx_c
	procedure, private :: var_list_append_cmplx_s
	procedure, private :: var_list_append_cmplx_c
	generic :: append_subevt => var_list_append_subevt_s, var_list_append_subevt_c
	procedure, private :: var_list_append_subevt_s
	procedure, private :: var_list_append_subevt_c
	generic :: append_pdg_array => var_list_append_pdg_array_s, var_list_append_pdg_array_c
	procedure, private :: var_list_append_pdg_array_s
	procedure, private :: var_list_append_pdg_array_c
	generic :: append_string => var_list_append_string_s, var_list_append_string_c
	procedure, private :: var_list_append_string_s
	procedure, private :: var_list_append_string_c
	<<Variables: public>>=
	public :: var_list_append_log
	public :: var_list_append_int
	public :: var_list_append_real
	public :: var_list_append_cmplx
	public :: var_list_append_subevt
	public :: var_list_append_pdg_array
	public :: var_list_append_string
	<<Variables: interfaces>>=
	interface var_list_append_log
	module procedure var_list_append_log_s
	module procedure var_list_append_log_c
	end interface
	interface var_list_append_int
	module procedure var_list_append_int_s
	module procedure var_list_append_int_c
	end interface
	interface var_list_append_real
	module procedure var_list_append_real_s
	module procedure var_list_append_real_c
	end interface
	interface var_list_append_cmplx
	module procedure var_list_append_cmplx_s
	module procedure var_list_append_cmplx_c
	end interface
	interface var_list_append_subevt
	module procedure var_list_append_subevt_s
	module procedure var_list_append_subevt_c
	end interface
	interface var_list_append_pdg_array
	module procedure var_list_append_pdg_array_s
	module procedure var_list_append_pdg_array_c
	end interface
	interface var_list_append_string
	module procedure var_list_append_string_s
	module procedure var_list_append_string_c
	end interface
	<<Variables: procedures>>=
	subroutine var_list_append_log_s &
	(var_list, name, lval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: lval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_log (var, name, lval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_log_s

	subroutine var_list_append_int_s &
	(var_list, name, ival, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: ival
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_int (var, name, ival, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_int_s

	subroutine var_list_append_real_s &
	(var_list, name, rval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	real(default), intent(in), optional :: rval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_real (var, name, rval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_real_s

	subroutine var_list_append_cmplx_s &
	(var_list, name, cval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	complex(default), intent(in), optional :: cval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_cmplx (var, name, cval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_cmplx_s

	subroutine var_list_append_subevt_s &
	(var_list, name, pval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), optional :: pval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_subevt (var, name, pval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_subevt_s

	subroutine var_list_append_pdg_array_s &
	(var_list, name, aval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), optional :: aval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_pdg_array (var, name, aval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_pdg_array_s

	subroutine var_list_append_string_s &
	(var_list, name, sval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: sval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_string (var, name, sval, intrinsic, user)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_string_s

	subroutine var_list_append_log_c &
	(var_list, name, lval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	logical, intent(in), optional :: lval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_log_s &
	(var_list, var_str (name), lval, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_log_c

	subroutine var_list_append_int_c &
	(var_list, name, ival, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	integer, intent(in), optional :: ival
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_int_s &
	(var_list, var_str (name), ival, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_int_c

	subroutine var_list_append_real_c &
	(var_list, name, rval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	real(default), intent(in), optional :: rval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_real_s &
	(var_list, var_str (name), rval, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_real_c

	subroutine var_list_append_cmplx_c &
	(var_list, name, cval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	complex(default), intent(in), optional :: cval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_cmplx_s &
	(var_list, var_str (name), cval, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_cmplx_c

	subroutine var_list_append_subevt_c &
	(var_list, name, pval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	type(subevt_t), intent(in), optional :: pval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_subevt_s &
	(var_list, var_str (name), pval, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_subevt_c

	subroutine var_list_append_pdg_array_c &
	(var_list, name, aval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	type(pdg_array_t), intent(in), optional :: aval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	call var_list_append_pdg_array_s &
	(var_list, var_str (name), aval, locked, verbose, &
	intrinsic, user, description)
	end subroutine var_list_append_pdg_array_c

	subroutine var_list_append_string_c &
	(var_list, name, sval, locked, verbose, intrinsic, user, description)
	class(var_list_t), intent(inout) :: var_list
	character(*), intent(in) :: name
	character(*), intent(in), optional :: sval
	logical, intent(in), optional :: locked, verbose, intrinsic, user
	type(string_t), intent(in), optional :: description
	if (present (sval)) then
	call var_list_append_string_s &
	(var_list, var_str (name), var_str (sval), &
	locked, verbose, intrinsic, user, description)
	else
	call var_list_append_string_s &
	(var_list, var_str (name), &
	locked=locked, verbose=verbose, intrinsic=intrinsic, &
	user=user, description=description)
	end if
	end subroutine var_list_append_string_c

	@ %def var_list_append_log
	@ %def var_list_append_int
	@ %def var_list_append_real
	@ %def var_list_append_cmplx
	@ %def var_list_append_subevt
	@ %def var_list_append_pdg_array
	@ %def var_list_append_string
	<<Variables: public>>=
	public :: var_list_append_log_ptr
	public :: var_list_append_int_ptr
	public :: var_list_append_real_ptr
	public :: var_list_append_cmplx_ptr
	public :: var_list_append_pdg_array_ptr
	public :: var_list_append_subevt_ptr
	public :: var_list_append_string_ptr
	<<Variables: var list: TBP>>=
	procedure :: append_log_ptr => var_list_append_log_ptr
	procedure :: append_int_ptr => var_list_append_int_ptr
	procedure :: append_real_ptr => var_list_append_real_ptr
	procedure :: append_cmplx_ptr => var_list_append_cmplx_ptr
	procedure :: append_pdg_array_ptr => var_list_append_pdg_array_ptr
	procedure :: append_subevt_ptr => var_list_append_subevt_ptr
	procedure :: append_string_ptr => var_list_append_string_ptr
	<<Variables: procedures>>=
	subroutine var_list_append_log_ptr &
	(var_list, name, lval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	logical, intent(in), target :: lval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_log_ptr (var, name, lval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_log_ptr

	subroutine var_list_append_int_ptr &
	(var_list, name, ival, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	integer, intent(in), target :: ival
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_int_ptr (var, name, ival, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_int_ptr

	subroutine var_list_append_real_ptr &
	(var_list, name, rval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	real(default), intent(in), target :: rval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_real_ptr (var, name, rval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_real_ptr

	subroutine var_list_append_cmplx_ptr &
	(var_list, name, cval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	complex(default), intent(in), target :: cval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_cmplx_ptr (var, name, cval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_cmplx_ptr

	subroutine var_list_append_pdg_array_ptr &
	(var_list, name, aval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), target :: aval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_pdg_array_ptr (var, name, aval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_pdg_array_ptr

	subroutine var_list_append_subevt_ptr &
	(var_list, name, pval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), target :: pval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_subevt_ptr (var, name, pval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_subevt_ptr

	subroutine var_list_append_string_ptr &
	(var_list, name, sval, is_known, locked, verbose, intrinsic, description)
	class(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(string_t), intent(in), target :: sval
	logical, intent(in), target :: is_known
	logical, intent(in), optional :: locked, verbose, intrinsic
	type(string_t), intent(in), optional :: description
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_string_ptr (var, name, sval, is_known, intrinsic)
	if (present (description)) call var_entry_set_description (var, description)
	if (present (locked)) call var_entry_lock (var, locked)
	call var_list_append (var_list, var, verbose)
	end subroutine var_list_append_string_ptr

	@ %def var_list_append_log_ptr
	@ %def var_list_append_int_ptr
	@ %def var_list_append_real_ptr
	@ %def var_list_append_cmplx_ptr
	@ %def var_list_append_pdg_array_ptr
	@ %def var_list_append_subevt_ptr
	@
	\subsubsection{Finalizer}
	Finalize, delete the list entry by entry. The link itself is kept
	intact. Follow link and delete recursively only if requested
	explicitly.
	<<Variables: var list: TBP>>=
	procedure :: final => var_list_final
	<<Variables: procedures>>=
	recursive subroutine var_list_final (vars, follow_link)
	class(var_list_t), intent(inout) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	vars%last => null ()
	do while (associated (vars%first))
	var => vars%first
	vars%first => var%next
	call var_entry_final (var)
	deallocate (var)
	end do
	if (present (follow_link)) then
	if (follow_link) then
	if (associated (vars%next)) then
	call vars%next%final (follow_link)
	deallocate (vars%next)
	end if
	end if
	end if
	end subroutine var_list_final

	@ %def var_list_final
	@
	\subsubsection{Output}
	Show variable list with precise control over options. E.g.,
	show only variables of a certain type.

	Many options, thus not an ordinary [[write]] method.
	<<Variables: public>>=
	public :: var_list_write
	<<Variables: var list: TBP>>=
	procedure :: write => var_list_write
	<<Variables: procedures>>=
	recursive subroutine var_list_write &
	(var_list, unit, follow_link, only_type, prefix, model_name, &
	intrinsic, pacified, descriptions, ascii_output)
	class(var_list_t), intent(in), target :: var_list
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: follow_link
	integer, intent(in), optional :: only_type
	character(*), intent(in), optional :: prefix
	type(string_t), intent(in), optional :: model_name
	logical, intent(in), optional :: intrinsic
	logical, intent(in), optional :: pacified
	logical, intent(in), optional :: descriptions
	logical, intent(in), optional :: ascii_output
	type(var_entry_t), pointer :: var
	integer :: u, length
	logical :: write_this, write_next
	u = given_output_unit (unit); if (u < 0) return
	if (present (prefix)) length = len (prefix)
	var => var_list%first
	if (associated (var)) then
	do while (associated (var))
	if (present (only_type)) then
	write_this = only_type == var%type
	else
	write_this = .true.
	end if
	if (write_this .and. present (prefix)) then
	if (prefix /= extract (var%name, 1, length)) &
	write_this = .false.
	end if
	if (write_this) then
	call var_entry_write &
	(var, unit, model_name=model_name, &
	intrinsic=intrinsic, pacified=pacified, &
	descriptions=descriptions, ascii_output=ascii_output)
	end if
	var => var%next
	end do
	end if
	if (present (follow_link)) then
	write_next = follow_link .and. associated (var_list%next)
	else
	write_next = associated (var_list%next)
	end if
	if (write_next) then
	call var_list_write (var_list%next, &
	unit, follow_link, only_type, prefix, model_name, &
	intrinsic, pacified)
	end if
	end subroutine var_list_write

	@ %def var_list_write
	@ Write only a certain variable.
	<<Variables: public>>=
	public :: var_list_write_var
	<<Variables: var list: TBP>>=
	procedure :: write_var => var_list_write_var
	<<Variables: procedures>>=
	recursive subroutine var_list_write_var &
	(var_list, name, unit, type, follow_link, &
	model_name, pacified, defined, descriptions, ascii_output)
	class(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: type
	logical, intent(in), optional :: follow_link
	type(string_t), intent(in), optional :: model_name
	logical, intent(in), optional :: pacified
	logical, intent(in), optional :: defined
	logical, intent(in), optional :: descriptions
	logical, intent(in), optional :: ascii_output
	type(var_entry_t), pointer :: var
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	var => var_list_get_var_ptr &
	(var_list, name, type, follow_link=follow_link, defined=defined)
	if (associated (var)) then
	call var_entry_write &
	(var, unit, model_name = model_name, &
	pacified = pacified, &
	descriptions=descriptions, ascii_output=ascii_output)
	else
	write (u, "(A)") char (name) // " = [undefined]"
	end if
	end subroutine var_list_write_var

	@ %def var_list_write_var
	@
	\subsection{Tools}
	Return a pointer to the variable list linked to by the current one.
	<<Variables: procedures>>=
	function var_list_get_next_ptr (var_list) result (next_ptr)
	type(var_list_t), pointer :: next_ptr
	type(var_list_t), intent(in) :: var_list
	next_ptr => var_list%next
	end function var_list_get_next_ptr

	@ %def var_list_get_next_ptr
	@ Used by [[eval_trees]]:
	Return a pointer to the variable with the requested name. If no such
	name exists, return a null pointer. In that case, try the next list
	if present, unless [[follow_link]] is unset. If [[defined]] is set, ignore
	entries that exist but are undefined.
	<<Variables: public>>=
	public :: var_list_get_var_ptr
	<<Variables: procedures>>=
	recursive function var_list_get_var_ptr &
	(var_list, name, type, follow_link, defined) result (var)
	type(var_entry_t), pointer :: var
	type(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: type
	logical, intent(in), optional :: follow_link, defined
	logical :: ignore_undef, search_next
	ignore_undef = .true.; if (present (defined)) ignore_undef = .not. defined
	var => var_list%first
	if (present (type)) then
	do while (associated (var))
	if (var%type == type) then
	if (var%name == name) then
	if (ignore_undef .or. var%is_defined) return
	end if
	end if
	var => var%next
	end do
	else
	do while (associated (var))
	if (var%name == name) then
	if (ignore_undef .or. var%is_defined) return
	end if
	var => var%next
	end do
	end if
	search_next = associated (var_list%next)
	if (present (follow_link)) &
	search_next = search_next .and. follow_link
	if (search_next) &
	var => var_list_get_var_ptr &
	(var_list%next, name, type, defined=defined)
	end function var_list_get_var_ptr

	@ %def var_list_get_var_ptr
	@ Return the variable type
	<<Variables: var list: TBP>>=
	procedure :: get_type => var_list_get_type
	<<Variables: procedures>>=
	function var_list_get_type (var_list, name, follow_link) result (type)
	class(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: follow_link
	integer :: type
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, follow_link=follow_link)
	if (associated (var)) then
	type = var%type
	else
	type = V_NONE
	end if
	end function var_list_get_type

	@ %def var_list_get_type
	@ Return true if the variable exists in the current list.
	<<Variables: var list: TBP>>=
	procedure :: contains => var_list_exists
	<<Variables: procedures>>=
	function var_list_exists (vars, name, follow_link) result (lval)
	logical :: lval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	lval = associated (var)
	end function var_list_exists

	@ %def var_list_exists
	@ Return true if the variable is declared as intrinsic. (This is not a
	property of the abstract [[vars_t]] type, and therefore the method is
	not inherited.)
	<<Variables: var list: TBP>>=
	procedure :: is_intrinsic => var_list_is_intrinsic
	<<Variables: procedures>>=
	function var_list_is_intrinsic (vars, name, follow_link) result (lval)
	logical :: lval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	lval = var%is_intrinsic
	else
	lval = .false.
	end if
	end function var_list_is_intrinsic

	@ %def var_list_is_intrinsic
	@ Return true if the value is known.
	<<Variables: var list: TBP>>=
	procedure :: is_known => var_list_is_known
	<<Variables: procedures>>=
	function var_list_is_known (vars, name, follow_link) result (lval)
	logical :: lval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	lval = var%is_known
	else
	lval = .false.
	end if
	end function var_list_is_known

	@ %def var_list_is_known
	@ Return true if the value is locked. (This is not a
	property of the abstract [[vars_t]] type, and therefore the method is
	not inherited.)
	<<Variables: var list: TBP>>=
	procedure :: is_locked => var_list_is_locked
	<<Variables: procedures>>=
	function var_list_is_locked (vars, name, follow_link) result (lval)
	logical :: lval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	lval = var_entry_is_locked (var)
	else
	lval = .false.
	end if
	end function var_list_is_locked

	@ %def var_list_is_locked
	@ Return several properties at once.
	<<Variables: var list: TBP>>=
	procedure :: get_var_properties => var_list_get_var_properties
	<<Variables: procedures>>=
	subroutine var_list_get_var_properties (vars, name, req_type, follow_link, &
	type, is_defined, is_known, is_locked)
	class(var_list_t), intent(in) :: vars
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: req_type
	logical, intent(in), optional :: follow_link
	integer, intent(out), optional :: type
	logical, intent(out), optional :: is_defined, is_known, is_locked
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, type=req_type, follow_link=follow_link)
	if (associated (var)) then
	if (present (type)) type = var_entry_get_type (var)
	if (present (is_defined)) is_defined = var_entry_is_defined (var)
	if (present (is_known)) is_known = var_entry_is_known (var)
	if (present (is_locked)) is_locked = var_entry_is_locked (var)
	else
	if (present (type)) type = V_NONE
	if (present (is_defined)) is_defined = .false.
	if (present (is_known)) is_known = .false.
	if (present (is_locked)) is_locked = .false.
	end if
	end subroutine var_list_get_var_properties

	@ %def var_list_get_var_properties
	@ Return the value, assuming that the type is correct. We consider only
	variable entries that have been [[defined]].

	For convenience, allow both variable and fixed-length (literal) strings.
	<<Variables: var list: TBP>>=
	procedure :: get_lval => var_list_get_lval
	procedure :: get_ival => var_list_get_ival
	procedure :: get_rval => var_list_get_rval
	procedure :: get_cval => var_list_get_cval
	procedure :: get_pval => var_list_get_pval
	procedure :: get_aval => var_list_get_aval
	procedure :: get_sval => var_list_get_sval
	<<Variables: procedures>>=
	function var_list_get_lval (vars, name, follow_link) result (lval)
	logical :: lval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_LOG, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	lval = var%lval
	else
	lval = .false.
	end if
	else
	lval = .false.
	end if
	end function var_list_get_lval

	function var_list_get_ival (vars, name, follow_link) result (ival)
	integer :: ival
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_INT, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	ival = var%ival
	else
	ival = 0
	end if
	else
	ival = 0
	end if
	end function var_list_get_ival

	function var_list_get_rval (vars, name, follow_link) result (rval)
	real(default) :: rval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_REAL, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	rval = var%rval
	else
	rval = 0
	end if
	else
	rval = 0
	end if
	end function var_list_get_rval

	function var_list_get_cval (vars, name, follow_link) result (cval)
	complex(default) :: cval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_CMPLX, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	cval = var%cval
	else
	cval = 0
	end if
	else
	cval = 0
	end if
	end function var_list_get_cval

	function var_list_get_aval (vars, name, follow_link) result (aval)
	type(pdg_array_t) :: aval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_PDG, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	aval = var%aval
	end if
	end if
	end function var_list_get_aval

	function var_list_get_pval (vars, name, follow_link) result (pval)
	type(subevt_t) :: pval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_SEV, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	pval = var%pval
	end if
	end if
	end function var_list_get_pval

	function var_list_get_sval (vars, name, follow_link) result (sval)
	type(string_t) :: sval
	type(string_t), intent(in) :: name
	class(var_list_t), intent(in) :: vars
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr &
	(vars, name, V_STR, follow_link, defined=.true.)
	if (associated (var)) then
	if (var_has_value (var)) then
	sval = var%sval
	else
	sval = ""
	end if
	else
	sval = ""
	end if
	end function var_list_get_sval

	@ %def var_list_get_lval
	@ %def var_list_get_ival
	@ %def var_list_get_rval
	@ %def var_list_get_cval
	@ %def var_list_get_pval
	@ %def var_list_get_aval
	@ %def var_list_get_sval
	@ Check for a valid value, given a pointer. Issue error messages if invalid.
	<<Variables: procedures>>=
	function var_has_value (var) result (valid)
	logical :: valid
	type(var_entry_t), pointer :: var
	if (associated (var)) then
	if (var%is_known) then
	valid = .true.
	else
	call msg_error ("The value of variable '" // char (var%name) &
	// "' is unknown but must be known at this point.")
	valid = .false.
	end if
	else
	call msg_error ("Variable '" // char (var%name) &
	// "' is undefined but must have a known value at this point.")
	valid = .false.
	end if
	end function var_has_value

	@ %def var_has_value
	@ Return pointers instead of values, including a pointer to the
	[[known]] entry.
	<<Variables: var list: TBP>>=
	procedure :: get_lptr => var_list_get_lptr
	procedure :: get_iptr => var_list_get_iptr
	procedure :: get_rptr => var_list_get_rptr
	procedure :: get_cptr => var_list_get_cptr
	procedure :: get_aptr => var_list_get_aptr
	procedure :: get_pptr => var_list_get_pptr
	procedure :: get_sptr => var_list_get_sptr
	<<Variables: procedures>>=
	subroutine var_list_get_lptr (var_list, name, lptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	logical, pointer, intent(out) :: lptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_LOG)
	if (associated (var)) then
	lptr => var_entry_get_lval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	lptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_lptr

	subroutine var_list_get_iptr (var_list, name, iptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	integer, pointer, intent(out) :: iptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_INT)
	if (associated (var)) then
	iptr => var_entry_get_ival_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	iptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_iptr

	subroutine var_list_get_rptr (var_list, name, rptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	real(default), pointer, intent(out) :: rptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_REAL)
	if (associated (var)) then
	rptr => var_entry_get_rval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	rptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_rptr

	subroutine var_list_get_cptr (var_list, name, cptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	complex(default), pointer, intent(out) :: cptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_CMPLX)
	if (associated (var)) then
	cptr => var_entry_get_cval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	cptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_cptr

	subroutine var_list_get_aptr (var_list, name, aptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	type(pdg_array_t), pointer, intent(out) :: aptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_PDG)
	if (associated (var)) then
	aptr => var_entry_get_aval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	aptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_aptr

	subroutine var_list_get_pptr (var_list, name, pptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	type(subevt_t), pointer, intent(out) :: pptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_SEV)
	if (associated (var)) then
	pptr => var_entry_get_pval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	pptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_pptr

	subroutine var_list_get_sptr (var_list, name, sptr, known)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	type(string_t), pointer, intent(out) :: sptr
	logical, pointer, intent(out), optional :: known
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_STR)
	if (associated (var)) then
	sptr => var_entry_get_sval_ptr (var)
	if (present (known)) known => var_entry_get_known_ptr (var)
	else
	sptr => null ()
	if (present (known)) known => null ()
	end if
	end subroutine var_list_get_sptr

	@ %def var_list_get_lptr
	@ %def var_list_get_iptr
	@ %def var_list_get_rptr
	@ %def var_list_get_cptr
	@ %def var_list_get_aptr
	@ %def var_list_get_pptr
	@ %def var_list_get_sptr
	@
	This bunch of methods handles the procedure-pointer cases.
	<<Variables: var list: TBP>>=
	procedure :: get_obs1_iptr => var_list_get_obs1_iptr
	procedure :: get_obs2_iptr => var_list_get_obs2_iptr
	procedure :: get_obsev_iptr => var_list_get_obsev_iptr
	procedure :: get_obs1_rptr => var_list_get_obs1_rptr
	procedure :: get_obs2_rptr => var_list_get_obs2_rptr
	procedure :: get_obsev_rptr => var_list_get_obsev_rptr
	<<Variables: procedures>>=
	subroutine var_list_get_obs1_iptr (var_list, name, obs1_iptr, p1)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_unary_int), pointer, intent(out) :: obs1_iptr
	type(prt_t), pointer, intent(out) :: p1
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBS1_INT)
	if (associated (var)) then
	call var_entry_assign_obs1_int_ptr (obs1_iptr, var)
	p1 => var_entry_get_prt1_ptr (var)
	else
	obs1_iptr => null ()
	p1 => null ()
	end if
	end subroutine var_list_get_obs1_iptr

	subroutine var_list_get_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_binary_int), pointer, intent(out) :: obs2_iptr
	type(prt_t), pointer, intent(out) :: p1, p2
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBS2_INT)
	if (associated (var)) then
	call var_entry_assign_obs2_int_ptr (obs2_iptr, var)
	p1 => var_entry_get_prt1_ptr (var)
	p2 => var_entry_get_prt2_ptr (var)
	else
	obs2_iptr => null ()
	p1 => null ()
	p2 => null ()
	end if
	end subroutine var_list_get_obs2_iptr

	subroutine var_list_get_obsev_iptr (var_list, name, obsev_iptr, pval)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_sev_int), pointer, intent(out) :: obsev_iptr
	type(subevt_t), pointer, intent(out) :: pval
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBSEV_INT)
	if (associated (var)) then
	call var_entry_assign_obsev_int_ptr (obsev_iptr, var)
	pval => var_entry_get_pval_ptr (var)
	else
	obsev_iptr => null ()
	pval => null ()
	end if
	end subroutine var_list_get_obsev_iptr

	subroutine var_list_get_obs1_rptr (var_list, name, obs1_rptr, p1)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_unary_real), pointer, intent(out) :: obs1_rptr
	type(prt_t), pointer, intent(out) :: p1
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBS1_REAL)
	if (associated (var)) then
	call var_entry_assign_obs1_real_ptr (obs1_rptr, var)
	p1 => var_entry_get_prt1_ptr (var)
	else
	obs1_rptr => null ()
	p1 => null ()
	end if
	end subroutine var_list_get_obs1_rptr

	subroutine var_list_get_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_binary_real), pointer, intent(out) :: obs2_rptr
	type(prt_t), pointer, intent(out) :: p1, p2
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBS2_REAL)
	if (associated (var)) then
	call var_entry_assign_obs2_real_ptr (obs2_rptr, var)
	p1 => var_entry_get_prt1_ptr (var)
	p2 => var_entry_get_prt2_ptr (var)
	else
	obs2_rptr => null ()
	p1 => null ()
	p2 => null ()
	end if
	end subroutine var_list_get_obs2_rptr

	subroutine var_list_get_obsev_rptr (var_list, name, obsev_rptr, pval)
	class(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_sev_real), pointer, intent(out) :: obsev_rptr
	type(subevt_t), pointer, intent(out) :: pval
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_OBSEV_REAL)
	if (associated (var)) then
	call var_entry_assign_obsev_real_ptr (obsev_rptr, var)
	pval => var_entry_get_pval_ptr (var)
	else
	obsev_rptr => null ()
	pval => null ()
	end if
	end subroutine var_list_get_obsev_rptr

	@ %def var_list_get_obs1_iptr
	@ %def var_list_get_obs2_iptr
	@ %def var_list_get_obsev_iptr
	@ %def var_list_get_obs1_rptr
	@ %def var_list_get_obs2_rptr
	@ %def var_list_get_obsev_rptr
	@
	\subsection{Process Result Variables}
	These variables are associated to process (integration) runs and their
	results. Their names contain brackets (so they look like function
	evaluations), therefore we need to special-case them.
	<<Variables: public>>=
	public :: var_list_set_procvar_int
	public :: var_list_set_procvar_real
	<<Variables: procedures>>=
	subroutine var_list_set_procvar_int (var_list, proc_id, name, ival)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: proc_id
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: ival
	type(string_t) :: var_name
	type(var_entry_t), pointer :: var
	var_name = name // "(" // proc_id // ")"
	var => var_list_get_var_ptr (var_list, var_name)
	if (.not. associated (var)) then
	call var_list%append_int (var_name, ival, intrinsic=.true.)
	else if (present (ival)) then
	call var_list%set_int (var_name, ival, is_known=.true.)
	end if
	end subroutine var_list_set_procvar_int

	subroutine var_list_set_procvar_real (var_list, proc_id, name, rval)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: proc_id
	type(string_t), intent(in) :: name
	real(default), intent(in), optional :: rval
	type(string_t) :: var_name
	type(var_entry_t), pointer :: var
	var_name = name // "(" // proc_id // ")"
	var => var_list_get_var_ptr (var_list, var_name)
	if (.not. associated (var)) then
	call var_list%append_real (var_name, rval, intrinsic=.true.)
	else if (present (rval)) then
	call var_list%set_real (var_name, rval, is_known=.true.)
	end if
	end subroutine var_list_set_procvar_real

	@ %def var_list_set_procvar_int
	@ %def var_list_set_procvar_real
	@
	\subsection{Observable initialization}
	Observables are formally treated as variables, which however are
	evaluated each time the observable is used. The arguments (pointers)
	to evaluate and the function are part of the variable-list entry.
	<<Variables: public>>=
	public :: var_list_append_obs1_iptr
	public :: var_list_append_obs2_iptr
	public :: var_list_append_obs1_rptr
	public :: var_list_append_obs2_rptr
	public :: var_list_append_obsev_iptr
	public :: var_list_append_obsev_rptr
	<<Variables: procedures>>=
	subroutine var_list_append_obs1_iptr (var_list, name, obs1_iptr, p1)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_unary_int) :: obs1_iptr
	type(prt_t), intent(in), target :: p1
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs (var, name, V_OBS1_INT, p1)
	var%obs1_int => obs1_iptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obs1_iptr

	subroutine var_list_append_obs2_iptr (var_list, name, obs2_iptr, p1, p2)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_binary_int) :: obs2_iptr
	type(prt_t), intent(in), target :: p1, p2
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs (var, name, V_OBS2_INT, p1, p2)
	var%obs2_int => obs2_iptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obs2_iptr

	subroutine var_list_append_obsev_iptr (var_list, name, obsev_iptr, sev)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_sev_int) :: obsev_iptr
	type(subevt_t), intent(in), target :: sev
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs_sev (var, name, V_OBSEV_INT, sev)
	var%obsev_int => obsev_iptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obsev_iptr

	subroutine var_list_append_obs1_rptr (var_list, name, obs1_rptr, p1)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_unary_real) :: obs1_rptr
	type(prt_t), intent(in), target :: p1
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs (var, name, V_OBS1_REAL, p1)
	var%obs1_real => obs1_rptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obs1_rptr

	subroutine var_list_append_obs2_rptr (var_list, name, obs2_rptr, p1, p2)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_binary_real) :: obs2_rptr
	type(prt_t), intent(in), target :: p1, p2
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs (var, name, V_OBS2_REAL, p1, p2)
	var%obs2_real => obs2_rptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obs2_rptr

	subroutine var_list_append_obsev_rptr (var_list, name, obsev_rptr, sev)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	procedure(obs_sev_real) :: obsev_rptr
	type(subevt_t), intent(in), target :: sev
	type(var_entry_t), pointer :: var
	allocate (var)
	call var_entry_init_obs_sev (var, name, V_OBSEV_REAL, sev)
	var%obsev_real => obsev_rptr
	call var_list_append (var_list, var)
	end subroutine var_list_append_obsev_rptr

	@ %def var_list_append_obs1_iptr
	@ %def var_list_append_obs2_iptr
	@ %def var_list_append_obs1_rptr
	@ %def var_list_append_obs2_rptr
	@ User observables: no pointer needs to be stored.
	<<Variables: public>>=
	public :: var_list_append_uobs_int
	public :: var_list_append_uobs_real
	<<Variables: procedures>>=
	subroutine var_list_append_uobs_int (var_list, name, p1, p2)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(prt_t), intent(in), target :: p1
	type(prt_t), intent(in), target, optional :: p2
	type(var_entry_t), pointer :: var
	allocate (var)
	if (present (p2)) then
	call var_entry_init_obs (var, name, V_UOBS2_INT, p1, p2)
	else
	call var_entry_init_obs (var, name, V_UOBS1_INT, p1)
	end if
	call var_list_append (var_list, var)
	end subroutine var_list_append_uobs_int

	subroutine var_list_append_uobs_real (var_list, name, p1, p2)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: name
	type(prt_t), intent(in), target :: p1
	type(prt_t), intent(in), target, optional :: p2
	type(var_entry_t), pointer :: var
	allocate (var)
	if (present (p2)) then
	call var_entry_init_obs (var, name, V_UOBS2_REAL, p1, p2)
	else
	call var_entry_init_obs (var, name, V_UOBS1_REAL, p1)
	end if
	call var_list_append (var_list, var)
	end subroutine var_list_append_uobs_real

	@ %def var_list_append_uobs_int
	@ %def var_list_append_uobs_real
	@
	\subsection{API for variable lists}
	Set a new value. If the variable holds a pointer, this pointer is
	followed, e.g., a model parameter is actually set. If [[ignore]] is
	set, do nothing if the variable does not exist. If [[verbose]] is
	set, echo the new value.

	Clear a variable (all variables), i.e., undefine the value.
	<<Variables: var list: TBP>>=
	procedure :: unset => var_list_clear
	<<Variables: procedures>>=
	subroutine var_list_clear (vars, name, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_clear (var)
	end if
	end subroutine var_list_clear

	@ %def var_list_clear
	@
	Setting the value, concise specific versions (implementing deferred TBP):
	<<Variables: var list: TBP>>=
	procedure :: set_ival => var_list_set_ival
	procedure :: set_rval => var_list_set_rval
	procedure :: set_cval => var_list_set_cval
	procedure :: set_lval => var_list_set_lval
	procedure :: set_sval => var_list_set_sval
	<<Variables: procedures>>=
	subroutine var_list_set_ival (vars, name, ival, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	integer, intent(in) :: ival
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_set_int (var, ival, is_known=.true.)
	end if
	end subroutine var_list_set_ival

	subroutine var_list_set_rval (vars, name, rval, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	real(default), intent(in) :: rval
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_set_real (var, rval, is_known=.true.)
	end if
	end subroutine var_list_set_rval

	subroutine var_list_set_cval (vars, name, cval, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: cval
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_set_cmplx (var, cval, is_known=.true.)
	end if
	end subroutine var_list_set_cval

	subroutine var_list_set_lval (vars, name, lval, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	logical, intent(in) :: lval
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_set_log (var, lval, is_known=.true.)
	end if
	end subroutine var_list_set_lval

	subroutine var_list_set_sval (vars, name, sval, follow_link)
	class(var_list_t), intent(inout) :: vars
	type(string_t), intent(in) :: name
	type(string_t), intent(in) :: sval
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (vars, name, follow_link=follow_link)
	if (associated (var)) then
	call var_entry_set_string (var, sval, is_known=.true.)
	end if
	end subroutine var_list_set_sval

	@ %def var_list_set_ival
	@ %def var_list_set_rval
	@ %def var_list_set_cval
	@ %def var_list_set_lval
	@ %def var_list_set_sval
	@
	Setting the value, verbose specific versions (as subroutines):
	<<Variables: var list: TBP>>=
	procedure :: set_log => var_list_set_log
	procedure :: set_int => var_list_set_int
	procedure :: set_real => var_list_set_real
	procedure :: set_cmplx => var_list_set_cmplx
	procedure :: set_subevt => var_list_set_subevt
	procedure :: set_pdg_array => var_list_set_pdg_array
	procedure :: set_string => var_list_set_string
	<<Variables: procedures>>=
	subroutine var_list_set_log &
	(var_list, name, lval, is_known, ignore, force, verbose, model_name)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	logical, intent(in) :: lval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_LOG)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_LOG)
	call var_entry_set_log (var, lval, is_known, verbose, model_name)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_log

	subroutine var_list_set_int &
	(var_list, name, ival, is_known, ignore, force, verbose, model_name)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(in) :: ival
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_INT)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_INT)
	call var_entry_set_int (var, ival, is_known, verbose, model_name)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_int

	subroutine var_list_set_real &
	(var_list, name, rval, is_known, ignore, force, &
	verbose, model_name, pacified)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	real(default), intent(in) :: rval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose, pacified
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_REAL)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_REAL)
	call var_entry_set_real &
	(var, rval, is_known, verbose, model_name, pacified)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_real

	subroutine var_list_set_cmplx &
	(var_list, name, cval, is_known, ignore, force, &
	verbose, model_name, pacified)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: cval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose, pacified
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_CMPLX)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_CMPLX)
	call var_entry_set_cmplx &
	(var, cval, is_known, verbose, model_name, pacified)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_cmplx

	subroutine var_list_set_pdg_array &
	(var_list, name, aval, is_known, ignore, force, verbose, model_name)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in) :: aval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_PDG)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_PDG)
	call var_entry_set_pdg_array &
	(var, aval, is_known, verbose, model_name)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_pdg_array

	subroutine var_list_set_subevt &
	(var_list, name, pval, is_known, ignore, force, verbose, model_name)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in) :: pval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_SEV)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_SEV)
	call var_entry_set_subevt &
	(var, pval, is_known, verbose, model_name)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_subevt

	subroutine var_list_set_string &
	(var_list, name, sval, is_known, ignore, force, verbose, model_name)
	class(var_list_t), intent(inout), target :: var_list
	type(string_t), intent(in) :: name
	type(string_t), intent(in) :: sval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: ignore, force, verbose
	type(string_t), intent(in), optional :: model_name
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name, V_STR)
	if (associated (var)) then
	if (.not. var_entry_is_locked (var, force)) then
	select case (var%type)
	case (V_STR)
	call var_entry_set_string &
	(var, sval, is_known, verbose, model_name)
	case default
	call var_mismatch_error (name)
	end select
	else
	call var_locked_error (name)
	end if
	else
	call var_missing_error (name, ignore)
	end if
	end subroutine var_list_set_string

	subroutine var_mismatch_error (name)
	type(string_t), intent(in) :: name
	call msg_fatal ("Type mismatch for variable '" // char (name) // "'")
	end subroutine var_mismatch_error

	subroutine var_locked_error (name)
	type(string_t), intent(in) :: name
	call msg_error ("Variable '" // char (name) // "' is not user-definable")
	end subroutine var_locked_error

	subroutine var_missing_error (name, ignore)
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: ignore
	logical :: error
	if (present (ignore)) then
	error = .not. ignore
	else
	error = .true.
	end if
	if (error) then
	call msg_fatal ("Variable '" // char (name) // "' has not been declared")
	end if
	end subroutine var_missing_error

	@ %def var_list_set_log
	@ %def var_list_set_int
	@ %def var_list_set_real
	@ %def var_list_set_cmplx
	@ %def var_list_set_subevt
	@ %def var_list_set_pdg_array
	@ %def var_list_set_string
	@ %def var_mismatch_error
	@ %def var_missing_error
	@
	Import values for the current variable list from another list.
	<<Variables: public>>=
	public :: var_list_import
	<<Variables: var list: TBP>>=
	procedure :: import => var_list_import
	<<Variables: procedures>>=
	subroutine var_list_import (var_list, src_list)
	class(var_list_t), intent(inout) :: var_list
	type(var_list_t), intent(in) :: src_list
	type(var_entry_t), pointer :: var, src
	var => var_list%first
	do while (associated (var))
	src => var_list_get_var_ptr (src_list, var%name)
	if (associated (src)) then
	call var_entry_copy_value (var, src)
	end if
	var => var%next
	end do
	end subroutine var_list_import

	@ %def var_list_import
	@ Mark all entries in the current variable list as undefined. This is done
	when a local variable list is discarded. If the local list is used again (by
	a loop), the entries will be re-initialized.
	<<Variables: public>>=
	public :: var_list_undefine
	<<Variables: var list: TBP>>=
	procedure :: undefine => var_list_undefine
	<<Variables: procedures>>=
	recursive subroutine var_list_undefine (var_list, follow_link)
	class(var_list_t), intent(inout) :: var_list
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var
	logical :: rec
	rec = .true.; if (present (follow_link)) rec = follow_link
	var => var_list%first
	do while (associated (var))
	call var_entry_undefine (var)
	var => var%next
	end do
	if (rec .and. associated (var_list%next)) then
	call var_list_undefine (var_list%next, follow_link=follow_link)
	end if
	end subroutine var_list_undefine

	@ %def var_list_undefine
	@ Make a deep copy of a variable list.
	<<Variables: public>>=
	public :: var_list_init_snapshot
	<<Variables: var list: TBP>>=
	procedure :: init_snapshot => var_list_init_snapshot
	<<Variables: procedures>>=
	recursive subroutine var_list_init_snapshot (var_list, vars_in, follow_link)
	class(var_list_t), intent(out) :: var_list
	type(var_list_t), intent(in) :: vars_in
	logical, intent(in), optional :: follow_link
	type(var_entry_t), pointer :: var, var_in
	type(var_list_t), pointer :: var_list_next
	logical :: rec
	rec = .true.; if (present (follow_link)) rec = follow_link
	var_in => vars_in%first
	do while (associated (var_in))
	allocate (var)
	call var_entry_init_copy (var, var_in)
	call var_entry_copy_value (var, var_in)
	call var_list_append (var_list, var)
	var_in => var_in%next
	end do
	if (rec .and. associated (vars_in%next)) then
	allocate (var_list_next)
	call var_list_init_snapshot (var_list_next, vars_in%next)
	call var_list%link (var_list_next)
	end if
	end subroutine var_list_init_snapshot

	@ %def var_list_init_snapshot
	@ Check if a user variable can be set. The [[new]] flag is set if the user
	variable has an explicit declaration. If an error occurs, return [[V_NONE]]
	as variable type.

	Also determine the actual type of generic numerical variables, which enter the
	procedure with type [[V_NONE]].
	<<Variables: public>>=
	public :: var_list_check_user_var
	<<Variables: var list: TBP>>=
	procedure :: check_user_var => var_list_check_user_var
	<<Variables: procedures>>=
	subroutine var_list_check_user_var (var_list, name, type, new)
	class(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(inout) :: type
	logical, intent(in) :: new
	type(var_entry_t), pointer :: var
	var => var_list_get_var_ptr (var_list, name)
	if (associated (var)) then
	if (type == V_NONE) then
	type = var_entry_get_type (var)
	end if
	if (var_entry_is_locked (var)) then
	call msg_fatal ("Variable '" // char (name) &
	// "' is not user-definable")
	type = V_NONE
	return
	else if (new) then
	if (var_entry_is_intrinsic (var)) then
	call msg_fatal ("Intrinsic variable '" &
	// char (name) // "' redeclared")
	type = V_NONE
	return
	end if
	if (var_entry_get_type (var) /= type) then
	call msg_fatal ("Variable '" // char (name) // "' " &
	// "redeclared with different type")
	type = V_NONE
	return
	end if
	end if
	end if
	end subroutine var_list_check_user_var

	@ %def var_list_check_user_var
	@
	\subsection{Default values for global var list}

	<<Variables: var list: TBP>>=
	procedure :: init_defaults => var_list_init_defaults
	<<Variables: procedures>>=
	subroutine var_list_init_defaults (var_list, seed, paths)
	class(var_list_t), intent(out) :: var_list
	integer, intent(in) :: seed
	type(paths_t), intent(in), optional :: paths
	call var_list%set_beams_defaults (paths)
	call var_list%set_core_defaults (seed)
	call var_list%set_integration_defaults ()
	call var_list%set_phase_space_defaults ()
	call var_list%set_gamelan_defaults ()
	call var_list%set_clustering_defaults ()
	call var_list%set_isolation_recomb_defaults ()
	call var_list%set_eio_defaults ()
	call var_list%set_shower_defaults ()
	call var_list%set_hadronization_defaults ()
	call var_list%set_tauola_defaults ()
	call var_list%set_mlm_matching_defaults ()
	call var_list%set_powheg_matching_defaults ()
	call var_list%append_log (var_str ("?ckkw_matching"), .false., &
	intrinsic=.true., description=var_str ('Master flag that switches ' // &
	'on the CKKW(-L) (LO) matching between hard scattering matrix ' // &
	'elements and QCD parton showers. Note that this is not yet ' // &
	'(completely) implemented in \whizard. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
	call var_list%set_openmp_defaults ()
	call var_list%set_mpi_defaults ()
	call var_list%set_nlo_defaults ()
	end subroutine var_list_init_defaults

	@ %def var_list_init_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_beams_defaults => var_list_set_beams_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_beams_defaults (var_list, paths)
	type(paths_t), intent(in), optional :: paths
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_real (var_str ("sqrts"), &
	intrinsic=.true., &
	description=var_str ('Real variable in order to set the center-of-mass ' // &
	'energy for the collisions (collider energy $\sqrt{s}$, not ' // &
	'hard interaction energy $\sqrt{\hat{s}}$): \ttt{sqrts = {\em ' // &
	'<num>} [ {\em <phys\_unit>} ]}. The physical unit can be one ' // &
	'of the following \ttt{eV}, \ttt{keV}, \ttt{MeV}, \ttt{GeV}, ' // &
	'and \ttt{TeV}. If absent, \whizard\ takes \ttt{GeV} as its ' // &
	'standard unit. Note that this variable is absolutely mandatory ' // &
	'for integration and simulation of scattering processes.'))
	call var_list%append_real (var_str ("luminosity"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This specifier \ttt{luminosity = {\em ' // &
	'<num>}} sets the integrated luminosity (in inverse femtobarns, ' // &
	'fb${}^{-1}$) for the event generation of the processes in the ' // &
	'\sindarin\ input files. Note that WHIZARD itself chooses the ' // &
	'number from the \ttt{luminosity} or from the \ttt{n\_events} ' // &
	'specifier, whichever would give the larger number of events. ' // &
	'As this depends on the cross section under consideration, it ' // &
	'might be different for different processes in the process list. ' // &
	'(cf. \ttt{n\_events}, \ttt{\$sample}, \ttt{sample\_format}, \ttt{?unweighted})'))
	call var_list%append_log (var_str ("?sf_trace"), .false., &
	intrinsic=.true., &
	description=var_str ('Debug flag that writes out detailed information ' // &
	'about the structure function setup into the file \ttt{{\em ' // &
	'<proc\_name>}\_sftrace.dat}. This file name can be changed ' // &
	'with ($\to$) \ttt{\$sf\_trace\_file}.'))
	call var_list%append_string (var_str ("$sf_trace_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('\ttt{\$sf\_trace\_file = "{\em <file\_name>}"} ' // &
	'allows to change the detailed structure function information ' // &
	'switched on by the debug flag ($\to$) \ttt{?sf\_trace} into ' // &
	'a different file \ttt{{\em <file\_name>}} than the default ' // &
	'\ttt{{\em <proc\_name>}\_sftrace.dat}.'))
	call var_list%append_log (var_str ("?sf_allow_s_mapping"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that determines whether special mappings ' // &
	'for processes with structure functions and $s$-channel resonances ' // &
	'are applied, e.g. Drell-Yan at hadron colliders, or $Z$ production ' // &
	'at linear colliders with beamstrahlung and ISR.'))
	if (present (paths)) then
	call var_list%append_string (var_str ("$lhapdf_dir"), paths%lhapdfdir, &
	intrinsic=.true., &
	description=var_str ('String variable that tells the path ' // &
	'where the \lhapdf\ library and PDF sets can be found. When ' // &
	'the library has been correctly recognized during configuration, ' // &
	'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
	'\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
	'\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
	else
	call var_list%append_string (var_str ("$lhapdf_dir"), var_str(""), &
	intrinsic=.true., &
	description=var_str ('String variable that tells the path ' // &
	'where the \lhapdf\ library and PDF sets can be found. When ' // &
	'the library has been correctly recognized during configuration, ' // &
	'this is automatically set by \whizard. (cf. also \ttt{lhapdf}, ' // &
	'\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
	'\ttt{lhapdf\_member}, \ttt{lhapdf\_photon\_scheme})'))
	end if
	call var_list%append_string (var_str ("$lhapdf_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('This string variable \ttt{\$lhapdf\_file ' // &
	'= "{\em <pdf\_set>}"} allows to specify the PDF set \ttt{{\em ' // &
	'<pdf\_set>}} from the external \lhapdf\ library. It must match ' // &
	'the exact name of the PDF set from the \lhapdf\ library. The ' // &
	'default is empty, and the default set from \lhapdf\ is taken. ' // &
	'Only one argument is possible, the PDF set must be identical ' // &
	'for both beams, unless there are fundamentally different beam ' // &
	'particles like proton and photon. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
	'\ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_photon\_scheme}, ' // &
	'\ttt{lhapdf\_member})'))
	call var_list%append_string (var_str ("$lhapdf_photon_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable \ttt{\$lhapdf\_photon\_file ' // &
	'= "{\em <pdf\_set>}"} analagous to ($\to$) \ttt{\$lhapdf\_file} ' // &
	'for photon PDF structure functions from the external \lhapdf\ ' // &
	'library. The name must exactly match the one of the set from ' // &
	'\lhapdf. (cf. \ttt{beams}, \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
	'\ttt{\$lhapdf\_file}, \ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member}, ' // &
	'\ttt{lhapdf\_photon\_scheme})'))
	call var_list%append_int (var_str ("lhapdf_member"), 0, &
	intrinsic=.true., &
	description=var_str ('Integer variable that specifies the number ' // &
	'of the corresponding PDF set chosen via the command ($\to$) ' // &
	'\ttt{\$lhapdf\_file} or ($\to$) \ttt{\$lhapdf\_photon\_file} ' // &
	'from the external \lhapdf\ library. E.g. error PDF sets can ' // &
	'be chosen by this. (cf. also \ttt{lhapdf}, \ttt{\$lhapdf\_dir}, ' // &
	'\ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, \ttt{\$lhapdf\_photon\_file}, ' // &
	'\ttt{lhapdf\_photon\_scheme})'))
	call var_list%append_int (var_str ("lhapdf_photon_scheme"), 0, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that controls the different ' // &
	'available schemes for photon PDFs inside the external \lhapdf\ ' // &
	'library. For more details see the \lhapdf\ manual. (cf. also ' // &
	'\ttt{lhapdf}, \ttt{\$lhapdf\_dir}, \ttt{\$lhapdf\_file}, \ttt{lhapdf\_photon}, ' // &
	'\ttt{\$lhapdf\_photon\_file}, \ttt{lhapdf\_member})'))
	call var_list%append_string (var_str ("$pdf_builtin_set"), var_str ("CTEQ6L"), &
	intrinsic=.true., &
	description=var_str ("For \whizard's internal PDF structure functions " // &
	'for hadron colliders, this string variable allows to set the ' // &
	'particular PDF set. (cf. also \ttt{pdf\_builtin}, \ttt{pdf\_builtin\_photon})'))
	call var_list%append_log (var_str ("?hoppet_b_matching"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that switches on the matching between ' // &
	'4- and 5-flavor schemes for hadron collider $b$-parton initiated ' // &
	'processes. Works either with builtin PDFs or with the external ' // &
	'\lhapdf\ interface. Needs the external \ttt{HOPPET} library ' // &
	'to be linked. (cf. \ttt{beams}, \ttt{pdf\_builtin}, \ttt{lhapdf})'))
	call var_list%append_real (var_str ("isr_alpha"), 0._default, &
	intrinsic=.true., &
	description=var_str ('For lepton collider initial-state QED ' // &
	'radiation (ISR), this real parameter sets the value of $\alpha_{em}$ ' // &
	'used in the structure function. If not set, it is taken from ' // &
	'the parameter set of the physics model in use (cf. also \ttt{isr}, ' // &
	'\ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
	'\ttt{?isr\_keep\_energy})'))
	call var_list%append_real (var_str ("isr_q_max"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set the ' // &
	'scale of the initial-state QED radiation (ISR) structure function. ' // &
	'If not set, it is taken internally to be $\sqrt{s}$. (cf. ' // &
	'also \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
	'\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
	call var_list%append_real (var_str ("isr_mass"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set by hand ' // &
	'the mass of the incoming particle for lepton collider initial-state ' // &
	'QED radiation (ISR). If not set, the mass for the initial beam ' // &
	'particle is taken from the model in use. (cf. also \ttt{isr}, ' // &
	'\ttt{isr\_q\_max}, \ttt{isr\_alpha}, \ttt{isr\_order}, \ttt{?isr\_recoil}, ' // &
	'\ttt{?isr\_keep\_energy})'))
	call var_list%append_int (var_str ("isr_order"), 3, &
	intrinsic=.true., &
	description=var_str ('For lepton collider initial-state QED ' // &
	'radiation (ISR), this integer parameter allows to set the order ' // &
	'up to which hard-collinear radiation is taken into account. ' // &
	'Default is the highest available, namely third order. (cf. ' // &
	'also \ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_alpha}, ' // &
	'\ttt{?isr\_recoil}, \ttt{?isr\_keep\_energy})'))
	call var_list%append_log (var_str ("?isr_recoil"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
	'$p_T$-kick for the lepton collider initial-state QED radiation ' // &
	'(ISR). (cf. also \ttt{isr}, \ttt{isr}, \ttt{isr\_alpha}, \ttt{isr\_mass}, ' // &
	'\ttt{isr\_order}, \ttt{isr\_q\_max})'))
	call var_list%append_log (var_str ("?isr_keep_energy"), .false., &
	intrinsic=.true., &
	description=var_str ('As the splitting kinematics for the ISR ' // &
	'structure function violates Lorentz invariance when the recoil ' // &
	'is switched on, this flag forces energy conservation when set ' // &
	'to true, otherwise violating energy conservation. (cf. also ' // &
	'\ttt{isr}, \ttt{isr\_q\_max}, \ttt{isr\_mass}, \ttt{isr\_order}, ' // &
	'\ttt{?isr\_recoil}, \ttt{?isr\_alpha})'))
	call var_list%append_log (var_str ("?isr_handler"), .false., &
	intrinsic=.true., &
	description=var_str ('Activate ISR ' // &
	'handler for event generation (no effect on integration). ' // &
	'Requires \ttt{isr\_recoil = false}'))
	call var_list%append_string (var_str ("$isr_handler_mode"), &
	var_str ("trivial"), &
	intrinsic=.true., &
	description=var_str ('Operation mode for the ISR ' // &
	'event handler. Allowed values: \ttt{trivial} (no effect), ' // &
	'\ttt{recoil} (recoil kinematics with two photons)'))
	call var_list%append_log (var_str ("?isr_handler_keep_mass"), .true., &
	intrinsic=.true., &
	description=var_str ('If \ttt{true} (default), force the incoming ' // &
	'partons of the hard process (after radiation) on their mass ' // &
	'shell. Otherwise, insert massless on-shell momenta. This ' // &
	'applies only for event generation (no effect on integration, ' // &
	'cf.\ also \ttt{?isr\_handler})'))
	call var_list%append_string (var_str ("$epa_mode"), &
	var_str ("default"), intrinsic=.true., &
	description=var_str ('For the equivalent photon approximation ' // &
	'(EPA), this string variable defines the mode, i.e. the explicit ' // &
	'formula for the EPA distribution. For more details cf. the manual. ' // &
	'Possible are \ttt{default} (\ttt{Budnev\_617}), \ttt{Budnev\_616e}, ' // &
	'\ttt{log\_power}, \ttt{log\_simple}, and \ttt{log}. ' // &
	'(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, ' // &
	'\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_real (var_str ("epa_alpha"), 0._default, &
	intrinsic=.true., &
	description=var_str ('For the equivalent photon approximation ' // &
	'(EPA), this real parameter sets the value of $\alpha_{em}$ ' // &
	'used in the structure function. If not set, it is taken from ' // &
	'the parameter set of the physics model in use (cf. also \ttt{epa}, ' // &
	'\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_e\_max}, \ttt{epa\_q\_min}, ' // &
	'\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_real (var_str ("epa_x_min"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the lower cutoff ' // &
	'for the energy fraction in the splitting for the equivalent-photon ' // &
	'approximation (EPA). This parameter has to be set by the user ' // &
	'to a non-zero value smaller than one. (cf. also \ttt{epa}, ' // &
	'\ttt{epa\_e\_max}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
	'\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_real (var_str ("epa_q_min"), 0._default, &
	intrinsic=.true., &
	description=var_str ('In the equivalent-photon approximation ' // &
	'(EPA), this real parameters sets the minimal value for the ' // &
	'transferred momentum. Either this parameter or the mass of ' // &
	'the beam particle has to be non-zero. (cf. also \ttt{epa}, ' // &
	'\ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, \ttt{epa\_q\_max}, ' // &
	'\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}, ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_real (var_str ("epa_q_max"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set the ' // &
	'upper energy cutoff for the equivalent-photon approximation ' // &
	'(EPA). If not set, \whizard\ simply takes the collider energy, ' // &
	'$\sqrt{s}$. (cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, ' // &
	'\ttt{epa\_alpha}, \ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
	'\ttt{?epa\_keep\_energy}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_real (var_str ("epa_mass"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set by hand ' // &
	'the mass of the incoming particle for the equivalent-photon ' // &
	'approximation (EPA). If not set, the mass for the initial beam ' // &
	'particle is taken from the model in use. (cf. also \ttt{epa}, ' // &
	'\ttt{epa\_x\_min}, \ttt{epa\_e\_max}, \ttt{epa\_alpha}, \ttt{epa\_q\_min}, ' // &
	'\ttt{?epa\_recoil}, \ttt{?epa\_keep\_energy}, \ttt{\$epa\_mode}. ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_log (var_str ("?epa_recoil"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to switch on recoil, i.e. a non-vanishing ' // &
	'$p_T$-kick for the equivalent-photon approximation (EPA). ' // &
	'(cf. also \ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
	'\ttt{epa\_e\_max}, \ttt{epa\_q\_min}, \ttt{?epa\_keep\_energy}, ' // &
	'\ttt{\$epa\_mode}, \ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_log (var_str ("?epa_keep_energy"), .false., &
	intrinsic=.true., &
	description=var_str ('As the splitting kinematics for the EPA ' // &
	'structure function violates Lorentz invariance when the recoil ' // &
	'is switched on, this flag forces energy conservation when set ' // &
	'to true, otherwise violating energy conservation. (cf. also ' // &
	'\ttt{epa}, \ttt{epa\_x\_min}, \ttt{epa\_mass}, \ttt{epa\_alpha}, ' // &
	'\ttt{epa\_q\_min}, \ttt{?epa\_recoil}, \ttt{\$epa\_mode}, ' // &
	'\ttt{?epa\_handler}, \ttt{\$epa\_handler\_mode})'))
	call var_list%append_log (var_str ("?epa_handler"), .false., &
	intrinsic=.true., &
	description=var_str ('Activate EPA ' // &
	'handler for event generation (no effect on integration). ' // &
	'Requires \ttt{epa\_recoil = false}'))
	call var_list%append_string (var_str ("$epa_handler_mode"), &
	var_str ("trivial"), &
	intrinsic=.true., &
	description=var_str ('Operation mode for the EPA ' // &
	'event handler. Allowed values: \ttt{trivial} (no effect), ' // &
	'\ttt{recoil} (recoil kinematics with two beams)'))
	call var_list%append_real (var_str ("ewa_x_min"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the lower cutoff ' // &
	'for the energy fraction in the splitting for the equivalent ' // &
	'$W$ approximation (EWA). This parameter has to be set by the ' // &
	'user to a non-zero value smaller than one. (cf. also \ttt{ewa}, ' // &
	'\ttt{ewa\_pt\_max}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
	'\ttt{?ewa\_recoil})'))
	call var_list%append_real (var_str ("ewa_pt_max"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set the ' // &
	'upper $p_T$ cutoff for the equivalent $W$ approximation (EWA). ' // &
	'If not set, \whizard\ simply takes the collider energy, $\sqrt{s}$. ' // &
	'(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy}, ' // &
	'\ttt{?ewa\_recoil})'))
	call var_list%append_real (var_str ("ewa_mass"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This real parameter allows to set by hand ' // &
	'the mass of the incoming particle for the equivalent $W$ approximation ' // &
	'(EWA). If not set, the mass for the initial beam particle is ' // &
	'taken from the model in use. (cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, ' // &
	'\ttt{ewa\_pt\_max}, \ttt{?ewa\_keep\_energy}, \ttt{?ewa\_recoil})'))
	call var_list%append_log (var_str ("?ewa_recoil"), .false., &
	intrinsic=.true., &
	description=var_str ('For the equivalent $W$ approximation (EWA), ' // &
	'this flag switches on recoil, i.e. non-collinear splitting. ' // &
	'(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // &
	'\ttt{ewa\_mass}, \ttt{?ewa\_keep\_energy})'))
	call var_list%append_log (var_str ("?ewa_keep_energy"), .false., &
	intrinsic=.true., &
	description=var_str ('As the splitting kinematics for the equivalent ' // &
	'$W$ approximation (EWA) violates Lorentz invariance when the ' // &
	'recoil is switched on, this flag forces energy conservation ' // &
	'when set to true, otherwise violating energy conservation. ' // &
	'(cf. also \ttt{ewa}, \ttt{ewa\_x\_min}, \ttt{ewa\_pt\_max}, ' // &
	'\ttt{ewa\_mass}, \ttt{?ewa\_recoil})'))
	call var_list%append_log (var_str ("?circe1_photon1"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to tell \whizard\ to use the photon ' // &
	'of the \circeone\ beamstrahlung structure function as initiator ' // &
	'for the hard scattering process in the first beam. (cf. also ' // &
	'\ttt{circe1}, \ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, ' // &
	'\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
	'\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
	'\ttt{?circe1\_with\_radiation})'))
	call var_list%append_log (var_str ("?circe1_photon2"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to tell \whizard\ to use the photon ' // &
	'of the \circeone\ beamstrahlung structure function as initiator ' // &
	'for the hard scattering process in the second beam. (cf. also ' // &
	'\ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{circe1\_sqrts}, ' // &
	'\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
	'\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
	'\newline\ttt{?circe1\_with\_radiation})'))
	call var_list%append_real (var_str ("circe1_sqrts"), &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows to set the ' // &
	'value of the collider energy for the lepton collider beamstrahlung ' // &
	'structure function \circeone. If not set, $\sqrt{s}$ is taken. ' // &
	'(cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // &
	'\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
	'\newline \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
	'\ttt{?circe1\_with\_radiation})'))
	call var_list%append_log (var_str ("?circe1_generate"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that determines whether the \circeone\ ' // &
	'structure function for lepton collider beamstrahlung uses the ' // &
	'generator mode for the spectrum, or a pre-defined (semi-)analytical ' // &
	'parameterization. Default is the generator mode. (cf. also ' // &
	'\ttt{circe1}, \ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // &
	'\ttt{circe1\_sqrts}, \ttt{?circe1\_map}, \ttt{circe1\_mapping\_slope}, ' // &
	'\ttt{circe1\_eps}, \newline \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
	'\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
	call var_list%append_log (var_str ("?circe1_map"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that determines whether the \circeone\ ' // &
	'structure function for lepton collider beamstrahlung uses special ' // &
	'mappings for $s$-channel resonances. (cf. also \ttt{circe1}, ' // &
	'\ttt{?circe1\_photon1}, \newline \ttt{?circe1\_photon2}, ' // &
	'\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
	'\ttt{circe1\_mapping\_slope}, \ttt{circe1\_eps}, \newline ' // &
	'\ttt{circe1\_ver}, \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, ' // &
	'\ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
	call var_list%append_real (var_str ("circe1_mapping_slope"), 2._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows to vary the ' // &
	'slope of the mapping function for the \circeone\ structure ' // &
	'function for lepton collider beamstrahlung from the default ' // &
	'value \ttt{2.}. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
	'\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
	'\ttt{?circe1\_map}, \ttt{circe1\_eps}, \ttt{circe1\_ver}, ' // &
	'\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline' // &
	'\ttt{?circe1\_with\_radiation})'))
	call var_list%append_real (var_str ("circe1_eps"), 1e-5_default, &
	intrinsic=.true., &
	description=var_str ('Real parameter, that takes care of the ' // &
	'mapping of the peak in the lepton collider beamstrahlung structure ' // &
	'function spectrum of \circeone. (cf. also \ttt{circe1}, \ttt{?circe1\_photons}, ' // &
	'\ttt{?circe1\_photon2}, \ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, ' // &
	'\ttt{?circe1\_map}, \ttt{circe1\_eps}, \newline ' // &
	'\ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, \ttt{circe1\_rev}, ' // &
	'\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \newline\ttt{?circe1\_with\_radiation})'))
	call var_list%append_int (var_str ("circe1_ver"), 0, intrinsic=.true., &
	description=var_str ('Integer parameter that sets the internal ' // &
	'versioning number of the \circeone\ structure function for lepton-collider ' // &
	'beamstrahlung. It has to be set by the user explicitly, it takes ' // &
	'values from one to ten. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, ' // &
	'\ttt{?circe1\_photon2}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
	'\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, ' // &
	'\ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{circe1\_chat}, ' // &
	'\ttt{?circe1\_with\_radiation})'))
	call var_list%append_int (var_str ("circe1_rev"), 0, intrinsic=.true., &
	description=var_str ('Integer parameter that sets the internal ' // &
	'revision number of the \circeone\ structure function for lepton-collider ' // &
	'beamstrahlung. The default \ttt{0} translates always into the ' // &
	'most recent version; older versions have to be accessed through ' // &
	'the explicit revision date. For more details cf.~the \circeone ' // &
	'manual. (cf. also \ttt{circe1}, \ttt{?circe1\_photon1}, \ttt{?circe1\_photon2}, ' // &
	'\ttt{?circe1\_generate}, \ttt{?circe1\_map}, \ttt{circe1\_eps}, ' // &
	'\ttt{circe1\_mapping\_slope}, \ttt{circe1\_sqrts}, \ttt{circe1\_ver}, ' // &
	'\ttt{\$circe1\_acc}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
	call var_list%append_string (var_str ("$circe1_acc"), var_str ("SBAND"), &
	intrinsic=.true., &
	description=var_str ('String variable that specifies the accelerator ' // &
	'type for the \circeone\ structure function for lepton-collider ' // &
	'beamstrahlung. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
	'\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
	'\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\newline \ttt{circe1\_rev}, \ttt{circe1\_chat}, \ttt{?circe1\_with\_radiation})'))
	call var_list%append_int (var_str ("circe1_chat"), 0, intrinsic=.true., &
	description=var_str ('Chattiness of the \circeone\ structure ' // &
	'function for lepton-collider beamstrahlung. The higher the integer ' // &
	'value, the more information will be given out by the \circeone\ ' // &
	'package. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
	'\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
	'\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc}, \ttt{?circe1\_with\_radiation})'))
	call var_list%append_log (var_str ("?circe1_with_radiation"), .false., &
	intrinsic=.true., &
	description=var_str ('This logical decides whether the additional photon ' // &
	'or electron ("beam remnant") will be considered in the event record or ' // &
	'not. (\ttt{?circe1\_photons}, \ttt{?circe1\_photon2}, ' // &
	'\ttt{circe1\_sqrts}, \ttt{?circe1\_generate}, \ttt{?circe1\_map}, ' // &
	'\ttt{circe1\_eps}, \ttt{circe1\_mapping\_slope}, \ttt{circe1\_ver}, ' // &
	'\newline \ttt{circe1\_rev}, \ttt{\$circe1\_acc})'))
	call var_list%append_log (var_str ("?circe2_polarized"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag whether the photon spectra from the ' // &
	'\circetwo\ structure function for lepton colliders should be ' // &
	'treated polarized. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, ' // &
	'\ttt{\$circe2\_design})'))
	call var_list%append_string (var_str ("$circe2_file"), &
	intrinsic=.true., &
	description=var_str ('String variable by which the corresponding ' // &
	'photon collider spectrum for the \circetwo\ structure function ' // &
	'can be selected. (cf. also \ttt{circe2}, \ttt{?circe2\_polarized}, ' // &
	'\ttt{\$circe2\_design})'))
	call var_list%append_string (var_str ("$circe2_design"), var_str ("*"), &
	intrinsic=.true., &
	description=var_str ('String variable that sets the collider ' // &
	'design for the \circetwo\ structure function for photon collider ' // &
	'spectra. (cf. also \ttt{circe2}, \ttt{\$circe2\_file}, \ttt{?circe2\_polarized})'))
	call var_list%append_real (var_str ("gaussian_spread1"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Parameter that sets the energy spread ' // &
	'($\sigma$ value) of the first beam for a Gaussian spectrum. ' // &
	'(cf. \ttt{gaussian})'))
	call var_list%append_real (var_str ("gaussian_spread2"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Ditto, for the second beam.'))
	call var_list%append_string (var_str ("$beam_events_file"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to set the ' // &
	"name of the external file from which a beamstrahlung's spectrum " // &
	'for lepton colliders as pairs of energy fractions is read in. ' // &
	'(cf. also \ttt{beam\_events}, \ttt{?beam\_events\_warn\_eof})'))
	call var_list%append_log (var_str ("?beam_events_warn_eof"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to ' // &
	'issue a warning when in a simulation the end of an external ' // &
	"file for beamstrahlung's spectra for lepton colliders are reached, " // &
	'and energy fractions from the beginning of the file are reused. ' // &
	'(cf. also \ttt{beam\_events}, \ttt{\$beam\_events\_file})'))
	call var_list%append_log (var_str ("?energy_scan_normalize"), .false., &
	intrinsic=.true., &
	description=var_str ('Normalization flag for the energy scan ' // &
	'structure function: if set the total cross section is normalized ' // &
	'to unity. (cf. also \ttt{energy\_scan})'))
	call var_list%append_string (var_str ("$negative_sf"), var_str ("default"), &
	intrinsic=.true., &
	description=var_str ('String variable to set the behavior to either ' // &
	'keep negative structure function/PDF values or set them to zero. ' // &
	'The default (\ttt{"default"}) takes the first option for NLO and the ' // &
	'second for LO processes. Explicit behavior can be set with ' // &
	'\ttt{"positive"} or \ttt{"negative"}.'))
	end subroutine var_list_set_beams_defaults

	@ %def var_list_set_beams_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_core_defaults => var_list_set_core_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_core_defaults (var_list, seed)
	class(var_list_t), intent(inout) :: var_list
	integer, intent(in) :: seed
	logical, target, save :: known = .true. !!! ??????
	real(default), parameter :: real_specimen = 1.
	call var_list_append_log_ptr &
	(var_list, var_str ("?logging"), logging, known, &
	intrinsic=.true., &
	description=var_str ('This logical -- when set to \ttt{false} ' // &
	'-- suppresses writing out a logfile (default: \ttt{whizard.log}) ' // &
	'for the whole \whizard\ run, or when \whizard\ is run with the ' // &
	'\ttt{--no-logging} option, to suppress parts of the logging ' // &
	'when setting it to \ttt{true} again at a later part of the ' // &
	'\sindarin\ input file. Mainly for debugging purposes. ' // &
	'(cf. also \ttt{?openmp\_logging}, \ttt{?mpi\_logging})'))
	call var_list%append_string (var_str ("$job_id"), &
	intrinsic=.true., &
	description=var_str ('Arbitrary string that can be used for ' // &
	'creating unique names. The variable is initialized with the ' // &
	'value of the \ttt{job\_id} option on startup. (cf. also ' // &
	'\ttt{\$compile\_workspace}, \ttt{\$run\_id})'))
	call var_list%append_string (var_str ("$compile_workspace"), &
	intrinsic=.true., &
	description=var_str ('If set, create process source code ' // &
	'and process-driver library code in a subdirectory with this ' // &
	'name. If non-existent, the directory will be created. (cf. ' // &
	'also \ttt{\$job\_id}, \ttt{\$run\_id}, \ttt{\$integrate\_workspace})'))
	call var_list%append_int (var_str ("seed"), seed, &
	intrinsic=.true., &
	description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
	'that allows to set a specific random seed \ttt{num}. If not ' // &
	'set, \whizard\ takes the time from the system clock to determine ' // &
	'the random seed.'))
	call var_list%append_string (var_str ("$model_name"), &
	intrinsic=.true., &
	description=var_str ('This variable makes the locally used physics ' // &
	'model available as a string, e.g. as \ttt{show (\$model\_name)}. ' // &
	'However, the user is not able to change the current model by ' // &
	'setting this variable to a different string. (cf. also \ttt{model}, ' // &
	'\ttt{\$library\_name}, \ttt{printf}, \ttt{show})'))
	call var_list%append_int (var_str ("process_num_id"), &
	intrinsic=.true., &
	description=var_str ('Using the integer \ttt{process\_num\_id ' // &
	'= {\em <int\_var>}} one can set a numerical identifier for processes ' // &
	'within a process library. This can be set either just before ' // &
	'the corresponding \ttt{process} definition or as an optional ' // &
	'local argument of the latter. (cf. also \ttt{process}, ' // &
	'\ttt{?proc\_as\_run\_id}, \ttt{lcio\_run\_id})'))
	call var_list%append_log (var_str ("?proc_as_run_id"), .true., &
	intrinsic=.true., &
	description=var_str ('Normally, for LCIO the process ID (cf. ' // &
	'\ttt{process\_num\_id}) is used as run ID, unless this flag is ' // &
	'set to \ttt{false}, cf. also \ttt{process}, \ttt{lcio\_run\_id}.'))
	call var_list%append_int (var_str ("lcio_run_id"), 0, &
	intrinsic=.true., &
	description=var_str ('Allows to set an integer run ID for the LCIO ' // &
	'event format. Normally, the process ID is taken as run ID, unless ' // &
	'the flag (cf.) \ttt{?proc\_as\_run\_id} is set to \ttt{false}, ' // &
	'cf. also \ttt{process}.'))
	call var_list%append_string (var_str ("$method"), var_str ("omega"), &
	intrinsic=.true., &
	description=var_str ('This string variable specifies the method ' // &
	'for the matrix elements to be used in the evaluation. The default ' // &
	"is the intrinsic \oMega\ matrix element generator " // &
	'(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
	'\ttt{"template\_unity"}, \ttt{"threshold"}. For processes defined ' // &
	'\ttt{"template"}, with \ttt{nlo\_calculation = ...}, please refer to ' // &
	'\ttt{\$born\_me\_method}, \ttt{\$real\_tree\_me\_method}, ' // &
	'\ttt{\$loop\_me\_method} and \ttt{\$correlation\_me\_method}.'))
	call var_list%append_log (var_str ("?report_progress"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag for the \oMega\ matrix element generator ' // &
	'whether to print out status messages about progress during ' // &
	'matrix element generation. (cf. also \ttt{\$method}, \ttt{\$omega\_flags})'))
	call var_list%append_log (var_str ("?me_verbose"), .false., &
	description=var_str ("Flag determining whether " // &
	"the makefile command for generating and compiling the \oMega\ matrix " // &
	"element code is silent or verbose. Default is silent."))
	call var_list%append_string (var_str ("$restrictions"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('This is an optional argument for process ' // &
	'definitions for the matrix element method \ttt{"omega"}. Using ' // &
	'the following construction, it defines a string variable, \ttt{process ' // &
	'\newline {\em <process\_name>} = {\em <particle1>}, {\em <particle2>} ' // &
	'=> {\em <particle3>}, {\em <particle4>}, ... \{ \$restrictions ' // &
	'= "{\em <restriction\_def>}" \}}. The string argument \ttt{{\em ' // &
	'<restriction\_def>}} is directly transferred during the code ' // &
	'generation to the ME generator \oMega. It has to be of the form ' // &
	'\ttt{n1 + n2 + ... \url{~} {\em <particle (list)>}}, where ' // &
	'\ttt{n1} and so on are the numbers of the particles above in ' // &
	'the process definition. The tilde specifies a certain intermediate ' // &
	'state to be equal to the particle(s) in \ttt{particle (list)}. ' // &
	'An example is \ttt{process eemm\_z = e1, E1 => e2, E2 ' // &
	'\{ \$restrictions = "1+2 \url{~} Z" \} } restricts the code ' // &
	'to be generated for the process $e^- e^+ \to \mu^- \mu^+$ to ' // &
	'the $s$-channel $Z$-boson exchange. For more details see Sec.~\ref{sec:omega_me} ' // &
	'(cf. also \ttt{process})'))
	call var_list%append_log (var_str ("?omega_write_phs_output"), .false., &
	intrinsic=.true., &
	description=var_str ('This flag decides whether a the phase-space ' // &
	'output is produced by the \oMega\ matrix element generator. This ' // &
	'output is written to file(s) and contains the Feynman diagrams ' // &
	'which belong to the process(es) under consideration. The file is ' // &
	'mandatory whenever the variable \ttt{\$phs\_method} has the value ' // &
	'\ttt{fast\_wood}, i.e. if the phase-space file is provided by ' // &
	'cascades2.'))
	call var_list%append_string (var_str ("$omega_flags"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to pass flags ' // &
	'to the \oMega\ matrix element generator. Normally, \whizard\ ' // &
	'takes care of all flags automatically. Note that for restrictions ' // &
	'of intermediate states, there is a special string variable: ' // &
	'(cf. $\to$) \ttt{\$restrictions}.'))
	call var_list%append_log (var_str ("?read_color_factors"), .true., &
	intrinsic=.true., &
	description=var_str ('This flag decides whether to read QCD ' // &
	'color factors from the matrix element provided by each method, ' // &
	'or to try and calculate the color factors in \whizard\ internally.'))
	call var_list%append_log (var_str ("?slha_read_input"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag which decides whether \whizard\ reads ' // &
	'in the SM and parameter information from the \ttt{SMINPUTS} ' // &
	'and \ttt{MINPAR} common blocks of the SUSY Les Houches Accord ' // &
	'files. (cf. also \ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, ' // &
	'\ttt{?slha\_read\_decays})'))
	call var_list%append_log (var_str ("?slha_read_spectrum"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag which decides whether \whizard\ reads ' // &
	'in the whole spectrum and mixing angle information from the ' // &
	'common blocks of the SUSY Les Houches Accord files. (cf. also ' // &
	'\ttt{read\_slha}, \ttt{write\_slha}, \ttt{?slha\_read\_decays}, ' // &
	'\ttt{?slha\_read\_input})'))
	call var_list%append_log (var_str ("?slha_read_decays"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag which decides whether \whizard\ reads ' // &
	'in the widths and branching ratios from the \ttt{DCINFO} common ' // &
	'block of the SUSY Les Houches Accord files. (cf. also \ttt{read\_slha}, ' // &
	'\ttt{write\_slha}, \ttt{?slha\_read\_spectrum}, \ttt{?slha\_read\_input})'))
	call var_list%append_string (var_str ("$library_name"), &
	intrinsic=.true., &
	description=var_str ('Similar to \ttt{\$model\_name}, this string ' // &
	'variable is used solely to access the name of the active process ' // &
	'library, e.g. in \ttt{printf} statements. (cf. \ttt{compile}, ' // &
	'\ttt{library}, \ttt{printf}, \ttt{show}, \ttt{\$model\_name})'))
	call var_list%append_log (var_str ("?alphas_is_fixed"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use a non-running ' // &
	'QCD $\alpha_s$. Note that this has to be set explicitly to $\ttt{false}$ ' // &
	'if the user wants to use one of the running $\alpha_s$ options. ' // &
	'(cf. also \ttt{alphas\_order}, \ttt{?alphas\_from\_lhapdf}, ' // &
	'\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
	'\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
	call var_list%append_log (var_str ("?alpha_is_fixed"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use a non-running ' // &
	'QED $\alpha$. Note that this has to be set explicitly to $\ttt{false}$ ' // &
	'if the user wants to use one of the running $\alpha$ options. ' // &
	'(cf. also \ttt{alpha\_order}, \ttt{alpha\_nf}, \ttt{alpha\_lep}, ' // &
	'\ttt{?alphas\_from\_me}'))
	call var_list%append_log (var_str ("?alphas_from_lhapdf"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use a running ' // &
	'$\alpha_s$ from the \lhapdf\ library (which has to be correctly ' // &
	'linked). Note that \ttt{?alphas\_is\_fixed} has to be set ' // &
	'explicitly to $\ttt{false}$. (cf. also \ttt{alphas\_order}, ' // &
	'\ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
	'\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
	'\ttt{lambda\_qcd})'))
	call var_list%append_log (var_str ("?alphas_from_pdf_builtin"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use a running ' // &
	'$\alpha_s$ from the internal PDFs. Note that in that case \ttt{?alphas\_is\_fixed} ' // &
	'has to be set explicitly to $\ttt{false}$. (cf. also ' // &
	'\ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
	'\ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, \newline \ttt{?alphas\_from\_lambda\_qcd}, ' // &
	'\ttt{lambda\_qcd})'))
	call var_list%append_log (var_str ("?alpha_evolve_analytic"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use analytic running ' // &
	'formulae for $\alpha$ instead of a numeric Runge-Kutta. ' // &
	'(cf. also \ttt{alpha\_order}, \ttt{?alpha\_is\_fixed}, ' // &
	'\ttt{alpha\_nf}, \ttt{alpha\_nlep}, \ttt{?alpha\_from\_me}) '))
	call var_list%append_int (var_str ("alphas_order"), 0, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the order ' // &
	'of the internal evolution for running $\alpha_s$ in \whizard: ' // &
	'the default, \ttt{0}, is LO running, \ttt{1} is NLO, \ttt{2} ' // &
	'is NNLO. (cf. also \ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, ' // &
	'\ttt{?alphas\_from\_pdf\_builtin}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_mz}, ' // &
	'\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
	call var_list%append_int (var_str ("alpha_order"), 0, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the order ' // &
	'of the internal evolution for running $\alpha$ in \whizard: ' // &
	'the default, \ttt{0}, is LO running, \ttt{1} is NLO. ' // &
	'(cf. also \ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, \ttt{alphas\_lep}, ' // &
	'\ttt{?alpha\_from\_me})'))
	call var_list%append_int (var_str ("alphas_nf"), 5, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of active quark flavors for the internal evolution for running ' // &
	'$\alpha_s$ in \whizard. (cf. also ' // &
	'\ttt{alphas\_is\_fixed}, \ttt{?alphas\_from\_lhapdf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
	'\ttt{alphas\_order}, \ttt{?alphas\_from\_mz}, \newline ' // &
	'\ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
	call var_list%append_int (var_str ("alpha_nf"), -1, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of active quark flavors for the internal evolution for running ' // &
	'$\alpha$ in \whizard. The default, \ttt{-1}, keeps it equal to \ttt{alphas\_nf} ' // &
	'\ttt{alpha\_is\_fixed}, \ttt{alphas\_order}, \ttt{?alpha\_from\_me}, ' // &
	'\ttt{?alpha\_evolve\_analytic}'))
	call var_list%append_int (var_str ("alpha_nlep"), 1, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of active leptons in the running of $\alpha$ in \whizard. The deffault is' // &
	'one, with only the electron considered massless (cf. also ' // &
	'\ttt{alpha\_is\_fixed}, \ttt{alpha\_nf}, ' // &
	'\ttt{alpha\_order}, \ttt{?alpha\_from\_me}, \ttt{?alpha\_evolve\_analytic})'))
	call var_list%append_log (var_str ("?alphas_from_mz"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use its internal ' // &
	'running $\alpha_s$ from $\alpha_s(M_Z)$. Note that in that ' // &
	'case \ttt{?alphas\_is\_fixed} has to be set explicitly to ' // &
	'$\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
	'\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
	'\newline \ttt{?alphas\_from\_lambda\_qcd}, \ttt{lambda\_qcd})'))
	call var_list%append_log (var_str ("?alphas_from_lambda_qcd"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to use its internal ' // &
	'running $\alpha_s$ from $\alpha_s(\Lambda_{QCD})$. Note that ' // &
	'in that case \ttt{?alphas\_is\_fixed} has to be set explicitly ' // &
	'to $\ttt{false}$. (cf. also \ttt{alphas\_order}, \ttt{?alphas\_is\_fixed}, ' // &
	'\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, \ttt{?alphas\_from\_pdf\_builtin}, ' // &
	'\newline \ttt{?alphas\_from\_mz}, \ttt{lambda\_qcd})'))
	call var_list%append_real (var_str ("lambda_qcd"), 200.e-3_default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the value for ' // &
	'$\Lambda_{QCD}$ used in the internal evolution for running ' // &
	'$\alpha_s$ in \whizard. (cf. also \ttt{alphas\_is\_fixed}, ' // &
	'\ttt{?alphas\_from\_lhapdf}, \ttt{alphas\_nf}, ' // &
	'\newline \ttt{?alphas\_from\_pdf\_builtin}, ' // &
	'\ttt{?alphas\_from\_mz}, \ttt{?alphas\_from\_lambda\_qcd}, ' // &
	'\ttt{alphas\_order})'))
	call var_list%append_log (var_str ("?fatal_beam_decay"), .true., &
	intrinsic=.true., &
	description=var_str ('Logical variable that let the user decide ' // &
	'whether the possibility of a beam decay is treated as a fatal ' // &
	'error or only as a warning. An example is a process $b t \to ' // &
	'X$, where the bottom quark as an inital state particle appears ' // &
	'as a possible decay product of the second incoming particle, ' // &
	'the top quark. This might trigger inconsistencies or instabilities ' // &
	'in the phase space set-up.'))
	call var_list%append_log (var_str ("?helicity_selection_active"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether \whizard\ uses ' // &
	'a numerical selection rule for vanishing helicities: if active, ' // &
	'then, if a certain helicity combination yields an absolute ' // &
	'(\oMega) matrix element smaller than a certain threshold ($\to$ ' // &
	'\ttt{helicity\_selection\_threshold}) more often than a certain ' // &
	'cutoff ($\to$ \ttt{helicity\_selection\_cutoff}), it will be dropped.'))
	call var_list%append_real (var_str ("helicity_selection_threshold"), &
	1E10_default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that gives the threshold ' // &
	'for the absolute value of a certain helicity combination of ' // &
	'an (\oMega) amplitude. If a certain number ($\to$ ' // &
	'\ttt{helicity\_selection\_cutoff}) of calls stays below this ' // &
	'threshold, that combination will be dropped from then on. (cf. ' // &
	'also \ttt{?helicity\_selection\_active})'))
	call var_list%append_int (var_str ("helicity_selection_cutoff"), 1000, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that gives the number ' // &
	"a certain helicity combination of an (\oMega) amplitude has " // &
	'to be below a certain threshold ($\to$ \ttt{helicity\_selection\_threshold}) ' // &
	'in order to be dropped from then on. (cf. also \ttt{?helicity\_selection\_active})'))
	call var_list%append_string (var_str ("$rng_method"), var_str ("tao"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to set the ' // &
	'method for the random number generation. Default is Donald ' // &
	"Knuth' RNG method \ttt{TAO}."))
	call var_list%append_log (var_str ("?vis_diags"), .false., &
	intrinsic=.true., &
	description=var_str ('Logical variable that allows to give out ' // &
	"a Postscript or PDF file for the Feynman diagrams for a \oMega\ " // &
	'process. (cf. \ttt{?vis\_diags\_color}).'))
	call var_list%append_log (var_str ("?vis_diags_color"), .false., &
	intrinsic=.true., &
	description=var_str ('Same as \ttt{?vis\_diags}, but switches ' // &
	'on color flow instead of Feynman diagram generation. (cf. \ttt{?vis\_diags}).'))
	call var_list%append_log (var_str ("?check_event_file"), .true., &
	intrinsic=.true., &
	description=var_str ('Setting this to false turns off all sanity ' // &
	'checks when reading a raw event file with previously generated ' // &
	'events. Use this at your own risk; the program may return ' // &
	'wrong results or crash if data do not match. (cf. also \ttt{?check\_grid\_file}, ' // &
	'\ttt{?check\_phs\_file})'))
	call var_list%append_string (var_str ("$event_file_version"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to set the ' // &
	'format version of the \whizard\ internal binary event format.'))
	call var_list%append_int (var_str ("n_events"), 0, &
	intrinsic=.true., &
	description=var_str ('This specifier \ttt{n\_events = {\em <num>}} ' // &
	'sets the number of events for the event generation of the processes ' // &
	'in the \sindarin\ input files. Note that WHIZARD itself chooses ' // &
	'the number from the \ttt{n\_events} or from the \ttt{luminosity} ' // &
	'specifier, whichever would give the larger number of events. ' // &
	'As this depends on the cross section under consideration, it ' // &
	'might be different for different processes in the process list. ' // &
	'(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
	'\ttt{?unweighted}, \ttt{event\_index\_offset})'))
	call var_list%append_int (var_str ("event_index_offset"), 0, &
	intrinsic=.true., &
	description=var_str ('The value ' // &
	'\ttt{event\_index\_offset = {\em <num>}} ' // &
	'initializes the event counter for a subsequent ' // &
	'event sample. By default (value 0), the first event ' // &
	'gets index value 1, incrementing by one for each generated event ' // &
	'within a sample. The event counter is initialized again ' // &
	'for each new sample (i.e., \ttt{integrate} command). ' // &
	'If events are read from file, and the ' // &
	'event file format supports event numbering, the event numbers ' // &
	'will be taken from file instead, and the value of ' // &
	'\ttt{event\_index\_offset} has no effect. ' // &
	'(cf. \ttt{luminosity}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
	'\ttt{?unweighted}, \ttt{n\_events})'))
	call var_list%append_log (var_str ("?unweighted"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that distinguishes between unweighted ' // &
	'and weighted event generation. (cf. also \ttt{simulate}, \ttt{n\_events}, ' // &
	'\ttt{luminosity}, \ttt{event\_index\_offset})'))
	call var_list%append_real (var_str ("safety_factor"), 1._default, &
	intrinsic=.true., &
	description=var_str ('This real variable \ttt{safety\_factor ' // &
	'= {\em <num>}} reduces the acceptance probability for unweighting. ' // &
	'If greater than one, excess events become less likely, but ' // &
	'the reweighting efficiency also drops. (cf. \ttt{simulate}, \ttt{?unweighted})'))
	call var_list%append_log (var_str ("?negative_weights"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that tells \whizard\ to allow negative ' // &
	'weights in integration and simulation. (cf. also \ttt{simulate}, ' // &
	'\ttt{?unweighted})'))
	call var_list%append_log (var_str ("?resonance_history"), .false., &
	intrinsic=.true., &
	description=var_str ( &
	'The logical variable \texttt{?resonance\_history ' // &
	'= true/false} specifies whether during a simulation pass, ' // &
	'the event generator should try to reconstruct intermediate ' // &
	'resonances. If activated, appropriate resonant subprocess ' // &
	'matrix element code will be automatically generated. '))
	call var_list%append_real (var_str ("resonance_on_shell_limit"), &
	4._default, &
	intrinsic=.true., &
	description=var_str ( &
	'The real variable \texttt{resonance\_on\_shell\_limit ' // &
	'= {\em <num>}} specifies the maximum relative distance from a ' // &
	'resonance peak, such that the kinematical configuration ' // &
	'can still be considered on-shell. This is relevant only if ' // &
	'\texttt{?resonance\_history = true}.'))
	call var_list%append_real (var_str ("resonance_on_shell_turnoff"), &
	0._default, &
	intrinsic=.true., &
	description=var_str ( &
	'The real variable \texttt{resonance\_on\_shell\_turnoff ' // &
	'= {\em <num>}}, if positive, ' // &
	'controls the smooth transition from resonance-like ' // &
	'to background-like events. The relative strength of a ' // &
	'resonance is reduced by a Gaussian with width given by this ' // &
	'variable. In any case, events are treated as background-like ' // &
	'when the off-shellness is greater than ' // &
	'\texttt{resonance\_on\_shell\_limit}. All of this applies ' // &
	'only if \texttt{?resonance\_history = true}.'))
	call var_list%append_real (var_str ("resonance_background_factor"), &
	1._default, &
	intrinsic=.true., &
	description=var_str ( &
	'The real variable \texttt{resonance\_background\_factor} ' // &
	'controls resonance insertion if a resonance ' // &
	'history applies to a particular event. In determining '// &
	'whether event kinematics qualifies as resonant or non-resonant, ' //&
	'the non-resonant probability is multiplied by this factor ' // &
	'Setting the factor to zero removes the background ' // &
	'configuration as long as the kinematics qualifies as on-shell ' // &
	'as qualified by \texttt{resonance\_on\_shell\_limit}.'))
	call var_list%append_log (var_str ("?keep_beams"), .false., &
	intrinsic=.true., &
	description=var_str ('The logical variable \ttt{?keep\_beams ' // &
	'= true/false} specifies whether beam particles and beam remnants ' // &
	'are included when writing event files. For example, in order ' // &
	'to read Les Houches accord event files into \pythia, no beam ' // &
	'particles are allowed.'))
	call var_list%append_log (var_str ("?keep_remnants"), .true., &
	intrinsic=.true., &
	description=var_str ('The logical variable \ttt{?keep\_beams ' // &
	'= true/false} is respected only if \ttt{?keep\_beams} is set. ' // &
	'If \ttt{true}, beam remnants are tagged as outgoing particles ' // &
	'if they have been neither showered nor hadronized, i.e., have ' // &
	'no children. If \ttt{false}, beam remnants are also included ' // &
	'in the event record, but tagged as unphysical. Note that for ' // &
	'ISR and/or beamstrahlung spectra, the radiated photons are ' // &
	'considered as beam remnants.'))
	call var_list%append_log (var_str ("?rescan_force"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that allows to bypass essential ' // &
	'checks on the particle set when reading event/rescanning files ' // &
	'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // &
	'\newline \ttt{?update\_weight})'))
	call var_list%append_log (var_str ("?recover_beams"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the beam particles ' // &
	'should be reconstructed when reading event/rescanning files ' // &
	'into \whizard. (cf. \ttt{rescan}, \ttt{?update\_event}, \ttt{?update\_sqme}, ' // &
	'\newline \ttt{?update\_weight})'))
	call var_list%append_log (var_str ("?update_event"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the events in ' // &
	'an event file should be rebuilt from the hard process when ' // &
	'reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
	'\ttt{?recover\_beams}, \ttt{?update\_sqme}, \ttt{?update\_weight})'))
	call var_list%append_log (var_str ("?update_sqme"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the squared ' // &
	'matrix element in an event file should be updated/recalculated ' // &
	'when reading event/rescanning files into \whizard. (cf. \ttt{rescan}, ' // &
	'\newline \ttt{?recover\_beams}, \ttt{?update\_event}, \ttt{?update\_weight})'))
	call var_list%append_log (var_str ("?update_weight"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the weights ' // &
	'in an event file should be updated/recalculated when reading ' // &
	'event/rescanning files into \whizard. (cf. \ttt{rescan}, \ttt{?recover\_beams}, ' // &
	'\newline \ttt{?update\_event}, \ttt{?update\_sqme})'))
	call var_list%append_log (var_str ("?use_alphas_from_file"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the current ' // &
	'$\alpha_s$ definition should be used when recalculating matrix ' // &
	'elements for events read from file, or the value that is stored ' // &
	'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
	'\ttt{?use\_scale\_from\_file})'))
	call var_list%append_log (var_str ("?use_scale_from_file"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the current ' // &
	'energy-scale expression should be used when recalculating matrix ' // &
	'elements for events read from file, or the value that is stored ' // &
	'in the file for that event. (cf. \ttt{rescan}, \ttt{?update\_sqme}, ' // &
	'\ttt{?use\_alphas\_from\_file})'))
	call var_list%append_log (var_str ("?allow_decays"), .true., &
	intrinsic=.true., &
	description=var_str ('Master flag to switch on cascade decays ' // &
	'for final state particles as an event transform. As a default, ' // &
	'it is switched on. (cf. also \ttt{?auto\_decays}, ' // &
	'\ttt{auto\_decays\_multiplicity}, \ttt{?auto\_decays\_radiative}, ' // &
	'\ttt{?decay\_rest\_frame})'))
	call var_list%append_log (var_str ("?auto_decays"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag, particularly as optional argument of the ($\to$) ' // &
	'\ttt{unstable} command, that tells \whizard\ to automatically ' // &
	'determine the decays of that particle up to the final state ' // &
	'multplicity ($\to$) \ttt{auto\_decays\_multiplicity}. Depending ' // &
	'on the flag ($\to$) \ttt{?auto\_decays\_radiative}, radiative ' // &
	'decays will be taken into account or not. (cf. also \ttt{unstable}, ' // &
	'\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay})'))
	call var_list%append_int (var_str ("auto_decays_multiplicity"), 2, &
	intrinsic=.true., &
	description=var_str ('Integer parameter, that sets -- ' // &
	'for the ($\to$) \ttt{?auto\_decays} option to let \whizard\ ' // &
	'automatically determine the decays of a particle set as ($\to$) ' // &
	'\ttt{unstable} -- the maximal final state multiplicity that ' // &
	'is taken into account. The default is \ttt{2}. The flag \ttt{?auto\_decays\_radiative} ' // &
	'decides whether radiative decays are taken into account. (cf.\ ' // &
	'also \ttt{unstable}, \ttt{?auto\_decays})'))
	call var_list%append_log (var_str ("?auto_decays_radiative"), .false., &
	intrinsic=.true., &
	description=var_str ("If \whizard's automatic detection " // &
	'of decay channels are switched on ($\to$ \ttt{?auto\_decays} ' // &
	'for the ($\to$) \ttt{unstable} command, this flags decides ' // &
	'whether radiative decays (e.g. containing additional photon(s)/gluon(s)) ' // &
	'are taken into account or not. (cf. also \ttt{unstable}, \ttt{auto\_decays\_multiplicity})'))
	call var_list%append_log (var_str ("?decay_rest_frame"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that allows to force a particle decay ' // &
	'to be simulated in its rest frame. This simplifies the calculation ' // &
	'for decays as stand-alone processes, but makes the process ' // &
	'unsuitable for use in a decay chain.'))
	call var_list%append_log (var_str ("?isotropic_decay"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that -- in case of using factorized ' // &
	'production and decays using the ($\to$) \ttt{unstable} command ' // &
	'-- tells \whizard\ to switch off spin correlations completely ' // &
	'(isotropic decay). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
	'\ttt{decay\_helicity}, \ttt{?diagonal\_decay})'))
	call var_list%append_log (var_str ("?diagonal_decay"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that -- in case of using factorized ' // &
	'production and decays using the ($\to$) \ttt{unstable} command ' // &
	'-- tells \whizard\ instead of full spin correlations to take ' // &
	'only the diagonal entries in the spin-density matrix (i.e. ' // &
	'classical spin correlations). (cf. also \ttt{unstable}, \ttt{?auto\_decays}, ' // &
	'\ttt{decay\_helicity}, \ttt{?isotropic\_decay})'))
	call var_list%append_int (var_str ("decay_helicity"), &
	intrinsic=.true., &
	description=var_str ('If this parameter is given an integer ' // &
	'value, any particle decay triggered by a subsequent \ttt{unstable} ' // &
	'declaration will receive a projection on the given helicity ' // &
	'state for the unstable particle. (cf. also \ttt{unstable}, ' // &
	'\ttt{?isotropic\_decay}, \ttt{?diagonal\_decay}. The latter ' // &
	'parameters, if true, take precdence over any \ttt{?decay\_helicity} setting.)'))
	call var_list%append_log (var_str ("?polarized_events"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that allows to select certain helicity ' // &
	'combinations in final state particles in the event files, ' // &
	'and perform analysis on polarized event samples. (cf. also ' // &
	'\ttt{simulate}, \ttt{polarized}, \ttt{unpolarized})'))
	call var_list%append_string (var_str ("$polarization_mode"), &
	var_str ("helicity"), &
	intrinsic=.true., &
	description=var_str ('String variable that specifies the mode in ' // &
	'which the polarization of particles is handled when polarized events ' // &
	'are written out. Possible options are \ttt{"ignore"}, \ttt{"helicity"}, ' // &
	'\ttt{"factorized"}, and \ttt{"correlated"}. For more details cf. the ' // &
	'detailed section.'))
	call var_list%append_log (var_str ("?colorize_subevt"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that enables color-index tracking ' // &
	'in the subevent (\ttt{subevt}) objects that are used for ' // &
	'internal event analysis.'))
	call var_list%append_real (var_str ("tolerance"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real variable that defines the absolute ' // &
	'tolerance with which the (logical) function \ttt{expect} accepts ' // &
	'equality or inequality: \ttt{tolerance = {\em <num>}}. This ' // &
	'can e.g. be used for cross-section tests and backwards compatibility ' // &
	'checks. (cf. also \ttt{expect})'))
	call var_list%append_int (var_str ("checkpoint"), 0, &
	intrinsic = .true., &
	description=var_str ('Setting this integer variable to a positive ' // &
	'integer $n$ instructs simulate to print out a progress summary ' // &
	'every $n$ events.'))
	call var_list%append_int (var_str ("event_callback_interval"), 0, &
	intrinsic = .true., &
	description=var_str ('Setting this integer variable to a positive ' // &
	'integer $n$ instructs simulate to print out a progress summary ' // &
	'every $n$ events.'))
	call var_list%append_log (var_str ("?pacify"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that allows to suppress numerical ' // &
	'noise and give screen and log file output with a lower number ' // &
	'of significant digits. Mainly for debugging purposes. (cf. also ' // &
	'\ttt{?sample\_pacify})'))
	call var_list%append_string (var_str ("$out_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('This character variable allows to specify ' // &
	'the name of the data file to which the histogram and plot data ' // &
	'are written (cf. also \ttt{write\_analysis}, \ttt{open\_out}, ' // &
	'\ttt{close\_out})'))
	call var_list%append_log (var_str ("?out_advance"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that sets advancing in the \ttt{printf} ' // &
	'output commands, i.e. continuous printing with no line feed ' // &
	'etc. (cf. also \ttt{printf})'))
	call var_list%append_int (var_str ("real_range"), &
	range (real_specimen), intrinsic = .true., locked = .true., &
	description=var_str ('This integer gives the decimal exponent ' // &
	'range of the numeric model for the real float type in use. It cannot ' // &
	'be set by the user. (cf. also \ttt{real\_precision}, ' // &
	'\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
	call var_list%append_int (var_str ("real_precision"), &
	precision (real_specimen), intrinsic = .true., locked = .true., &
	description=var_str ('This integer gives the precision of ' // &
	'the numeric model for the real float type in use. It cannot ' // &
	'be set by the user. (cf. also \ttt{real\_range}, ' // &
	'\ttt{real\_epsilon}, \ttt{real\_tiny}).'))
	call var_list%append_real (var_str ("real_epsilon"), &
	epsilon (real_specimen), intrinsic = .true., locked = .true., &
	description=var_str ('This gives the smallest number $E$ ' // &
	'of the same kind as the float type for which $1 + E > 1$. ' // &
	'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
	'\ttt{real\_tiny}, \ttt{real\_precision}).'))
	call var_list%append_real (var_str ("real_tiny"), &
	tiny (real_specimen), intrinsic = .true., locked = .true., &
	description=var_str ('This gives the smallest positive (non-zero) ' // &
	'number in the numeric model for the real float type in use. ' // &
	'It cannot be set by the user. (cf. also \ttt{real\_range}, ' // &
	'\ttt{real\_epsilon}, \ttt{real\_precision}).'))
	end subroutine var_list_set_core_defaults

	@ %def var_list_set_core_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_integration_defaults => var_list_set_integration_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_integration_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_string (var_str ("$integration_method"), var_str ("vamp"), &
	intrinsic=.true., &
	description=var_str ('This string variable specifies the method ' // &
	'for performing the multi-dimensional phase-space integration. ' // &
	'The default is the \vamp\ algorithm (\ttt{"vamp"}), other options ' // &
	'are via the numerical midpoint rule (\ttt{"midpoint"}) or an ' // &
	'alternate \vamptwo\ implementation that is MPI-parallelizable ' // &
	'(\ttt{"vamp2"}).'))
	call var_list%append_int (var_str ("threshold_calls"), 10, &
	intrinsic=.true., &
	description=var_str ('This integer variable gives a limit for ' // &
	'the number of calls in a given channel which acts as a lower ' // &
	'threshold for the channel weight. If the number of calls in ' // &
	'that channel falls below this threshold, the weight is not ' // &
	'lowered further but kept at this threshold. (cf. also ' // &
	'\ttt{channel\_weights\_power})'))
	call var_list%append_int (var_str ("min_calls_per_channel"), 10, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that modifies the settings ' // &
	"of the \vamp\ integrator's grid parameters. It sets the minimal " // &
	'number every channel must be called. If the number of calls ' // &
	'from the iterations is too small, \whizard\ will automatically ' // &
	'increase the number of calls. (cf. \ttt{iterations}, \ttt{min\_calls\_per\_bin}, ' // &
	'\ttt{min\_bins}, \ttt{max\_bins})'))
	call var_list%append_int (var_str ("min_calls_per_bin"), 10, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that modifies the settings ' // &
	"of the \vamp\ integrator's grid parameters. It sets the minimal " // &
	'number every bin in an integration dimension must be called. ' // &
	'If the number of calls from the iterations is too small, \whizard\ ' // &
	'will automatically increase the number of calls. (cf. \ttt{iterations}, ' // &
	'\ttt{min\_calls\_per\_channel}, \ttt{min\_bins}, \ttt{max\_bins})'))
	call var_list%append_int (var_str ("min_bins"), 3, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that modifies the settings ' // &
	"of the \vamp\ integrator's grid parameters. It sets the minimal " // &
	'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
	'\ttt{max\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
	call var_list%append_int (var_str ("max_bins"), 20, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that modifies the settings ' // &
	"of the \vamp\ integrator's grid parameters. It sets the maximal " // &
	'number of bins per integration dimension. (cf. \ttt{iterations}, ' // &
	'\ttt{min\_bins}, \ttt{min\_calls\_per\_channel}, \ttt{min\_calls\_per\_bin})'))
	call var_list%append_log (var_str ("?stratified"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that switches between stratified ' // &
	'and importance sampling for the \vamp\ integration method.'))
	call var_list%append_log (var_str ("?use_vamp_equivalences"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether equivalence ' // &
	'relations (symmetries) between different integration channels ' // &
	'are used by the \vamp\ integrator.'))
	call var_list%append_log (var_str ("?vamp_verbose"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that sets the chattiness of the \vamp\ ' // &
	'integrator. If set, not only errors, but also all warnings and ' // &
	'messages will be written out (not the default). (cf. also \newline ' // &
	'\ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_global\_verbose}, ' // &
	'\ttt{?vamp\_history\_channels}, \newline \ttt{?vamp\_history\_channels\_verbose})'))
	call var_list%append_log (var_str ("?vamp_history_global"), &
	.true., intrinsic=.true., &
	description=var_str ('Flag that decides whether the global history ' // &
	'of the grid adaptation of the \vamp\ integrator are written ' // &
	'into the process logfiles. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
	'\ttt{?vamp\_history\_channels}, \ttt{?vamp\_history\_channels\_verbose}, ' // &
	'\ttt{?vamp\_verbose})'))
	call var_list%append_log (var_str ("?vamp_history_global_verbose"), &
	.false., intrinsic=.true., &
	description=var_str ('Flag that decides whether the global history ' // &
	'of the grid adaptation of the \vamp\ integrator are written ' // &
	'into the process logfiles in an extended version. Only for debugging ' // &
	'purposes. (cf. also \ttt{?vamp\_history\_global}, \ttt{?vamp\_history\_channels}, ' // &
	'\ttt{?vamp\_verbose}, \ttt{?vamp\_history\_channels\_verbose})'))
	call var_list%append_log (var_str ("?vamp_history_channels"), &
	.false., intrinsic=.true., &
	description=var_str ('Flag that decides whether the history of ' // &
	'the grid adaptation of the \vamp\ integrator for every single ' // &
	'channel are written into the process logfiles. Only for debugging ' // &
	'purposes. (cf. also \ttt{?vamp\_history\_global\_verbose}, ' // &
	'\ttt{?vamp\_history\_global}, \ttt{?vamp\_verbose}, \newline ' // &
	'\ttt{?vamp\_history\_channels\_verbose})'))
	call var_list%append_log (var_str ("?vamp_history_channels_verbose"), &
	.false., intrinsic=.true., &
	description=var_str ('Flag that decides whether the history of ' // &
	'the grid adaptation of the \vamp\ integrator for every single ' // &
	'channel are written into the process logfiles in an extended ' // &
	'version. Only for debugging purposes. (cf. also \ttt{?vamp\_history\_global}, ' // &
	'\ttt{?vamp\_history\_channels}, \ttt{?vamp\_verbose}, \ttt{?vamp\_history\_global\_verbose})'))
	call var_list%append_string (var_str ("$run_id"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable \ttt{\$run\_id = "{\em ' // &
	'<id>}"} that allows to set a special ID for a particular process ' // &
	'run, e.g. in a scan. The run ID is then attached to the process ' // &
	'log file: \newline \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
	'<id>}.log}, the \vamp\ grid file: \newline \ttt{{\em <proc\_name>}\_{\em ' // &
	'<proc\_comp>}.{\em <id>}.vg}, and the phase space file: \newline ' // &
	'\ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em <id>}.phs}. ' // &
	'The run ID string distinguishes among several runs for the ' // &
	'same process. It identifies process instances with respect ' // &
	'to adapted integration grids and similar run-specific data. ' // &
	'The run ID is kept when copying processes for creating instances, ' // &
	'however, so it does not distinguish event samples. (cf.\ also ' // &
	'\ttt{\$job\_id}, \ttt{\$compile\_workspace}'))
	call var_list%append_int (var_str ("n_calls_test"), 0, &
	intrinsic=.true., &
	description=var_str ('Integer variable that allows to set a ' // &
	'certain number of matrix element sampling test calls without ' // &
	'actually integrating the process under consideration. (cf. ' // &
	'\ttt{integrate})'))
	call var_list%append_log (var_str ("?integration_timer"), .true., &
	intrinsic=.true., &
	description=var_str ('This flag switches the integration timer ' // &
	'on and off, that gives the estimate for the duration of the ' // &
	'generation of 10,000 unweighted events for each integrated ' // &
	'process.'))
	call var_list%append_log (var_str ("?check_grid_file"), .true., &
	intrinsic=.true., &
	description=var_str ('Setting this to false turns off all sanity ' // &
	'checks when reading a grid file with previous integration data. ' // &
	'Use this at your own risk; the program may return wrong results ' // &
	'or crash if data do not match. (cf. also \ttt{?check\_event\_file}, \ttt{?check\_phs\_file}) '))
	call var_list%append_real (var_str ("accuracy_goal"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows the user to ' // &
	'set a minimal accuracy that should be achieved in the Monte-Carlo ' // &
	'integration of a certain process. If that goal is reached, ' // &
	'grid and weight adapation stop, and this result is used for ' // &
	'simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
	'\ttt{error\_goal}, \ttt{relative\_error\_goal}, ' // &
	'\ttt{error\_threshold})'))
	call var_list%append_real (var_str ("error_goal"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows the user to ' // &
	'set a minimal absolute error that should be achieved in the ' // &
	'Monte-Carlo integration of a certain process. If that goal ' // &
	'is reached, grid and weight adapation stop, and this result ' // &
	'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
	'\ttt{accuracy\_goal}, \ttt{relative\_error\_goal}, \ttt{error\_threshold})'))
	call var_list%append_real (var_str ("relative_error_goal"), 0._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows the user to ' // &
	'set a minimal relative error that should be achieved in the ' // &
	'Monte-Carlo integration of a certain process. If that goal ' // &
	'is reached, grid and weight adaptation stop, and this result ' // &
	'is used for simulation. (cf. also \ttt{integrate}, \ttt{iterations}, ' // &
	'\ttt{accuracy\_goal}, \ttt{error\_goal}, \ttt{error\_threshold})'))
	call var_list%append_int (var_str ("integration_results_verbosity"), 1, &
	intrinsic=.true., &
	description=var_str ('Integer parameter for the verbosity of ' // &
	'the integration results in the process-specific logfile.'))
	call var_list%append_real (var_str ("error_threshold"), &
	0._default, intrinsic=.true., &
	description=var_str ('The real parameter \ttt{error\_threshold ' // &
	'= {\em <num>}} declares that any error value (in absolute numbers) ' // &
	'smaller than \ttt{{\em <num>}} is to be considered zero. The ' // &
	'units are \ttt{fb} for scatterings and \ttt{GeV} for decays. ' // &
	'(cf. also \ttt{integrate}, \ttt{iterations}, \ttt{accuracy\_goal}, ' // &
	'\ttt{error\_goal}, \ttt{relative\_error\_goal})'))
	call var_list%append_real (var_str ("channel_weights_power"), 0.25_default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that allows to vary the ' // &
	'exponent of the channel weights for the \vamp\ integrator.'))
	call var_list%append_string (var_str ("$integrate_workspace"), &
	intrinsic=.true., &
	description=var_str ('Character string that tells \whizard\ ' // &
	'the subdirectory where to find the run-specific phase-space ' // &
	'configuration and the \vamp\ and \vamptwo\ grid files. ' // &
	'If undefined (as per default), \whizard\ creates them and ' // &
	'searches for them in the ' // &
	'current directory. (cf. also \ttt{\$job\_id}, ' // &
	'\ttt{\$run\_id}, \ttt{\$compile\_workspace})'))
	call var_list%append_int (var_str ("vamp_grid_checkpoint"), 1, &
	intrinsic=.true., &
	description=var_str ('Integer parameter for setting checkpoints to save ' // &
	'the current state of the grids and the results so far of the integration. ' // &
	'Allowed are all positive integer. Zero values corresponds to a checkpoint ' // &
	'after each integration pass, a one value to a checkpoint after each iteration ' // &
	'(default) and an $N$ value correspond to a checkpoint after $N$ iterations ' // &
	' or after each pass, respectively.'))
	call var_list%append_string (var_str ("$vamp_grid_format"), var_str ("ascii"), &
	intrinsic=.true., &
	description=var_str ('Character string that tells \whizard\ ' // &
	'the file format for \ttt{vamp2} to use for writing and reading ' // &
	'the configuration for the multi-channel integration setup and the ' // &
	'\vamptwo\ (only) grid data. The values can be \ttt{ascii} for a single ' // &
	'human-readable grid file with ending \ttt{.vg2} or \ttt{binary} for two files, ' // &
	'a human-readable header file with ending \ttt{.vg2} and binary file with ending ' // &
	'\ttt{.vgx2} storing the grid data.' // &
	'The main purpose of the binary format is to perform faster I/O, e.g. for HPC runs.' // &
	'\whizard\ can convert between the different file formats automatically.'))
	call var_list%append_string (var_str ("$vamp_parallel_method"), var_str ("simple"), &
	intrinsic=.true., &
	description=var_str ('Character string that tells \whizard\ ' // &
	'the parallel method to use for parallel integration within \ttt{vamp2}.' // &
	' (i) \ttt{simple} (default) is a local work sharing approach without the need of communication ' // &
	'between all workers except for the communication during result collection.' // &
	' (ii) \ttt{load} is a global queue approach where the master worker acts as a' // &
	'governor listening and providing work for each worker. The queue is filled and assigned with workers ' // &
	'a-priori with respect to the assumed computational impact of each channel.' // &
	'Both approaches use the same mechanism for result collection using non-blocking ' // &
	'communication allowing for a efficient usage of the computing resources.'))
	end subroutine var_list_set_integration_defaults

	@ %def var_list_set_integration_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_phase_space_defaults => var_list_set_phase_space_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_phase_space_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_string (var_str ("$phs_method"), var_str ("default"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to choose ' // &
	'the phase-space parameterization method. The default is the ' // &
	'\ttt{"wood"} method that takes into account electroweak/BSM ' // &
	'resonances. Note that this might not be the best choice for ' // &
	'(pure) QCD amplitudes. (cf. also \ttt{\$phs\_file})'))
	call var_list%append_log (var_str ("?vis_channels"), .false., &
	intrinsic=.true., &
	description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
	'command that demands \whizard\ to generate a PDF or postscript ' // &
	'output showing the classification of the found phase space ' // &
	'channels (if the phase space method \ttt{wood} has been used) ' // &
	'according to their properties: \ttt{integrate (foo) \{ iterations=3:10000 ' // &
	'?vis\_channels = true \}}. The default is \ttt{false}. (cf. ' // &
	'also \ttt{integrate}, \ttt{?vis\_history})'))
	call var_list%append_log (var_str ("?check_phs_file"), .true., &
	intrinsic=.true., &
	description=var_str ('Setting this to false turns off all sanity ' // &
	'checks when reading a previously generated phase-space configuration ' // &
	'file. Use this at your own risk; the program may return wrong ' // &
	'results or crash if data do not match. (cf. also \ttt{?check\_event\_file}, ' // &
	'\ttt{?check\_grid\_file})'))
	call var_list%append_string (var_str ("$phs_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('This string variable allows the user to ' // &
	'set an individual file name for the phase space parameterization ' // &
	'for a particular process: \ttt{\$phs\_file = "{\em <file\_name>}"}. ' // &
	'If not set, the default is \ttt{{\em <proc\_name>}\_{\em <proc\_comp>}.{\em ' // &
	'<run\_id>}.phs}. (cf. also \ttt{\$phs\_method})'))
	call var_list%append_log (var_str ("?phs_only"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag (particularly as optional argument ' // &
	'of the $\to$ \ttt{integrate} command) that allows to only generate ' // &
	'the phase space file, but not perform the integration. (cf. ' // &
	'also \ttt{\$phs\_method}, \ttt{\$phs\_file})'))
	call var_list%append_real (var_str ("phs_threshold_s"), 50._default, &
	intrinsic=.true., &
	description=var_str ('For the phase space method \ttt{wood}, ' // &
	'this real parameter sets the threshold below which particles ' // &
	'are assumed to be massless in the $s$-channel like kinematic ' // &
	'regions. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_off\_shell}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
	'\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
	'\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
	call var_list%append_real (var_str ("phs_threshold_t"), 100._default, &
	intrinsic=.true., &
	description=var_str ('For the phase space method \ttt{wood}, ' // &
	'this real parameter sets the threshold below which particles ' // &
	'are assumed to be massless in the $t$-channel like kinematic ' // &
	'regions. (cf. also \ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, ' // &
	'\newline \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
	'\ttt{?phs\_step\_mapping\_exp}, \newline \ttt{?phs\_s\_mapping})'))
	call var_list%append_int (var_str ("phs_off_shell"), 2, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of off-shell (not $t$-channel-like, non-resonant) lines that ' // &
	'are taken into account to find a valid phase-space setup in ' // &
	'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // &
	'\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_e\_scale}, ' // &
	'\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
	'\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
	'\ttt{?phs\_s\_mapping})'))
	call var_list%append_int (var_str ("phs_t_channel"), 6, &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of $t$-channel propagators in multi-peripheral diagrams that ' // &
	'are taken into account to find a valid phase-space setup in ' // &
	'the \ttt{wood} phase-space method. (cf. also \ttt{phs\_threshold\_t}, ' // &
	'\ttt{phs\_threshold\_s}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
	'\ttt{phs\_m\_scale}, \ttt{phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
	'\ttt{?phs\_step\_mapping}, \newline \ttt{?phs\_step\_mapping\_exp}, ' // &
	'\ttt{?phs\_s\_mapping})'))
	call var_list%append_real (var_str ("phs_e_scale"), 10._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the energy scale ' // &
	'that acts as a cutoff for parameterizing radiation-like kinematics ' // &
	'in the \ttt{wood} phase space method. \whizard\ takes the maximum ' // &
	'of this value and the width of the propagating particle as ' // &
	'a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
	'\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
	'\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
	call var_list%append_real (var_str ("phs_m_scale"), 10._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the mass scale ' // &
	'that acts as a cutoff for parameterizing collinear and infrared ' // &
	'kinematics in the \ttt{wood} phase space method. \whizard\ ' // &
	'takes the maximum of this value and the mass of the propagating ' // &
	'particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
	'\ttt{phs\_q\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_step\_mapping}, ' // &
	'\ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
	call var_list%append_real (var_str ("phs_q_scale"), 10._default, &
	intrinsic=.true., &
	description=var_str ('Real parameter that sets the momentum ' // &
	'transfer scale that acts as a cutoff for parameterizing $t$- ' // &
	'and $u$-channel like kinematics in the \ttt{wood} phase space ' // &
	'method. \whizard\ takes the maximum of this value and the mass ' // &
	'of the propagating particle as a cutoff. (cf. also \ttt{phs\_threshold\_t}, ' // &
	'\ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, ' // &
	'\ttt{phs\_e\_scale}, \ttt{phs\_m\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
	'\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp}, ' // &
	'\newline \ttt{?phs\_s\_mapping})'))
	call var_list%append_log (var_str ("?phs_keep_nonresonant"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether the \ttt{wood} ' // &
	'phase space method takes into account also non-resonant contributions. ' // &
	'(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_m\_scale}, ' // &
	'\ttt{phs\_q\_scale}, \ttt{phs\_e\_scale}, \ttt{?phs\_step\_mapping}, ' // &
	'\newline \ttt{?phs\_step\_mapping\_exp}, \ttt{?phs\_s\_mapping})'))
	call var_list%append_log (var_str ("?phs_step_mapping"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that switches on (or off) a particular ' // &
	'phase space mapping for resonances, where the mass and width ' // &
	'of the resonance are explicitly set as channel cutoffs. (cf. ' // &
	'also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, \ttt{phs\_t\_channel}, ' // &
	'\ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, \newline \ttt{phs\_m\_scale}, ' // &
	'\ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, \ttt{?phs\_step\_mapping\_exp}, ' // &
	'\newline \ttt{?phs\_s\_mapping})'))
	call var_list%append_log (var_str ("?phs_step_mapping_exp"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that switches on (or off) a particular ' // &
	'phase space mapping for resonances, where the mass and width ' // &
	'of the resonance are explicitly set as channel cutoffs. This ' // &
	'is an exponential mapping in contrast to ($\to$) \ttt{?phs\_step\_mapping}. ' // &
	'(cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
	'\ttt{phs\_m\_scale}, \newline \ttt{?phs\_q\_scale}, \ttt{?phs\_keep\_resonant}, ' // &
	'\ttt{?phs\_step\_mapping}, \ttt{?phs\_s\_mapping})'))
	call var_list%append_log (var_str ("?phs_s_mapping"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that allows special mapping for $s$-channel ' // &
	'resonances. (cf. also \ttt{phs\_threshold\_t}, \ttt{phs\_threshold\_s}, ' // &
	'\ttt{phs\_t\_channel}, \ttt{phs\_off\_shell}, \ttt{phs\_e\_scale}, ' // &
	'\ttt{phs\_m\_scale}, \newline \ttt{?phs\_keep\_resonant}, \ttt{?phs\_q\_scale}, ' // &
	'\ttt{?phs\_step\_mapping}, \ttt{?phs\_step\_mapping\_exp})'))
	call var_list%append_log (var_str ("?vis_history"), .false., &
	intrinsic=.true., &
	description=var_str ('Optional logical argument for the \ttt{integrate} ' // &
	'command that demands \whizard\ to generate a PDF or postscript ' // &
	'output showing the adaptation history of the Monte-Carlo integration ' // &
	'of the process under consideration. (cf. also \ttt{integrate}, ' // &
	'\ttt{?vis\_channels})'))
	end subroutine var_list_set_phase_space_defaults

	@ %def var_list_set_phase_space_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_gamelan_defaults => var_list_set_gamelan_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_gamelan_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_int (&
	var_str ("n_bins"), 20, &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: integer value that sets the number of bins in histograms. ' // &
	'(cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
	'\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
	'\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, ' // &
	'\ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
	'\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
	'\ttt{\$symbol})'))
	call var_list%append_log (&
	var_str ("?normalize_bins"), .false., &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that determines whether the weights shall be normalized ' // &
	'to the bin width or not. (cf. also \ttt{n\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
	'\newline \ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \newline ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$obs_label"), var_str (""), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: this is a string variable \ttt{\$obs\_label = "{\em ' // &
	'<LaTeX\_Code>}"} that allows to attach a label to a plotted ' // &
	'or histogrammed observable. (cf. also \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$obs_unit"), var_str (""), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: this is a string variable \ttt{\$obs\_unit = "{\em ' // &
	'<LaTeX\_Code>}"} that allows to attach a \LaTeX\ physical unit ' // &
	'to a plotted or histogrammed observable. (cf. also \ttt{n\_bins}, ' // &
	'\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
	'\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$title"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('This string variable sets the title of ' // &
	'a plot in a \whizard\ analysis setup, e.g. a histogram or an ' // &
	'observable. The syntax is \ttt{\$title = "{\em <your title>}"}. ' // &
	'This title appears as a section header in the analysis file, ' // &
	'but not in the screen output of the analysis. (cf. also \ttt{n\_bins}, ' // &
	'\ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
	'\ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \newline \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$description"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to specify ' // &
	'a description text for the analysis, \ttt{\$description = "{\em ' // &
	'<LaTeX analysis descr.>}"}. This line appears below the title ' // &
	'of a corresponding analysis, on top of the respective plot. ' // &
	'(cf. also \ttt{analysis}, \ttt{n\_bins}, \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{?y\_log}, ' // &
	'\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?fill\_curve}, \ttt{?draw\_piecewise}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$x_label"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable, \ttt{\$x\_label = "{\em ' // &
	'<LaTeX code>}"}, that sets the $x$ axis label in a plot or ' // &
	'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // &
	'\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{\$y\_label}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_string (var_str ("$y_label"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable, \ttt{\$y\_label = "{\em ' // &
	'<LaTeX\_code>}"}, that sets the $y$ axis label in a plot or ' // &
	'histogram in a \whizard\ analysis. (cf. also \ttt{analysis}, ' // &
	'\ttt{n\_bins}, \ttt{?normalize\_bins}, \ttt{\$obs\_unit}, \ttt{?y\_log}, ' // &
	'\ttt{?x\_log}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?fill\_curve}, \newline \ttt{?draw\_piecewise}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{\$symbol}, \ttt{?draw\_symbols}, ' // &
	'\newline \ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options})'))
	call var_list%append_int (var_str ("graph_width_mm"), 130, &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: integer value that sets the width of a graph or histogram ' // &
	'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
	'\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_int (var_str ("graph_height_mm"), 90, &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: integer value that sets the height of a graph or histogram ' // &
	'in millimeters. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, \ttt{?draw\_base}, ' // &
	'\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_log (var_str ("?y_log"), .false., &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that makes the $y$ axis logarithmic. (cf. also ' // &
	'\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
	'\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
	'\ttt{\$symbol})'))
	call var_list%append_log (var_str ("?x_log"), .false., &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that makes the $x$ axis logarithmic. (cf. also ' // &
	'\ttt{?normalize\_bins}, \ttt{\$obs\_label}, \ttt{\$obs\_unit}, ' // &
	'\ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, \ttt{\$y\_label}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{graph\_width\_mm}, \ttt{?y\_log}, ' // &
	'\ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{\$gmlcode\_fg}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \newline \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
	'\ttt{\$symbol})'))
	call var_list%append_real (var_str ("x_min"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: real parameter that sets the lower limit of the $x$ ' // &
	'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_real (var_str ("x_max"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: real parameter that sets the upper limit of the $x$ ' // &
	'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{x\_min}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_real (var_str ("y_min"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: real parameter that sets the lower limit of the $y$ ' // &
	'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{x\_max}, \ttt{y\_max}, \ttt{x\_min}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_real (var_str ("y_max"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: real parameter that sets the upper limit of the $y$ ' // &
	'axis plotting or histogram interval. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \newline \ttt{?x\_log}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{x\_max}, \ttt{x\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{\$gmlcode\_fg}, \ttt{?draw\_base}, \newline \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$gmlcode_bg"), var_str (""), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: string variable that allows to define a background ' // &
	'for plots and histograms (i.e. it is overwritten by the plot/histogram), ' // &
	'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
	'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
	'\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$gmlcode_fg"), var_str (""), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: string variable that allows to define a foreground ' // &
	'for plots and histograms (i.e. it overwrites the plot/histogram), ' // &
	'e.g. a grid: \ttt{\$gmlcode\_bg = "standardgrid.lr(5);"}. For ' // &
	'more details, see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
	'\newline \ttt{?fill\_curve}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \newline \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_log (var_str ("?draw_histogram"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that tells \whizard\ to either plot data as a ' // &
	'histogram or as a continuous line (if $\to$ \ttt{?draw\_curve} ' // &
	'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
	'\ttt{\$symbol})'))
	call var_list%append_log (var_str ("?draw_base"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that tells \whizard\ to insert a \ttt{base} statement ' // &
	'in the analysis code to calculate the plot data from a data ' // &
	'set. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\ttt{\$symbol}, \newline \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
	'\newline \ttt{\$err\_options})'))
	call var_list%append_log (var_str ("?draw_piecewise"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that tells \whizard\ to data from a data set piecewise, ' // &
	'i.e. histogram style. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, ' // &
	'\ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_base}, \ttt{?fill\_curve}, ' // &
	'\ttt{\$symbol}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options})'))
	call var_list%append_log (var_str ("?fill_curve"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that tells \whizard\ to fill data curves (e.g. ' // &
	'as a histogram). The style can be set with $\to$ \ttt{\$fill\_options ' // &
	'= "{\em <LaTeX\_code>}"}. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
	'\ttt{?draw\_symbols}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_log (var_str ("?draw_curve"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that tells \whizard\ to either plot data as a ' // &
	'continuous line or as a histogram (if $\to$ \ttt{?draw\_histogram} ' // &
	'is set \ttt{true}). (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\ttt{?draw\_histogram}, \ttt{?draw\_errors}, \ttt{?draw\_symbols}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \ttt{\$err\_options}, ' // &
	'\ttt{\$symbol})'))
	call var_list%append_log (var_str ("?draw_errors"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that determines whether error bars should be drawn ' // &
	'or not. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\newline \ttt{\$draw\_options}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_log (var_str ("?draw_symbols"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: flag that determines whether particular symbols (specified ' // &
	'by $\to$ \ttt{\$symbol = "{\em <LaTeX\_code>}"}) should be ' // &
	'used for plotting data points (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
	'\ttt{?fill\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_curve}, ' // &
	'\ttt{?draw\_errors}, \ttt{\$fill\_options}, \ttt{\$draw\_options}, ' // &
	'\newline \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$fill_options"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: \ttt{\$fill\_options = "{\em <LaTeX\_code>}"} is a ' // &
	'string variable that allows to set fill options when plotting ' // &
	'data as filled curves with the $\to$ \ttt{?fill\_curve} flag. ' // &
	'For more details see the \gamelan\ manual. (cf. also \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_label}, \ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, ' // &
	'\ttt{\$x\_label}, \ttt{\$y\_label}, \ttt{graph\_width\_mm}, ' // &
	'\ttt{graph\_height\_mm}, \ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, ' // &
	'\ttt{x\_max}, \ttt{y\_min}, \ttt{y\_max}, \ttt{\$gmlcode\_fg}, ' // &
	'\ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, \ttt{?draw\_piecewise}, ' // &
	'\ttt{?draw\_curve}, \ttt{?draw\_histogram}, \ttt{?draw\_errors}, ' // &
	'\newline \ttt{?draw\_symbols}, \ttt{?fill\_curve}, \ttt{\$draw\_options}, ' // &
	'\ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$draw_options"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: \ttt{\$draw\_options = "{\em <LaTeX\_code>}"} is a ' // &
	'string variable that allows to set specific drawing options ' // &
	'for plots and histograms. For more details see the \gamelan\ ' // &
	'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
	'\newline \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_errors}, \ttt{?draw\_symbols}, \newline \ttt{\$fill\_options}, ' // &
	'\ttt{?draw\_histogram}, \ttt{\$err\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$err_options"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: \ttt{\$err\_options = "{\em <LaTeX\_code>}"} is a string ' // &
	'variable that allows to set specific drawing options for errors ' // &
	'in plots and histograms. For more details see the \gamelan\ ' // &
	'manual. (cf. also \ttt{?normalize\_bins}, \ttt{\$obs\_label}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, \ttt{?draw\_base}, ' // &
	'\ttt{?draw\_piecewise}, \ttt{?fill\_curve}, \ttt{?draw\_histogram}, ' // &
	'\ttt{?draw\_errors}, \newline \ttt{?draw\_symbols}, \ttt{\$fill\_options}, ' // &
	'\ttt{?draw\_histogram}, \ttt{\$draw\_options}, \ttt{\$symbol})'))
	call var_list%append_string (var_str ("$symbol"), &
	intrinsic=.true., &
	description=var_str ("Settings for \whizard's internal graphics " // &
	'output: \ttt{\$symbol = "{\em <LaTeX\_code>}"} is a string ' // &
	'variable for the symbols that should be used for plotting data ' // &
	'points. (cf. also \ttt{\$obs\_label}, \ttt{?normalize\_bins}, ' // &
	'\ttt{\$obs\_unit}, \ttt{\$title}, \ttt{\$description}, \ttt{\$x\_label}, ' // &
	'\ttt{\$y\_label}, \newline \ttt{graph\_width\_mm}, \ttt{graph\_height\_mm}, ' // &
	'\ttt{?y\_log}, \ttt{?x\_log}, \ttt{x\_min}, \ttt{x\_max}, \ttt{y\_min}, ' // &
	'\ttt{y\_max}, \newline \ttt{\$gmlcode\_fg}, \ttt{\$gmlcode\_bg}, ' // &
	'\ttt{?draw\_base}, \ttt{?draw\_piecewise}, \ttt{?fill\_curve}, ' // &
	'\newline \ttt{?draw\_histogram}, \ttt{?draw\_curve}, \ttt{?draw\_errors}, ' // &
	'\ttt{\$fill\_options}, \ttt{\$draw\_options}, \newline \ttt{\$err\_options}, ' // &
	'\ttt{?draw\_symbols})'))
	call var_list%append_log (&
	var_str ("?analysis_file_only"), .false., &
	intrinsic=.true., &
	description=var_str ('Allows to specify that only \LaTeX\ files ' // &
	"for \whizard's graphical analysis are written out, but not processed. " // &
	'(cf. \ttt{compile\_analysis}, \ttt{write\_analysis})'))
	end subroutine var_list_set_gamelan_defaults

	@ %def var_list_set_gamelan_defaults
	@ FastJet parameters and friends
	<<Variables: var list: TBP>>=
	procedure :: set_clustering_defaults => var_list_set_clustering_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_clustering_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_int (&
	var_str ("kt_algorithm"), &
	kt_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the ' // &
	'interfaced external \fastjet\ package. (cf. also ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
	'\ttt{plugin\_algorithm}, ' // &
	'\newline\ttt{genkt\_[for\_passive\_]algorithm}, ' // &
	'\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("cambridge_algorithm"), &
	cambridge_algorithm, intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("antikt_algorithm"), &
	antikt_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("genkt_algorithm"), &
	genkt_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_for\_passive\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r}), \ttt{jet\_p}'))
	call var_list%append_int (&
	var_str ("cambridge_for_passive_algorithm"), &
	cambridge_for_passive_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_algorithm}, \ttt{plugin\_algorithm}, \newline ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("genkt_for_passive_algorithm"), &
	genkt_for_passive_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_for\_passive\_algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_algorithm}, \ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("ee_kt_algorithm"), &
	ee_kt_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_genkt\_algorithm}, ' // &
	'\ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("ee_genkt_algorithm"), &
	ee_genkt_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{plugin\_algorithm}, ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_kt\_algorithm}, ' // &
	'\ttt{jet\_r}), \ttt{jet\_p})'))
	call var_list%append_int (&
	var_str ("plugin_algorithm"), &
	plugin_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('Specifies a jet algorithm for the ($\to$) ' // &
	'\ttt{jet\_algorithm} command, used in the ($\to$) \ttt{cluster} ' // &
	'subevent function. At the moment only available for the interfaced ' // &
	'external \fastjet\ package. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r})'))
	call var_list%append_int (&
	var_str ("undefined_jet_algorithm"), &
	undefined_jet_algorithm, &
	intrinsic = .true., locked = .true., &
	description=var_str ('This is just a place holder for any kind of jet ' // &
	'jet algorithm that is not further specified. (cf. also \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_for\_passive\_algorithm}, \newline ' // &
	'\ttt{genkt\_[for\_passive\_]algorithm}, \ttt{ee\_[gen]kt\_algorithm}, ' // &
	'\ttt{jet\_r}, \ttt{plugin\_algorithm})'))
	call var_list%append_int (&
	var_str ("jet_algorithm"), undefined_jet_algorithm, &
	intrinsic = .true., &
	description=var_str ('Variable that allows to set the type of ' // &
	'jet algorithm when using the external \fastjet\ library. It ' // &
	'accepts one of the following algorithms: ($\to$) \ttt{kt\_algorithm}, ' // &
	'\newline ($\to$) \ttt{cambridge\_[for\_passive\_]algorithm}, ' // &
	'($\to$) \ttt{antikt\_algorithm}, ($\to$) \ttt{plugin\_algorithm}, ' // &
	'($\to$) \ttt{genkt\_[for\_passive\_]algorithm}, ($\to$) ' // &
	'\ttt{ee\_[gen]kt\_algorithm}). (cf. also \ttt{cluster}, ' // &
	'\ttt{jet\_p}, \ttt{jet\_r}, \ttt{jet\_ycut})'))
	call var_list%append_real (&
	var_str ("jet_r"), 0._default, &
	intrinsic = .true., &
	description=var_str ('Value for the distance measure $R$ used in ' // &
	'some algorithms that are available via the interface ' // &
	'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // &
	'\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
	'\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
	'\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_ycut})'))
	call var_list%append_real (&
	var_str ("jet_p"), 0._default, &
	intrinsic = .true., &
	description=var_str ('Value for the exponent of the distance measure $R$ in ' // &
	'the generalized $k_T$ algorithms that are available via the interface ' // &
	'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // &
	'\ttt{jet\_algorithm}, \ttt{kt\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
	'\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
	'\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_r}, \newline\ttt{jet\_ycut})'))
	call var_list%append_real (&
	var_str ("jet_ycut"), 0._default, &
	intrinsic = .true., &
	description=var_str ('Value for the $y$ separation measure used in ' // &
	'the Cambridge-Aachen algorithms that are available via the interface ' // &
	'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // &
	'\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
	'\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
	'\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
	call var_list%append_real (&
	var_str ("jet_dcut"), 0._default, &
	intrinsic = .true., &
	description=var_str ('Value for the $d_{ij}$ separation measure used in ' // &
	'the $e^+e^- k_T$ algorithms that are available via the interface ' // &
	'to the \fastjet\ package. (cf. also \ttt{cluster}, \ttt{combine}, ' // &
	'\ttt{kt\_algorithm}, \ttt{jet\_algorithm}, ' // &
	'\ttt{cambridge\_[for\_passive\_]algorithm}, \ttt{antikt\_algorithm}, ' // &
	'\newline \ttt{plugin\_algorithm}, \ttt{genkt\_[for\_passive\_]algorithm}, ' // &
	'\ttt{ee\_[gen]kt\_algorithm}, \ttt{jet\_p}, \newline\ttt{jet\_r})'))
	call var_list%append_log (&
	var_str ("?keep_flavors_when_clustering"), .false., &
	intrinsic = .true., &
	description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_clustering ' // &
	'= true/false} specifies whether the flavor of a jet should be ' // &
	'kept during \ttt{cluster} when a jet consists of one quark and ' // &
	'zero or more gluons. Especially useful for cuts on b-tagged ' // &
	'jets (cf. also \ttt{cluster}).'))
	end subroutine var_list_set_clustering_defaults

	@ %def var_list_set_clustering_defaults
	@ Frixione isolation and photon recombination parameters and all that:
	<<Variables: var list: TBP>>=
	procedure :: set_isolation_recomb_defaults => &
	var_list_set_isolation_recomb_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_isolation_recomb_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_real (var_str ("photon_iso_eps"), 1._default, &
	intrinsic=.true., &
	description=var_str ('Photon isolation parameter $\epsilon_\gamma$ ' // &
	'(energy fraction) from hep-ph/9801442 (cf. also ' // &
	'\ttt{photon\_iso\_n}, \ttt{photon\_iso\_r0})'))
	call var_list%append_real (var_str ("photon_iso_n"), 1._default, &
	intrinsic=.true., &
	description=var_str ('Photon isolation parameter $n$ ' // &
	'(cone function exponent) from hep-ph/9801442 (cf. also ' // &
	'\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_r0})'))
	call var_list%append_real (var_str ("photon_iso_r0"), 0.4_default, &
	intrinsic=.true., &
	description=var_str ('Photon isolation parameter $R_0^\gamma$ ' // &
	'(isolation cone radius) from hep-ph/9801442 (cf. also ' // &
	'\ttt{photon\_iso\_eps}, \ttt{photon\_iso\_n})'))
	call var_list%append_real (var_str ("photon_rec_r0"), 0.1_default, &
	intrinsic=.true., &
	description=var_str ('Photon recombination parameter $R_0^\gamma$ ' // &
	'for photon recombination in NLO EW calculations'))
	call var_list%append_log (&
	var_str ("?keep_flavors_when_recombining"), .true., &
	intrinsic = .true., &
	description=var_str ('The logical variable \ttt{?keep\_flavors\_when\_recombining ' // &
	'= true/false} specifies whether the flavor of a particle should be ' // &
	'kept during \ttt{photon\_recombination} when a jet/lepton consists of one lepton/quark ' // &
	'and zero or more photons (cf. also \ttt{photon\_recombination}).'))
	end subroutine var_list_set_isolation_recomb_defaults

	@ %def var_list_set_isolation_recomb_defaults
	<<Variables: var list: TBP>>=
	procedure :: set_eio_defaults => var_list_set_eio_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_eio_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_string (var_str ("$sample"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable to set the (base) name ' // &
	'of the event output format, e.g. \ttt{\$sample = "foo"} will ' // &
	'result in an intrinsic binary format event file \ttt{foo.evx}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{simulate}, \ttt{hepevt}, ' // &
	'\ttt{ascii}, \ttt{athena}, \ttt{debug}, \ttt{long}, \ttt{short}, ' // &
	'\ttt{hepmc}, \ttt{lhef}, \ttt{lha}, \ttt{stdhep}, \ttt{stdhep\_up}, ' // &
	'\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, \ttt{sample\_max\_tries})'))
	call var_list%append_string (var_str ("$sample_normalization"), var_str ("auto"),&
	intrinsic=.true., &
	description=var_str ('String variable that allows to set the ' // &
	'normalization of generated events. There are four options: ' // &
	'option \ttt{"1"} (events normalized to one), \ttt{"1/n"} (sum ' // &
	'of all events in a sample normalized to one), \ttt{"sigma"} ' // &
	'(events normalized to the cross section of the process), and ' // &
	'\ttt{"sigma/n"} (sum of all events normalized to the cross ' // &
	'section). The default is \ttt{"auto"} where unweighted events ' // &
	'are normalized to one, and weighted ones to the cross section. ' // &
	'(cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
	'\ttt{?sample\_pacify}, \ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
	'\ttt{sample\_split\_n\_kbytes})'))
	call var_list%append_log (var_str ("?sample_pacify"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag, mainly for debugging purposes: suppresses ' // &
	'numerical noise in the output of a simulation. (cf. also \ttt{simulate}, ' // &
	'\ttt{\$sample}, \ttt{sample\_format}, \ttt{\$sample\_normalization}, ' // &
	'\ttt{sample\_max\_tries}, \ttt{sample\_split\_n\_evt}, ' // &
	'\ttt{sample\_split\_n\_kbytes})'))
	call var_list%append_log (var_str ("?sample_select"), .true., &
	intrinsic=.true., &
	description=var_str ('Logical that determines whether a selection should ' // &
	'be applied to the output event format or not. If set to \ttt{false} a ' // &
	'selection is only considered for the evaluation of observables. (cf. ' // &
	'\ttt{select}, \ttt{selection}, \ttt{analysis})'))
	call var_list%append_int (var_str ("sample_max_tries"), 10000, &
	intrinsic = .true., &
	description=var_str ('Integer variable that sets the maximal ' // &
	'number of tries for generating a single event. The event might ' // &
	'be vetoed because of a very low unweighting efficiency, errors ' // &
	'in the event transforms like decays, shower, matching, hadronization ' // &
	'etc. (cf. also \ttt{simulate}, \ttt{\$sample}, \ttt{sample\_format}, ' // &
	'\ttt{?sample\_pacify}, \ttt{\$sample\_normalization}, ' // &
	'\ttt{sample\_split\_n\_evt}, \newline\ttt{sample\_split\_n\_kbytes})'))
	call var_list%append_int (var_str ("sample_split_n_evt"), 0, &
	intrinsic = .true., &
	description=var_str ('When generating events, this integer parameter ' // &
	'\ttt{sample\_split\_n\_evt = {\em <num>}} gives the number \ttt{{\em ' // &
	'<num>}} of breakpoints in the event files, i.e. it splits the ' // &
	'event files into \ttt{{\em <num>} + 1} parts. The parts are ' // &
	'denoted by \ttt{{\em <proc\_name>}.{\em <split\_index>}.{\em ' // &
	'<evt\_extension>}}. Here, \ttt{{\em <split\_index>}} is an integer ' // &
	'running from \ttt{0} to \ttt{{\em <num>}}. The start can be ' // &
	'reset by ($\to$) \ttt{sample\_split\_index}. (cf. also \ttt{simulate}, ' // &
	'\ttt{\$sample}, \ttt{sample\_format}, \ttt{sample\_max\_tries}, ' // &
	'\ttt{\$sample\_normalization}, \ttt{?sample\_pacify}, ' // &
	'\ttt{sample\_split\_n\_kbytes})'))
	call var_list%append_int (var_str ("sample_split_n_kbytes"), 0, &
	intrinsic = .true., &
	description=var_str ('When generating events, this integer parameter ' // &
	'\ttt{sample\_split\_n\_kbytes = {\em <num>}} limits the file ' // &
	'size of event files. Whenever an event file has exceeded this ' // &
	'size, counted in kilobytes, the following events will be written ' // &
	'to a new file. The naming conventions are the same as for ' // &
	'\ttt{sample\_split\_n\_evt}. (cf. also \ttt{simulate}, \ttt{\$sample}, ' // &
	'\ttt{sample\_format}, \ttt{sample\_max\_tries}, \ttt{\$sample\_normalization}, ' // &
	'\ttt{?sample\_pacify})'))
	call var_list%append_int (var_str ("sample_split_index"), 0, &
	intrinsic = .true., &
	description=var_str ('Integer number that gives the starting ' // &
	'index \ttt{sample\_split\_index = {\em <split\_index>}} for ' // &
	'the numbering of event samples \ttt{{\em <proc\_name>}.{\em ' // &
	'<split\_index>}.{\em <evt\_extension>}} split by the \ttt{sample\_split\_n\_evt ' // &
	'= {\em <num>}}. The index runs from \ttt{{\em <split\_index>}} ' // &
	'to \newline \ttt{{\em <split\_index>} + {\em <num>}}. (cf. also \ttt{simulate}, ' // &
	'\ttt{\$sample}, \ttt{sample\_format}, \newline\ttt{\$sample\_normalization}, ' // &
	'\ttt{sample\_max\_tries}, \ttt{?sample\_pacify})'))
	call var_list%append_string (var_str ("$rescan_input_format"), var_str ("raw"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to set the ' // &
	'event format of the event file that is to be rescanned by the ' // &
	'($\to$) \ttt{rescan} command.'))
	call var_list%append_log (var_str ("?read_raw"), .true., &
	intrinsic=.true., &
	description=var_str ('This flag demands \whizard\ to (try to) ' // &
	'read events (from the internal binary format) first before ' // &
	'generating new ones. (cf. \ttt{simulate}, \ttt{?write\_raw}, ' // &
	'\ttt{\$sample}, \ttt{sample\_format})'))
	call var_list%append_log (var_str ("?write_raw"), .true., &
	intrinsic=.true., &
	description=var_str ("Flag to write out events in \whizard's " // &
	'internal binary format. (cf. \ttt{simulate}, \ttt{?read\_raw}, ' // &
	'\ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_raw"), var_str ("evx"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_raw ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	"to which events in \whizard's internal format are written. If " // &
	'not set, the default file name and suffix is \ttt{{\em <process\_name>}.evx}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_default"), var_str ("evt"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_default ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in a the standard \whizard\ verbose ASCII format ' // &
	'are written. If not set, the default file name and suffix is ' // &
	'\ttt{{\em <process\_name>}.evt}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample})'))
	call var_list%append_string (var_str ("$debug_extension"), var_str ("debug"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$debug\_extension ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in a long verbose format with debugging information ' // &
	'are written. If not set, the default file name and suffix is ' // &
	'\ttt{{\em <process\_name>}.debug}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{?debug\_process}, \ttt{?debug\_transforms}, ' // &
	'\ttt{?debug\_decay}, \ttt{?debug\_verbose})'))
	call var_list%append_log (var_str ("?debug_process"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether process information ' // &
	'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
	'\ttt{?debug\_decay}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
	call var_list%append_log (var_str ("?debug_transforms"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether information ' // &
	'about event transforms will be displayed in the ASCII debug ' // &
	'event format ($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{?debug\_decay}, \ttt{\$debug\_extension}, ' // &
	'\ttt{?debug\_process}, \ttt{?debug\_verbose})'))
	call var_list%append_log (var_str ("?debug_decay"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether decay information ' // &
	'will be displayed in the ASCII debug event format ($\to$) \ttt{debug}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{\$debug\_extension}, ' // &
	'\ttt{?debug\_process}, \ttt{?debug\_transforms}, \ttt{?debug\_verbose})'))
	call var_list%append_log (var_str ("?debug_verbose"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether extensive verbose ' // &
	'information will be included in the ASCII debug event format ' // &
	'($\to$) \ttt{debug}. (cf. also \ttt{sample\_format}, \ttt{\$sample}, ' // &
	'\ttt{\$debug\_extension}, \ttt{?debug\_decay}, \ttt{?debug\_transforms}, ' // &
	'\ttt{?debug\_process})'))
	call var_list%append_string (var_str ("$dump_extension"), var_str ("pset.dat"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$dump\_extension ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	"to which events in \whizard's internal particle set format " // &
	'are written. If not set, the default file name and suffix is ' // &
	'\ttt{{\em <process\_name>}.pset.dat}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
	'\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
	call var_list%append_log (var_str ("?dump_compressed"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that, if set to \ttt{true}, issues ' // &
	'a very compressed and clear version of the \ttt{dump} ($\to$) ' // &
	'event format. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{dump}, \ttt{\$dump\_extension}, ' // &
	'\ttt{?dump\_screen}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
	call var_list%append_log (var_str ("?dump_weights"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
	'cross sections, weights and excess in the \ttt{dump} ($\to$) ' // &
	'event format. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
	'\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_summary})'))
	call var_list%append_log (var_str ("?dump_summary"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that, if set to \ttt{true}, includes ' // &
	'a summary with momentum sums for incoming and outgoing particles ' // &
	'as well as for beam remnants in the \ttt{dump} ($\to$) ' // &
	'event format. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
	'\ttt{\$dump\_extension}, \ttt{?dump\_screen}, \ttt{?dump\_weights})'))
	call var_list%append_log (var_str ("?dump_screen"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that, if set to \ttt{true}, outputs ' // &
	'events for the \ttt{dump} ($\to$) event format on screen ' // &
	' instead of to a file. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample}, \ttt{dump}, \ttt{?dump\_compressed}, ' // &
	'\ttt{\$dump\_extension}, \ttt{?dump\_summary}, \ttt{?dump\_weights})'))
	call var_list%append_log (var_str ("?hepevt_ensure_order"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to ensure that the particle set confirms ' // &
	'the HEPEVT standard. This involves some copying and reordering ' // &
	'to guarantee that mothers and daughters are always next to ' // &
	'each other. Usually this is not necessary.'))
	call var_list%append_string (var_str ("$extension_hepevt"), var_str ("hepevt"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_hepevt ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the \whizard\ version 1 style HEPEVT ASCII ' // &
	'format are written. If not set, the default file name and suffix ' // &
	'is \ttt{{\em <process\_name>}.hepevt}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_ascii_short"), &
	var_str ("short.evt"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_short ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the so called short variant of the \whizard\ ' // &
	'version 1 style HEPEVT ASCII format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.short.evt}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_ascii_long"), &
	var_str ("long.evt"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_ascii\_long ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the so called long variant of the \whizard\ ' // &
	'version 1 style HEPEVT ASCII format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.long.evt}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_athena"), &
	var_str ("athena.evt"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_athena ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the ATHENA file format are written. If not ' // &
	'set, the default file name and suffix is \ttt{{\em <process\_name>}.athena.evt}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_mokka"), &
	var_str ("mokka.evt"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_mokka ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the MOKKA format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.mokka.evt}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$lhef_version"), var_str ("2.0"), &
	intrinsic = .true., &
	description=var_str ('Specifier for the Les Houches Accord (LHEF) ' // &
	'event format files with XML headers to discriminate among different ' // &
	'versions of this format. (cf. also \ttt{\$sample}, \ttt{sample\_format}, ' // &
	'\ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
	'\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
	'\ttt{?lhef\_write\_sqme\_alt})'))
	call var_list%append_string (var_str ("$lhef_extension"), var_str ("lhe"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$lhef\_extension ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the LHEF format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.lhe}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample}, \ttt{lhef}, ' // &
	'\ttt{\$lhef\_extension}, \ttt{\$lhef\_version}, \ttt{?lhef\_write\_sqme\_prc}, ' // &
	'\ttt{?lhef\_write\_sqme\_ref}, \ttt{?lhef\_write\_sqme\_alt})'))
	call var_list%append_log (var_str ("?lhef_write_sqme_prc"), .true., &
	intrinsic = .true., &
	description=var_str ('Flag that decides whether in the ($\to$) ' // &
	'\ttt{lhef} event format the weights of the squared matrix element ' // &
	'of the corresponding process shall be written in the LHE file. ' // &
	'(cf. also \ttt{\$sample}, \ttt{sample\_format}, \ttt{lhef}, ' // &
	'\ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, \ttt{?lhef\_write\_sqme\_ref}, ' // &
	'\newline \ttt{?lhef\_write\_sqme\_alt})'))
	call var_list%append_log (var_str ("?lhef_write_sqme_ref"), .false., &
	intrinsic = .true., &
	description=var_str ('Flag that decides whether in the ($\to$) ' // &
	'\ttt{lhef} event format reference weights of the squared matrix ' // &
	'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
	'\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
	'\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_alt})'))
	call var_list%append_log (var_str ("?lhef_write_sqme_alt"), .true., &
	intrinsic = .true., &
	description=var_str ('Flag that decides whether in the ($\to$) ' // &
	'\ttt{lhef} event format alternative weights of the squared matrix ' // &
	'element shall be written in the LHE file. (cf. also \ttt{\$sample}, ' // &
	'\ttt{sample\_format}, \ttt{lhef}, \ttt{\$lhef\_extension}, \ttt{\$lhef\_extension}, ' // &
	'\ttt{?lhef\_write\_sqme\_prc}, \ttt{?lhef\_write\_sqme\_ref})'))
	call var_list%append_string (var_str ("$extension_lha"), var_str ("lha"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_lha ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the (deprecated) LHA format are written. ' // &
	'If not set, the default file name and suffix is \ttt{{\em <process\_name>}.lha}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_hepmc"), var_str ("hepmc"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_hepmc ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the HepMC format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.hepmc}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_log (var_str ("?hepmc_output_cross_section"), .false., &
	intrinsic = .true., &
	description=var_str ('Flag for the HepMC event format that allows ' // &
	'to write out the cross section (and error) from the integration ' // &
	'together with each HepMC event. This can be used by programs ' // &
	'like Rivet to scale histograms according to the cross section. ' // &
	'(cf. also \ttt{hepmc})'))
	call var_list%append_log (var_str ("?hepmc3_write_flows"), .false., &
	intrinsic = .true., &
	description=var_str ('Flag for the HepMC3 event format that decides' // &
	'whether to write out color flows. The default is \ttt{false}. ' // &
	'(cf. also \ttt{hepmc})'))
	call var_list%append_string (var_str ("$hepmc3_mode"), var_str ("HepMC3"), &
	intrinsic = .true., &
	description=var_str ('This specifies the writer mode for HepMC3. ' // &
	'Possible values are \ttt{HepMC2}, \ttt{HepMC3} (default), ' // &
	'\ttt{HepEVT}, \ttt{Root}. and \ttt{RootTree} (cf. also \ttt{hepmc})'))
	call var_list%append_string (var_str ("$extension_lcio"), var_str ("slcio"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_lcio ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the LCIO format are written. If not set, ' // &
	'the default file name and suffix is \ttt{{\em <process\_name>}.slcio}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_stdhep"), var_str ("hep"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_stdhep ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the StdHEP format via the HEPEVT common ' // &
	'block are written. If not set, the default file name and suffix ' // &
	'is \ttt{{\em <process\_name>}.hep}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_stdhep_up"), &
	var_str ("up.hep"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_up ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the StdHEP format via the HEPRUP/HEPEUP ' // &
	'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
	'is the default file name and suffix, if this variable not set. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_stdhep_ev4"), &
	var_str ("ev4.hep"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_stdhep\_ev4 ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the StdHEP format via the HEPEVT/HEPEV4 ' // &
	'common blocks are written. \ttt{{\em <process\_name>}.up.hep} ' // &
	'is the default file name and suffix, if this variable not set. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_hepevt_verb"), &
	var_str ("hepevt.verb"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_hepevt\_verb ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the \whizard\ version 1 style extended or ' // &
	'verbose HEPEVT ASCII format are written. If not set, the default ' // &
	'file name and suffix is \ttt{{\em <process\_name>}.hepevt.verb}. ' // &
	'(cf. also \ttt{sample\_format}, \ttt{\$sample})'))
	call var_list%append_string (var_str ("$extension_lha_verb"), &
	var_str ("lha.verb"), intrinsic=.true., &
	description=var_str ('String variable that allows via \ttt{\$extension\_lha\_verb ' // &
	'= "{\em <suffix>}"} to specify the suffix for the file \ttt{name.suffix} ' // &
	'to which events in the (deprecated) extended or verbose LHA ' // &
	'format are written. If not set, the default file name and suffix ' // &
	'is \ttt{{\em <process\_name>}.lha.verb}. (cf. also \ttt{sample\_format}, ' // &
	'\ttt{\$sample})'))
	end subroutine var_list_set_eio_defaults

	@ %def var_list_set_eio_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_shower_defaults => var_list_set_shower_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_shower_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (var_str ("?allow_shower"), .true., &
	intrinsic=.true., &
	description=var_str ('Master flag to switch on (initial and ' // &
	'final state) parton shower, matching/merging as an event ' // &
	'transform. As a default, it is switched on. (cf. also \ttt{?ps\_ ' // &
	'....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_fsr_active"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that switches final-state QCD radiation ' // &
	'(FSR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
	'\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_isr_active"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag that switches initial-state QCD ' // &
	'radiation (ISR) on. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_taudec_active"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to switch on $\tau$ decays, at ' // &
	'the moment only via the included external package \ttt{TAUOLA} ' // &
	'and \ttt{PHOTOS}. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?muli_active"), .false., &
	intrinsic=.true., &
	description=var_str ("Master flag that switches on \whizard's " // &
	'module for multiple interaction with interleaved QCD parton ' // &
	'showers for hadron colliders. Note that this feature is still ' // &
	'experimental. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...})'))
	call var_list%append_string (var_str ("$shower_method"), var_str ("WHIZARD"), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to specify ' // &
	'which parton shower is being used, the default, \ttt{"WHIZARD"}, ' // &
	'is one of the in-house showers of \whizard. Other possibilities ' // &
	'at the moment are only \ttt{"PYTHIA6"}.'))
	call var_list%append_log (var_str ("?shower_verbose"), .false., &
	intrinsic=.true., &
	description=var_str ('Flag to switch on verbose messages when ' // &
	'using shower and/or hadronization. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...},'))
	call var_list%append_string (var_str ("$ps_PYTHIA_PYGIVE"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to pass options ' // &
	'for tunes etc. to the attached \pythia\ parton shower or hadronization, ' // &
	'e.g.: \ttt{\$ps\_PYTHIA\_PYGIVE = "MSTJ(41)=1"}. (cf. also ' // &
	'\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_string (var_str ("$ps_PYTHIA8_config"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to pass options ' // &
	'for tunes etc. to the attached \pythia\ttt{8} parton shower or hadronization, ' // &
	'e.g.: \ttt{\$ps\_PYTHIA8\_config = "PartonLevel:MPI = off"}. (cf. also ' // &
	'\newline \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_string (var_str ("$ps_PYTHIA8_config_file"), var_str (""), &
	intrinsic=.true., &
	description=var_str ('String variable that allows to pass a filename to a ' // &
	'\pythia\ttt{8} configuration file.'))
	call var_list%append_real (&
	var_str ("ps_mass_cutoff"), 1._default, intrinsic = .true., &
	description=var_str ('Real value that sets the QCD parton shower ' // &
	'lower cutoff scale, where hadronization sets in. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (&
	var_str ("ps_fsr_lambda"), 0.29_default, intrinsic = .true., &
	description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
	'used in running $\alpha_s$ for time-like showers is set (except ' // &
	'for showers in the decay of a resonance). (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (&
	var_str ("ps_isr_lambda"), 0.29_default, intrinsic = .true., &
	description=var_str ('By this real parameter, the value of $\Lambda_{QCD}$ ' // &
	'used in running $\alpha_s$ for space-like showers is set. (cf. ' // &
	'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
	'\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_int (&
	var_str ("ps_max_n_flavors"), 5, intrinsic = .true., &
	description=var_str ('This integer parameter sets the maxmimum ' // &
	'number of flavors that can be produced in a QCD shower $g\to ' // &
	'q\bar q$. It is also used as the maximal number of active flavors ' // &
	'for the running of $\alpha_s$ in the shower (with a minimum ' // &
	'of 3). (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_isr_alphas_running"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether a running ' // &
	'$\alpha_s$ is taken in space-like QCD parton showers. (cf. ' // &
	'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
	'\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_fsr_alphas_running"), .true., &
	intrinsic=.true., &
	description=var_str ('Flag that decides whether a running ' // &
	'$\alpha_s$ is taken in time-like QCD parton showers. (cf. ' // &
	'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
	'\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str ("ps_fixed_alphas"), &
	0._default, intrinsic = .true., &
	description=var_str ('This real parameter sets the value of $\alpha_s$ ' // &
	'if it is (cf. $\to$ \ttt{?ps\_isr\_alphas\_running}, \newline ' // &
	'\ttt{?ps\_fsr\_alphas\_running}) not running in initial and/or ' // &
	'final-state QCD showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_isr_pt_ordered"), .false., &
	intrinsic=.true., &
	description=var_str ('By this flag, it can be switched between ' // &
	'the analytic QCD ISR shower (\ttt{false}, default) and the ' // &
	'$p_T$ ISR QCD shower (\ttt{true}). (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str ("?ps_isr_angular_ordered"), .true., &
	intrinsic=.true., &
	description=var_str ('If switched one, this flag forces opening ' // &
	'angles of emitted partons in the QCD ISR shower to be strictly ' // &
	'ordered, i.e. increasing towards the hard interaction. (cf. ' // &
	'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
	'\ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("ps_isr_primordial_kt_width"), 0._default, intrinsic = .true., &
	description=var_str ('This real parameter sets the width $\sigma ' // &
	'= \braket{k_T^2}$ for the Gaussian primordial $k_T$ distribution ' // &
	'inside the hadron, given by: $\exp[-k_T^2/\sigma^2] k_T dk_T$. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("ps_isr_primordial_kt_cutoff"), 5._default, intrinsic = .true., &
	description=var_str ('Real parameter that sets the upper cutoff ' // &
	'for the primordial $k_T$ distribution inside a hadron. (cf. ' // &
	'also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, ' // &
	'\ttt{?hadronization\_active}, \ttt{?mlm\_ ...})'))
	call var_list%append_real (var_str &
	("ps_isr_z_cutoff"), 0.999_default, intrinsic = .true., &
	description=var_str ('This real parameter allows to set the upper ' // &
	'cutoff on the splitting variable $z$ in space-like QCD parton ' // &
	'showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
	'\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("ps_isr_minenergy"), 1._default, intrinsic = .true., &
	description=var_str ('By this real parameter, the minimal effective ' // &
	'energy (in the c.m. frame) of a time-like or on-shell-emitted ' // &
	'parton in a space-like QCD shower is set. For a hard subprocess ' // &
	'that is not in the rest frame, this number is roughly reduced ' // &
	'by a boost factor $1/\gamma$ to the rest frame of the hard scattering ' // &
	'process. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
	'\ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("ps_isr_tscalefactor"), 1._default, intrinsic = .true., &
	description=var_str ('The $Q^2$ scale of the hard scattering ' // &
	'process is multiplied by this real factor to define the maximum ' // &
	'parton virtuality allowed in time-like QCD showers. This does ' // &
	'only apply to $t$- and $u$-channels, while for $s$-channel resonances ' // &
	'the maximum virtuality is set by $m^2$. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_log (var_str &
	("?ps_isr_only_onshell_emitted_partons"), .false., intrinsic=.true., &
	description=var_str ('This flag if set true sets all emitted ' // &
	'partons off space-like showers on-shell, i.e. it would not allow ' // &
	'associated time-like showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?hadronization\_active})'))
	end subroutine var_list_set_shower_defaults

	@ %def var_list_set_shower_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_hadronization_defaults => var_list_set_hadronization_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_hadronization_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log &
	(var_str ("?allow_hadronization"), .true., intrinsic=.true., &
	description=var_str ('Master flag to switch on hadronization ' // &
	'as an event transform. As a default, it is switched on. (cf. ' // &
	'also \ttt{?ps\_ ....}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, ' // &
	'\ttt{?hadronization\_active})'))
	call var_list%append_log &
	(var_str ("?hadronization_active"), .false., intrinsic=.true., &
	description=var_str ('Master flag to switch hadronization (through ' // &
	'the attached \pythia\ package) on or off. As a default, it is ' // &
	'off. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...})'))
	call var_list%append_string &
	(var_str ("$hadronization_method"), var_str ("PYTHIA6"), intrinsic = .true., &
	description=var_str ("Determines whether \whizard's own " // &
	"hadronization or the (internally included) \pythiasix\ should be used."))
	call var_list%append_real &
	(var_str ("hadron_enhanced_fraction"), 0.01_default, intrinsic = .true., &
	description=var_str ('Fraction of Lund strings that break with enhanced ' // &
	'width. [not yet active]'))
	call var_list%append_real &
	(var_str ("hadron_enhanced_width"), 2.0_default, intrinsic = .true., &
	description=var_str ('Enhancement factor for the width of breaking ' // &
	'Lund strings. [not yet active]'))
	end subroutine var_list_set_hadronization_defaults

	@ %def var_list_set_hadronization_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_tauola_defaults => var_list_set_tauola_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_tauola_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (&
	var_str ("?ps_tauola_photos"), .false., intrinsic=.true., &
	description=var_str ('Flag to switch on \ttt{PHOTOS} for photon ' // &
	'showering inside the \ttt{TAUOLA} package. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_log (&
	var_str ("?ps_tauola_transverse"), .false., intrinsic=.true., &
	description=var_str ('Flag to switch transverse $\tau$ polarization ' // &
	'on or off for Higgs decays into $\tau$ leptons. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_log (&
	var_str ("?ps_tauola_dec_rad_cor"), .true., intrinsic=.true., &
	description=var_str ('Flag to switch radiative corrections for ' // &
	'$\tau$ decays in \ttt{TAUOLA} on or off. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_int (&
	var_str ("ps_tauola_dec_mode1"), 0, intrinsic = .true., &
	description=var_str ('Integer code to request a specific $\tau$ ' // &
	'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
	'in correlated decays -- for the second $\tau$. For more information ' // &
	'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_int (&
	var_str ("ps_tauola_dec_mode2"), 0, intrinsic = .true., &
	description=var_str ('Integer code to request a specific $\tau$ ' // &
	'decay within \ttt{TAUOLA} for the decaying $\tau$, and -- ' // &
	'in correlated decays -- for the second $\tau$. For more information ' // &
	'cf. the comments in the code or the \ttt{TAUOLA} manual. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_real (&
	var_str ("ps_tauola_mh"), 125._default, intrinsic = .true., &
	description=var_str ('Real option to set the Higgs mass for Higgs ' // &
	'decays into $\tau$ leptons in the interface to \ttt{TAUOLA}. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_real (&
	var_str ("ps_tauola_mix_angle"), 90._default, intrinsic = .true., &
	description=var_str ('Option to set the mixing angle between ' // &
	'scalar and pseudoscalar Higgs bosons for Higgs decays into $\tau$ ' // &
	'leptons in the interface to \ttt{TAUOLA}. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	call var_list%append_log (&
	var_str ("?ps_tauola_pol_vector"), .false., intrinsic = .true., &
	description=var_str ('Flag to decide whether for transverse $\tau$ ' // &
	'polarization, polarization information should be taken from ' // &
	'\ttt{TAUOLA} or not. The default is just based on random numbers. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{?mlm\_ ...}, \ttt{?ps\_taudec\_active})'))
	end subroutine var_list_set_tauola_defaults

	@ %def var_list_set_tauola_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_mlm_matching_defaults => var_list_set_mlm_matching_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_mlm_matching_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (var_str ("?mlm_matching"), .false., &
	intrinsic=.true., &
	description=var_str ('Master flag to switch on MLM (LO) jet ' // &
	'matching between hard matrix elements and the QCD parton ' // &
	'shower. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, ' // &
	'\ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Qcut_ME"), 0._default, intrinsic = .true., &
	description=var_str ('Real parameter that in the MLM jet matching ' // &
	'between hard matrix elements and QCD parton shower sets a possible ' // &
	'virtuality cut on jets from the hard matrix element. (cf. also ' // &
	'\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
	'...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Qcut_PS"), 0._default, intrinsic = .true., &
	description=var_str ('Real parameter that in the MLM jet matching ' // &
	'between hard matrix elements and QCD parton shower sets a possible ' // &
	'virtuality cut on jets from the parton shower. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_ptmin"), 0._default, intrinsic = .true., &
	description=var_str ('This real parameter sets a minimal $p_T$ ' // &
	'that enters the $y_{cut}$ jet clustering measure in the MLM ' // &
	'jet matching between hard matrix elements and QCD parton showers. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_etamax"), 0._default, intrinsic = .true., &
	description=var_str ('This real parameter sets a maximal pseudorapidity ' // &
	'that enters the MLM jet matching between hard matrix elements ' // &
	'and QCD parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Rmin"), 0._default, intrinsic = .true., &
	description=var_str ('Real parameter that sets a minimal $R$ ' // &
	'distance value that enters the $y_{cut}$ jet clustering measure ' // &
	'in the MLM jet matching between hard matrix elements and QCD ' // &
	'parton showers. (cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ' // &
	'...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Emin"), 0._default, intrinsic = .true., &
	description=var_str ('Real parameter that sets a minimal energy ' // &
	'$E_{min}$ value as an infrared cutoff in the MLM jet matching ' // &
	'between hard matrix elements and QCD parton showers. (cf. also ' // &
	'\ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ' // &
	'...}, \ttt{?hadronization\_active})'))
	call var_list%append_int (var_str &
	("mlm_nmaxMEjets"), 0, intrinsic = .true., &
	description=var_str ('This integer sets the maximal number of ' // &
	'jets that are available from hard matrix elements in the MLM ' // &
	'jet matching between hard matrix elements and QCD parton shower. ' // &
	'(cf. also \ttt{?allow\_shower}, \ttt{?ps\_ ...}, \ttt{\$ps\_ ' // &
	'...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_ETclusfactor"), 0.2_default, intrinsic = .true., &
	description=var_str ('This real parameter is a factor that enters ' // &
	'the calculation of the $y_{cut}$ measure for jet clustering ' // &
	'after the parton shower in the MLM jet matching between hard ' // &
	'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_ETclusminE"), 5._default, intrinsic = .true., &
	description=var_str ('This real parameter is a minimal energy ' // &
	'that enters the calculation of the $y_{cut}$ measure for jet ' // &
	'clustering after the parton shower in the MLM jet matching between ' // &
	'hard matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_etaclusfactor"), 1._default, intrinsic = .true., &
	description=var_str ('This real parameter is a factor that enters ' // &
	'the calculation of the $y_{cut}$ measure for jet clustering ' // &
	'after the parton shower in the MLM jet matching between hard ' // &
	'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Rclusfactor"), 1._default, intrinsic = .true., &
	description=var_str ('This real parameter is a factor that enters ' // &
	'the calculation of the $y_{cut}$ measure for jet clustering ' // &
	'after the parton shower in the MLM jet matching between hard ' // &
	'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))
	call var_list%append_real (var_str &
	("mlm_Eclusfactor"), 1._default, intrinsic = .true., &
	description=var_str ('This real parameter is a factor that enters ' // &
	'the calculation of the $y_{cut}$ measure for jet clustering ' // &
	'after the parton shower in the MLM jet matching between hard ' // &
	'matrix elements and QCD parton showers. (cf. also \ttt{?allow\_shower}, ' // &
	'\ttt{?ps\_ ...}, \ttt{\$ps\_ ...}, \ttt{mlm\_ ...}, \ttt{?hadronization\_active})'))

	end subroutine var_list_set_mlm_matching_defaults

	@ %def var_list_set_mlm_matching_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_powheg_matching_defaults => &
	var_list_set_powheg_matching_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_powheg_matching_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (var_str ("?powheg_matching"), &
	.false., intrinsic = .true., &
	description=var_str ('Activates Powheg matching. Needs to be ' // &
	'combined with the \ttt{?combined\_nlo\_integration}-method.'))
	call var_list%append_log (var_str ("?powheg_use_singular_jacobian"), &
	.false., intrinsic = .true., &
	description=var_str ('This allows to give a different ' // &
	'normalization of the Jacobian, resulting in an alternative ' // &
	'POWHEG damping in the singular regions.'))
	call var_list%append_int (var_str ("powheg_grid_size_xi"), &
	5, intrinsic = .true., &
	description=var_str ('Number of $\xi$ points in the POWHEG grid.'))
	call var_list%append_int (var_str ("powheg_grid_size_y"), &
	5, intrinsic = .true., &
	description=var_str ('Number of $y$ points in the POWHEG grid.'))
	call var_list%append_real (var_str ("powheg_pt_min"), &
	1._default, intrinsic = .true., &
	description=var_str ('Lower $p_T$-cut-off for the POWHEG ' // &
	'hardest emission.'))
	call var_list%append_real (var_str ("powheg_lambda"), &
	LAMBDA_QCD_REF, intrinsic = .true., &
	description=var_str ('Reference scale of the $\alpha_s$ evolution ' // &
	'in the POWHEG matching algorithm.'))
	call var_list%append_log (var_str ("?powheg_test_sudakov"), &
	.false., intrinsic = .true., &
	description=var_str ('Performs an internal consistency check ' // &
	'on the POWHEG event generation.'))
	call var_list%append_log (var_str ("?powheg_disable_sudakov"), &
	.false., intrinsic = .true., &
	description=var_str ('This flag allows to set the Sudakov form ' // &
	'factor to one. This effectively results in a version of ' // &
	'the matrix-element method (MEM) at NLO.'))
	end subroutine var_list_set_powheg_matching_defaults

	@ %def var_list_set_powheg_matching_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_openmp_defaults => var_list_set_openmp_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_openmp_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (var_str ("?omega_openmp"), &
	openmp_is_active (), &
	intrinsic=.true., &
	description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
	"for \oMega\ matrix elements. (cf. also \ttt{\$method}, \ttt{\$omega\_flag})"))
	call var_list%append_log (var_str ("?openmp_is_active"), &
	openmp_is_active (), &
	locked=.true., intrinsic=.true., &
	description=var_str ('Flag to switch on or off OpenMP multi-threading ' // &
	'for \whizard. (cf. also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, ' // &
	'\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
	call var_list%append_int (var_str ("openmp_num_threads_default"), &
	openmp_get_default_max_threads (), &
	locked=.true., intrinsic=.true., &
	description=var_str ('Integer parameter that shows the number ' // &
	'of default OpenMP threads for multi-threading. Note that this ' // &
	'parameter can only be accessed, but not reset by the user. (cf. ' // &
	'also \ttt{?openmp\_logging}, \ttt{openmp\_num\_threads}, \ttt{?omega\_openmp})'))
	call var_list%append_int (var_str ("openmp_num_threads"), &
	openmp_get_max_threads (), &
	intrinsic=.true., &
	description=var_str ('Integer parameter that sets the number ' // &
	'of OpenMP threads for multi-threading. (cf. also \ttt{?openmp\_logging}, ' // &
	'\ttt{openmp\_num\_threads\_default}, \ttt{?omega\_openmp})'))
	call var_list%append_log (var_str ("?openmp_logging"), &
	.true., intrinsic=.true., &
	description=var_str ('This logical -- when set to \ttt{false} ' // &
	'-- suppresses writing out messages about OpenMP parallelization ' // &
	'(number of used threads etc.) on screen and into the logfile ' // &
	'(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
	'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // &
	'\ttt{?mpi\_logging})'))
	end subroutine var_list_set_openmp_defaults

	@ %def var_list_set_openmp_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_mpi_defaults => var_list_set_mpi_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_mpi_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_log (var_str ("?mpi_logging"), &
	.false., intrinsic=.true., &
	description=var_str('This logical -- when set to \ttt{false} ' // &
	'-- suppresses writing out messages about MPI parallelization ' // &
	'(number of used workers etc.) on screen and into the logfile ' // &
	'(default name \ttt{whizard.log}) for the whole \whizard\ run. ' // &
	'Mainly for debugging purposes. (cf. also \ttt{?logging}, ' // &
	'\ttt{?openmp\_logging})'))
	end subroutine var_list_set_mpi_defaults

	@ %def var_list_set_mpi_defaults
	@
	<<Variables: var list: TBP>>=
	procedure :: set_nlo_defaults => var_list_set_nlo_defaults
	<<Variables: procedures>>=
	subroutine var_list_set_nlo_defaults (var_list)
	class(var_list_t), intent(inout) :: var_list
	call var_list%append_string (var_str ("$born_me_method"), &
	var_str (""), intrinsic = .true., &
	description=var_str ("This string variable specifies the method " // &
	"for the matrix elements to be used in the evaluation of the " // &
	"Born part of the NLO computation. The default is the empty string, " // &
	"i.e. the \ttt{\$method} being the intrinsic \oMega\ matrix element " // &
	'generator (\ttt{"omega"}), other options ' // &
	'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, ' // &
	'\ttt{"template\_unity"}, \ttt{"threshold"}, \ttt{"gosam"}, ' // &
	'\ttt{"openloops"}. Note that this option is inoperative if ' // &
	'no NLO calculation is specified in the process definition. ' // &
	'If you want ot use different matrix element methods in a LO ' // &
	'computation, use the usual \ttt{method} command. (cf. also ' // &
	'\ttt{\$correlation\_me\_method}, ' // &
	'\ttt{\$dglap\_me\_method}, \ttt{\$loop\_me\_method} and ' // &
	'\ttt{\$real\_tree\_me\_method}.)'))
	call var_list%append_string (var_str ("$loop_me_method"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('This string variable specifies the method ' // &
	'for the matrix elements to be used in the evaluation of the ' // &
	'virtual part of the NLO computation. The default is the empty string, ' // &
	'i.e. the same as \ttt{\$method}. Working options are: ' // &
	'\ttt{"threshold"}, \ttt{"openloops"}, \ttt{"recola"}, \ttt{"gosam"}. ' // &
	'(cf. also \ttt{\$real\_tree\_me\_method}, \ttt{\$correlation\_me\_method} ' // &
	'and \ttt{\$born\_me\_method}.)'))
	call var_list%append_string (var_str ("$correlation_me_method"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('This string variable specifies ' // &
	'the method for the matrix elements to be used in the evaluation ' // &
	'of the color (and helicity) correlated part of the NLO computation. ' // &
	"The default is the same as the \ttt{\$method}, i.e. the intrinsic " // &
	"\oMega\ matrix element generator " // &
	'(\ttt{"omega"}), other options are: \ttt{"ovm"}, \ttt{"unit\_test"}, ' // &
	'\ttt{"template"}, \ttt{"template\_unity"}, \ttt{"threshold"}, ' // &
	'\ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
	'\ttt{\$born\_me\_method}, \ttt{\$dglap\_me\_method}, ' // &
	'\ttt{\$loop\_me\_method} and \newline' // &
	'\ttt{\$real\_tree\_me\_method}.)'))
	call var_list%append_string (var_str ("$real_tree_me_method"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('This string variable specifies the method ' // &
	'for the matrix elements to be used in the evaluation of the ' // &
	'real part of the NLO computation. The default is the same as ' // &
	'the \ttt{\$method}, i.e. the intrinsic ' // &
	"\oMega\ matrix element generator " // &
	'(\ttt{"omega"}), other options ' // &
	'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
	'\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also ' // &
	'\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
	'\ttt{\$dglap\_me\_method} and \ttt{\$loop\_me\_method}.)'))
	call var_list%append_string (var_str ("$dglap_me_method"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('This string variable specifies the method ' // &
	'for the matrix elements to be used in the evaluation of the ' // &
	'DGLAP remnants of the NLO computation. The default is the same as ' // &
	"\ttt{\$method}, i.e. the \oMega\ matrix element generator " // &
	'(\ttt{"omega"}), other options ' // &
	'are: \ttt{"ovm"}, \ttt{"unit\_test"}, \ttt{"template"}, \ttt{"template\_unity"}, ' // &
	'\ttt{"threshold"}, \ttt{"gosam"}, \ttt{"openloops"}. (cf. also \newline' // &
	'\ttt{\$born\_me\_method}, \ttt{\$correlation\_me\_method}, ' // &
	'\ttt{\$loop\_me\_method} and \ttt{\$real\_tree\_me\_method}.)'))
	call var_list%append_log (&
	var_str ("?test_soft_limit"), .false., intrinsic = .true., &
	description=var_str ('Sets the fixed values $\tilde{\xi} = 0.00001$ ' // &
	'and $y = 0.5$ as radiation variables. This way, only soft, ' // &
	'but non-collinear phase space points are generated, which allows ' // &
	'for testing subtraction in this region.'))
	call var_list%append_log (&
	var_str ("?test_coll_limit"), .false., intrinsic = .true., &
	description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
	'and $y = 0.9999999$ as radiation variables. This way, only collinear, ' // &
	'but non-soft phase space points are generated, which allows ' // &
	'for testing subtraction in this region. Can be combined with ' // &
	'\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
	call var_list%append_log (&
	var_str ("?test_anti_coll_limit"), .false., intrinsic = .true., &
	description=var_str ('Sets the fixed values $\tilde{\xi} = 0.5$ ' // &
	'and $y = -0.9999999$ as radiation variables. This way, only anti-collinear, ' // &
	'but non-soft phase space points are generated, which allows ' // &
	'for testing subtraction in this region. Can be combined with ' // &
	'\ttt{?test\_soft\_limit} to probe soft-collinear regions.'))
	call var_list%append_string (var_str ("$select_alpha_regions"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('Fixes the $\alpha_r$ in the real ' // &
	' subtraction component. Allows for testing in one individual ' // &
	'singular region.'))
	call var_list%append_string (var_str ("$virtual_selection"), &
	var_str ("Full"), intrinsic = .true., &
	description=var_str ('String variable to select either the full ' // &
	'or only parts of the virtual components of an NLO calculation. ' // &
	'Possible modes are \ttt{"Full"}, \ttt{"OLP"} and ' // &
	'\ttt{"Subtraction."}. Mainly for debugging purposes.'))
	call var_list%append_log (var_str ("?virtual_collinear_resonance_aware"), &
	.true., intrinsic = .true., &
	description=var_str ('This flag allows to switch between two ' // &
	'different implementations of the collinear subtraction in the ' // &
	'resonance-aware FKS setup.'))
	call var_list%append_real (&
	var_str ("blha_top_yukawa"), -1._default, intrinsic = .true., &
	description=var_str ('If this value is set, the given value will ' // &
	'be used as the top Yukawa coupling instead of the top mass. ' // &
	'Note that having different values for $y_t$ and $m_t$ must be ' // &
	'supported by your OLP-library and yield errors if this is not the case.'))
	call var_list%append_string (var_str ("$blha_ew_scheme"), &
	var_str ("alpha_internal"), intrinsic = .true., &
	description=var_str ('String variable that transfers the electroweak ' // &
	'renormalization scheme via BLHA to the one-loop provider. Possible ' // &
	'values are \ttt{GF} or \ttt{Gmu} for the $G_\mu$ scheme, ' // &
	'\ttt{alpha\_internal} (default, $G_\mu$ scheme, but value of ' // &
	'$\alpha_S$ calculated internally by \whizard), \ttt{alpha\_mz} ' // &
	'and \ttt{alpha\_0} (or \ttt{alpha\_thompson}) for different schemes ' // &
	'with $\alpha$ as input.'))
	call var_list%append_int (var_str ("openloops_verbosity"), 1, &
	intrinsic = .true., &
	description=var_str ('Decides how much \openloops\ output is printed. ' // &
	'Can have values 0, 1 and 2, where 2 is the highest verbosity level.'))
	call var_list%append_log (var_str ("?openloops_use_cms"), &
	.true., intrinsic = .true., &
	description=var_str ('Activates the complex mass scheme in ' // &
	'\openloops. (cf. also ' // &
	'\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
	'\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
	'\ttt{openloops\_stability\_log}, \newline' // &
	'\ttt{\$openloops\_extra\_cmd})'))
	call var_list%append_int (var_str ("openloops_phs_tolerance"), 7, &
	intrinsic = .true., &
	description=var_str ('This integer parameter gives via ' // &
	'\ttt{openloops\_phs\_tolerance = <n>} the relative numerical ' // &
	'tolerance $10^{-n}$ for the momentum conservation of the ' // &
	'external particles within \openloops. (cf. also ' // &
	'\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
	'\ttt{?openloops\_switch\_off\_muon\_yukawa}, ' // &
	'\newline\ttt{openloops\_stability\_log}, ' // &
	'\ttt{\$openloops\_extra\_cmd})'))
	call var_list%append_int (var_str ("openloops_stability_log"), 0, &
	intrinsic = .true., &
	description=var_str ('Creates the directory \ttt{stability\_log} ' // &
	'containing information about the performance of the \openloops ' // &
	'matrix elements. Possible values are 0 (No output), 1 (On ' // &
	'\ttt{finish()}-call), 2 (Adaptive) and 3 (Always).'))
	call var_list%append_log (var_str ("?openloops_switch_off_muon_yukawa"), &
	.false., intrinsic = .true., &
	description=var_str ('Sets the Yukawa coupling of muons for ' // &
	'\openloops\ to zero. (cf. also ' // &
	'\ttt{openloos\_verbosity}, \ttt{\$method}, ' // &
	'\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
	'\ttt{\$openloops\_extra\_cmd})'))
	call var_list%append_string (var_str ("$openloops_extra_cmd"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('String variable to transfer customized ' // &
	'special commands to \openloops. The three supported examples ' // &
	'\ttt{\$openloops\_extra\_command = "extra approx top/stop/not"} ' // &
	'are for selection of subdiagrams in top production. (cf. also ' // &
	'\ttt{\$method}, \ttt{openloos\_verbosity}, ' // &
	'\ttt{?openloops\_use\_cms}, \ttt{openloops\_stability\_log}, ' // &
	'\ttt{?openloops\_switch\_off\_muon\_yukawa})'))
	call var_list%append_real (var_str ("ellis_sexton_scale"), &
	-1._default, intrinsic = .true., &
	description = var_str ('Real positive paramter for the Ellis-Sexton scale' // &
	'$\mathcal{Q}$ used both in the finite one-loop contribution provided by' // &
	'the OLP and in the virtual counter terms. The NLO cross section is' // &
	'independent of $\mathcal{Q}$. Therefore, this allows for debugging of' // &
	'the implemention of the virtual counter terms. As the default' // &
	'$\mathcal{Q} = \mu_{\rm{R}}$ is chosen. So far, setting this parameter' // &
	'only works for OpenLoops2, otherwise the default behaviour is invoked.'))
	call var_list%append_log (var_str ("?disable_subtraction"), &
	.false., intrinsic = .true., &
	description=var_str ('Disables the subtraction of soft and collinear ' // &
	'divergences from the real matrix element.'))
	call var_list%append_real (var_str ("fks_dij_exp1"), &
	1._default, intrinsic = .true., &
	description=var_str ('Fine-tuning parameters of the FKS ' // &
	'final state partition functions. The exact meaning depends ' // &
	'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp2}, ' // &
	'\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
	call var_list%append_real (var_str ("fks_dij_exp2"), &
	1._default, intrinsic = .true., &
	description=var_str ('Fine-tuning parameters of the FKS ' // &
	'initial state partition functions. The exact meaning depends ' // &
	'on the mapping implementation. (cf. also \ttt{fks\_dij\_exp1}, ' // &
	'\ttt{\$fks\_mapping\_type}, \ttt{fks\_xi\_min}, \ttt{fks\_y\_max})'))
	call var_list%append_real (var_str ("fks_xi_min"), &
	0._default, intrinsic = .true., &
	description=var_str ('Real parameter for the FKS ' // &
	'phase space that sets the numerical lower value of the $\xi$ ' // &
	'variable. Valid for the value range $[\texttt{tiny\_07},1]$, where ' // &
	'value inputs out of bounds will take the value of the closest bound. ' // &
	'Here, $\texttt{tiny\_07} = \texttt{1E0\_default * epsilon (0.\_default)}$, where ' // &
	'\ttt{epsilon} is an intrinsic Fortran function. (cf. also \ttt{fks\_dij\_exp1}, ' // &
	'\ttt{fks\_dij\_exp2}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_y\_max})'))
	call var_list%append_real (var_str ("fks_y_max"), &
	1._default, intrinsic = .true., &
	description=var_str ('Real parameter for the FKS ' // &
	'phase space that sets the numerical upper value of the $\left\|y\right\|$ ' // &
	'variable. Valid for ranges $[0,1]$, where value inputs out of bounds will take ' // &
	'the value of the closest bound. Only supported for massless FSR. ' // &
	'(cf. also \ttt{fks\_dij\_exp1}, \ttt{\$fks\_mapping\_type}, \ttt{fks\_dij\_exp2})'))
	call var_list%append_log (var_str ("?vis_fks_regions"), &
	.false., intrinsic = .true., &
	description=var_str ('Logical variable that, if set to ' // &
	'\ttt{true}, generates \LaTeX\ code and executes it into a PDF ' // &
	' to produce a table of all singular FKS regions and their ' // &
	' flavor structures. The default is \ttt{false}.'))
	call var_list%append_real (var_str ("fks_xi_cut"), &
	1.0_default, intrinsic = .true., &
	description = var_str ('(Experimental) Real parameter for the FKS ' // &
	'phase space that applies a cut to $\xi$ variable with $0 < \xi_{\text{cut}}' // &
	'\leq \xi_{\text{max}}$. The dependence on the parameter vanishes between ' // &
	'real subtraction and integrated subtraction term. Could thus be used for debugging. ' // &
	'This is not implemented properly, use at your own risk!'))
	call var_list%append_real (var_str ("fks_delta_o"), &
	2._default, intrinsic = .true., &
	description = var_str ('Real parameter for the FKS ' // &
	'phase space that applies a cut to the $y$ variable with $0 < \delta_o \leq 2$ ' // &
	'for final state singularities only. ' // &
	'The dependence on the parameter vanishes between real subtraction and integrated ' // &
	'subtraction term. For debugging purposes.'))
	call var_list%append_real (var_str ("fks_delta_i"), &
	2._default, intrinsic = .true., &
	description = var_str ('Real parameter for the FKS ' // &
	'phase space that applies a cut to the $y$ variable with ' // &
	'$0 < \delta_{\mathrm{I}} \leq 2$ '// &
	'for initial state singularities only. ' // &
	'The dependence on the parameter vanishes between real subtraction and integrated ' // &
	'subtraction term. For debugging purposes.'))
	call var_list%append_string (var_str ("$fks_mapping_type"), &
	var_str ("default"), intrinsic = .true., &
	description=var_str ('Sets the FKS mapping type. Possible values ' // &
	'are \ttt{"default"} and \ttt{"resonances"}. The latter option ' // &
	'activates the resonance-aware subtraction mode and induces the ' // &
	'generation of a soft mismatch component. (cf. also ' // &
	'\ttt{fks\_dij\_exp1}, \ttt{fks\_dij\_exp2}, \ttt{fks\_xi\_min}, ' // &
	'\ttt{fks\_y\_max})'))
	call var_list%append_string (var_str ("$resonances_exclude_particles"), &
	var_str ("default"), intrinsic = .true., &
	description=var_str ('Accepts a string of particle names. These ' // &
	'particles will be ignored when the resonance histories are generated. ' // &
	'If \ttt{\$fks\_mapping\_type} is not \ttt{"resonances"}, this ' // &
	'option does nothing.'))
	call var_list%append_int (var_str ("alpha_power"), &
	2, intrinsic = .true., &
	description=var_str ('Fixes the electroweak coupling ' // &
	'powers used by BLHA matrix element generators. Setting these ' // &
	'values is necessary for the correct generation of OLP-files. ' // &
	'Having inconsistent values yields to error messages by the corresponding ' // &
	'OLP-providers.'))
	call var_list%append_int (var_str ("alphas_power"), &
	0, intrinsic = .true., &
	description=var_str ('Fixes the strong coupling ' // &
	'powers used by BLHA matrix element generators. Setting these ' // &
	'values is necessary for the correct generation of OLP-files. ' // &
	'Having inconsistent values yields to error messages by the corresponding ' // &
	'OLP-providers.'))
	call var_list%append_log (var_str ("?combined_nlo_integration"), &
	.false., intrinsic = .true., &
	description=var_str ('When this option is set to \ttt{true}, ' // &
	'the NLO integration will not be performed in the separate components, ' // &
	'but instead the sum of all components will be integrated directly. ' // &
	'When fixed-order NLO events are requested, this integration ' // &
	'mode is possible, but not necessary. However, it is necessary ' // &
	'for POWHEG events.'))
	call var_list%append_log (var_str ("?fixed_order_nlo_events"), &
	.false., intrinsic = .true., &
	description=var_str ('Induces the generation of fixed-order ' // &
	'NLO events.'))
	call var_list%append_log (var_str ("?check_event_weights_against_xsection"), &
	.false., intrinsic = .true., &
	description=var_str ('Activates an internal recording of event ' // &
	'weights when unweighted events are generated. At the end of ' // &
	'the simulation, the mean value of the weights and its standard ' // &
	'deviation are displayed. This allows to cross-check event generation ' // &
	'and integration, because the value displayed must be equal to ' // &
	'the integration result.'))
	call var_list%append_log (var_str ("?keep_failed_events"), &
	.false., intrinsic = .true., &
	description=var_str ('In the context of weighted event generation, ' // &
	'if set to \ttt{true}, events with failed kinematics will be ' // &
	'written to the event output with an associated weight of zero. ' // &
	'This way, the total cross section can be reconstructed from the event output.'))
	call var_list%append_int (var_str ("gks_multiplicity"), &
	0, intrinsic = .true., &
	description=var_str ('Jet multiplicity for the GKS merging scheme.'))
	call var_list%append_string (var_str ("$gosam_filter_lo"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('The filter string given to \gosam\ in order to ' // &
	'filter out tree-level diagrams. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
	'\ttt{\$gosam\_symmetries})'))
	call var_list%append_string (var_str ("$gosam_filter_nlo"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('The same as \ttt{\$gosam\_filter\_lo}, but for ' // &
	'loop matrix elements. (cf. also \ttt{\$gosam\_filter\_nlo}, ' // &
	'\ttt{\$gosam\_symmetries})'))
	call var_list%append_string (var_str ("$gosam_symmetries"), &
	var_str ("family,generation"), intrinsic = .true., &
	description=var_str ('String variable that is transferred to \gosam\ ' // &
	'configuration file to determine whether certain helicity configurations ' // &
	'are considered to be equal. Possible values are \ttt{flavour}, ' // &
	'\ttt{family} etc. For more info see the \gosam\ manual.'))
	call var_list%append_int (var_str ("form_threads"), &
	2, intrinsic = .true., &
	description=var_str ('The number of threads used by \gosam\ when ' // &
	'matrix elements are evaluated using \ttt{FORM}'))
	call var_list%append_int (var_str ("form_workspace"), &
	1000, intrinsic = .true., &
	description=var_str ('The size of the workspace \gosam\ requires ' // &
	'from \ttt{FORM}. Inside \ttt{FORM}, it corresponds to the heap ' // &
	'size used by the algebra processor.'))
	call var_list%append_string (var_str ("$gosam_fc"), &
	var_str (""), intrinsic = .true., &
	description=var_str ('The Fortran compiler used by \gosam.'))
	call var_list%append_real (&
	var_str ("mult_call_real"), 1._default, &
	intrinsic = .true., &
	description=var_str ('(Real-valued) multiplier for the number ' // &
	'of calls used in the integration of the real subtraction ' // &
	'NLO component. This way, a higher accuracy can be achieved for ' // &
	'the real component, while simultaneously avoiding redundant ' // &
	'integration calls for the other components. (cf. also ' // &
	'\ttt{mult\_call\_dglap}, \ttt{mult\_call\_virt})'))
	call var_list%append_real (&
	var_str ("mult_call_virt"), 1._default, &
	intrinsic = .true., &
	description=var_str ('(Real-valued) multiplier for the number ' // &
	'of calls used in the integration of the virtual NLO ' // &
	'component. This way, a higher accuracy can be achieved for ' // &
	'this component, while simultaneously avoiding redundant ' // &
	'integration calls for the other components. (cf. also ' // &
	'\ttt{mult\_call\_dglap}, \ttt{mult\_call\_real})'))
	call var_list%append_real (&
	var_str ("mult_call_dglap"), 1._default, &
	intrinsic = .true., &
	description=var_str ('(Real-valued) multiplier for the number ' // &
	'of calls used in the integration of the DGLAP remnant NLO ' // &
	'component. This way, a higher accuracy can be achieved for ' // &
	'this component, while simultaneously avoiding redundant ' // &
	'integration calls for the other components. (cf. also ' // &
	'\ttt{mult\_call\_real}, \ttt{mult\_call\_virt})'))
	call var_list%append_string (var_str ("$dalitz_plot"), &
	var_str (''), intrinsic = .true., &
	description=var_str ('This string variable has two purposes: ' // &
	'when different from the empty string, it switches on generation ' // &
	'of the Dalitz plot file (ASCII tables) for the real emitters. ' // &
	'The string variable itself provides the file name.'))
	call var_list%append_string (var_str ("$nlo_correction_type"), &
	var_str ("QCD"), intrinsic = .true., &
	description=var_str ('String variable which sets the NLO correction ' // &
	'type via \ttt{nlo\_correction\_type = "{\em <type>}"} to either ' // &
	'\ttt{"QCD"}, \ttt{"EW"}, or to all with \ttt{\em{<type>}} ' // &
	'set to \ttt{"Full"}. Must be set before the \texttt{process} statement.'))
	call var_list%append_string (var_str ("$exclude_gauge_splittings"), &
	var_str ("c:b:t:e2:e3"), intrinsic = .true., &
	description=var_str ('String variable that allows via ' // &
	'\ttt{\$exclude\_gauge\_splittings = "{\em <prt1>:<prt2>:\dots}"} ' // &
	'to exclude fermion flavors from gluon/photon splitting into ' // &
	'fermion pairs beyond LO. For example \ttt{\$exclude\_gauge\_splittings ' // &
	'= "c:s:b:t"} would lead to \ttt{gl => u U} and \ttt{gl => d ' // &
	'D} as possible splittings in QCD. It is important to keep in ' // &
	'mind that only the particles listed in the string are excluded! ' // &
	'In QED this string would additionally allow for all splittings into ' // &
	'lepton pairs \ttt{A => l L}. Therefore, once set the variable ' // &
	'acts as a replacement of the default value, not as an addition! ' // &
	'Note: \ttt{"\em <prt>"} can be both particle or antiparticle. It ' // &
	'will always exclude the corresponding fermion pair. An empty ' // &
	'string allows for all fermion flavors to take part in the splitting! ' // &
	'Also, particles included in an \ttt{alias} are not excluded by ' // &
	'\ttt{\$exclude\_gauge\_splittings}!'))
	call var_list%append_log (var_str ("?nlo_use_born_scale"), &
	.false., intrinsic = .true., &
	description=var_str ('Flag that decides whether a scale expression ' // &
	'defined for the Born component of an NLO process shall be applied ' // &
	'to all other components as well or not. ' // &
	'(cf. also \ttt{?nlo\_cut\_all\_real\_sqmes})'))
	call var_list%append_log (var_str ("?nlo_cut_all_real_sqmes"), &
	.false., intrinsic = .true., &
	description=var_str ('Flag that decides whether in the case that ' // &
	'the real component does not pass a cut, its subtraction term ' // &
	'shall be discarded for that phase space point as well or not. ' // &
	'(cf. also \ttt{?nlo\_use\_born\_scale})'))
	call var_list%append_string (var_str ("$real_partition_mode"), var_str ("default"), &
	intrinsic=.true., &
	description=var_str ('String variable to choose which parts of the real cross ' // &
	'section are to be integrated. With the default value (\ttt{"default"}) ' // &
	'or \ttt{"off"} the real cross section is integrated as usual without partition. ' // &
	'If set to \ttt{"on"} or \ttt{"all"}, the real cross section is split into singular ' // &
	'and finite part using a partition function $F$, such that $\mathcal{R} ' // &
	'= [1-F(p_T^2)]\mathcal{R} + F(p_T^2)\mathcal{R} = \mathcal{R}_{\text{fin}} ' // &
	'+ \mathcal{R}_{\text{sing}}$. The emission generation is then performed ' // &
	'using $\mathcal{R}_{\text{sing}}$, whereas $\mathcal{R}_{\text{fin}}$ ' // &
	'is treated separately. If set to \ttt{"singular"} (\ttt{"finite"}), ' // &
	'only the singular (finite) real component is integrated.' // &
	'(cf. also \ttt{real\_partition\_scale})'))
	call var_list%append_real (var_str ("real_partition_scale"), &
	10._default, intrinsic = .true., &
	description=var_str ('This real variable sets the invariant mass ' // &
	'of the FKS pair used as a separator between the singular and the ' // &
	'finite part of the real subtraction terms in an NLO calculation, ' // &
	'e.g. in $e^+e^- \to t\bar tj$. (cf. also \ttt{\$real\_partition\_mode})'))
	call var_list%append_log (var_str ("?nlo_reuse_amplitudes_fks"), &
	.false., intrinsic = .true., &
	description=var_str ('Only compute real and virtual amplitudes for ' // &
	'subprocesses that give a different amplitude and reuse the result ' // &
	'for equivalent subprocesses. ' // &
	'Might give a speed-up for some processes. Might ' // &
	'break others, especially in cases where resonance histories are needed. ' // &
	'Experimental feature, use at your own risk!'))
	end subroutine var_list_set_nlo_defaults

	@ %def var_list_set_nlo_defaults
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Observables}

	In this module we define concrete variables and operators (observables)
	that we want to support in expressions.
	<<[[observables.f90]]>>=
	<<File header>>

	module observables

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use diagnostics
	use lorentz
	use subevents
	use variables

	<<Standard module head>>

	<<Observables: public>>

	contains

	<<Observables: procedures>>

	end module observables
	@ %def observables
	@
	\subsection{Process-specific variables}
	We allow the user to set a numeric process ID for each declared process.
	<<Observables: public>>=
	public :: var_list_init_num_id
	<<Observables: procedures>>=
	subroutine var_list_init_num_id (var_list, proc_id, num_id)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: proc_id
	integer, intent(in), optional :: num_id
	call var_list_set_procvar_int (var_list, proc_id, &
	var_str ("num_id"), num_id)
	end subroutine var_list_init_num_id

	@ %def var_list_init_num_id
	@
	Integration results are stored in special variables. They are
	initialized by this subroutine. The values may or may not already
	known.

	Note: the values which are accessible are those that are unique for a
	process with multiple MCI records. The rest has been discarded.
	<<Observables: public>>=
	public :: var_list_init_process_results
	<<Observables: procedures>>=
	subroutine var_list_init_process_results (var_list, proc_id, &
	n_calls, integral, error, accuracy, chi2, efficiency)
	type(var_list_t), intent(inout) :: var_list
	type(string_t), intent(in) :: proc_id
	integer, intent(in), optional :: n_calls
	real(default), intent(in), optional :: integral, error, accuracy
	real(default), intent(in), optional :: chi2, efficiency
	call var_list_set_procvar_real (var_list, proc_id, &
	var_str ("integral"), integral)
	call var_list_set_procvar_real (var_list, proc_id, &
	var_str ("error"), error)
	end subroutine var_list_init_process_results

	@ %def var_list_init_process_results
	@
	\subsection{Observables as Pseudo-Variables}
	Unary and binary observables are different. Most unary observables
	can be equally well evaluated for particle pairs. Binary observables
	cannot be evaluated for single particles.
	<<Observables: public>>=
	public :: var_list_set_observables_unary
	public :: var_list_set_observables_binary
	public :: var_list_set_observables_sev
	<<Observables: procedures>>=
	subroutine var_list_set_observables_unary (var_list, prt1)
	type(var_list_t), intent(inout) :: var_list
	type(prt_t), intent(in), target :: prt1
	call var_list_append_obs1_iptr &
	(var_list, var_str ("PDG"), obs_pdg1, prt1)
	call var_list_append_obs1_iptr &
	(var_list, var_str ("Hel"), obs_helicity1, prt1)
	call var_list_append_obs1_iptr &
	(var_list, var_str ("Ncol"), obs_n_col1, prt1)
	call var_list_append_obs1_iptr &
	(var_list, var_str ("Nacl"), obs_n_acl1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("M"), obs_signed_mass1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("M2"), obs_mass_squared1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("E"), obs_energy1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Px"), obs_px1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Py"), obs_py1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Pz"), obs_pz1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("P"), obs_p1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Pl"), obs_pl1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Pt"), obs_pt1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Theta"), obs_theta1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Phi"), obs_phi1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Rap"), obs_rap1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Eta"), obs_eta1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Theta_star"), obs_theta_star1, prt1)
	call var_list_append_obs1_rptr &
	(var_list, var_str ("Dist"), obs_dist1, prt1)
	call var_list_append_uobs_real &
	(var_list, var_str ("_User_obs_real"), prt1)
	call var_list_append_uobs_int &
	(var_list, var_str ("_User_obs_int"), prt1)
	end subroutine var_list_set_observables_unary

	subroutine var_list_set_observables_binary (var_list, prt1, prt2)
	type(var_list_t), intent(inout) :: var_list
	type(prt_t), intent(in), target :: prt1
	type(prt_t), intent(in), optional, target :: prt2
	call var_list_append_obs2_iptr &
	(var_list, var_str ("PDG"), obs_pdg2, prt1, prt2)
	call var_list_append_obs2_iptr &
	(var_list, var_str ("Hel"), obs_helicity2, prt1, prt2)
	call var_list_append_obs2_iptr &
	(var_list, var_str ("Ncol"), obs_n_col2, prt1, prt2)
	call var_list_append_obs2_iptr &
	(var_list, var_str ("Nacl"), obs_n_acl2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("M"), obs_signed_mass2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("M2"), obs_mass_squared2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("E"), obs_energy2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Px"), obs_px2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Py"), obs_py2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Pz"), obs_pz2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("P"), obs_p2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Pl"), obs_pl2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Pt"), obs_pt2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Theta"), obs_theta2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Phi"), obs_phi2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Rap"), obs_rap2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Eta"), obs_eta2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Theta_star"), obs_theta_star2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("Dist"), obs_dist2, prt1, prt2)
	call var_list_append_obs2_rptr &
	(var_list, var_str ("kT"), obs_ktmeasure, prt1, prt2)
	call var_list_append_uobs_real &
	(var_list, var_str ("_User_obs_real"), prt1, prt2)
	call var_list_append_uobs_int &
	(var_list, var_str ("_User_obs_int"), prt1, prt2)
	end subroutine var_list_set_observables_binary

	subroutine var_list_set_observables_sev (var_list, pval)
	type(var_list_t), intent(inout) :: var_list
	type(subevt_t), intent(in), target:: pval
	call var_list_append_obsev_rptr &
	(var_list, var_str ("Ht"), obs_ht, pval)
	end subroutine var_list_set_observables_sev

	@ %def var_list_set_observables_unary var_list_set_observables_binary
	@ %def var_list_set_observables_nary
	\subsection{Checks}
	<<Observables: public>>=
	public :: var_list_check_observable
	<<Observables: procedures>>=
	subroutine var_list_check_observable (var_list, name, type)
	class(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(inout) :: type
	if (string_is_observable_id (name)) then
	call msg_fatal ("Variable name '" // char (name) &
	// "' is reserved for an observable")
	type = V_NONE
	return
	end if
	end subroutine var_list_check_observable

	@ %def var_list_check_observable
	@
	Check if a variable name is defined as an observable:
	<<Observables: procedures>>=
	function string_is_observable_id (string) result (flag)
	logical :: flag
	type(string_t), intent(in) :: string
	select case (char (string))
	case ("PDG", "Hel", "Ncol", "Nacl", &
	"M", "M2", "E", "Px", "Py", "Pz", "P", "Pl", "Pt", &
	"Theta", "Phi", "Rap", "Eta", "Theta_star", "Dist", "kT", &
	"Ht")
	flag = .true.
	case default
	flag = .false.
	end select
	end function string_is_observable_id

	@ %def string_is_observable_id
	@ Check for result and process variables.
	<<Observables: public>>=
	public :: var_list_check_result_var
	<<Observables: procedures>>=
	subroutine var_list_check_result_var (var_list, name, type)
	class(var_list_t), intent(in), target :: var_list
	type(string_t), intent(in) :: name
	integer, intent(inout) :: type
	if (string_is_integer_result_var (name)) type = V_INT
	if (.not. var_list%contains (name)) then
	if (string_is_result_var (name)) then
	call msg_fatal ("Result variable '" // char (name) // "' " &
	// "set without prior integration")
	type = V_NONE
	return
	else if (string_is_num_id (name)) then
	call msg_fatal ("Numeric process ID '" // char (name) // "' " &
	// "set without process declaration")
	type = V_NONE
	return
	end if
	end if
	end subroutine var_list_check_result_var

	@ %def var_list_check_result_var
	@
	Check if a variable name is a result variable of integer type:
	<<Observables: procedures>>=
	function string_is_integer_result_var (string) result (flag)
	logical :: flag
	type(string_t), intent(in) :: string
	type(string_t) :: buffer, name, separator
	buffer = string
	call split (buffer, name, "(", separator=separator) ! ")"
	if (separator == "(") then
	select case (char (name))
	case ("num_id", "n_calls")
	flag = .true.
	case default
	flag = .false.
	end select
	else
	flag = .false.
	end if
	end function string_is_integer_result_var

	@ %def string_is_integer_result_var
	@
	Check if a variable name is an integration-result variable:
	<<Observables: procedures>>=
	function string_is_result_var (string) result (flag)
	logical :: flag
	type(string_t), intent(in) :: string
	type(string_t) :: buffer, name, separator
	buffer = string
	call split (buffer, name, "(", separator=separator) ! ")"
	if (separator == "(") then
	select case (char (name))
	case ("integral", "error")
	flag = .true.
	case default
	flag = .false.
	end select
	else
	flag = .false.
	end if
	end function string_is_result_var

	@ %def string_is_result_var
	@
	Check if a variable name is a numeric process ID:
	<<Observables: procedures>>=
	function string_is_num_id (string) result (flag)
	logical :: flag
	type(string_t), intent(in) :: string
	type(string_t) :: buffer, name, separator
	buffer = string
	call split (buffer, name, "(", separator=separator) ! ")"
	if (separator == "(") then
	select case (char (name))
	case ("num_id")
	flag = .true.
	case default
	flag = .false.
	end select
	else
	flag = .false.
	end if
	end function string_is_num_id

	@ %def string_is_num_id
	@
	\subsection{Observables}
	These are analogous to the unary and binary numeric functions listed
	above. An observable takes the [[pval]] component(s) of its one or
	two argument nodes and produces an integer or real value.

	\subsubsection{Integer-valued unary observables}
	The PDG code
	<<Observables: procedures>>=
	integer function obs_pdg1 (prt1) result (pdg)
	type(prt_t), intent(in) :: prt1
	pdg = prt_get_pdg (prt1)
	end function obs_pdg1

	@ %def obs_pdg
	@ The helicity. The return value is meaningful only if the particle
	is polarized, otherwise an invalid value is returned (-9).
	<<Observables: procedures>>=
	integer function obs_helicity1 (prt1) result (h)
	type(prt_t), intent(in) :: prt1
	if (prt_is_polarized (prt1)) then
	h = prt_get_helicity (prt1)
	else
	h = -9
	end if
	end function obs_helicity1

	@ %def obs_helicity1
	@ The number of open color (anticolor) lines. The return value is meaningful
	only if the particle is colorized (i.e., the subevent has been given color
	information), otherwise the function returns zero.
	<<Observables: procedures>>=
	integer function obs_n_col1 (prt1) result (n)
	type(prt_t), intent(in) :: prt1
	if (prt_is_colorized (prt1)) then
	n = prt_get_n_col (prt1)
	else
	n = 0
	end if
	end function obs_n_col1

	integer function obs_n_acl1 (prt1) result (n)
	type(prt_t), intent(in) :: prt1
	if (prt_is_colorized (prt1)) then
	n = prt_get_n_acl (prt1)
	else
	n = 0
	end if
	end function obs_n_acl1

	@ %def obs_n_col1
	@ %def obs_n_acl1
	@
	\subsubsection{Real-valued unary observables}
	The invariant mass squared, obtained from the separately stored value.
	<<Observables: procedures>>=
	real(default) function obs_mass_squared1 (prt1) result (p2)
	type(prt_t), intent(in) :: prt1
	p2 = prt_get_msq (prt1)
	end function obs_mass_squared1

	@ %def obs_mass_squared1
	@ The signed invariant mass, which is the signed square root of the
	previous observable.
	<<Observables: procedures>>=
	real(default) function obs_signed_mass1 (prt1) result (m)
	type(prt_t), intent(in) :: prt1
	real(default) :: msq
	msq = prt_get_msq (prt1)
	m = sign (sqrt (abs (msq)), msq)
	end function obs_signed_mass1

	@ %def obs_signed_mass1
	@ The particle energy
	<<Observables: procedures>>=
	real(default) function obs_energy1 (prt1) result (e)
	type(prt_t), intent(in) :: prt1
	e = energy (prt_get_momentum (prt1))
	end function obs_energy1

	@ %def obs_energy1
	@ Particle momentum (components)
	<<Observables: procedures>>=
	real(default) function obs_px1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = vector4_get_component (prt_get_momentum (prt1), 1)
	end function obs_px1

	real(default) function obs_py1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = vector4_get_component (prt_get_momentum (prt1), 2)
	end function obs_py1

	real(default) function obs_pz1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = vector4_get_component (prt_get_momentum (prt1), 3)
	end function obs_pz1

	real(default) function obs_p1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = space_part_norm (prt_get_momentum (prt1))
	end function obs_p1

	real(default) function obs_pl1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = longitudinal_part (prt_get_momentum (prt1))
	end function obs_pl1

	real(default) function obs_pt1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = transverse_part (prt_get_momentum (prt1))
	end function obs_pt1

	@ %def obs_px1 obs_py1 obs_pz1
	@ %def obs_p1 obs_pl1 obs_pt1
	@ Polar and azimuthal angle (lab frame).
	<<Observables: procedures>>=
	real(default) function obs_theta1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = polar_angle (prt_get_momentum (prt1))
	end function obs_theta1

	real(default) function obs_phi1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = azimuthal_angle (prt_get_momentum (prt1))
	end function obs_phi1

	@ %def obs_theta1 obs_phi1
	@ Rapidity and pseudorapidity
	<<Observables: procedures>>=
	real(default) function obs_rap1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = rapidity (prt_get_momentum (prt1))
	end function obs_rap1

	real(default) function obs_eta1 (prt1) result (p)
	type(prt_t), intent(in) :: prt1
	p = pseudorapidity (prt_get_momentum (prt1))
	end function obs_eta1

	@ %def obs_rap1 obs_eta1
	@ Meaningless: Polar angle in the rest frame of the two arguments
	combined.
	<<Observables: procedures>>=
	real(default) function obs_theta_star1 (prt1) result (dist)
	type(prt_t), intent(in) :: prt1
	call msg_fatal (" 'Theta_star' is undefined as unary observable")
	dist = 0
	end function obs_theta_star1

	@ %def obs_theta_star1
	@ [Obsolete] Meaningless: Polar angle in the rest frame of the 2nd argument.
	<<XXX Observables: procedures>>=
	real(default) function obs_theta_rf1 (prt1) result (dist)
	type(prt_t), intent(in) :: prt1
	call msg_fatal (" 'Theta_RF' is undefined as unary observable")
	dist = 0
	end function obs_theta_rf1

	@ %def obs_theta_rf1
	@ Meaningless: Distance on the $\eta$-$\phi$ cylinder.
	<<Observables: procedures>>=
	real(default) function obs_dist1 (prt1) result (dist)
	type(prt_t), intent(in) :: prt1
	call msg_fatal (" 'Dist' is undefined as unary observable")
	dist = 0
	end function obs_dist1

	@ %def obs_dist1
	@
	\subsubsection{Integer-valued binary observables}
	These observables are meaningless as binary functions.
	<<Observables: procedures>>=
	integer function obs_pdg2 (prt1, prt2) result (pdg)
	type(prt_t), intent(in) :: prt1, prt2
	call msg_fatal (" PDG_Code is undefined as binary observable")
	pdg = 0
	end function obs_pdg2

	integer function obs_helicity2 (prt1, prt2) result (h)
	type(prt_t), intent(in) :: prt1, prt2
	call msg_fatal (" Helicity is undefined as binary observable")
	h = 0
	end function obs_helicity2

	integer function obs_n_col2 (prt1, prt2) result (n)
	type(prt_t), intent(in) :: prt1, prt2
	call msg_fatal (" Ncol is undefined as binary observable")
	n = 0
	end function obs_n_col2

	integer function obs_n_acl2 (prt1, prt2) result (n)
	type(prt_t), intent(in) :: prt1, prt2
	call msg_fatal (" Nacl is undefined as binary observable")
	n = 0
	end function obs_n_acl2

	@ %def obs_pdg2
	@ %def obs_helicity2
	@ %def obs_n_col2
	@ %def obs_n_acl2
	@
	\subsubsection{Real-valued binary observables}
	The invariant mass squared, obtained from the separately stored value.
	<<Observables: procedures>>=
	real(default) function obs_mass_squared2 (prt1, prt2) result (p2)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p2 = prt_get_msq (prt)
	end function obs_mass_squared2

	@ %def obs_mass_squared2
	@ The signed invariant mass, which is the signed square root of the
	previous observable.
	<<Observables: procedures>>=
	real(default) function obs_signed_mass2 (prt1, prt2) result (m)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	real(default) :: msq
	call prt_init_combine (prt, prt1, prt2)
	msq = prt_get_msq (prt)
	m = sign (sqrt (abs (msq)), msq)
	end function obs_signed_mass2

	@ %def obs_signed_mass2
	@ The particle energy
	<<Observables: procedures>>=
	real(default) function obs_energy2 (prt1, prt2) result (e)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	e = energy (prt_get_momentum (prt))
	end function obs_energy2

	@ %def obs_energy2
	@ Particle momentum (components)
	<<Observables: procedures>>=
	real(default) function obs_px2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = vector4_get_component (prt_get_momentum (prt), 1)
	end function obs_px2

	real(default) function obs_py2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = vector4_get_component (prt_get_momentum (prt), 2)
	end function obs_py2

	real(default) function obs_pz2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = vector4_get_component (prt_get_momentum (prt), 3)
	end function obs_pz2

	real(default) function obs_p2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = space_part_norm (prt_get_momentum (prt))
	end function obs_p2

	real(default) function obs_pl2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = longitudinal_part (prt_get_momentum (prt))
	end function obs_pl2

	real(default) function obs_pt2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = transverse_part (prt_get_momentum (prt))
	end function obs_pt2

	@ %def obs_px2 obs_py2 obs_pz2
	@ %def obs_p2 obs_pl2 obs_pt2
	@ Enclosed angle and azimuthal distance (lab frame).
	<<Observables: procedures>>=
	real(default) function obs_theta2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	p = enclosed_angle (prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_theta2

	real(default) function obs_phi2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = azimuthal_distance (prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_phi2

	@ %def obs_theta2 obs_phi2
	@ Rapidity and pseudorapidity distance
	<<Observables: procedures>>=
	real(default) function obs_rap2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	p = rapidity_distance &
	(prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_rap2

	real(default) function obs_eta2 (prt1, prt2) result (p)
	type(prt_t), intent(in) :: prt1, prt2
	type(prt_t) :: prt
	call prt_init_combine (prt, prt1, prt2)
	p = pseudorapidity_distance &
	(prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_eta2

	@ %def obs_rap2 obs_eta2
	@ [This doesn't work! The principle of no common particle for momentum
	combination prohibits us from combining a decay particle with the momentum
	of its parent.] Polar angle in the rest frame of the 2nd argument.
	<<XXX Observables: procedures>>=
	real(default) function obs_theta_rf2 (prt1, prt2) result (theta)
	type(prt_t), intent(in) :: prt1, prt2
	theta = enclosed_angle_rest_frame &
	(prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_theta_rf2

	@ %def obs_theta_rf2
	@ Polar angle of the first particle in the rest frame of the two particles
	combined.
	<<Observables: procedures>>=
	real(default) function obs_theta_star2 (prt1, prt2) result (theta)
	type(prt_t), intent(in) :: prt1, prt2
	theta = enclosed_angle_rest_frame &
	(prt_get_momentum (prt1), &
	prt_get_momentum (prt1) + prt_get_momentum (prt2))
	end function obs_theta_star2

	@ %def obs_theta_star2
	@ Distance on the $\eta$-$\phi$ cylinder.
	<<Observables: procedures>>=
	real(default) function obs_dist2 (prt1, prt2) result (dist)
	type(prt_t), intent(in) :: prt1, prt2
	dist = eta_phi_distance &
	(prt_get_momentum (prt1), prt_get_momentum (prt2))
	end function obs_dist2

	@ %def obs_dist2
	@ Durham kT measure.
	<<Observables: procedures>>=
	real(default) function obs_ktmeasure (prt1, prt2) result (kt)
	type(prt_t), intent(in) :: prt1, prt2
	real (default) :: q2, e1, e2
	! Normalized scale to one for now! (#67)
	q2 = 1
	e1 = energy (prt_get_momentum (prt1))
	e2 = energy (prt_get_momentum (prt2))
	kt = (2/q2) * min(e12,e22) * &
	(1 - enclosed_angle_ct(prt_get_momentum (prt1), &
	prt_get_momentum (prt2)))
	end function obs_ktmeasure

	@ %def obs_ktmeasure
	@ Subeventary observables, e.g. the transverse mass $H_T$.
	<<Observables: procedures>>=
	real(default) function obs_ht (sev) result (ht)
	type(subevt_t), intent(in) :: sev
	integer :: i, n
	type(prt_t) :: prt
	- n = subevt_get_length (sev)
	+ n = sev%get_length ()
	ht = 0
	do i = 1, n
	- prt = subevt_get_prt (sev, i)
	+ prt = sev%get_prt (i)
	ht = ht + &
	sqrt (obs_pt1(prt)**2 + obs_mass_squared1(prt))
	end do
	end function obs_ht

	@ %def obs_ht
	Index: trunk/src/process_integration/process_integration.nw
	===================================================================
	--- trunk/src/process_integration/process_integration.nw (revision 8777)
	+++ trunk/src/process_integration/process_integration.nw (revision 8778)
	@@ -1,19803 +1,19795 @@
	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: integration and process objects and such
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Integration and Process Objects}
	\includemodulegraph{process_integration}

	This is the central part of the \whizard\ package. It provides the
	functionality for evaluating structure functions, kinematics and matrix
	elements, integration and event generation. It combines the various
	parts that deal with those tasks individually and organizes the data
	transfer between them.

	\begin{description}
	\item[subevt\_expr]
	This enables process observables as (abstract) expressions, to be
	evaluated for each process call.
	\item[parton\_states]
	A [[parton_state_t]] object represents an elementary partonic
	interaction. There are two versions: one for the isolated
	elementary process, one for the elementary process convoluted with
	the structure-function chain. The parton state is an effective
	state. It needs not coincide with the seed-kinematics state which is
	used in evaluating phase space.
	\item[process]
	Here, all pieces are combined for the purpose of evaluating the
	elementary processes. The whole algorithm is coded in terms of
	abstract data types as defined in the appropriate modules: [[prc_core]]
	for matrix-element evaluation, [[prc_core_def]] for the associated
	configuration and driver, [[sf_base]] for beams and structure-functions,
	[[phs_base]] for phase space, and [[mci_base]] for integration and event
	generation.
	\item[process\_config]
	\item[process\_counter]
	Very simple object for statistics
	\item[process\_mci]
	\item[pcm]
	\item[kinematics]
	\item[instances]
	While the above modules set up all static information, the instances
	have the changing event data. There are term and process instances but
	no component instances.
	\item[process\_stacks]
	Process stacks collect process objects.
	\end{description}

	We combine here hard interactions, phase space, and (for scatterings)
	structure functions and interfaces them to the integration module.

	The process object implements the combination of a fixed beam and
	structure-function setup with a number of elementary processes. The
	latter are called process components. The process object
	represents an entity which is supposedly observable. It should
	be meaningful to talk about the cross section of a process.

	The individual components of a process are, technically, processes
	themselves, but they may have unphysical cross sections which have to
	be added for a physical result. Process components may be exclusive
	tree-level elementary processes, dipole subtraction term, loop
	corrections, etc.

	The beam and structure function setup is common to all process
	components. Thus, there is only one instance of this part.

	The process may be a scattering process or a decay process. In the
	latter case, there are no structure functions, and the beam setup
	consists of a single particle. Otherwise, the two classes are treated
	on the same footing.

	Once a sampling point has been chosen, a process determines a set of
	partons with a correlated density matrix of quantum numbers. In
	general, each sampling point will generate, for each process component,
	one or more distinct parton configurations. This is the [[computed]]
	state. The computed state is the subject of the multi-channel
	integration algorithm.

	For NLO computations, it is necessary to project the computed states
	onto another set of parton configurations (e.g., by recombining
	certain pairs). This is the [[observed]] state. When computing
	partonic observables, the information is taken from the observed
	state.

	For the purpose of event generation, we will later select one parton
	configuration from the observed state and collapse the correlated
	quantum state. This configuration is then dressed by applying parton
	shower, decays and hadronization. The decay chain, in particular,
	combines a scattering process with possible subsequent decay processes
	on the parton level, which are full-fledged process objects themselves.

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process observables}
	We define an abstract [[subevt_expr_t]] object as an extension of the
	[[subevt_t]] type. The object contains a local variable list, variable
	instances (as targets for pointers in the variable list), and evaluation
	trees. The evaluation trees reference both the variables and the [[subevt]].

	There are two instances of the abstract type: one for process instances, one
	for physical events. Both have a common logical expression [[selection]]
	which determines whether the object passes user-defined cuts.

	The intention is that we fill the [[subevt_t]] base object and compute the
	variables once we have evaluated a kinematical phase space point (or a
	complete event). We then evaluate the expressions and can use the results in
	further calculations.

	The [[process_expr_t]] extension contains furthermore scale and weight
	expressions. The [[event_expr_t]] extension contains a reweighting-factor
	expression and a logical expression for event analysis. In practice, we will
	link the variable list of the [[event_obs]] object to the variable list of the
	currently active [[process_obs]] object, such that the process variables are
	available to both objects. Event variables are meaningful only for physical
	events.

	Note that there are unit tests, but they are deferred to the
	[[expr_tests]] module.
	<<[[subevt_expr.f90]]>>=
	<<File header>>
	module subevt_expr

	<<Use kinds>>
	<<Use strings>>
	use constants, only: zero, one
	use io_units
	use format_utils, only: write_separator
	use diagnostics
	use lorentz
	use subevents
	use variables
	use flavors
	use quantum_numbers
	use interactions
	use particles
	use expr_base

	<<Standard module head>>

	<<Subevt expr: public>>

	<<Subevt expr: types>>

	<<Subevt expr: interfaces>>

	contains

	<<Subevt expr: procedures>>

	end module subevt_expr
	@ %def subevt_expr
	@
	\subsection{Abstract base type}
	<<Subevt expr: types>>=
	type, extends (subevt_t), abstract :: subevt_expr_t
	logical :: subevt_filled = .false.
	type(var_list_t) :: var_list
	real(default) :: sqrts_hat = 0
	integer :: n_in = 0
	integer :: n_out = 0
	integer :: n_tot = 0
	logical :: has_selection = .false.
	class(expr_t), allocatable :: selection
	logical :: colorize_subevt = .false.
	contains
	<<Subevt expr: subevt expr: TBP>>
	end type subevt_expr_t

	@ %def subevt_expr_t
	@ Output: Base and extended version. We already have a [[write]] routine for
	the [[subevt_t]] parent type.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: base_write => subevt_expr_write
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_write (object, unit, pacified)
	class(subevt_expr_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: pacified
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Local variables:"
	call write_separator (u)
	call var_list_write (object%var_list, u, follow_link=.false., &
	pacified = pacified)
	call write_separator (u)
	if (object%subevt_filled) then
	call object%subevt_t%write (u, pacified = pacified)
	if (object%has_selection) then
	call write_separator (u)
	write (u, "(1x,A)") "Selection expression:"
	call write_separator (u)
	call object%selection%write (u)
	end if
	else
	write (u, "(1x,A)") "subevt: [undefined]"
	end if
	end subroutine subevt_expr_write

	@ %def subevt_expr_write
	@ Finalizer.
	<<Subevt expr: subevt expr: TBP>>=
	procedure (subevt_expr_final), deferred :: final
	procedure :: base_final => subevt_expr_final
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_final (object)
	class(subevt_expr_t), intent(inout) :: object
	call object%var_list%final ()
	if (object%has_selection) then
	call object%selection%final ()
	end if
	end subroutine subevt_expr_final

	@ %def subevt_expr_final
	@
	\subsection{Initialization}
	Initialization: define local variables and establish pointers.

	The common variables are [[sqrts]] (the nominal beam energy, fixed),
	[[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for
	the [[subevt]]. With the exception of [[sqrts]], all are implemented as
	pointers to subobjects.
	<<Subevt expr: subevt expr: TBP>>=
	procedure (subevt_expr_setup_vars), deferred :: setup_vars
	procedure :: base_setup_vars => subevt_expr_setup_vars
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_setup_vars (expr, sqrts)
	class(subevt_expr_t), intent(inout), target :: expr
	real(default), intent(in) :: sqrts
	call expr%var_list%final ()
	call var_list_append_real (expr%var_list, &
	var_str ("sqrts"), sqrts, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("sqrts_hat"), expr%sqrts_hat, &
	is_known = expr%subevt_filled, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_int_ptr (expr%var_list, &
	var_str ("n_in"), expr%n_in, &
	is_known = expr%subevt_filled, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_int_ptr (expr%var_list, &
	var_str ("n_out"), expr%n_out, &
	is_known = expr%subevt_filled, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_int_ptr (expr%var_list, &
	var_str ("n_tot"), expr%n_tot, &
	is_known = expr%subevt_filled, &
	locked = .true., verbose = .false., intrinsic = .true.)
	end subroutine subevt_expr_setup_vars

	@ %def subevt_expr_setup_vars
	@ Append the subevent expr (its base-type core) itself to the variable
	list, if it is not yet present.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: setup_var_self => subevt_expr_setup_var_self
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_setup_var_self (expr)
	class(subevt_expr_t), intent(inout), target :: expr
	if (.not. expr%var_list%contains (var_str ("@evt"))) then
	call var_list_append_subevt_ptr &
	(expr%var_list, &
	var_str ("@evt"), expr%subevt_t, &
	is_known = expr%subevt_filled, &
	locked = .true., verbose = .false., intrinsic=.true.)
	end if
	end subroutine subevt_expr_setup_var_self

	@ %def subevt_expr_setup_var_self
	@ Link a variable list to the local one. This could be done event by event,
	but before evaluating expressions.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: link_var_list => subevt_expr_link_var_list
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_link_var_list (expr, var_list)
	class(subevt_expr_t), intent(inout) :: expr
	type(var_list_t), intent(in), target :: var_list
	call expr%var_list%link (var_list)
	end subroutine subevt_expr_link_var_list

	@ %def subevt_expr_link_var_list
	@ Compile the selection expression. If there is no expression, the build
	method will not allocate the expression object.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: setup_selection => subevt_expr_setup_selection
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_setup_selection (expr, ef_cuts)
	class(subevt_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_cuts
	call ef_cuts%build (expr%selection)
	if (allocated (expr%selection)) then
	call expr%setup_var_self ()
	call expr%selection%setup_lexpr (expr%var_list)
	expr%has_selection = .true.
	end if
	end subroutine subevt_expr_setup_selection

	@ %def subevt_expr_setup_selection
	@ (De)activate color storage and evaluation for the expression. The subevent
	particles will have color information.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: colorize => subevt_expr_colorize
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_colorize (expr, colorize_subevt)
	class(subevt_expr_t), intent(inout), target :: expr
	logical, intent(in) :: colorize_subevt
	expr%colorize_subevt = colorize_subevt
	end subroutine subevt_expr_colorize

	@ %def subevt_expr_colorize
	@
	\subsection{Evaluation}
	Reset to initial state, i.e., mark the [[subevt]] as invalid.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: reset_contents => subevt_expr_reset_contents
	procedure :: base_reset_contents => subevt_expr_reset_contents
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_reset_contents (expr)
	class(subevt_expr_t), intent(inout) :: expr
	expr%subevt_filled = .false.
	end subroutine subevt_expr_reset_contents

	@ %def subevt_expr_reset_contents
	@ Evaluate the selection expression and return the result. There is also a
	deferred version: this should evaluate the remaining expressions if the event
	has passed.
	<<Subevt expr: subevt expr: TBP>>=
	procedure :: base_evaluate => subevt_expr_evaluate
	<<Subevt expr: procedures>>=
	subroutine subevt_expr_evaluate (expr, passed)
	class(subevt_expr_t), intent(inout) :: expr
	logical, intent(out) :: passed
	if (expr%has_selection) then
	call expr%selection%evaluate ()
	if (expr%selection%is_known ()) then
	passed = expr%selection%get_log ()
	else
	call msg_error ("Evaluate selection expression: result undefined")
	passed = .false.
	end if
	else
	passed = .true.
	end if
	end subroutine subevt_expr_evaluate

	@ %def subevt_expr_evaluate
	@
	\subsection{Implementation for partonic events}
	This implementation contains the expressions that we can evaluate for the
	partonic process during integration.
	<<Subevt expr: public>>=
	public :: parton_expr_t
	<<Subevt expr: types>>=
	type, extends (subevt_expr_t) :: parton_expr_t
	integer, dimension(:), allocatable :: i_beam
	integer, dimension(:), allocatable :: i_in
	integer, dimension(:), allocatable :: i_out
	logical :: has_scale = .false.
	logical :: has_fac_scale = .false.
	logical :: has_ren_scale = .false.
	logical :: has_weight = .false.
	class(expr_t), allocatable :: scale
	class(expr_t), allocatable :: fac_scale
	class(expr_t), allocatable :: ren_scale
	class(expr_t), allocatable :: weight
	contains
	<<Subevt expr: parton expr: TBP>>
	end type parton_expr_t

	@ %def parton_expr_t
	@ Finalizer.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: final => parton_expr_final
	<<Subevt expr: procedures>>=
	subroutine parton_expr_final (object)
	class(parton_expr_t), intent(inout) :: object
	call object%base_final ()
	if (object%has_scale) then
	call object%scale%final ()
	end if
	if (object%has_fac_scale) then
	call object%fac_scale%final ()
	end if
	if (object%has_ren_scale) then
	call object%ren_scale%final ()
	end if
	if (object%has_weight) then
	call object%weight%final ()
	end if
	end subroutine parton_expr_final

	@ %def parton_expr_final
	@ Output: continue writing the active expressions, after the common selection
	expression.

	Note: the [[prefix]] argument is declared in the [[write]] method of the
	[[subevt_t]] base type. Here, it is unused.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: write => parton_expr_write
	<<Subevt expr: procedures>>=
	subroutine parton_expr_write (object, unit, prefix, pacified)
	class(parton_expr_t), intent(in) :: object
	integer, intent(in), optional :: unit
	character(*), intent(in), optional :: prefix
	logical, intent(in), optional :: pacified
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (u, pacified = pacified)
	if (object%subevt_filled) then
	if (object%has_scale) then
	call write_separator (u)
	write (u, "(1x,A)") "Scale expression:"
	call write_separator (u)
	call object%scale%write (u)
	end if
	if (object%has_fac_scale) then
	call write_separator (u)
	write (u, "(1x,A)") "Factorization scale expression:"
	call write_separator (u)
	call object%fac_scale%write (u)
	end if
	if (object%has_ren_scale) then
	call write_separator (u)
	write (u, "(1x,A)") "Renormalization scale expression:"
	call write_separator (u)
	call object%ren_scale%write (u)
	end if
	if (object%has_weight) then
	call write_separator (u)
	write (u, "(1x,A)") "Weight expression:"
	call write_separator (u)
	call object%weight%write (u)
	end if
	end if
	end subroutine parton_expr_write

	@ %def parton_expr_write
	@ Define variables.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: setup_vars => parton_expr_setup_vars
	<<Subevt expr: procedures>>=
	subroutine parton_expr_setup_vars (expr, sqrts)
	class(parton_expr_t), intent(inout), target :: expr
	real(default), intent(in) :: sqrts
	call expr%base_setup_vars (sqrts)
	end subroutine parton_expr_setup_vars

	@ %def parton_expr_setup_vars
	@ Compile the scale expressions. If a pointer is disassociated, there is
	no expression.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: setup_scale => parton_expr_setup_scale
	procedure :: setup_fac_scale => parton_expr_setup_fac_scale
	procedure :: setup_ren_scale => parton_expr_setup_ren_scale
	<<Subevt expr: procedures>>=
	subroutine parton_expr_setup_scale (expr, ef_scale)
	class(parton_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_scale
	call ef_scale%build (expr%scale)
	if (allocated (expr%scale)) then
	call expr%setup_var_self ()
	call expr%scale%setup_expr (expr%var_list)
	expr%has_scale = .true.
	end if
	end subroutine parton_expr_setup_scale

	subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
	class(parton_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_fac_scale
	call ef_fac_scale%build (expr%fac_scale)
	if (allocated (expr%fac_scale)) then
	call expr%setup_var_self ()
	call expr%fac_scale%setup_expr (expr%var_list)
	expr%has_fac_scale = .true.
	end if
	end subroutine parton_expr_setup_fac_scale

	subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
	class(parton_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_ren_scale
	call ef_ren_scale%build (expr%ren_scale)
	if (allocated (expr%ren_scale)) then
	call expr%setup_var_self ()
	call expr%ren_scale%setup_expr (expr%var_list)
	expr%has_ren_scale = .true.
	end if
	end subroutine parton_expr_setup_ren_scale

	@ %def parton_expr_setup_scale
	@ %def parton_expr_setup_fac_scale
	@ %def parton_expr_setup_ren_scale
	@ Compile the weight expression.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: setup_weight => parton_expr_setup_weight
	<<Subevt expr: procedures>>=
	subroutine parton_expr_setup_weight (expr, ef_weight)
	class(parton_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_weight
	call ef_weight%build (expr%weight)
	if (allocated (expr%weight)) then
	call expr%setup_var_self ()
	call expr%weight%setup_expr (expr%var_list)
	expr%has_weight = .true.
	end if
	end subroutine parton_expr_setup_weight

	@ %def parton_expr_setup_weight
	@ Filling the partonic state consists of two parts. The first routine
	prepares the subevt without assigning momenta. It takes the particles from an
	[[interaction_t]]. It needs the indices and flavors for the beam,
	incoming, and outgoing particles.

	We can assume that the particle content of the subevt does not change.
	Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already
	in this initialization step.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: setup_subevt => parton_expr_setup_subevt
	<<Subevt expr: procedures>>=
	subroutine parton_expr_setup_subevt (expr, int, &
	i_beam, i_in, i_out, f_beam, f_in, f_out)
	class(parton_expr_t), intent(inout) :: expr
	type(interaction_t), intent(in), target :: int
	integer, dimension(:), intent(in) :: i_beam, i_in, i_out
	type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
	allocate (expr%i_beam (size (i_beam)))
	allocate (expr%i_in (size (i_in)))
	allocate (expr%i_out (size (i_out)))
	expr%i_beam = i_beam
	expr%i_in = i_in
	expr%i_out = i_out
	call interaction_to_subevt (int, &
	expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
	- call subevt_set_pdg_beam (expr%subevt_t, f_beam%get_pdg ())
	- call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ())
	- call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ())
	- call subevt_set_p2_beam (expr%subevt_t, f_beam%get_mass () ** 2)
	- call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass () ** 2)
	- call subevt_set_p2_outgoing (expr%subevt_t, f_out%get_mass () ** 2)
	+ call expr%set_pdg_beam (f_beam%get_pdg ())
	+ call expr%set_pdg_incoming (f_in%get_pdg ())
	+ call expr%set_pdg_outgoing (f_out%get_pdg ())
	+ call expr%set_p2_beam (f_beam%get_mass () ** 2)
	+ call expr%set_p2_incoming (f_in%get_mass () ** 2)
	+ call expr%set_p2_outgoing (f_out%get_mass () ** 2)
	expr%n_in = size (i_in)
	expr%n_out = size (i_out)
	expr%n_tot = expr%n_in + expr%n_out
	end subroutine parton_expr_setup_subevt

	@ %def parton_expr_setup_subevt
	@ Transfer PDG codes, masses (initalization) and momenta to a
	predefined subevent. We use the flavor assignment of the first
	branch in the interaction state matrix. Only incoming and outgoing
	particles are transferred. Switch momentum sign for incoming
	particles.
	<<Subevt expr: interfaces>>=
	interface interaction_momenta_to_subevt
	module procedure interaction_momenta_to_subevt_id
	module procedure interaction_momenta_to_subevt_tr
	end interface

	<<Subevt expr: procedures>>=
	subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt)
	type(interaction_t), intent(in), target :: int
	integer, dimension(:), intent(in) :: j_beam, j_in, j_out
	type(subevt_t), intent(out) :: subevt
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: n_beam, n_in, n_out, i, j
	allocate (flv (int%get_n_tot ()))
	flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1))
	n_beam = size (j_beam)
	n_in = size (j_in)
	n_out = size (j_out)
	call subevt_init (subevt, n_beam + n_in + n_out)
	do i = 1, n_beam
	j = j_beam(i)
	- call subevt_set_beam (subevt, i, &
	- flv(j)%get_pdg (), &
	- vector4_null, &
	- flv(j)%get_mass () ** 2)
	+ call subevt%set_beam (i, flv(j)%get_pdg (), &
	+ vector4_null, flv(j)%get_mass () ** 2)
	end do
	do i = 1, n_in
	j = j_in(i)
	- call subevt_set_incoming (subevt, n_beam + i, &
	- flv(j)%get_pdg (), &
	- vector4_null, &
	- flv(j)%get_mass () ** 2)
	+ call subevt%set_incoming (n_beam + i, flv(j)%get_pdg (), &
	+ vector4_null, flv(j)%get_mass () ** 2)
	end do
	do i = 1, n_out
	j = j_out(i)
	- call subevt_set_outgoing (subevt, n_beam + n_in + i, &
	- flv(j)%get_pdg (), &
	- vector4_null, &
	+ call subevt%set_outgoing (n_beam + n_in + i, &
	+ flv(j)%get_pdg (), vector4_null, &
	flv(j)%get_mass () ** 2)
	end do
	end subroutine interaction_to_subevt

	subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt)
	type(interaction_t), intent(in) :: int
	integer, dimension(:), intent(in) :: j_beam, j_in, j_out
	type(subevt_t), intent(inout) :: subevt
	- call subevt_set_p_beam (subevt, - int%get_momenta (j_beam))
	- call subevt_set_p_incoming (subevt, - int%get_momenta (j_in))
	- call subevt_set_p_outgoing (subevt, int%get_momenta (j_out))
	+ call subevt%set_p_beam (- int%get_momenta (j_beam))
	+ call subevt%set_p_incoming (- int%get_momenta (j_in))
	+ call subevt%set_p_outgoing (int%get_momenta (j_out))
	end subroutine interaction_momenta_to_subevt_id

	subroutine interaction_momenta_to_subevt_tr &
	(int, j_beam, j_in, j_out, lt, subevt)
	type(interaction_t), intent(in) :: int
	integer, dimension(:), intent(in) :: j_beam, j_in, j_out
	type(subevt_t), intent(inout) :: subevt
	type(lorentz_transformation_t), intent(in) :: lt
	- call subevt_set_p_beam &
	- (subevt, - lt * int%get_momenta (j_beam))
	- call subevt_set_p_incoming &
	- (subevt, - lt * int%get_momenta (j_in))
	- call subevt_set_p_outgoing &
	- (subevt, lt * int%get_momenta (j_out))
	+ call subevt%set_p_beam (- lt * int%get_momenta (j_beam))
	+ call subevt%set_p_incoming (- lt * int%get_momenta (j_in))
	+ call subevt%set_p_outgoing (lt * int%get_momenta (j_out))
	end subroutine interaction_momenta_to_subevt_tr

	@ %def interaction_momenta_to_subevt
	@ The second part takes the momenta from the interaction object and thus
	completes the subevt. The partonic energy can then be computed.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: fill_subevt => parton_expr_fill_subevt
	<<Subevt expr: procedures>>=
	subroutine parton_expr_fill_subevt (expr, int)
	class(parton_expr_t), intent(inout) :: expr
	type(interaction_t), intent(in), target :: int
	call interaction_momenta_to_subevt (int, &
	expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
	- expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
	+ expr%sqrts_hat = expr%get_sqrts_hat ()
	expr%subevt_filled = .true.
	end subroutine parton_expr_fill_subevt

	@ %def parton_expr_fill_subevt
	@ Evaluate, if the event passes the selection. For absent expressions we take
	default values.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: evaluate => parton_expr_evaluate
	<<Subevt expr: procedures>>=
	subroutine parton_expr_evaluate &
	(expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
	class(parton_expr_t), intent(inout) :: expr
	logical, intent(out) :: passed
	real(default), intent(out) :: scale
	real(default), allocatable, intent(out) :: fac_scale
	real(default), allocatable, intent(out) :: ren_scale
	real(default), intent(out) :: weight
	real(default), intent(in), allocatable, optional :: scale_forced
	logical, intent(in), optional :: force_evaluation
	logical :: force_scale, force_eval
	force_scale = .false.; force_eval = .false.
	if (present (scale_forced)) force_scale = allocated (scale_forced)
	if (present (force_evaluation)) force_eval = force_evaluation
	call expr%base_evaluate (passed)
	if (passed .or. force_eval) then
	if (force_scale) then
	scale = scale_forced
	else if (expr%has_scale) then
	call expr%scale%evaluate ()
	if (expr%scale%is_known ()) then
	scale = expr%scale%get_real ()
	else
	call msg_error ("Evaluate scale expression: result undefined")
	scale = zero
	end if
	else
	scale = expr%sqrts_hat
	end if
	if (expr%has_fac_scale) then
	call expr%fac_scale%evaluate ()
	if (expr%fac_scale%is_known ()) then
	if (.not. allocated (fac_scale)) then
	allocate (fac_scale, source = expr%fac_scale%get_real ())
	else
	fac_scale = expr%fac_scale%get_real ()
	end if
	else
	call msg_error ("Evaluate factorization scale expression: &
	&result undefined")
	end if
	end if
	if (expr%has_ren_scale) then
	call expr%ren_scale%evaluate ()
	if (expr%ren_scale%is_known ()) then
	if (.not. allocated (ren_scale)) then
	allocate (ren_scale, source = expr%ren_scale%get_real ())
	else
	ren_scale = expr%ren_scale%get_real ()
	end if
	else
	call msg_error ("Evaluate renormalization scale expression: &
	&result undefined")
	end if
	end if
	if (expr%has_weight) then
	call expr%weight%evaluate ()
	if (expr%weight%is_known ()) then
	weight = expr%weight%get_real ()
	else
	call msg_error ("Evaluate weight expression: result undefined")
	weight = zero
	end if
	else
	weight = one
	end if
	else
	weight = zero
	end if
	end subroutine parton_expr_evaluate

	@ %def parton_expr_evaluate
	@ Return the beam/incoming parton indices.
	<<Subevt expr: parton expr: TBP>>=
	procedure :: get_beam_index => parton_expr_get_beam_index
	procedure :: get_in_index => parton_expr_get_in_index
	<<Subevt expr: procedures>>=
	subroutine parton_expr_get_beam_index (expr, i_beam)
	class(parton_expr_t), intent(in) :: expr
	integer, dimension(:), intent(out) :: i_beam
	i_beam = expr%i_beam
	end subroutine parton_expr_get_beam_index

	subroutine parton_expr_get_in_index (expr, i_in)
	class(parton_expr_t), intent(in) :: expr
	integer, dimension(:), intent(out) :: i_in
	i_in = expr%i_in
	end subroutine parton_expr_get_in_index

	@ %def parton_expr_get_beam_index
	@ %def parton_expr_get_in_index
	@
	\subsection{Implementation for full events}
	This implementation contains the expressions that we can evaluate for the
	full event. It also contains data that pertain to the event, suitable
	for communication with external event formats. These data
	simultaneously serve as pointer targets for the variable lists hidden
	in the expressions (eval trees).

	Squared matrix element and weight values: when reading events from
	file, the [[ref]] value is the number in the file, while the [[prc]]
	value is the number that we calculate from the momenta in the file,
	possibly with different parameters. When generating events the first
	time, or if we do not recalculate, the numbers should coincide.
	Furthermore, the array of [[alt]] values is copied from an array of
	alternative event records. These values should represent calculated
	values.
	<<Subevt expr: public>>=
	public :: event_expr_t
	<<Subevt expr: types>>=
	type, extends (subevt_expr_t) :: event_expr_t
	logical :: has_reweight = .false.
	logical :: has_analysis = .false.
	class(expr_t), allocatable :: reweight
	class(expr_t), allocatable :: analysis
	logical :: has_id = .false.
	type(string_t) :: id
	logical :: has_num_id = .false.
	integer :: num_id = 0
	logical :: has_index = .false.
	integer :: index = 0
	logical :: has_sqme_ref = .false.
	real(default) :: sqme_ref = 0
	logical :: has_sqme_prc = .false.
	real(default) :: sqme_prc = 0
	logical :: has_weight_ref = .false.
	real(default) :: weight_ref = 0
	logical :: has_weight_prc = .false.
	real(default) :: weight_prc = 0
	logical :: has_excess_prc = .false.
	real(default) :: excess_prc = 0
	integer :: n_alt = 0
	logical :: has_sqme_alt = .false.
	real(default), dimension(:), allocatable :: sqme_alt
	logical :: has_weight_alt = .false.
	real(default), dimension(:), allocatable :: weight_alt
	contains
	<<Subevt expr: event expr: TBP>>
	end type event_expr_t

	@ %def event_expr_t
	@ Finalizer for the expressions.
	<<Subevt expr: event expr: TBP>>=
	procedure :: final => event_expr_final
	<<Subevt expr: procedures>>=
	subroutine event_expr_final (object)
	class(event_expr_t), intent(inout) :: object
	call object%base_final ()
	if (object%has_reweight) then
	call object%reweight%final ()
	end if
	if (object%has_analysis) then
	call object%analysis%final ()
	end if
	end subroutine event_expr_final

	@ %def event_expr_final
	@ Output: continue writing the active expressions, after the common selection
	expression.

	Note: the [[prefix]] argument is declared in the [[write]] method of the
	[[subevt_t]] base type. Here, it is unused.
	<<Subevt expr: event expr: TBP>>=
	procedure :: write => event_expr_write
	<<Subevt expr: procedures>>=
	subroutine event_expr_write (object, unit, prefix, pacified)
	class(event_expr_t), intent(in) :: object
	integer, intent(in), optional :: unit
	character(*), intent(in), optional :: prefix
	logical, intent(in), optional :: pacified
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (u, pacified = pacified)
	if (object%subevt_filled) then
	if (object%has_reweight) then
	call write_separator (u)
	write (u, "(1x,A)") "Reweighting expression:"
	call write_separator (u)
	call object%reweight%write (u)
	end if
	if (object%has_analysis) then
	call write_separator (u)
	write (u, "(1x,A)") "Analysis expression:"
	call write_separator (u)
	call object%analysis%write (u)
	end if
	end if
	end subroutine event_expr_write

	@ %def event_expr_write
	@ Initializer. This is required only for the [[sqme_alt]] and
	[[weight_alt]] arrays.
	<<Subevt expr: event expr: TBP>>=
	procedure :: init => event_expr_init
	<<Subevt expr: procedures>>=
	subroutine event_expr_init (expr, n_alt)
	class(event_expr_t), intent(out) :: expr
	integer, intent(in), optional :: n_alt
	if (present (n_alt)) then
	expr%n_alt = n_alt
	allocate (expr%sqme_alt (n_alt), source = 0._default)
	allocate (expr%weight_alt (n_alt), source = 0._default)
	end if
	end subroutine event_expr_init

	@ %def event_expr_init
	@ Define variables. We have the variables of the base type plus
	specific variables for full events. There is the event index.
	<<Subevt expr: event expr: TBP>>=
	procedure :: setup_vars => event_expr_setup_vars
	<<Subevt expr: procedures>>=
	subroutine event_expr_setup_vars (expr, sqrts)
	class(event_expr_t), intent(inout), target :: expr
	real(default), intent(in) :: sqrts
	call expr%base_setup_vars (sqrts)
	call var_list_append_string_ptr (expr%var_list, &
	var_str ("$process_id"), expr%id, &
	is_known = expr%has_id, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_int_ptr (expr%var_list, &
	var_str ("process_num_id"), expr%num_id, &
	is_known = expr%has_num_id, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("sqme"), expr%sqme_prc, &
	is_known = expr%has_sqme_prc, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("sqme_ref"), expr%sqme_ref, &
	is_known = expr%has_sqme_ref, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_int_ptr (expr%var_list, &
	var_str ("event_index"), expr%index, &
	is_known = expr%has_index, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("event_weight"), expr%weight_prc, &
	is_known = expr%has_weight_prc, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("event_weight_ref"), expr%weight_ref, &
	is_known = expr%has_weight_ref, &
	locked = .true., verbose = .false., intrinsic = .true.)
	call var_list_append_real_ptr (expr%var_list, &
	var_str ("event_excess"), expr%excess_prc, &
	is_known = expr%has_excess_prc, &
	locked = .true., verbose = .false., intrinsic = .true.)
	end subroutine event_expr_setup_vars

	@ %def event_expr_setup_vars
	@ Compile the analysis expression. If the pointer is disassociated, there is
	no expression.
	<<Subevt expr: event expr: TBP>>=
	procedure :: setup_analysis => event_expr_setup_analysis
	<<Subevt expr: procedures>>=
	subroutine event_expr_setup_analysis (expr, ef_analysis)
	class(event_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_analysis
	call ef_analysis%build (expr%analysis)
	if (allocated (expr%analysis)) then
	call expr%setup_var_self ()
	call expr%analysis%setup_lexpr (expr%var_list)
	expr%has_analysis = .true.
	end if
	end subroutine event_expr_setup_analysis

	@ %def event_expr_setup_analysis
	@ Compile the reweight expression.
	<<Subevt expr: event expr: TBP>>=
	procedure :: setup_reweight => event_expr_setup_reweight
	<<Subevt expr: procedures>>=
	subroutine event_expr_setup_reweight (expr, ef_reweight)
	class(event_expr_t), intent(inout), target :: expr
	class(expr_factory_t), intent(in) :: ef_reweight
	call ef_reweight%build (expr%reweight)
	if (allocated (expr%reweight)) then
	call expr%setup_var_self ()
	call expr%reweight%setup_expr (expr%var_list)
	expr%has_reweight = .true.
	end if
	end subroutine event_expr_setup_reweight

	@ %def event_expr_setup_reweight
	@ Store the string or numeric process ID. This should be done during
	initialization.
	<<Subevt expr: event expr: TBP>>=
	procedure :: set_process_id => event_expr_set_process_id
	procedure :: set_process_num_id => event_expr_set_process_num_id
	<<Subevt expr: procedures>>=
	subroutine event_expr_set_process_id (expr, id)
	class(event_expr_t), intent(inout) :: expr
	type(string_t), intent(in) :: id
	expr%id = id
	expr%has_id = .true.
	end subroutine event_expr_set_process_id

	subroutine event_expr_set_process_num_id (expr, num_id)
	class(event_expr_t), intent(inout) :: expr
	integer, intent(in) :: num_id
	expr%num_id = num_id
	expr%has_num_id = .true.
	end subroutine event_expr_set_process_num_id

	@ %def event_expr_set_process_id
	@ %def event_expr_set_process_num_id
	@ Reset / set the data that pertain to a particular event. The event
	index is reset unless explicitly told to keep it.
	<<Subevt expr: event expr: TBP>>=
	procedure :: reset_contents => event_expr_reset_contents
	procedure :: set => event_expr_set
	<<Subevt expr: procedures>>=
	subroutine event_expr_reset_contents (expr)
	class(event_expr_t), intent(inout) :: expr
	call expr%base_reset_contents ()
	expr%has_sqme_ref = .false.
	expr%has_sqme_prc = .false.
	expr%has_sqme_alt = .false.
	expr%has_weight_ref = .false.
	expr%has_weight_prc = .false.
	expr%has_weight_alt = .false.
	expr%has_excess_prc = .false.
	end subroutine event_expr_reset_contents

	subroutine event_expr_set (expr, &
	weight_ref, weight_prc, weight_alt, &
	excess_prc, &
	sqme_ref, sqme_prc, sqme_alt)
	class(event_expr_t), intent(inout) :: expr
	real(default), intent(in), optional :: weight_ref, weight_prc
	real(default), intent(in), optional :: excess_prc
	real(default), intent(in), optional :: sqme_ref, sqme_prc
	real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
	if (present (sqme_ref)) then
	expr%has_sqme_ref = .true.
	expr%sqme_ref = sqme_ref
	end if
	if (present (sqme_prc)) then
	expr%has_sqme_prc = .true.
	expr%sqme_prc = sqme_prc
	end if
	if (present (sqme_alt)) then
	expr%has_sqme_alt = .true.
	expr%sqme_alt = sqme_alt
	end if
	if (present (weight_ref)) then
	expr%has_weight_ref = .true.
	expr%weight_ref = weight_ref
	end if
	if (present (weight_prc)) then
	expr%has_weight_prc = .true.
	expr%weight_prc = weight_prc
	end if
	if (present (weight_alt)) then
	expr%has_weight_alt = .true.
	expr%weight_alt = weight_alt
	end if
	if (present (excess_prc)) then
	expr%has_excess_prc = .true.
	expr%excess_prc = excess_prc
	end if
	end subroutine event_expr_set

	@ %def event_expr_reset_contents event_expr_set
	@ Access the subevent index.
	<<Subevt expr: event expr: TBP>>=
	procedure :: has_event_index => event_expr_has_event_index
	procedure :: get_event_index => event_expr_get_event_index
	<<Subevt expr: procedures>>=
	function event_expr_has_event_index (expr) result (flag)
	class(event_expr_t), intent(in) :: expr
	logical :: flag
	flag = expr%has_index
	end function event_expr_has_event_index

	function event_expr_get_event_index (expr) result (index)
	class(event_expr_t), intent(in) :: expr
	integer :: index
	if (expr%has_index) then
	index = expr%index
	else
	index = 0
	end if
	end function event_expr_get_event_index

	@ %def event_expr_has_event_index
	@ %def event_expr_get_event_index
	@ Set/increment the subevent index. Initialize it if necessary.
	<<Subevt expr: event expr: TBP>>=
	procedure :: set_event_index => event_expr_set_event_index
	procedure :: reset_event_index => event_expr_reset_event_index
	procedure :: increment_event_index => event_expr_increment_event_index
	<<Subevt expr: procedures>>=
	subroutine event_expr_set_event_index (expr, index)
	class(event_expr_t), intent(inout) :: expr
	integer, intent(in) :: index
	expr%index = index
	expr%has_index = .true.
	end subroutine event_expr_set_event_index

	subroutine event_expr_reset_event_index (expr)
	class(event_expr_t), intent(inout) :: expr
	expr%has_index = .false.
	end subroutine event_expr_reset_event_index

	subroutine event_expr_increment_event_index (expr, offset)
	class(event_expr_t), intent(inout) :: expr
	integer, intent(in), optional :: offset
	if (expr%has_index) then
	expr%index = expr%index + 1
	else if (present (offset)) then
	call expr%set_event_index (offset + 1)
	else
	call expr%set_event_index (1)
	end if
	end subroutine event_expr_increment_event_index

	@ %def event_expr_set_event_index
	@ %def event_expr_increment_event_index
	@ Fill the event expression: take the particle data and kinematics
	from a [[particle_set]] object.

	We allow the particle content to change for each event. Therefore, we set the
	event variables each time.

	Also increment the event index; initialize it if necessary.
	<<Subevt expr: event expr: TBP>>=
	procedure :: fill_subevt => event_expr_fill_subevt
	<<Subevt expr: procedures>>=
	subroutine event_expr_fill_subevt (expr, particle_set)
	class(event_expr_t), intent(inout) :: expr
	type(particle_set_t), intent(in) :: particle_set
	call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt)
	- expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
	- expr%n_in = subevt_get_n_in (expr%subevt_t)
	- expr%n_out = subevt_get_n_out (expr%subevt_t)
	+ expr%sqrts_hat = expr%get_sqrts_hat ()
	+ expr%n_in = expr%get_n_in ()
	+ expr%n_out = expr%get_n_out ()
	expr%n_tot = expr%n_in + expr%n_out
	expr%subevt_filled = .true.
	end subroutine event_expr_fill_subevt

	@ %def event_expr_fill_subevt
	@ Evaluate, if the event passes the selection. For absent expressions we take
	default values.
	<<Subevt expr: event expr: TBP>>=
	procedure :: evaluate => event_expr_evaluate
	<<Subevt expr: procedures>>=
	subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag)
	class(event_expr_t), intent(inout) :: expr
	logical, intent(out) :: passed
	real(default), intent(out) :: reweight
	logical, intent(out) :: analysis_flag
	call expr%base_evaluate (passed)
	if (passed) then
	if (expr%has_reweight) then
	call expr%reweight%evaluate ()
	if (expr%reweight%is_known ()) then
	reweight = expr%reweight%get_real ()
	else
	call msg_error ("Evaluate reweight expression: &
	&result undefined")
	reweight = 0
	end if
	else
	reweight = 1
	end if
	if (expr%has_analysis) then
	call expr%analysis%evaluate ()
	if (expr%analysis%is_known ()) then
	analysis_flag = expr%analysis%get_log ()
	else
	call msg_error ("Evaluate analysis expression: &
	&result undefined")
	analysis_flag = .false.
	end if
	else
	analysis_flag = .true.
	end if
	end if
	end subroutine event_expr_evaluate

	@ %def event_expr_evaluate
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Parton states}
	A [[parton_state_t]] object contains the effective kinematics and
	dynamics of an elementary partonic interaction, with or without the
	beam/structure function state included. The type is abstract and has
	two distinct extensions. The [[isolated_state_t]] extension describes
	the isolated elementary interaction where the [[int_eff]] subobject
	contains the complex transition amplitude, exclusive in all quantum
	numbers. The particle content and kinematics describe the effective
	partonic state. The [[connected_state_t]] extension contains the
	partonic [[subevt]] and the expressions for cuts and scales which use
	it.

	In the isolated state, the effective partonic interaction may either
	be identical to the hard interaction, in which case it is just a
	pointer to the latter. Or it may involve a rearrangement of partons,
	in which case we allocate it explicitly and flag this by
	[[int_is_allocated]].

	The [[trace]] evaluator contains the absolute square of the effective
	transition amplitude matrix, summed over final states. It is also summed over
	initial states, depending on the the beam setup allows. The result is used for
	integration.

	The [[matrix]] evaluator is the counterpart of [[trace]] which is kept
	exclusive in all observable quantum numbers. The [[flows]] evaluator is
	furthermore exclusive in colors, but neglecting all color interference. The
	[[matrix]] and [[flows]] evaluators are filled only for sampling points that
	become part of physical events.

	Note: It would be natural to make the evaluators allocatable. The extra
	[[has_XXX]] flags indicate whether evaluators are active, instead.

	This module contains no unit tests. The tests are covered by the
	[[processes]] module below.
	<<[[parton_states.f90]]>>=
	<<File header>>
	module parton_states

	<<Use kinds>>
	<<Use debug>>
	use io_units
	use format_utils, only: write_separator
	use diagnostics
	use lorentz
	use subevents
	use variables
	use expr_base
	use model_data
	use flavors
	use helicities
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use interactions
	use evaluators

	use beams
	use sf_base
	use process_constants
	use prc_core
	use subevt_expr

	<<Standard module head>>

	<<Parton states: public>>

	<<Parton states: types>>

	contains

	<<Parton states: procedures>>

	end module parton_states
	@ %def parton_states
	@
	\subsection{Abstract base type}
	The common part are the evaluators, one for the trace (summed over all
	quantum numbers), one for the transition matrix (summed only over
	unobservable quantum numbers), and one for the flow distribution
	(transition matrix without interferences, exclusive in color flow).
	<<Parton states: types>>=
	type, abstract :: parton_state_t
	logical :: has_trace = .false.
	logical :: has_matrix = .false.
	logical :: has_flows = .false.
	type(evaluator_t) :: trace
	type(evaluator_t) :: matrix
	type(evaluator_t) :: flows
	contains
	<<Parton states: parton state: TBP>>
	end type parton_state_t

	@ %def parton_state_t
	@ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object
	and the (hard) effective interaction [[int_eff]], separately, both are
	implemented as a pointer. The evaluators (trace, matrix, flows) apply
	to the hard interaction only.

	If the effective interaction differs from the hard interaction, the
	pointer is allocated explicitly. Analogously for [[sf_chain_eff]].
	<<Parton states: public>>=
	public :: isolated_state_t
	<<Parton states: types>>=
	type, extends (parton_state_t) :: isolated_state_t
	logical :: sf_chain_is_allocated = .false.
	type(sf_chain_instance_t), pointer :: sf_chain_eff => null ()
	logical :: int_is_allocated = .false.
	type(interaction_t), pointer :: int_eff => null ()
	contains
	<<Parton states: isolated state: TBP>>
	end type isolated_state_t

	@ %def isolated_state_t
	@ The [[connected_state_t]] extension contains all data that enable
	the evaluation of observables for the effective connected state. The
	evaluators connect the (effective) structure-function chain and hard
	interaction that were kept separate in the [[isolated_state_t]].

	The [[flows_sf]] evaluator is an extended copy of the
	structure-function

	The [[expr]] subobject consists of the [[subevt]], a simple event record,
	expressions for cuts etc.\ which refer to this record, and a [[var_list]]
	which contains event-specific variables, linked to the process variable
	list. Variables used within the expressions are looked up in [[var_list]].
	<<Parton states: public>>=
	public :: connected_state_t
	<<Parton states: types>>=
	type, extends (parton_state_t) :: connected_state_t
	type(state_flv_content_t) :: state_flv
	logical :: has_flows_sf = .false.
	type(evaluator_t) :: flows_sf
	logical :: has_expr = .false.
	type(parton_expr_t) :: expr
	contains
	<<Parton states: connected state: TBP>>
	end type connected_state_t

	@ %def connected_state_t
	@ Output: each evaluator is written only when it is active. The
	[[sf_chain]] is only written if it is explicitly allocated.
	<<Parton states: parton state: TBP>>=
	procedure :: write => parton_state_write
	<<Parton states: procedures>>=
	subroutine parton_state_write (state, unit, testflag)
	class(parton_state_t), intent(in) :: state
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	select type (state)
	class is (isolated_state_t)
	if (state%sf_chain_is_allocated) then
	call write_separator (u)
	call state%sf_chain_eff%write (u)
	end if
	if (state%int_is_allocated) then
	call write_separator (u)
	write (u, "(1x,A)") &
	"Effective interaction:"
	call write_separator (u)
	call state%int_eff%basic_write (u, testflag = testflag)
	end if
	class is (connected_state_t)
	if (state%has_flows_sf) then
	call write_separator (u)
	write (u, "(1x,A)") &
	"Evaluator (extension of the beam evaluator &
	&with color contractions):"
	call write_separator (u)
	call state%flows_sf%write (u, testflag = testflag)
	end if
	end select
	if (state%has_trace) then
	call write_separator (u)
	write (u, "(1x,A)") &
	"Evaluator (trace of the squared transition matrix):"
	call write_separator (u)
	call state%trace%write (u, testflag = testflag)
	end if
	if (state%has_matrix) then
	call write_separator (u)
	write (u, "(1x,A)") &
	"Evaluator (squared transition matrix):"
	call write_separator (u)
	call state%matrix%write (u, testflag = testflag)
	end if
	if (state%has_flows) then
	call write_separator (u)
	write (u, "(1x,A)") &
	"Evaluator (squared color-flow matrix):"
	call write_separator (u)
	call state%flows%write (u, testflag = testflag)
	end if
	select type (state)
	class is (connected_state_t)
	if (state%has_expr) then
	call write_separator (u)
	call state%expr%write (u)
	end if
	end select
	end subroutine parton_state_write

	@ %def parton_state_write
	@ Finalize interaction and evaluators, but only if allocated.
	<<Parton states: parton state: TBP>>=
	procedure :: final => parton_state_final
	<<Parton states: procedures>>=
	subroutine parton_state_final (state)
	class(parton_state_t), intent(inout) :: state
	if (state%has_flows) then
	call state%flows%final ()
	state%has_flows = .false.
	end if
	if (state%has_matrix) then
	call state%matrix%final ()
	state%has_matrix = .false.
	end if
	if (state%has_trace) then
	call state%trace%final ()
	state%has_trace = .false.
	end if
	select type (state)
	class is (connected_state_t)
	if (state%has_flows_sf) then
	call state%flows_sf%final ()
	state%has_flows_sf = .false.
	end if
	call state%expr%final ()
	class is (isolated_state_t)
	if (state%int_is_allocated) then
	call state%int_eff%final ()
	deallocate (state%int_eff)
	state%int_is_allocated = .false.
	end if
	if (state%sf_chain_is_allocated) then
	call state%sf_chain_eff%final ()
	end if
	end select
	end subroutine parton_state_final

	@ %def parton_state_final
	@
	\subsection{Common Initialization}
	Initialize the isolated parton state. In this version, the
	effective structure-function chain [[sf_chain_eff]] and the effective
	interaction [[int_eff]] both are trivial pointers to the seed
	structure-function chain and to the hard interaction, respectively.
	<<Parton states: isolated state: TBP>>=
	procedure :: init => isolated_state_init
	<<Parton states: procedures>>=
	subroutine isolated_state_init (state, sf_chain, int)
	class(isolated_state_t), intent(out) :: state
	type(sf_chain_instance_t), intent(in), target :: sf_chain
	type(interaction_t), intent(in), target :: int
	state%sf_chain_eff => sf_chain
	state%int_eff => int
	end subroutine isolated_state_init

	@ %def isolated_state_init
	@
	\subsection{Evaluator initialization: isolated state}
	Create an evaluator for the trace of the squared transition matrix.
	The trace goes over all outgoing quantum numbers. Whether we trace
	over incoming quantum numbers other than color, depends on the given
	[[qn_mask_in]].

	There are two options: explicitly computing the color factor table
	([[use_cf]] false; [[nc]] defined), or taking the color factor
	table from the hard matrix element data.
	<<Parton states: isolated state: TBP>>=
	procedure :: setup_square_trace => isolated_state_setup_square_trace
	<<Parton states: procedures>>=
	subroutine isolated_state_setup_square_trace (state, core, &
	qn_mask_in, col, keep_fs_flavor)
	class(isolated_state_t), intent(inout), target :: state
	class(prc_core_t), intent(in) :: core
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
	!!! Actually need allocatable attribute here for once because col might
	!!! enter the subroutine non-allocated.
	integer, intent(in), dimension(:), allocatable :: col
	logical, intent(in) :: keep_fs_flavor
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	associate (data => core%data)
	allocate (qn_mask (data%n_in + data%n_out))
	qn_mask( : data%n_in) = &
	quantum_numbers_mask (.false., .true., .false.) &
	.or. qn_mask_in
	qn_mask(data%n_in + 1 : ) = &
	quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.)
	if (core%use_color_factors) then
	call state%trace%init_square (state%int_eff, qn_mask, &
	col_flow_index = data%cf_index, &
	col_factor = data%color_factors, &
	col_index_hi = col, &
	nc = core%nc)
	else
	call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc)
	end if
	end associate
	state%has_trace = .true.
	end subroutine isolated_state_setup_square_trace

	@ %def isolated_state_setup_square_trace
	@ Set up an identity-evaluator for the trace. This implies that [[me]]
	is considered to be a squared amplitude, as for example for BLHA matrix
	elements.
	<<Parton states: isolated state: TBP>>=
	procedure :: setup_identity_trace => isolated_state_setup_identity_trace
	<<Parton states: procedures>>=
	subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, &
	keep_fs_flavors, keep_colors)
	class(isolated_state_t), intent(inout), target :: state
	class(prc_core_t), intent(in) :: core
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
	logical, intent(in), optional :: keep_fs_flavors, keep_colors
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	logical :: fs_flv_flag, col_flag
	fs_flv_flag = .true.; col_flag = .true.
	if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
	if (present(keep_colors)) col_flag = .not. keep_colors
	associate (data => core%data)
	allocate (qn_mask (data%n_in + data%n_out))
	qn_mask( : data%n_in) = &
	quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in
	qn_mask(data%n_in + 1 : ) = &
	quantum_numbers_mask (fs_flv_flag, col_flag, .true.)
	end associate
	call state%int_eff%set_mask (qn_mask)
	call state%trace%init_identity (state%int_eff)
	state%has_trace = .true.
	end subroutine isolated_state_setup_identity_trace

	@ %def isolated_state_setup_identity_trace
	@ Set up the evaluator for the transition matrix, exclusive in
	helicities where this is requested.

	For all unstable final-state particles we keep polarization according to the
	applicable decay options. If the process is a decay itself, this applies also
	to the initial state.

	For all polarized final-state particles, we keep polarization including
	off-diagonal entries. We drop helicity completely for unpolarized final-state
	particles.

	For the initial state, if the particle has not been handled yet, we
	apply the provided [[qn_mask_in]] which communicates the beam properties.
	<<Parton states: isolated state: TBP>>=
	procedure :: setup_square_matrix => isolated_state_setup_square_matrix
	<<Parton states: procedures>>=
	subroutine isolated_state_setup_square_matrix &
	(state, core, model, qn_mask_in, col)
	class(isolated_state_t), intent(inout), target :: state
	class(prc_core_t), intent(in) :: core
	class(model_data_t), intent(in), target :: model
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	integer, dimension(:), intent(in) :: col
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	logical :: helmask, helmask_hd
	associate (data => core%data)
	allocate (qn_mask (data%n_in + data%n_out))
	allocate (flv (data%n_flv))
	do i = 1, data%n_in + data%n_out
	call flv%init (data%flv_state(i,:), model)
	if ((data%n_in == 1 .or. i > data%n_in) &
	.and. any (.not. flv%is_stable ())) then
	helmask = all (flv%decays_isotropically ())
	helmask_hd = all (flv%decays_diagonal ())
	qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, &
	mask_hd = helmask_hd)
	else if (i > data%n_in) then
	helmask = all (.not. flv%is_polarized ())
	qn_mask(i) = quantum_numbers_mask (.false., .true., helmask)
	else
	qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) &
	.or. qn_mask_in(i)
	end if
	end do
	if (core%use_color_factors) then
	call state%matrix%init_square (state%int_eff, qn_mask, &
	col_flow_index = data%cf_index, &
	col_factor = data%color_factors, &
	col_index_hi = col, &
	nc = core%nc)
	else
	call state%matrix%init_square (state%int_eff, &
	qn_mask, &
	nc = core%nc)
	end if
	end associate
	state%has_matrix = .true.
	end subroutine isolated_state_setup_square_matrix

	@ %def isolated_state_setup_square_matrix
	@ This procedure initializes the evaluator that computes the
	contributions to color flows, neglecting color interference.
	The incoming-particle mask can be used to sum over incoming flavor.

	Helicity handling: see above.
	<<Parton states: isolated state: TBP>>=
	procedure :: setup_square_flows => isolated_state_setup_square_flows
	<<Parton states: procedures>>=
	subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in)
	class(isolated_state_t), intent(inout), target :: state
	class(prc_core_t), intent(in) :: core
	class(model_data_t), intent(in), target :: model
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	logical :: helmask, helmask_hd
	associate (data => core%data)
	allocate (qn_mask (data%n_in + data%n_out))
	allocate (flv (data%n_flv))
	do i = 1, data%n_in + data%n_out
	call flv%init (data%flv_state(i,:), model)
	if ((data%n_in == 1 .or. i > data%n_in) &
	.and. any (.not. flv%is_stable ())) then
	helmask = all (flv%decays_isotropically ())
	helmask_hd = all (flv%decays_diagonal ())
	qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, &
	mask_hd = helmask_hd)
	else if (i > data%n_in) then
	helmask = all (.not. flv%is_polarized ())
	qn_mask(i) = quantum_numbers_mask (.false., .false., helmask)
	else
	qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) &
	.or. qn_mask_in(i)
	end if
	end do
	call state%flows%init_square (state%int_eff, qn_mask, &
	expand_color_flows = .true.)
	end associate
	state%has_flows = .true.
	end subroutine isolated_state_setup_square_flows

	@ %def isolated_state_setup_square_flows
	@
	\subsection{Evaluator initialization: connected state}
	Set up a trace evaluator as a product of two evaluators (incoming state,
	effective interaction). In the result, all quantum numbers are summed over.

	If the optional [[int]] interaction is provided, use this for the
	first factor in the convolution. Otherwise, use the final interaction
	of the stored [[sf_chain]].

	The [[resonant]] flag applies if we want to construct
	a decay chain. The resonance property can propagate to the final
	event output.

	If an extended structure function is required [[requires_extended_sf]],
	we have to not consider [[sub]] as a quantum number.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_connected_trace => connected_state_setup_connected_trace
	<<Parton states: procedures>>=
	subroutine connected_state_setup_connected_trace &
	(state, isolated, int, resonant, undo_helicities, &
	keep_fs_flavors, requires_extended_sf)
	class(connected_state_t), intent(inout), target :: state
	type(isolated_state_t), intent(in), target :: isolated
	type(interaction_t), intent(in), optional, target :: int
	logical, intent(in), optional :: resonant
	logical, intent(in), optional :: undo_helicities
	logical, intent(in), optional :: keep_fs_flavors
	logical, intent(in), optional :: requires_extended_sf
	type(quantum_numbers_mask_t) :: mask
	type(interaction_t), pointer :: src_int, beam_int
	logical :: reduce, fs_flv_flag
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
	"connected_state_setup_connected_trace")
	reduce = .false.; fs_flv_flag = .true.
	if (present (undo_helicities)) reduce = undo_helicities
	if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
	mask = quantum_numbers_mask (fs_flv_flag, .true., .true.)
	if (present (int)) then
	src_int => int
	else
	src_int => isolated%sf_chain_eff%get_out_int_ptr ()
	end if

	if (debug2_active (D_PROCESS_INTEGRATION)) then
	call src_int%basic_write ()
	end if

	call state%trace%init_product (src_int, isolated%trace, &
	qn_mask_conn = mask, &
	qn_mask_rest = mask, &
	connections_are_resonant = resonant, &
	ignore_sub_for_qn = requires_extended_sf)

	if (reduce) then
	beam_int => isolated%sf_chain_eff%get_beam_int_ptr ()
	call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ())
	call undo_qn_hel (src_int, mask, src_int%get_n_tot ())
	call beam_int%set_matrix_element (cmplx (1, 0, default))
	call src_int%set_matrix_element (cmplx (1, 0, default))
	end if

	state%has_trace = .true.
	contains
	subroutine undo_qn_hel (int_in, mask, n_tot)
	type(interaction_t), intent(inout) :: int_in
	type(quantum_numbers_mask_t), intent(in) :: mask
	integer, intent(in) :: n_tot
	type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in
	mask_in = mask
	call int_in%set_mask (mask_in)
	end subroutine undo_qn_hel
	end subroutine connected_state_setup_connected_trace

	@ %def connected_state_setup_connected_trace
	@ Set up a matrix evaluator as a product of two evaluators (incoming
	state, effective interation). In the intermediate state, color and
	helicity is summed over. In the final state, we keep the quantum
	numbers which are present in the original evaluators.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_connected_matrix => connected_state_setup_connected_matrix
	<<Parton states: procedures>>=
	subroutine connected_state_setup_connected_matrix &
	(state, isolated, int, resonant, qn_filter_conn)
	class(connected_state_t), intent(inout), target :: state
	type(isolated_state_t), intent(in), target :: isolated
	type(interaction_t), intent(in), optional, target :: int
	logical, intent(in), optional :: resonant
	type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
	type(quantum_numbers_mask_t) :: mask
	type(interaction_t), pointer :: src_int
	mask = quantum_numbers_mask (.false., .true., .true.)
	if (present (int)) then
	src_int => int
	else
	src_int => isolated%sf_chain_eff%get_out_int_ptr ()
	end if
	call state%matrix%init_product &
	(src_int, isolated%matrix, mask, &
	qn_filter_conn = qn_filter_conn, &
	connections_are_resonant = resonant)
	state%has_matrix = .true.
	end subroutine connected_state_setup_connected_matrix

	@ %def connected_state_setup_connected_matrix
	@ Set up a matrix evaluator as a product of two evaluators (incoming
	state, effective interation). In the intermediate state, only
	helicity is summed over. In the final state, we keep the quantum
	numbers which are present in the original evaluators.


	If the optional [[int]] interaction is provided, use this for the
	first factor in the convolution. Otherwise, use the final interaction
	of the stored [[sf_chain]], after creating an intermediate interaction
	that includes a correlated color state. We assume that for a
	caller-provided [[int]], this is not necessary.

	For fixed-order NLO differential distribution, we are interested at
	the partonic level, no parton showering takes place as this would
	demand for a proper matching. So, the flows in the [[connected_state]]
	are not needed, and the color part will be masked for the interaction
	coming from the [[sf_chain]]. The squared matrix elements coming from
	the OLP provider at the moment do not come with flows anyhow. This
	needs to be revised once the matching to the shower is completed.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_connected_flows => connected_state_setup_connected_flows
	<<Parton states: procedures>>=
	subroutine connected_state_setup_connected_flows &
	(state, isolated, int, resonant, qn_filter_conn, mask_color)
	class(connected_state_t), intent(inout), target :: state
	type(isolated_state_t), intent(in), target :: isolated
	type(interaction_t), intent(in), optional, target :: int
	logical, intent(in), optional :: resonant, mask_color
	type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
	type(quantum_numbers_mask_t) :: mask
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf
	type(interaction_t), pointer :: src_int
	logical :: mask_c
	mask_c = .false.
	if (present (mask_color)) mask_c = mask_color
	mask = quantum_numbers_mask (.false., .false., .true.)
	if (present (int)) then
	src_int => int
	else
	src_int => isolated%sf_chain_eff%get_out_int_ptr ()
	call state%flows_sf%init_color_contractions (src_int)
	state%has_flows_sf = .true.
	src_int => state%flows_sf%interaction_t
	if (mask_c) then
	allocate (mask_sf (src_int%get_n_tot ()))
	mask_sf = quantum_numbers_mask (.false., .true., .false.)
	call src_int%reduce_state_matrix (mask_sf, keep_order = .true.)
	end if
	end if
	call state%flows%init_product (src_int, isolated%flows, mask, &
	qn_filter_conn = qn_filter_conn, &
	connections_are_resonant = resonant)
	state%has_flows = .true.
	end subroutine connected_state_setup_connected_flows

	@ %def connected_state_setup_connected_flows
	@ Determine and store the flavor content for the connected state.
	This queries the [[matrix]] evaluator component, which should hold the
	requested flavor information.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_state_flv => connected_state_setup_state_flv
	<<Parton states: procedures>>=
	subroutine connected_state_setup_state_flv (state, n_out_hard)
	class(connected_state_t), intent(inout), target :: state
	integer, intent(in) :: n_out_hard
	call interaction_get_flv_content &
	(state%matrix%interaction_t, state%state_flv, n_out_hard)
	end subroutine connected_state_setup_state_flv

	@ %def connected_state_setup_state_flv
	@ Return the current flavor state object.
	<<Parton states: connected state: TBP>>=
	procedure :: get_state_flv => connected_state_get_state_flv
	<<Parton states: procedures>>=
	function connected_state_get_state_flv (state) result (state_flv)
	class(connected_state_t), intent(in) :: state
	type(state_flv_content_t) :: state_flv
	state_flv = state%state_flv
	end function connected_state_get_state_flv

	@ %def connected_state_get_state_flv
	@
	\subsection{Cuts and expressions}
	Set up the [[subevt]] that corresponds to the connected interaction.
	The index arrays refer to the interaction.

	We assign the particles as follows: the beam particles are the first
	two (decay process: one) entries in the trace evaluator. The incoming
	partons are identified by their link to the outgoing partons of the
	structure-function chain. The outgoing partons are those of the trace
	evaluator, which include radiated partons during the
	structure-function chain.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_subevt => connected_state_setup_subevt
	<<Parton states: procedures>>=
	subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out)
	class(connected_state_t), intent(inout), target :: state
	type(sf_chain_instance_t), intent(in), target :: sf_chain
	type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
	integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
	integer, dimension(:), allocatable :: i_beam, i_in, i_out
	integer :: sf_out_i
	type(interaction_t), pointer :: sf_int
	sf_int => sf_chain%get_out_int_ptr ()
	n_beam = size (f_beam)
	n_in = size (f_in)
	n_out = size (f_out)
	n_vir = state%trace%get_n_vir ()
	n_tot = state%trace%get_n_tot ()
	allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
	i_beam = [(i, i = 1, n_beam)]
	do j = 1, n_in
	sf_out_i = sf_chain%get_out_i (j)
	i_in(j) = interaction_find_link &
	(state%trace%interaction_t, sf_int, sf_out_i)
	end do
	i_out = [(i, i = n_vir + 1, n_tot)]
	call state%expr%setup_subevt (state%trace%interaction_t, &
	i_beam, i_in, i_out, f_beam, f_in, f_out)
	state%has_expr = .true.
	end subroutine connected_state_setup_subevt

	@ %def connected_state_setup_subevt
	@ Initialize the variable list specific for this state/term. We insert event
	variables ([[sqrts_hat]]) and link the process variable list. The variable
	list acquires pointers to subobjects of [[state]], which must therefore have a
	[[target]] attribute.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_var_list => connected_state_setup_var_list
	<<Parton states: procedures>>=
	subroutine connected_state_setup_var_list (state, process_var_list, beam_data)
	class(connected_state_t), intent(inout), target :: state
	type(var_list_t), intent(in), target :: process_var_list
	type(beam_data_t), intent(in) :: beam_data
	call state%expr%setup_vars (beam_data%get_sqrts ())
	call state%expr%link_var_list (process_var_list)
	end subroutine connected_state_setup_var_list

	@ %def connected_state_setup_var_list
	@ Allocate the cut expression etc.
	<<Parton states: connected state: TBP>>=
	procedure :: setup_cuts => connected_state_setup_cuts
	procedure :: setup_scale => connected_state_setup_scale
	procedure :: setup_fac_scale => connected_state_setup_fac_scale
	procedure :: setup_ren_scale => connected_state_setup_ren_scale
	procedure :: setup_weight => connected_state_setup_weight
	<<Parton states: procedures>>=
	subroutine connected_state_setup_cuts (state, ef_cuts)
	class(connected_state_t), intent(inout), target :: state
	class(expr_factory_t), intent(in) :: ef_cuts
	call state%expr%setup_selection (ef_cuts)
	end subroutine connected_state_setup_cuts

	subroutine connected_state_setup_scale (state, ef_scale)
	class(connected_state_t), intent(inout), target :: state
	class(expr_factory_t), intent(in) :: ef_scale
	call state%expr%setup_scale (ef_scale)
	end subroutine connected_state_setup_scale

	subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
	class(connected_state_t), intent(inout), target :: state
	class(expr_factory_t), intent(in) :: ef_fac_scale
	call state%expr%setup_fac_scale (ef_fac_scale)
	end subroutine connected_state_setup_fac_scale

	subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
	class(connected_state_t), intent(inout), target :: state
	class(expr_factory_t), intent(in) :: ef_ren_scale
	call state%expr%setup_ren_scale (ef_ren_scale)
	end subroutine connected_state_setup_ren_scale

	subroutine connected_state_setup_weight (state, ef_weight)
	class(connected_state_t), intent(inout), target :: state
	class(expr_factory_t), intent(in) :: ef_weight
	call state%expr%setup_weight (ef_weight)
	end subroutine connected_state_setup_weight

	@ %def connected_state_setup_expressions
	@ Reset the expression object: invalidate the subevt.
	<<Parton states: connected state: TBP>>=
	procedure :: reset_expressions => connected_state_reset_expressions
	<<Parton states: procedures>>=
	subroutine connected_state_reset_expressions (state)
	class(connected_state_t), intent(inout) :: state
	if (state%has_expr) call state%expr%reset_contents ()
	end subroutine connected_state_reset_expressions

	@ %def connected_state_reset_expressions
	@
	\subsection{Evaluation}
	Transfer momenta to the trace evaluator and fill the [[subevt]] with
	this effective kinematics, if applicable.

	Note: we may want to apply a boost for the [[subevt]].
	<<Parton states: parton state: TBP>>=
	procedure :: receive_kinematics => parton_state_receive_kinematics
	<<Parton states: procedures>>=
	subroutine parton_state_receive_kinematics (state)
	class(parton_state_t), intent(inout), target :: state
	if (state%has_trace) then
	call state%trace%receive_momenta ()
	select type (state)
	class is (connected_state_t)
	if (state%has_expr) then
	call state%expr%fill_subevt (state%trace%interaction_t)
	end if
	end select
	end if
	end subroutine parton_state_receive_kinematics

	@ %def parton_state_receive_kinematics
	@ Recover kinematics: We assume that the trace evaluator is filled
	with momenta. Send those momenta back to the sources, then fill the
	variables and subevent as above.

	The incoming momenta of the connected state are not connected to the
	isolated state but to the beam interaction. Therefore, the incoming
	momenta within the isolated state do not become defined, yet.
	Instead, we reconstruct the beam (and ISR) momentum configuration.
	<<Parton states: parton state: TBP>>=
	procedure :: send_kinematics => parton_state_send_kinematics
	<<Parton states: procedures>>=
	subroutine parton_state_send_kinematics (state)
	class(parton_state_t), intent(inout), target :: state
	if (state%has_trace) then
	call interaction_send_momenta (state%trace%interaction_t)
	select type (state)
	class is (connected_state_t)
	call state%expr%fill_subevt (state%trace%interaction_t)
	end select
	end if
	end subroutine parton_state_send_kinematics

	@ %def parton_state_send_kinematics
	@ Evaluate the expressions. The routine evaluates first the cut expression.
	If the event passes, it evaluates the other expressions. Where no expressions
	are defined, default values are inserted.
	<<Parton states: connected state: TBP>>=
	procedure :: evaluate_expressions => connected_state_evaluate_expressions
	<<Parton states: procedures>>=
	subroutine connected_state_evaluate_expressions (state, passed, &
	scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
	class(connected_state_t), intent(inout) :: state
	logical, intent(out) :: passed
	real(default), intent(out) :: scale, weight
	real(default), intent(out), allocatable :: fac_scale, ren_scale
	real(default), intent(in), allocatable, optional :: scale_forced
	logical, intent(in), optional :: force_evaluation
	if (state%has_expr) then
	call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, &
	scale_forced, force_evaluation)
	end if
	end subroutine connected_state_evaluate_expressions

	@ %def connected_state_evaluate_expressions
	@ Evaluate the structure-function chain, if it is allocated
	explicitly. The argument is the factorization scale.

	If the chain is merely a pointer, the chain should already be
	evaluated at this point.
	<<Parton states: isolated state: TBP>>=
	procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain
	<<Parton states: procedures>>=
	subroutine isolated_state_evaluate_sf_chain (state, fac_scale)
	class(isolated_state_t), intent(inout) :: state
	real(default), intent(in) :: fac_scale
	if (state%sf_chain_is_allocated) call state%sf_chain_eff%evaluate (fac_scale)
	end subroutine isolated_state_evaluate_sf_chain

	@ %def isolated_state_evaluate_sf_chain
	@ Evaluate the trace.
	<<Parton states: parton state: TBP>>=
	procedure :: evaluate_trace => parton_state_evaluate_trace
	<<Parton states: procedures>>=
	subroutine parton_state_evaluate_trace (state)
	class(parton_state_t), intent(inout) :: state
	if (state%has_trace) call state%trace%evaluate ()
	end subroutine parton_state_evaluate_trace

	@ %def parton_state_evaluate_trace
	<<Parton states: parton state: TBP>>=
	procedure :: evaluate_matrix => parton_state_evaluate_matrix
	<<Parton states: procedures>>=
	subroutine parton_state_evaluate_matrix (state)
	class(parton_state_t), intent(inout) :: state
	if (state%has_matrix) call state%matrix%evaluate ()
	end subroutine parton_state_evaluate_matrix

	@ %def parton_state_evaluate_matrix
	@ Evaluate the extra evaluators that we need for physical events.
	<<Parton states: parton state: TBP>>=
	procedure :: evaluate_event_data => parton_state_evaluate_event_data
	<<Parton states: procedures>>=
	subroutine parton_state_evaluate_event_data (state, only_momenta)
	class(parton_state_t), intent(inout) :: state
	logical, intent(in), optional :: only_momenta
	logical :: only_mom
	only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta
	select type (state)
	type is (connected_state_t)
	if (state%has_flows_sf) then
	call state%flows_sf%receive_momenta ()
	if (.not. only_mom) call state%flows_sf%evaluate ()
	end if
	end select
	if (state%has_matrix) then
	call state%matrix%receive_momenta ()
	if (.not. only_mom) call state%matrix%evaluate ()
	end if
	if (state%has_flows) then
	call state%flows%receive_momenta ()
	if (.not. only_mom) call state%flows%evaluate ()
	end if
	end subroutine parton_state_evaluate_event_data

	@ %def parton_state_evaluate_event_data
	@ Normalize the helicity density matrix by its trace, i.e., factor out
	the trace and put it into an overall normalization factor. The trace
	and flow evaluators are unchanged.
	<<Parton states: parton state: TBP>>=
	procedure :: normalize_matrix_by_trace => &
	parton_state_normalize_matrix_by_trace
	<<Parton states: procedures>>=
	subroutine parton_state_normalize_matrix_by_trace (state)
	class(parton_state_t), intent(inout) :: state
	if (state%has_matrix) call state%matrix%normalize_by_trace ()
	end subroutine parton_state_normalize_matrix_by_trace

	@ %def parton_state_normalize_matrix_by_trace
	@
	\subsection{Accessing the state}
	Three functions return a pointer to the event-relevant interactions.
	<<Parton states: parton state: TBP>>=
	procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr
	procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr
	procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr
	<<Parton states: procedures>>=
	function parton_state_get_trace_int_ptr (state) result (ptr)
	class(parton_state_t), intent(in), target :: state
	type(interaction_t), pointer :: ptr
	if (state%has_trace) then
	ptr => state%trace%interaction_t
	else
	ptr => null ()
	end if
	end function parton_state_get_trace_int_ptr

	function parton_state_get_matrix_int_ptr (state) result (ptr)
	class(parton_state_t), intent(in), target :: state
	type(interaction_t), pointer :: ptr
	if (state%has_matrix) then
	ptr => state%matrix%interaction_t
	else
	ptr => null ()
	end if
	end function parton_state_get_matrix_int_ptr

	function parton_state_get_flows_int_ptr (state) result (ptr)
	class(parton_state_t), intent(in), target :: state
	type(interaction_t), pointer :: ptr
	if (state%has_flows) then
	ptr => state%flows%interaction_t
	else
	ptr => null ()
	end if
	end function parton_state_get_flows_int_ptr

	@ %def parton_state_get_trace_int_ptr
	@ %def parton_state_get_matrix_int_ptr
	@ %def parton_state_get_flows_int_ptr
	@ Return the indices of the beam particles and the outgoing particles within
	the trace (and thus, matrix and flows) evaluator, respectively.
	<<Parton states: connected state: TBP>>=
	procedure :: get_beam_index => connected_state_get_beam_index
	procedure :: get_in_index => connected_state_get_in_index
	<<Parton states: procedures>>=
	subroutine connected_state_get_beam_index (state, i_beam)
	class(connected_state_t), intent(in) :: state
	integer, dimension(:), intent(out) :: i_beam
	call state%expr%get_beam_index (i_beam)
	end subroutine connected_state_get_beam_index

	subroutine connected_state_get_in_index (state, i_in)
	class(connected_state_t), intent(in) :: state
	integer, dimension(:), intent(out) :: i_in
	call state%expr%get_in_index (i_in)
	end subroutine connected_state_get_in_index

	@ %def connected_state_get_beam_index
	@ %def connected_state_get_in_index
	@
	<<Parton states: public>>=
	public :: refill_evaluator
	<<Parton states: procedures>>=
	subroutine refill_evaluator (sqme, qn, flv_index, evaluator)
	complex(default), intent(in), dimension(:) :: sqme
	type(quantum_numbers_t), intent(in), dimension(:,:) :: qn
	integer, intent(in), dimension(:), optional :: flv_index
	type(evaluator_t), intent(inout) :: evaluator
	integer :: i, i_flv
	do i = 1, size (sqme)
	if (present (flv_index)) then
	i_flv = flv_index(i)
	else
	i_flv = i
	end if
	call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), &
	match_only_flavor = .true.)
	end do
	end subroutine refill_evaluator

	@ %def refill_evaluator
	@ Return the number of outgoing (hard) particles for the state.
	<<Parton states: parton state: TBP>>=
	procedure :: get_n_out => parton_state_get_n_out
	<<Parton states: procedures>>=
	function parton_state_get_n_out (state) result (n)
	class(parton_state_t), intent(in), target :: state
	integer :: n
	n = state%trace%get_n_out ()
	end function parton_state_get_n_out

	@ %def parton_state_get_n_out
	@
	\subsection{Unit tests}
	<<[[parton_states_ut.f90]]>>=
	<<File header>>

	module parton_states_ut
	use unit_tests
	use parton_states_uti

	<<Standard module head>>

	<<Parton states: public test>>

	contains

	<<Parton states: test driver>>

	end module parton_states_ut
	@ %def parton_states_ut
	<<[[parton_states_uti.f90]]>>=
	<<File header>>

	module parton_states_uti

	<<Use kinds>>
	<<Use strings>>
	use constants, only: zero
	use numeric_utils
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use sf_base, only: sf_chain_instance_t
	use state_matrices, only: state_matrix_t
	use prc_template_me, only: prc_template_me_t
	use interactions, only: interaction_t
	use models, only: model_t, create_test_model
	use parton_states

	<<Standard module head>>

	<<Parton states: test declarations>>

	contains

	<<Parton states: tests>>

	end module parton_states_uti
	@ %def parton_states_uti
	@
	<<Parton states: public test>>=
	public :: parton_states_test
	<<Parton states: test driver>>=
	subroutine parton_states_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Parton states: execute tests>>
	end subroutine parton_states_test

	@ %def parton_states_test
	@
	\subsubsection{Test a simple isolated state}
	<<Parton states: execute tests>>=
	call test (parton_states_1, "parton_states_1", &
	"Create a 2 -> 2 isolated state and compute trace", &
	u, results)
	<<Parton states: test declarations>>=
	public :: parton_states_1
	<<Parton states: tests>>=
	subroutine parton_states_1 (u)
	integer, intent(in) :: u
	type(state_matrix_t), allocatable :: state
	type(flavor_t), dimension(2) :: flv_in
	type(flavor_t), dimension(2) :: flv_out1, flv_out2
	type(flavor_t), dimension(4) :: flv_tot
	type(helicity_t), dimension(4) :: hel
	type(color_t), dimension(4) :: col
	integer :: h1, h2, h3, h4
	integer :: f
	integer :: i
	type(quantum_numbers_t), dimension(4) :: qn
	type(prc_template_me_t) :: core
	type(sf_chain_instance_t), target :: sf_chain
	type(interaction_t), target :: int
	type(isolated_state_t) :: isolated_state
	integer :: n_states = 0
	integer, dimension(:), allocatable :: col_flow_index
	type(quantum_numbers_mask_t), dimension(2) :: qn_mask
	integer, dimension(8) :: i_allowed_states
	complex(default), dimension(8) :: me
	complex(default) :: me_check_tot, me_check_1, me_check_2, me2
	logical :: tmp1, tmp2
	type(model_t), pointer :: test_model => null ()

	write (u, "(A)") "* Test output: parton_states_1"
	write (u, "(A)") "* Purpose: Test the standard parton states"
	write (u, "(A)")

	call flv_in%init ([11, -11])
	call flv_out1%init ([1, -1])
	call flv_out2%init ([2, -2])

	write (u, "(A)") "* Using incoming flavors: "
	call flavor_write_array (flv_in, u)
	write (u, "(A)") "* Two outgoing flavor structures: "
	call flavor_write_array (flv_out1, u)
	call flavor_write_array (flv_out2, u)


	write (u, "(A)") "* Initialize state matrix"
	allocate (state)
	call state%init ()

	write (u, "(A)") "* Fill state matrix"
	call col(3)%init ([1])
	call col(4)%init ([-1])
	do f = 1, 2
	do h1 = -1, 1, 2
	do h2 = -1, 1, 2
	do h3 = -1, 1, 2
	do h4 = -1, 1, 2
	n_states = n_states + 1
	call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
	if (f == 1) then
	flv_tot = [flv_in, flv_out1]
	else
	flv_tot = [flv_in, flv_out2]
	end if
	call qn%init (flv_tot, col, hel)
	call state%add_state (qn)
	end do
	end do
	end do
	end do
	end do

	!!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations
	!!! -> 32 states.
	write (u, "(A)")
	write (u, "(A,I2)") "* Generated number of states: ", n_states

	call state%freeze ()

	!!! Indices of the helicity configurations which are non-zero
	i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27]
	me = [cmplx (-1.89448E-5_default, 9.94456E-7_default, default), &
	cmplx (-8.37887E-2_default, 4.30842E-3_default, default), &
	cmplx (-1.99997E-1_default, -1.01985E-2_default, default), &
	cmplx ( 1.79717E-5_default, 9.27038E-7_default, default), &
	cmplx (-1.74859E-5_default, 8.78819E-7_default, default), &
	cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), &
	cmplx ( 2.41331E-1_default, 1.23306E-2_default, default), &
	cmplx (-3.59435E-5_default, -1.85407E-6_default, default)]
	me_check_tot = cmplx (zero, zero, default)
	me_check_1 = cmplx (zero, zero, default)
	me_check_2 = cmplx (zero, zero, default)
	do i = 1, 8
	me2 = me(i) * conjg (me(i))
	me_check_tot = me_check_tot + me2
	if (i < 5) then
	me_check_1 = me_check_1 + me2
	else
	me_check_2 = me_check_2 + me2
	end if
	call state%set_matrix_element (i_allowed_states(i), me(i))
	end do

	!!! Do not forget the color factor
	me_check_tot = 3._default * me_check_tot
	me_check_1 = 3._default * me_check_1
	me_check_2 = 3._default * me_check_2
	write (u, "(A)")

	write (u, "(A)") "* Setup interaction"
	call int%basic_init (2, 0, 2, set_relations = .true.)
	call int%set_state_matrix (state)

	core%data%n_in = 2; core%data%n_out = 2
	core%data%n_flv = 2
	allocate (core%data%flv_state (4, 2))
	core%data%flv_state (1, :) = [11, 11]
	core%data%flv_state (2, :) = [-11, -11]
	core%data%flv_state (3, :) = [1, 2]
	core%data%flv_state (4, :) = [-1, -2]
	core%use_color_factors = .false.
	core%nc = 3

	write (u, "(A)") "* Init isolated state"
	call isolated_state%init (sf_chain, int)
	!!! There is only one color flow.
	allocate (col_flow_index (n_states)); col_flow_index = 1
	call qn_mask%init (.false., .false., .true., mask_cg = .false.)
	write (u, "(A)") "* Give a trace to the isolated state"
	call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.)
	call isolated_state%evaluate_trace ()
	write (u, "(A)")
	write (u, "(A)", advance = "no") "* Squared matrix element correct: "
	write (u, "(L1)") nearly_equal (me_check_tot, &
	isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default)


	write (u, "(A)") "* Give a matrix to the isolated state"
	call create_test_model (var_str ("SM"), test_model)
	call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index)
	call isolated_state%evaluate_matrix ()

	write (u, "(A)") "* Sub-matrixelements correct: "
	tmp1 = nearly_equal (me_check_1, &
	isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default)
	tmp2 = nearly_equal (me_check_2, &
	isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default)
	write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2

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

	@ %def parton_states_1
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process component management}
	This module contains tools for managing and combining process
	components and matrix-element code and values, acting at a level below
	the actual process definition.

	\subsection{Abstract base type}
	The types introduced here are abstract base types.
	<<[[pcm_base.f90]]>>=
	<<File header>>

	module pcm_base

	<<Use kinds>>
	use io_units
	use diagnostics
	use format_utils, only: write_integer_array
	use format_utils, only: write_separator
	use physics_defs, only: BORN, NLO_REAL
	<<Use strings>>
	use os_interface, only: os_data_t

	use process_libraries, only: process_component_def_t
	use process_libraries, only: process_library_t

	use prc_core_def
	use prc_core

	use variables, only: var_list_t
	use mappings, only: mapping_defaults_t
	use phs_base, only: phs_config_t
	use phs_forests, only: phs_parameters_t
	use mci_base, only: mci_t
	use model_data, only: model_data_t
	use models, only: model_t

	use blha_config, only: blha_master_t
	use blha_olp_interfaces, only: blha_template_t
	use process_config
	use process_mci, only: process_mci_entry_t

	<<Standard module head>>

	<<PCM base: public>>

	<<PCM base: parameters>>

	<<PCM base: types>>

	<<PCM base: interfaces>>

	contains

	<<PCM base: procedures>>

	end module pcm_base
	@ %def pcm_base
	@
	\subsection{Core management}
	This object holds information about the cores used by the components
	and allocates the corresponding manager instance.

	[[i_component]] is the index of the process component which this core belongs
	to. The pointer to the core definition is a convenient help in configuring
	the core itself.

	We allow for a [[blha_config]] configuration object that covers BLHA cores.
	The BLHA standard is suitable generic to warrant support outside of specific
	type extension (i.e., applies to LO and NLO if requested). The BLHA
	configuration is allocated only if the core requires it.
	<<PCM base: public>>=
	public :: core_entry_t
	<<PCM base: types>>=
	type :: core_entry_t
	integer :: i_component = 0
	logical :: active = .false.
	class(prc_core_def_t), pointer :: core_def => null ()
	type(blha_template_t), allocatable :: blha_config
	class(prc_core_t), allocatable :: core
	contains
	<<PCM base: core entry: TBP>>
	end type core_entry_t

	@ %def core_entry_t
	@
	<<PCM base: core entry: TBP>>=
	procedure :: get_core_ptr => core_entry_get_core_ptr
	<<PCM base: procedures>>=
	function core_entry_get_core_ptr (core_entry) result (core)
	class(core_entry_t), intent(in), target :: core_entry
	class(prc_core_t), pointer :: core
	if (allocated (core_entry%core)) then
	core => core_entry%core
	else
	core => null ()
	end if
	end function core_entry_get_core_ptr

	@ %def core_entry_get_core_ptr
	@ Configure the core object after allocation with correct type. The
	[[core_def]] object pointer and the index [[i_component]] of the associated
	process component are already there.
	<<PCM base: core entry: TBP>>=
	procedure :: configure => core_entry_configure
	<<PCM base: procedures>>=
	subroutine core_entry_configure (core_entry, lib, id)
	class(core_entry_t), intent(inout) :: core_entry
	type(process_library_t), intent(in), target :: lib
	type(string_t), intent(in) :: id
	call core_entry%core%init &
	(core_entry%core_def, lib, id, core_entry%i_component)
	end subroutine core_entry_configure

	@ %def core_entry_configure
	@
	\subsection{Process component manager}
	The process-component manager [[pcm]] is the master component of the
	[[process_t]] object. It serves two purposes:
	\begin{enumerate}
	\item
	It holds configuration data which allow us to centrally manage the
	components, terms, etc.\ of the process object.
	\item
	It implements the methods that realize the algorithm for constructing
	the process object and computing an integral. This algorithm makes
	use of the data stored within [[pcm]].
	\end{enumerate}
	To this end, the object is abstract and polymorphic. The two
	extensions that we support, implement (a) default tree-level
	calculation, optionally including a sum over sub-processes with
	different particle content, or (b) the FKS-NLO subtraction algorithm for
	QCD-corrected processes. In both cases, the type extensions may hold
	suitable further data.

	Data included in the base type:

	The number of components determines the [[component_selected]] array.

	[[i_phs_config]] is a lookup table that holds the PHS configuration index
	for a given component index.

	[[i_core]] is a lookup table that holds the core-entry index for a
	given component index.

	[[i_mci]] is a lookup table that holds the integrator (MCI) index for
	a given component index.
	<<PCM base: public>>=
	public :: pcm_t
	<<PCM base: types>>=
	type, abstract :: pcm_t
	logical :: initialized = .false.
	logical :: has_pdfs = .false.
	integer :: n_components = 0
	integer :: n_cores = 0
	integer :: n_mci = 0
	logical, dimension(:), allocatable :: component_selected
	logical, dimension(:), allocatable :: component_active
	integer, dimension(:), allocatable :: i_phs_config
	integer, dimension(:), allocatable :: i_core
	integer, dimension(:), allocatable :: i_mci
	type(blha_template_t) :: blha_defaults
	logical :: uses_blha = .false.
	type(os_data_t) :: os_data
	contains
	<<PCM base: pcm: TBP>>
	end type pcm_t

	@ %def pcm_t
	@ The factory method. We use the [[inout]] intent, so calling this
	again is an error.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_allocate_workspace), deferred :: allocate_workspace
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_allocate_workspace (pcm, work)
	import
	class(pcm_t), intent(in) :: pcm
	class(pcm_workspace_t), intent(inout), allocatable :: work
	end subroutine pcm_allocate_workspace
	end interface

	@ %def pcm_allocate_workspace
	@
	<<PCM base: pcm: TBP>>=
	procedure(pcm_is_nlo), deferred :: is_nlo
	<<PCM base: interfaces>>=
	abstract interface
	function pcm_is_nlo (pcm) result (is_nlo)
	import
	logical :: is_nlo
	class(pcm_t), intent(in) :: pcm
	end function pcm_is_nlo
	end interface

	@ %def pcm_is_nlo
	@
	<<PCM base: pcm: TBP>>=
	procedure(pcm_final), deferred :: final
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_final (pcm)
	import
	class(pcm_t), intent(inout) :: pcm
	end subroutine pcm_final
	end interface

	@ %def pcm_final
	@
	\subsection{Initialization methods}
	The PCM has the duty to coordinate and configure the process-object
	components.

	Initialize the PCM configuration itself, using environment data.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_init), deferred :: init
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_init (pcm, env, meta)
	import
	class(pcm_t), intent(out) :: pcm
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	end subroutine pcm_init
	end interface

	@ %def pcm_init
	@
	Initialize the BLHA configuration block, the component-independent default
	settings. This is to be called by [[pcm_init]]. We use the provided variable
	list.

	This block is filled regardless of whether BLHA is actually used, because why
	not? We use a default value for the scheme (not set in unit tests).
	<<PCM base: pcm: TBP>>=
	procedure :: set_blha_defaults => pcm_set_blha_defaults
	<<PCM base: procedures>>=
	subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list)
	class(pcm_t), intent(inout) :: pcm
	type(var_list_t), intent(in) :: var_list
	logical, intent(in) :: polarized_beams
	logical :: muon_yukawa_off
	real(default) :: top_yukawa
	type(string_t) :: ew_scheme
	muon_yukawa_off = &
	var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa"))
	top_yukawa = &
	var_list%get_rval (var_str ("blha_top_yukawa"))
	ew_scheme = &
	var_list%get_sval (var_str ("$blha_ew_scheme"))
	if (ew_scheme == "") ew_scheme = "Gmu"
	call pcm%blha_defaults%init &
	(polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme)
	end subroutine pcm_set_blha_defaults

	@ %def pcm_set_blha_defaults
	@ Read the method settings from the variable list and store them in the BLHA
	master. The details depend on the [[pcm]] concrete type.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_set_blha_methods), deferred :: set_blha_methods
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_set_blha_methods (pcm, blha_master, var_list)
	import
	class(pcm_t), intent(inout) :: pcm
	type(blha_master_t), intent(inout) :: blha_master
	type(var_list_t), intent(in) :: var_list
	end subroutine pcm_set_blha_methods
	end interface

	@ %def pcm_set_blha_methods
	@ Produce the LO and NLO flavor-state tables (as far as available), as
	appropriate for BLHA configuration. We may inspect either the PCM itself or
	the array of process cores.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real)
	import
	class(pcm_t), intent(in) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	integer, dimension(:,:), allocatable, intent(out) :: flv_born
	integer, dimension(:,:), allocatable, intent(out) :: flv_real
	end subroutine pcm_get_blha_flv_states
	end interface

	@ %def pcm_get_blha_flv_states
	@
	Allocate the right number of process components. The number is also stored in
	the process meta. Initially, all components are active but none are
	selected.
	<<PCM base: pcm: TBP>>=
	procedure :: allocate_components => pcm_allocate_components
	<<PCM base: procedures>>=
	subroutine pcm_allocate_components (pcm, comp, meta)
	class(pcm_t), intent(inout) :: pcm
	type(process_component_t), dimension(:), allocatable, intent(out) :: comp
	type(process_metadata_t), intent(in) :: meta
	pcm%n_components = meta%n_components
	allocate (comp (pcm%n_components))
	allocate (pcm%component_selected (pcm%n_components), source = .false.)
	allocate (pcm%component_active (pcm%n_components), source = .true.)
	end subroutine pcm_allocate_components

	@ %def pcm_allocate_components
	@ Each process component belongs to a category/type, which we identify by a
	universal integer constant. The categories can be taken from the process
	definition. For easy lookup, we store the categories in an array.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_categorize_components), deferred :: categorize_components
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_categorize_components (pcm, config)
	import
	class(pcm_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	end subroutine pcm_categorize_components
	end interface

	@ %def pcm_categorize_components
	@
	Allocate the right number and type(s) of process-core
	objects, i.e., the interface object between the process and matrix-element
	code.

	Within the [[pcm]] block, also associate cores with components and store
	relevant configuration data, including the [[i_core]] lookup table.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_allocate_cores), deferred :: allocate_cores
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_allocate_cores (pcm, config, core_entry)
	import
	class(pcm_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
	end subroutine pcm_allocate_cores
	end interface

	@ %def pcm_allocate_cores
	@ Generate and interface external code for a single core, if this is
	required.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_prepare_any_external_code), deferred :: &
	prepare_any_external_code
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_prepare_any_external_code &
	(pcm, core_entry, i_core, libname, model, var_list)
	import
	class(pcm_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	integer, intent(in) :: i_core
	type(string_t), intent(in) :: libname
	type(model_data_t), intent(in), target :: model
	type(var_list_t), intent(in) :: var_list
	end subroutine pcm_prepare_any_external_code
	end interface

	@ %def pcm_prepare_any_external_code
	@ Prepare the BLHA configuration for a core object that requires it. This
	does not affect the core object, which may not yet be allocated.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_setup_blha), deferred :: setup_blha
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_setup_blha (pcm, core_entry)
	import
	class(pcm_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	end subroutine pcm_setup_blha
	end interface

	@ %def pcm_setup_blha
	@ Configure the BLHA interface for a core object that requires it. This is
	separate from the previous method, assuming that the [[pcm]] has to allocate
	the actual cores and acquire some data in-between.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_prepare_blha_core (pcm, core_entry, model)
	import
	class(pcm_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	class(model_data_t), intent(in), target :: model
	end subroutine pcm_prepare_blha_core
	end interface

	@ %def pcm_prepare_blha_core
	@ Allocate and configure the MCI (multi-channel integrator) records and their
	relation to process components, appropriate for the algorithm implemented by
	[[pcm]].

	Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a
	factory method for allocating the [[mci_t]] object with a specific concrete
	type. The call may depend on the concrete [[pcm]] type.
	<<PCM base: public>>=
	public :: dispatch_mci_proc
	<<PCM base: interfaces>>=
	abstract interface
	subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo)
	import
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	end subroutine dispatch_mci_proc
	end interface

	@ %def dispatch_mci_proc
	<<PCM base: pcm: TBP>>=
	procedure(pcm_setup_mci), deferred :: setup_mci
	procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_setup_mci (pcm, mci_entry)
	import
	class(pcm_t), intent(inout) :: pcm
	type(process_mci_entry_t), &
	dimension(:), allocatable, intent(out) :: mci_entry
	end subroutine pcm_setup_mci
	end interface

	abstract interface
	subroutine pcm_call_dispatch_mci (pcm, &
	dispatch_mci, var_list, process_id, mci_template)
	import
	class(pcm_t), intent(inout) :: pcm
	procedure(dispatch_mci_proc) :: dispatch_mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	class(mci_t), intent(out), allocatable :: mci_template
	end subroutine pcm_call_dispatch_mci
	end interface

	@ %def pcm_setup_mci
	@ %def pcm_call_dispatch_mci
	@ Proceed with PCM configuration based on the core and component
	configuration data. Base version is empty.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_complete_setup), deferred :: complete_setup
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_complete_setup (pcm, core_entry, component, model)
	import
	class(pcm_t), intent(inout) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	type(process_component_t), dimension(:), intent(inout) :: component
	type(model_t), intent(in), target :: model
	end subroutine pcm_complete_setup
	end interface

	@ %def pcm_complete_setup
	@
	\subsubsection{Retrieve information}
	Return the core index that belongs to a particular component.
	<<PCM base: pcm: TBP>>=
	procedure :: get_i_core => pcm_get_i_core
	<<PCM base: procedures>>=
	function pcm_get_i_core (pcm, i_component) result (i_core)
	class(pcm_t), intent(in) :: pcm
	integer, intent(in) :: i_component
	integer :: i_core
	if (allocated (pcm%i_core)) then
	i_core = pcm%i_core(i_component)
	else
	i_core = 0
	end if
	end function pcm_get_i_core

	@ %def pcm_get_i_core
	@
	\subsubsection{Phase-space configuration}
	Allocate and initialize the right number and type(s) of phase-space
	configuration entries. The [[i_phs_config]] lookup table must be set
	accordingly.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_init_phs_config), deferred :: init_phs_config
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_init_phs_config &
	(pcm, phs_entry, meta, env, phs_par, mapping_defs)
	import
	class(pcm_t), intent(inout) :: pcm
	type(process_phs_config_t), &
	dimension(:), allocatable, intent(out) :: phs_entry
	type(process_metadata_t), intent(in) :: meta
	type(process_environment_t), intent(in) :: env
	type(mapping_defaults_t), intent(in) :: mapping_defs
	type(phs_parameters_t), intent(in) :: phs_par
	end subroutine pcm_init_phs_config
	end interface

	@ %def pcm_init_phs_config
	@
	Initialize a single component. We require all process-configuration blocks,
	and specific templates for the phase-space and integrator configuration.

	We also provide the current component index [[i]] and the [[active]] flag.
	<<PCM base: pcm: TBP>>=
	procedure(pcm_init_component), deferred :: init_component
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_init_component &
	(pcm, component, i, active, phs_config, env, meta, config)
	import
	class(pcm_t), intent(in) :: pcm
	type(process_component_t), intent(out) :: component
	integer, intent(in) :: i
	logical, intent(in) :: active
	class(phs_config_t), allocatable, intent(in) :: phs_config
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	type(process_config_data_t), intent(in) :: config
	end subroutine pcm_init_component
	end interface

	@ %def pcm_init_component
	@
	Record components in the process [[meta]] data if they have turned
	out to be inactive.
	<<PCM base: pcm: TBP>>=
	procedure :: record_inactive_components => pcm_record_inactive_components
	<<PCM base: procedures>>=
	subroutine pcm_record_inactive_components (pcm, component, meta)
	class(pcm_t), intent(inout) :: pcm
	type(process_component_t), dimension(:), intent(in) :: component
	type(process_metadata_t), intent(inout) :: meta
	integer :: i
	pcm%component_active = component%active
	do i = 1, pcm%n_components
	if (.not. component(i)%active) call meta%deactivate_component (i)
	end do
	end subroutine pcm_record_inactive_components

	@ %def pcm_record_inactive_components
	@
	\subsection{Manager workspace}
	This object deals with the actual (squared) matrix element values. It
	holds any central data that are generated and/or used when calculating
	a particular phase-space point.

	Since phase-space points are associated with an integrator, we expect the
	instances of this type to correspond to MCI instances.
	<<PCM base: public>>=
	public :: pcm_workspace_t
	<<PCM base: types>>=
	type, abstract :: pcm_workspace_t
	! class(pcm_t), pointer :: config => null ()
	logical :: bad_point = .false.
	contains
	<<PCM base: pcm instance: TBP>>
	end type pcm_workspace_t

	@ %def pcm_workspace_t
	@
	<<PCM base: pcm instance: TBP>>=
	procedure(pcm_work_final), deferred :: final
	<<PCM base: interfaces>>=
	abstract interface
	subroutine pcm_work_final (pcm_work)
	import
	class(pcm_workspace_t), intent(inout) :: pcm_work
	end subroutine pcm_work_final
	end interface

	@ %def pcm_work_final
	@
	<<PCM base: pcm instance: TBP>>=
	procedure(pcm_work_is_nlo), deferred :: is_nlo
	<<PCM base: interfaces>>=
	abstract interface
	function pcm_work_is_nlo (pcm_work) result (is_nlo)
	import
	logical :: is_nlo
	class(pcm_workspace_t), intent(inout) :: pcm_work
	end function pcm_work_is_nlo
	end interface

	@ %def pcm_work_is_nlo
	@
	<<XXX PCM base: pcm instance: TBP>>=
	procedure :: link_config => pcm_work_link_config
	<<XXX PCM base: procedures>>=
	subroutine pcm_work_link_config (pcm_work, config)
	class(pcm_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in), target :: config
	pcm_work%config => config
	end subroutine pcm_work_link_config

	@ %def pcm_work_link_config
	@
	<<PCM base: pcm instance: TBP>>=
	procedure :: is_valid => pcm_work_is_valid
	<<PCM base: procedures>>=
	function pcm_work_is_valid (pcm_work) result (valid)
	logical :: valid
	class(pcm_workspace_t), intent(in) :: pcm_work
	valid = .not. pcm_work%bad_point
	end function pcm_work_is_valid

	@ %def pcm_work_is_valid
	@
	<<PCM base: pcm instance: TBP>>=
	procedure :: set_bad_point => pcm_work_set_bad_point
	<<PCM base: procedures>>=
	pure subroutine pcm_work_set_bad_point (pcm_work, bad_point)
	class(pcm_workspace_t), intent(inout) :: pcm_work
	logical, intent(in) :: bad_point
	pcm_work%bad_point = pcm_work%bad_point .or. bad_point
	end subroutine pcm_work_set_bad_point

	@ %def pcm_work_set_bad_point
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{The process object}
	<<[[process.f90]]>>=
	<<File header>>

	module process

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use format_utils, only: write_separator
	use constants
	use diagnostics
	use numeric_utils
	use lorentz
	use cputime
	use md5
	use rng_base
	use dispatch_rng, only: dispatch_rng_factory
	use dispatch_rng, only: update_rng_seed_in_var_list
	use os_interface
	use sm_qcd
	use integration_results
	use mci_base
	use flavors
	use model_data
	use models
	use physics_defs
	use process_libraries
	use process_constants
	use particles
	use variables
	use beam_structures
	use beams
	use interactions
	use pdg_arrays
	use expr_base
	use sf_base
	use sf_mappings
	use resonances, only: resonance_history_t, resonance_history_set_t

	use prc_test_core, only: test_t
	use prc_core_def, only: prc_core_def_t
	use prc_core, only: prc_core_t, helicity_selection_t
	use prc_external, only: prc_external_t
	use prc_recola, only: prc_recola_t
	use blha_olp_interfaces, only: prc_blha_t, blha_template_t
	use prc_threshold, only: prc_threshold_t
	use phs_fks, only: phs_fks_config_t

	use phs_base
	use mappings, only: mapping_defaults_t
	use phs_forests, only: phs_parameters_t
	use phs_wood, only: phs_wood_config_t
	use dispatch_phase_space, only: dispatch_phs
	use blha_config, only: blha_master_t
	use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES

	use parton_states, only: connected_state_t
	use pcm_base
	use pcm
	use process_counter
	use process_config
	use process_mci

	<<Standard module head>>

	<<Process: public>>

	<<Process: public parameters>>

	<<Process: types>>

	<<Process: interfaces>>

	contains

	<<Process: procedures>>

	end module process
	@ %def process
	@
	\subsection{Process status}
	Store counter and status information in a process object.
	<<Process: types>>=
	type :: process_status_t
	private
	end type process_status_t

	@ %def process_status_t
	@
	\subsection{Process status}
	Store integration results in a process object.
	<<Process: types>>=
	type :: process_results_t
	private
	end type process_results_t

	@ %def process_results_t
	@
	\subsection{The process type}
	NOTE: The description below represents the intended structure after
	refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.

	A [[process]] object is the internal representation of integration-run
	methods and data, as they are controlled by the user via a Sindarin
	script. The process object provides access to matrix elements (the
	actual ``process'' definitions that the user has provided before), it
	defines the separation into individually integrable components, and it
	manages phase-space construction, the actual integration over phase
	space, and the accumulation of results.

	As a workspace for individual sampling calls, we introduce an
	associated [[process_instance]] object type elsewhere. The
	[[process]] object contains data that either define the configuration
	or accumulate results from a complete integration pass.

	After successful phase-space integration, subsequent event generation
	is not actually represented by the [[process]] object. However, any
	event generation refers to an existing [[process]] object which
	represents a specific integration pass, and it uses a fresh
	[[process_instance]] workspace for calculations.

	The process object consists of several subobjects with their specific
	purposes. The corresponding types are defined below. (Technically,
	the subobject type definitions have to come before the process type
	definition, but with NOWEB magic we reverse this order here.)

	The [[meta]] object describes the process globally. All
	contents become fixed when the object is initialized. Similarly, the
	[[env]] component captures the (Sindarin) environment at the point
	where the process object is initialized.

	The [[config]] object holds physical and technical configuration data
	that are collected and derived from the environment during process
	initialization, and which are common to all process components.

	The [[pcm]] object (process-component manager) is polymorphic. This
	is an object which holds data which represent the process-object
	structure and breakdown, and it contains the methods that implement
	the algorithm of managing this structure, accumulating partial
	results, and finally collecting the pieces. Depending on the generic
	process type, the contents of [[pcm]] do vary. In particular, there
	is some base-type data content and a simple (default) extension which
	is designed for traditional \oMega\ matrix elements and tree-level
	integration, possibly with several sub-processes to sum over. The
	second extension is designed for the FKS phase-space and subtraction
	algorithm for NLO QCD, which interfaces external one-loop providers.

	The [[component]] subobjects are, first of all, interfaces to the
	original process-component definitions that have been provided by the
	user, which the program has already taken to produce matrix-element
	code and interfaces. The management of those components is deferred
	by [[pcm]], which contains the information that defines the role of
	each component. In particular, in the default (LO) version, process
	components correspond to distinct particle combinations which have
	been included in the original process definition. In the FKS-NLO
	version, the breakdown of a NLO process into Born, real, virtual,
	etc.\ components determines the setup.

	The [[phs_config]] subobjects hold data that allow and implement the
	construction of phase-space configurations. The type
	[[process_phs_config_t]] is a wrapper type around the concrete
	polymorphic [[phs_config_t]] object type, which manages phase-space
	construction, including some bookkeeping required for setting up
	multi-channel integration. In the LO case, we expect a separate entry
	for each independent sub-process. For the FKS-NLO algorithm, we
	expect several entries: a default-type entry which implements the
	underlying Born phase space, and additional entries which enable
	the construction of various real-radiation and subtraction kinematics
	configurations.

	A [[core_entry]] is the interface to existing matrix-element and
	interaction code. Depending on the process and its components, there
	may be various distinct matrix elements to compute.

	The [[mci_entry]] objects configure distinct MC input parameter sets
	and their associated (multi-channel) integrators.

	The [[rng_factory]] object is a single objects which constructs
	individual random-number generators for various tasks, in a uniform
	and well-defined way.

	The [[beam_config]] object describes the incoming particles, either the
	decay mother or the scattering beams. It also contains the spectrum-
	and structure-function setup, which has to interact with the
	phase-space and integrator facilities.

	The [[term]] subobjects break down the process in its smallest parts
	which appear in the calculation. For LO processes, the correspondence
	between terms and components is one-to-one. The FKS-NLO algorithm
	requires not just separation of Born, real, and virtual components but
	also subtraction terms, and a decomposition of the real phase space
	into singular regions. The general idea is that the integration
	results of distinct sets of terms are summed over to provide the
	results of individual components. This is also controlled by the
	[[pcm]] subobject.

	The [[process_status]] object is a bookkeeping device that allows us
	to query the status of an ongoing calculation.

	The [[process_results]] object collects the integration results for
	external use, including integration history information.
	<<Process: public>>=
	public :: process_t
	<<Process: types>>=
	type :: process_t
	private
	type(process_metadata_t) :: &
	meta
	type(process_environment_t) :: &
	env
	type(process_config_data_t) :: &
	config
	class(pcm_t), allocatable :: &
	pcm
	type(process_component_t), dimension(:), allocatable :: &
	component
	type(process_phs_config_t), dimension(:), allocatable :: &
	phs_entry
	type(core_entry_t), dimension(:), allocatable :: &
	core_entry
	type(process_mci_entry_t), dimension(:), allocatable :: &
	mci_entry
	class(rng_factory_t), allocatable :: &
	rng_factory
	type(process_beam_config_t) :: &
	beam_config
	type(process_term_t), dimension(:), allocatable :: &
	term
	type(process_status_t) :: &
	status
	type(process_results_t) :: &
	result
	contains
	<<Process: process: TBP>>
	end type process_t

	@ %def process_t
	@
	\subsection{Process pointer}
	Wrapper type for storing pointers to process objects in arrays.
	<<Process: public>>=
	public :: process_ptr_t
	<<Process: types>>=
	type :: process_ptr_t
	type(process_t), pointer :: p => null ()
	end type process_ptr_t

	@ %def process_ptr_t
	@
	\subsection{Output}
	This procedure is an important debugging and inspection tool; it is
	not used during normal operation. The process object is written
	to a file (identified by unit, which may also be standard output).
	Optional flags determine whether we show everything or just the
	interesting parts.

	The shorthand as a traditional TBP.
	<<Process: process: TBP>>=
	procedure :: write => process_write
	<<Process: procedures>>=
	subroutine process_write (process, screen, unit, &
	show_os_data, show_var_list, show_rng, show_expressions, pacify)
	class(process_t), intent(in) :: process
	logical, intent(in) :: screen
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_os_data
	logical, intent(in), optional :: show_var_list
	logical, intent(in), optional :: show_rng
	logical, intent(in), optional :: show_expressions
	logical, intent(in), optional :: pacify
	integer :: u, iostat
	character(0) :: iomsg
	integer, dimension(:), allocatable :: v_list
	u = given_output_unit (unit)
	allocate (v_list (0))
	call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
	call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
	call set_flag (v_list, F_SHOW_RNG, show_rng)
	call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions)
	call set_flag (v_list, F_PACIFY, pacify)
	if (screen) then
	call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
	else
	call process%write_formatted (u, "DT", v_list, iostat, iomsg)
	end if
	end subroutine process_write

	@ %def process_write
	@ Standard DTIO procedure with binding.

	For the particular application, the screen format is triggered by the
	[[LISTDIRECTED]] option for the [[iotype]] format editor string. The
	other options activate when the particular parameter value is found in
	[[v_list]].

	NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0.

	TODO wk 2018: The default could be to show everything, and we should have separate
	switches for all major parts. Currently, there are only a few.
	<<Process: process: TBP>>=
	! generic :: write (formatted) => write_formatted
	procedure :: write_formatted => process_write_formatted
	<<Process: procedures>>=
	subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg)
	class(process_t), intent(in) :: dtv
	integer, intent(in) :: unit
	character(*), intent(in) :: iotype
	integer, dimension(:), intent(in) :: v_list
	integer, intent(out) :: iostat
	character(*), intent(inout) :: iomsg
	integer :: u
	logical :: screen
	logical :: var_list
	logical :: rng_factory
	logical :: expressions
	logical :: counters
	logical :: os_data
	logical :: model
	logical :: pacify
	integer :: i
	u = unit
	select case (iotype)
	case ("LISTDIRECTED")
	screen = .true.
	case default
	screen = .false.
	end select
	var_list = flagged (v_list, F_SHOW_VAR_LIST)
	rng_factory = flagged (v_list, F_SHOW_RNG, .true.)
	expressions = flagged (v_list, F_SHOW_EXPRESSIONS)
	counters = .true.
	os_data = flagged (v_list, F_SHOW_OS_DATA)
	model = .false.
	pacify = flagged (v_list, F_PACIFY)
	associate (process => dtv)
	if (screen) then
	write (msg_buffer, "(A)") repeat ("-", 72)
	call msg_message ()
	else
	call write_separator (u, 2)
	end if
	call process%meta%write (u, screen)
	if (var_list) then
	call process%env%write (u, show_var_list=var_list, &
	show_model=.false., show_lib=.false., &
	show_os_data=os_data)
	else if (.not. screen) then
	write (u, "(1x,A)") "Variable list: [not shown]"
	end if
	if (process%meta%type == PRC_UNKNOWN) then
	call write_separator (u, 2)
	return
	else if (screen) then
	return
	end if
	call write_separator (u)
	call process%config%write (u, counters, model, expressions)
	if (rng_factory) then
	if (allocated (process%rng_factory)) then
	call write_separator (u)
	call process%rng_factory%write (u)
	end if
	end if
	call write_separator (u, 2)
	if (allocated (process%component)) then
	write (u, "(1x,A)") "Process component configuration:"
	do i = 1, size (process%component)
	call write_separator (u)
	call process%component(i)%write (u)
	end do
	else
	write (u, "(1x,A)") "Process component configuration: [undefined]"
	end if
	call write_separator (u, 2)
	if (allocated (process%term)) then
	write (u, "(1x,A)") "Process term configuration:"
	do i = 1, size (process%term)
	call write_separator (u)
	call process%term(i)%write (u)
	end do
	else
	write (u, "(1x,A)") "Process term configuration: [undefined]"
	end if
	call write_separator (u, 2)
	call process%beam_config%write (u)
	call write_separator (u, 2)
	if (allocated (process%mci_entry)) then
	write (u, "(1x,A)") "Multi-channel integrator configurations:"
	do i = 1, size (process%mci_entry)
	call write_separator (u)
	write (u, "(1x,A,I0,A)") "MCI #", i, ":"
	call process%mci_entry(i)%write (u, pacify)
	end do
	end if
	call write_separator (u, 2)
	end associate
	iostat = 0
	iomsg = ""
	end subroutine process_write_formatted

	@ %def process_write_formatted
	@
	<<Process: process: TBP>>=
	procedure :: write_meta => process_write_meta
	<<Process: procedures>>=
	subroutine process_write_meta (process, unit, testflag)
	class(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u, i
	u = given_output_unit (unit)
	select case (process%meta%type)
	case (PRC_UNKNOWN)
	write (u, "(1x,A)") "Process instance [undefined]"
	return
	case (PRC_DECAY)
	write (u, "(1x,A)", advance="no") "Process instance [decay]:"
	case (PRC_SCATTERING)
	write (u, "(1x,A)", advance="no") "Process instance [scattering]:"
	case default
	call msg_bug ("process_instance_write: undefined process type")
	end select
	write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'"
	write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'"
	if (allocated (process%meta%component_id)) then
	write (u, "(3x,A)") "Process components:"
	do i = 1, size (process%meta%component_id)
	if (process%pcm%component_selected(i)) then
	write (u, "(3x,'*')", advance="no")
	else
	write (u, "(4x)", advance="no")
	end if
	write (u, "(1x,I0,9A)") i, ": '", &
	char (process%meta%component_id (i)), "': ", &
	char (process%meta%component_description (i))
	end do
	end if
	end subroutine process_write_meta

	@ %def process_write_meta
	@ Screen output. Write a short account of the process configuration
	and the current results. The verbose version lists the components,
	the short version just the results.
	<<Process: process: TBP>>=
	procedure :: show => process_show
	<<Process: procedures>>=
	subroutine process_show (object, unit, verbose)
	class(process_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	logical :: verb
	real(default) :: err_percent
	u = given_output_unit (unit)
	verb = .true.; if (present (verbose)) verb = verbose
	if (verb) then
	call object%meta%show (u, object%config%model%get_name ())
	select case (object%meta%type)
	case (PRC_DECAY)
	write (u, "(2x,A)", advance="no") "Computed width ="
	case (PRC_SCATTERING)
	write (u, "(2x,A)", advance="no") "Computed cross section ="
	case default; return
	end select
	else
	if (object%meta%run_id /= "") then
	write (u, "('Run',1x,A,':',1x)", advance="no") &
	char (object%meta%run_id)
	end if
	write (u, "(A)", advance="no") char (object%meta%id)
	select case (object%meta%num_id)
	case (0)
	write (u, "(':')")
	case default
	write (u, "(1x,'(',I0,')',':')") object%meta%num_id
	end select
	write (u, "(2x)", advance="no")
	end if
	if (object%has_integral_tot ()) then
	write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") &
	object%get_integral_tot (), object%get_error_tot ()
	select case (object%meta%type)
	case (PRC_DECAY)
	write (u, "(1x,A)", advance="no") "GeV"
	case (PRC_SCATTERING)
	write (u, "(1x,A)", advance="no") "fb "
	case default
	write (u, "(1x,A)", advance="no") " "
	end select
	if (object%get_integral_tot () /= 0) then
	err_percent = abs (100 &
	* object%get_error_tot () / object%get_integral_tot ())
	else
	err_percent = 0
	end if
	if (err_percent == 0) then
	write (u, "(1x,'(',F4.0,4x,'%)')") err_percent
	else if (err_percent < 0.1) then
	write (u, "(1x,'(',F7.3,1x,'%)')") err_percent
	else if (err_percent < 1) then
	write (u, "(1x,'(',F6.2,2x,'%)')") err_percent
	else if (err_percent < 10) then
	write (u, "(1x,'(',F5.1,3x,'%)')") err_percent
	else
	write (u, "(1x,'(',F4.0,4x,'%)')") err_percent
	end if
	else
	write (u, "(A)") "[integral undefined]"
	end if
	end subroutine process_show

	@ %def process_show
	@ Finalizer. Explicitly iterate over all subobjects that may contain
	allocated pointers.

	TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not
	called. The reason is that this deletes model data local to the process,
	but these could be referenced by pointers (flavor objects) from some
	persistent event record. Obviously, such side effects should be avoided, but
	this requires refactoring the event-handling procedures.
	<<Process: process: TBP>>=
	procedure :: final => process_final
	<<Process: procedures>>=
	subroutine process_final (process)
	class(process_t), intent(inout) :: process
	integer :: i
	! call process%meta%final ()
	call process%env%final ()
	! call process%config%final ()
	if (allocated (process%component)) then
	do i = 1, size (process%component)
	call process%component(i)%final ()
	end do
	end if
	if (allocated (process%term)) then
	do i = 1, size (process%term)
	call process%term(i)%final ()
	end do
	end if
	call process%beam_config%final ()
	if (allocated (process%mci_entry)) then
	do i = 1, size (process%mci_entry)
	call process%mci_entry(i)%final ()
	end do
	end if
	if (allocated (process%pcm)) then
	call process%pcm%final ()
	deallocate (process%pcm)
	end if
	end subroutine process_final

	@ %def process_final
	@
	\subsubsection{Process setup}
	Initialize a process. We need a process library [[lib]] and the process
	identifier [[proc_id]] (string). We will fetch the current run ID from the
	variable list [[var_list]].

	We collect all important data from the environment and store them in the
	appropriate places. OS data, model, and variable list are copied
	into [[env]] (true snapshot), also the process library (pointer only).

	The [[meta]] subobject is initialized with process ID and attributes taken
	from the process library.

	We initialize the [[config]] subobject with all data that are relevant for
	this run, using the settings from [[env]]. These data determine the MD5 sum
	for this run, which allows us to identify the setup and possibly skips in a
	later re-run.

	We also allocate and initialize the embedded RNG factory. We take the seed
	from the [[var_list]], and we should return the [[var_list]] to the caller
	with a new seed.

	Finally, we allocate the process component manager [[pcm]], which implements
	the chosen algorithm for process integration. The first task of the manager
	is to allocate the component array and to determine the component categories
	(e.g., Born/Virtual etc.).

	TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we
	eventually want to eliminate dependencies on concrete [[pcm_t]] extensions.
	<<Process: process: TBP>>=
	procedure :: init => process_init
	<<Process: procedures>>=
	subroutine process_init &
	(process, proc_id, lib, os_data, model, var_list, beam_structure)
	class(process_t), intent(out) :: process
	type(string_t), intent(in) :: proc_id
	type(process_library_t), intent(in), target :: lib
	type(os_data_t), intent(in) :: os_data
	class(model_t), intent(in), target :: model
	type(var_list_t), intent(inout), target, optional :: var_list
	type(beam_structure_t), intent(in), optional :: beam_structure
	integer :: next_rng_seed
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init")
	associate &
	(meta => process%meta, env => process%env, config => process%config)
	call env%init &
	(model, lib, os_data, var_list, beam_structure)
	call meta%init &
	(proc_id, lib, env%get_var_list_ptr ())
	call config%init &
	(meta, env)
	call dispatch_rng_factory &
	(process%rng_factory, env%get_var_list_ptr (), next_rng_seed)
	call update_rng_seed_in_var_list (var_list, next_rng_seed)
	call dispatch_pcm &
	(process%pcm, config%process_def%is_nlo ())
	associate (pcm => process%pcm)
	call pcm%init (env, meta)
	call pcm%allocate_components (process%component, meta)
	call pcm%categorize_components (config)
	end associate
	end associate
	end subroutine process_init

	@ %def process_init
	@
	\subsection{Process component manager}
	The [[pcm]] (read: process-component manager) takes the responsibility of
	steering the actual algorithm of configuration and integration. Depending on
	the concrete type, different algorithms can be implemented.

	The first version of this supports just two implementations: leading-order
	(tree-level) integration and event generation, and NLO (QCD/FKS subtraction).
	We thus can start with a single logical for steering the dispatcher.

	TODO wk 2018: Eventually, we may eliminate all references to the extensions of
	[[pcm_t]] from this module and therefore move this outside the module as well.
	<<Process: procedures>>=
	subroutine dispatch_pcm (pcm, is_nlo)
	class(pcm_t), allocatable, intent(out) :: pcm
	logical, intent(in) :: is_nlo
	if (.not. is_nlo) then
	allocate (pcm_default_t :: pcm)
	else
	allocate (pcm_nlo_t :: pcm)
	end if
	end subroutine dispatch_pcm

	@ %def dispatch_pcm
	@ This step is performed after phase-space and core objects are done: collect
	all missing information and prepare the process component manager for the
	appropriate integration algorithm.
	<<Process: process: TBP>>=
	procedure :: complete_pcm_setup => process_complete_pcm_setup
	<<Process: procedures>>=
	subroutine process_complete_pcm_setup (process)
	class(process_t), intent(inout) :: process
	call process%pcm%complete_setup &
	(process%core_entry, process%component, process%env%get_model_ptr ())
	end subroutine process_complete_pcm_setup

	@ %def process_complete_pcm_setup
	@
	\subsection{Core management}
	Allocate cores (interface objects to matrix-element code).

	The [[dispatch_core]] procedure is taken as an argument, so we do not depend on
	the implementation, and thus on the specific core types.

	The [[helicity_selection]] object collects data that the matrix-element
	code needs for configuring the appropriate behavior.

	After the cores have been allocated, and assuming the phs initial
	configuration has been done before, we proceed with computing the [[pcm]]
	internal data.
	<<Process: process: TBP>>=
	procedure :: setup_cores => process_setup_cores
	<<Process: procedures>>=
	subroutine process_setup_cores (process, dispatch_core, &
	helicity_selection, use_color_factors, has_beam_pol)
	class(process_t), intent(inout) :: process
	procedure(dispatch_core_proc) :: dispatch_core
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	logical, intent(in), optional :: use_color_factors
	logical, intent(in), optional :: has_beam_pol
	integer :: i
	associate (pcm => process%pcm)
	call pcm%allocate_cores (process%config, process%core_entry)
	do i = 1, size (process%core_entry)
	call dispatch_core (process%core_entry(i)%core, &
	process%core_entry(i)%core_def, &
	process%config%model, &
	helicity_selection, &
	process%config%qcd, &
	use_color_factors, &
	has_beam_pol)
	call process%core_entry(i)%configure &
	(process%env%get_lib_ptr (), process%meta%id)
	if (process%core_entry(i)%core%uses_blha ()) then
	call pcm%setup_blha (process%core_entry(i))
	end if
	end do
	end associate
	end subroutine process_setup_cores

	@ %def process_setup_cores
	<<Process: interfaces>>=
	abstract interface
	subroutine dispatch_core_proc (core, core_def, model, &
	helicity_selection, qcd, use_color_factors, has_beam_pol)
	import
	class(prc_core_t), allocatable, intent(inout) :: core
	class(prc_core_def_t), intent(in) :: core_def
	class(model_data_t), intent(in), target, optional :: model
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	type(qcd_t), intent(in), optional :: qcd
	logical, intent(in), optional :: use_color_factors
	logical, intent(in), optional :: has_beam_pol
	end subroutine dispatch_core_proc
	end interface

	@ %def dispatch_core_proc
	@ Use the [[pcm]] to initialize the BLHA interface for each core which
	requires it.
	<<Process: process: TBP>>=
	procedure :: prepare_blha_cores => process_prepare_blha_cores
	<<Process: procedures>>=
	subroutine process_prepare_blha_cores (process)
	class(process_t), intent(inout), target :: process
	integer :: i
	associate (pcm => process%pcm)
	do i = 1, size (process%core_entry)
	associate (core_entry => process%core_entry(i))
	if (core_entry%core%uses_blha ()) then
	pcm%uses_blha = .true.
	call pcm%prepare_blha_core (core_entry, process%config%model)
	end if
	end associate
	end do
	end associate
	end subroutine process_prepare_blha_cores

	@ %def process_prepare_blha_cores
	@ Create the BLHA interface data, using PCM for specific data, and write the
	BLHA contract file(s).

	We take various configuration data and copy them to the [[blha_master]]
	record, which then creates and writes the contracts.

	For assigning the QCD/EW coupling powers, we inspect the first process
	component only. The other parameters are taken as-is from the process
	environment variables.
	<<Process: process: TBP>>=
	procedure :: create_blha_interface => process_create_blha_interface
	<<Process: procedures>>=
	subroutine process_create_blha_interface (process)
	class(process_t), intent(inout) :: process
	integer :: alpha_power, alphas_power
	integer :: openloops_phs_tolerance, openloops_stability_log
	logical :: use_cms
	type(string_t) :: ew_scheme, correction_type
	type(string_t) :: openloops_extra_cmd
	type(blha_master_t) :: blha_master
	integer, dimension(:,:), allocatable :: flv_born, flv_real
	if (process%pcm%uses_blha) then
	call collect_configuration_parameters (process%get_var_list_ptr ())
	call process%component(1)%config%get_coupling_powers &
	(alpha_power, alphas_power)
	associate (pcm => process%pcm)
	call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ())
	call blha_master%set_ew_scheme (ew_scheme)
	call blha_master%allocate_config_files ()
	call blha_master%set_correction_type (correction_type)
	call blha_master%setup_additional_features ( &
	openloops_phs_tolerance, &
	use_cms, &
	openloops_stability_log, &
	extra_cmd = openloops_extra_cmd, &
	beam_structure = process%env%get_beam_structure ())
	call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real)
	call blha_master%set_photon_characteristics (flv_born, process%config%n_in)
	call blha_master%generate (process%meta%id, &
	process%config%model, process%config%n_in, &
	alpha_power, alphas_power, &
	flv_born, flv_real)
	call blha_master%write_olp (process%meta%id)
	end associate
	end if
	contains
	subroutine collect_configuration_parameters (var_list)
	type(var_list_t), intent(in) :: var_list
	openloops_phs_tolerance = &
	var_list%get_ival (var_str ("openloops_phs_tolerance"))
	openloops_stability_log = &
	var_list%get_ival (var_str ("openloops_stability_log"))
	use_cms = &
	var_list%get_lval (var_str ("?openloops_use_cms"))
	ew_scheme = &
	var_list%get_sval (var_str ("$blha_ew_scheme"))
	correction_type = &
	var_list%get_sval (var_str ("$nlo_correction_type"))
	openloops_extra_cmd = &
	var_list%get_sval (var_str ("$openloops_extra_cmd"))
	end subroutine collect_configuration_parameters
	end subroutine process_create_blha_interface

	@ %def process_create_blha_interface
	@ Initialize the process components, one by one. We require templates for the
	[[mci]] (integrator) and [[phs_config]] (phase-space) configuration data.

	The [[active]] flag is set if the component has an associated matrix
	element, so we can compute it. The case of no core is a unit-test case.

	The specifics depend on the algorithm and are delegated to the [[pcm]]
	process-component manager.

	The optional [[phs_config]] overrides a pre-generated config array (for unit
	test).
	<<Process: process: TBP>>=
	procedure :: init_components => process_init_components
	<<Process: procedures>>=
	subroutine process_init_components (process, phs_config)
	class(process_t), intent(inout), target :: process
	class(phs_config_t), allocatable, intent(in), optional :: phs_config
	integer :: i, i_core
	class(prc_core_t), pointer :: core
	logical :: active
	associate (pcm => process%pcm)
	do i = 1, pcm%n_components
	i_core = pcm%get_i_core(i)
	if (i_core > 0) then
	core => process%get_core_ptr (i_core)
	active = core%has_matrix_element ()
	else
	active = .true.
	end if
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then
	if (pcm%component_type(i) == COMP_REAL_SING) then
	active = .false.
	end if
	end if
	end select
	if (present (phs_config)) then
	call pcm%init_component (process%component(i), &
	i, &
	active, &
	phs_config, &
	process%env, process%meta, process%config)
	else
	call pcm%init_component (process%component(i), &
	i, &
	active, &
	process%phs_entry(pcm%i_phs_config(i))%phs_config, &
	process%env, process%meta, process%config)
	end if
	end do
	end associate
	end subroutine process_init_components

	@ %def process_init_components
	@ If process components have turned out to be inactive, this has to be
	recorded in the [[meta]] block. Delegate to the [[pcm]].
	<<Process: process: TBP>>=
	procedure :: record_inactive_components => process_record_inactive_components
	<<Process: procedures>>=
	subroutine process_record_inactive_components (process)
	class(process_t), intent(inout) :: process
	associate (pcm => process%pcm)
	call pcm%record_inactive_components (process%component, process%meta)
	end associate
	end subroutine process_record_inactive_components

	@ %def process_record_inactive_components
	@ Determine the process terms for each process component.
	<<Process: process: TBP>>=
	procedure :: setup_terms => process_setup_terms
	<<Process: procedures>>=
	subroutine process_setup_terms (process, with_beams)
	class(process_t), intent(inout), target :: process
	logical, intent(in), optional :: with_beams
	class(model_data_t), pointer :: model
	integer :: i, j, k, i_term
	integer, dimension(:), allocatable :: n_entry
	integer :: n_components, n_tot
	integer :: i_sub
	type(string_t) :: subtraction_method
	class(prc_core_t), pointer :: core => null ()
	logical :: setup_subtraction_component, singular_real
	logical :: requires_spin_correlations
	integer :: nlo_type_to_fetch, n_emitters
	i_sub = 0
	model => process%config%model
	n_components = process%meta%n_components
	allocate (n_entry (n_components), source = 0)
	do i = 1, n_components
	associate (component => process%component(i))
	if (component%active) then
	n_entry(i) = 1
	if (component%get_nlo_type () == NLO_REAL) then
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	if (component%component_type /= COMP_REAL_FIN) &
	n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs ()
	end select
	end if
	end if
	end associate
	end do
	n_tot = sum (n_entry)
	allocate (process%term (n_tot))
	k = 0
	if (process%is_nlo_calculation ()) then
	i_sub = process%component(1)%config%get_associated_subtraction ()
	subtraction_method = process%component(i_sub)%config%get_me_method ()
	if (debug_on) call msg_debug2 &
	(D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method)
	end if

	do i = 1, n_components
	associate (component => process%component(i))
	if (.not. component%active) cycle
	allocate (component%i_term (n_entry(i)))
	do j = 1, n_entry(i)
	singular_real = component%get_nlo_type () == NLO_REAL &
	.and. component%component_type /= COMP_REAL_FIN
	setup_subtraction_component = singular_real .and. j == n_entry(i)
	i_term = k + j
	component%i_term(j) = i_term
	if (singular_real) then
	process%term(i_term)%i_sub = k + n_entry(i)
	else
	process%term(i_term)%i_sub = 0
	end if
	if (setup_subtraction_component) then
	select type (pcm => process%pcm)
	class is (pcm_nlo_t)
	process%term(i_term)%i_core = pcm%i_core(pcm%i_sub)
	end select
	else
	process%term(i_term)%i_core = process%pcm%get_i_core(i)
	end if

	if (process%term(i_term)%i_core == 0) then
	call msg_bug ("Process '" // char (process%get_id ()) &
	// "': core not found!")
	end if
	core => process%get_core_term (i_term)
	if (i_sub > 0) then
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	requires_spin_correlations = &
	pcm%region_data%requires_spin_correlations ()
	n_emitters = pcm%region_data%get_n_emitters_sc ()
	class default
	requires_spin_correlations = .false.
	n_emitters = 0
	end select
	if (requires_spin_correlations) then
	call process%term(i_term)%init ( &
	i_term, i, j, core, model, &
	nlo_type = component%config%get_nlo_type (), &
	use_beam_pol = with_beams, &
	subtraction_method = subtraction_method, &
	has_pdfs = process%pcm%has_pdfs, &
	n_emitters = n_emitters)
	else
	call process%term(i_term)%init ( &
	i_term, i, j, core, model, &
	nlo_type = component%config%get_nlo_type (), &
	use_beam_pol = with_beams, &
	subtraction_method = subtraction_method, &
	has_pdfs = process%pcm%has_pdfs)
	end if
	else
	call process%term(i_term)%init ( &
	i_term, i, j, core, model, &
	nlo_type = component%config%get_nlo_type (), &
	use_beam_pol = with_beams, &
	has_pdfs = process%pcm%has_pdfs)
	end if
	end do
	end associate
	k = k + n_entry(i)
	end do
	process%config%n_terms = n_tot
	end subroutine process_setup_terms

	@ %def process_setup_terms
	@ Initialize the beam setup. This is the trivial version where the
	incoming state of the matrix element coincides with the initial state
	of the process. For a scattering process, we need the c.m. energy,
	all other variables are set to their default values (no polarization,
	lab frame and c.m.\ frame coincide, etc.)

	We assume that all components consistently describe a scattering
	process, i.e., two incoming particles.

	Note: The current layout of the [[beam_data_t]] record requires that the
	flavor for each beam is unique. For processes with multiple
	flavors in the initial state, one has to set up beams explicitly.
	This restriction could be removed by extending the code in the
	[[beams]] module.
	<<Process: process: TBP>>=
	procedure :: setup_beams_sqrts => process_setup_beams_sqrts
	<<Process: procedures>>=
	subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core)
	class(process_t), intent(inout) :: process
	real(default), intent(in) :: sqrts
	type(beam_structure_t), intent(in), optional :: beam_structure
	integer, intent(in), optional :: i_core
	type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
	integer, dimension(2) :: pdg_scattering
	type(flavor_t), dimension(2) :: flv_in
	integer :: i, i0, ic
	allocate (pdg_in (2, process%meta%n_components))
	i0 = 0
	do i = 1, process%meta%n_components
	if (process%component(i)%active) then
	if (present (i_core)) then
	ic = i_core
	else
	ic = process%pcm%get_i_core (i)
	end if
	associate (core => process%core_entry(ic)%core)
	pdg_in(:,i) = core%data%get_pdg_in ()
	end associate
	if (i0 == 0) i0 = i
	end if
	end do
	do i = 1, process%meta%n_components
	if (.not. process%component(i)%active) then
	pdg_in(:,i) = pdg_in(:,i0)
	end if
	end do
	- if (all (pdg_array_get_length (pdg_in) == 1) .and. &
	+ if (all (pdg_in%get_length () == 1) .and. &
	all (pdg_in(1,:) == pdg_in(1,i0)) .and. &
	all (pdg_in(2,:) == pdg_in(2,i0))) then
	- pdg_scattering = pdg_array_get (pdg_in(:,i0), 1)
	+ pdg_scattering(:) = pdg_in(:,i0)%get (1)
	call flv_in%init (pdg_scattering, process%config%model)
	call process%beam_config%init_scattering (flv_in, sqrts, beam_structure)
	else
	call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", &
	[var_str (" --------------------------------------------"), &
	var_str ("Inconsistent initial state. This happens if either "), &
	var_str ("several processes with non-matching initial states "), &
	var_str ("have been added, or for a single process with an "), &
	var_str ("initial state flavor sum. In that case, please set beams "), &
	var_str ("explicitly [singling out a flavor / structure function.]")])
	end if
	end subroutine process_setup_beams_sqrts

	@ %def process_setup_beams_sqrts
	@ This is the version that applies to decay processes. The energy is the
	particle mass, hence no extra argument.
	<<Process: process: TBP>>=
	procedure :: setup_beams_decay => process_setup_beams_decay
	<<Process: procedures>>=
	subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core)
	class(process_t), intent(inout), target :: process
	logical, intent(in), optional :: rest_frame
	type(beam_structure_t), intent(in), optional :: beam_structure
	integer, intent(in), optional :: i_core
	type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
	integer, dimension(1) :: pdg_decay
	type(flavor_t), dimension(1) :: flv_in
	integer :: i, i0, ic
	allocate (pdg_in (1, process%meta%n_components))
	i0 = 0
	do i = 1, process%meta%n_components
	if (process%component(i)%active) then
	if (present (i_core)) then
	ic = i_core
	else
	ic = process%pcm%get_i_core (i)
	end if
	associate (core => process%core_entry(ic)%core)
	pdg_in(:,i) = core%data%get_pdg_in ()
	end associate
	if (i0 == 0) i0 = i
	end if
	end do
	do i = 1, process%meta%n_components
	if (.not. process%component(i)%active) then
	pdg_in(:,i) = pdg_in(:,i0)
	end if
	end do
	- if (all (pdg_array_get_length (pdg_in) == 1) &
	+ if (all (pdg_in%get_length () == 1) &
	.and. all (pdg_in(1,:) == pdg_in(1,i0))) then
	- pdg_decay = pdg_array_get (pdg_in(:,i0), 1)
	+ pdg_decay(:) = pdg_in(:,i0)%get (1)
	call flv_in%init (pdg_decay, process%config%model)
	call process%beam_config%init_decay (flv_in, rest_frame, beam_structure)
	else
	call msg_fatal ("Setting up decay '" &
	// char (process%meta%id) // "': decaying particle not unique")
	end if
	end subroutine process_setup_beams_decay

	@ %def process_setup_beams_decay
	@ We have to make sure that the masses of the various flavors
	in a given position in the particle string coincide.
	<<Process: process: TBP>>=
	procedure :: check_masses => process_check_masses
	<<Process: procedures>>=
	subroutine process_check_masses (process)
	class(process_t), intent(in) :: process
	type(flavor_t), dimension(:), allocatable :: flv
	real(default), dimension(:), allocatable :: mass
	integer :: i, j
	integer :: i_component
	class(prc_core_t), pointer :: core
	do i = 1, process%get_n_terms ()
	i_component = process%term(i)%i_component
	if (.not. process%component(i_component)%active) cycle
	core => process%get_core_term (i)
	associate (data => core%data)
	allocate (flv (data%n_flv), mass (data%n_flv))
	do j = 1, data%n_in + data%n_out
	call flv%init (data%flv_state(j,:), process%config%model)
	mass = flv%get_mass ()
	if (any (.not. nearly_equal(mass, mass(1)))) then
	call msg_fatal ("Process '" // char (process%meta%id) // "': " &
	// "mass values in flavor combination do not coincide. ")
	end if
	end do
	deallocate (flv, mass)
	end associate
	end do
	end subroutine process_check_masses

	@ %def process_check_masses
	@ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t.
	their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully
	set up. For processes with structure function, subprocesses which lead to the same
	amplitude for the hard interaction can differ if structure functions are applied.
	In this case we remap flavor structures to themselves if the eqvivalent hard interaction
	flavor structure has no identical initial state.
	<<Process: process: TBP>>=
	procedure :: optimize_nlo_singular_regions => process_optimize_nlo_singular_regions
	<<Process: procedures>>=
	subroutine process_optimize_nlo_singular_regions (process)
	class(process_t), intent(inout) :: process
	class(prc_core_t), pointer :: core, core_sub
	integer, dimension(:), allocatable :: eqv_flv_index_born
	integer, dimension(:), allocatable :: eqv_flv_index_real
	integer, dimension(:,:), allocatable :: flv_born, flv_real
	integer :: i_flv, i_flv2, n_in, i
	integer :: i_component, i_core, i_core_sub
	logical :: fetched_born, fetched_real
	logical :: optimize
	fetched_born = .false.; fetched_real = .false.
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	optimize = pcm%settings%reuse_amplitudes_fks
	if (optimize) then
	do i_component = 1, pcm%n_components
	i_core = pcm%get_i_core(i_component)
	core => process%get_core_ptr (i_core)
	if (.not. core%data_known) cycle
	associate (data => core%data)
	if (pcm%nlo_type_core(i_core) == NLO_REAL .and. &
	.not. pcm%component_type(i_component) == COMP_SUB) then
	if (allocated (core%data%eqv_flv_index)) then
	eqv_flv_index_real = core%get_equivalent_flv_index ()
	fetched_real = .true.
	end if
	i_core_sub = pcm%get_i_core (pcm%i_sub)
	core_sub => process%get_core_ptr (i_core_sub)
	if (allocated (core_sub%data%eqv_flv_index)) then
	eqv_flv_index_born = core_sub%get_equivalent_flv_index ()
	fetched_born = .true.
	end if
	if (fetched_born .and. fetched_real) exit
	end if
	end associate
	end do
	if (.not. fetched_born .or. .not. fetched_real) then
	call msg_warning('Failed to fetch flavor equivalence indices. &
	&Disabling singular region optimization')
	optimize = .false.
	eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
	eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
	end if
	if (optimize .and. pcm%has_pdfs) then
	flv_born = pcm%region_data%get_flv_states_born ()
	flv_real = pcm%region_data%get_flv_states_real ()
	n_in = pcm%region_data%n_in
	do i_flv = 1, size (eqv_flv_index_born)
	do i_flv2 = 1, i_flv
	if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= &
	flv_born(1:n_in, i_flv))) then
	eqv_flv_index_born(i_flv) = i_flv
	exit
	end if
	end do
	end do
	do i_flv = 1, size (eqv_flv_index_real)
	do i_flv2 = 1, i_flv
	if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= &
	flv_real(1:n_in, i_flv))) then
	eqv_flv_index_real(i_flv) = i_flv
	exit
	end if
	end do
	end do
	end if
	else
	eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
	eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
	end if
	pcm%region_data%eqv_flv_index_born = eqv_flv_index_born
	pcm%region_data%eqv_flv_index_real = eqv_flv_index_real
	call pcm%region_data%find_eqv_regions (optimize)
	end select
	end subroutine process_optimize_nlo_singular_regions

	@ %def process_optimize_nlo_singular_regions
	@ For some structure functions we need to get the list of initial
	state flavors. This is a two-dimensional array. The first index is
	the beam index, the second index is the component index. Each array
	element is itself a PDG array object, which consists of the list of
	incoming PDG values for this beam and component.
	<<Process: process: TBP>>=
	procedure :: get_pdg_in => process_get_pdg_in
	<<Process: procedures>>=
	subroutine process_get_pdg_in (process, pdg_in)
	class(process_t), intent(in), target :: process
	type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in
	integer :: i, i_core
	allocate (pdg_in (process%config%n_in, process%meta%n_components))
	do i = 1, process%meta%n_components
	if (process%component(i)%active) then
	i_core = process%pcm%get_i_core (i)
	associate (core => process%core_entry(i_core)%core)
	pdg_in(:,i) = core%data%get_pdg_in ()
	end associate
	end if
	end do
	end subroutine process_get_pdg_in

	@ %def process_get_pdg_in
	@ The phase-space configuration object, in case we need it separately.
	<<Process: process: TBP>>=
	procedure :: get_phs_config => process_get_phs_config
	<<Process: procedures>>=
	function process_get_phs_config (process, i_component) result (phs_config)
	class(phs_config_t), pointer :: phs_config
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_component
	if (allocated (process%component)) then
	phs_config => process%component(i_component)%phs_config
	else
	phs_config => null ()
	end if
	end function process_get_phs_config

	@ %def process_get_phs_config
	@ The resonance history set can be extracted from the phase-space
	configuration. However, this is only possible if the default phase-space
	method (wood) has been chosen. If [[include_trivial]] is set, we include the
	resonance history with no resonances in the set.
	<<Process: process: TBP>>=
	procedure :: extract_resonance_history_set &
	=> process_extract_resonance_history_set
	<<Process: procedures>>=
	subroutine process_extract_resonance_history_set &
	(process, res_set, include_trivial, i_component)
	class(process_t), intent(in), target :: process
	type(resonance_history_set_t), intent(out) :: res_set
	logical, intent(in), optional :: include_trivial
	integer, intent(in), optional :: i_component
	integer :: i
	i = 1; if (present (i_component)) i = i_component
	select type (phs_config => process%get_phs_config (i))
	class is (phs_wood_config_t)
	call phs_config%extract_resonance_history_set (res_set, include_trivial)
	class default
	call msg_error ("process '" // char (process%get_id ()) &
	// "': extract resonance histories: phase-space method must be &
	&'wood'. No resonances can be determined.")
	end select
	end subroutine process_extract_resonance_history_set

	@ %def process_extract_resonance_history_set
	@ Initialize from a complete beam setup. If the beam setup does not
	apply directly to the process, choose a fallback option as a straight
	scattering or decay process.
	<<Process: process: TBP>>=
	procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure
	<<Process: procedures>>=
	subroutine process_setup_beams_beam_structure &
	(process, beam_structure, sqrts, decay_rest_frame)
	class(process_t), intent(inout) :: process
	type(beam_structure_t), intent(in) :: beam_structure
	real(default), intent(in) :: sqrts
	logical, intent(in), optional :: decay_rest_frame
	integer :: n_in
	logical :: applies
	n_in = process%get_n_in ()
	call beam_structure%check_against_n_in (process%get_n_in (), applies)
	if (applies) then
	call process%beam_config%init_beam_structure &
	(beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame)
	else if (n_in == 2) then
	call process%setup_beams_sqrts (sqrts, beam_structure)
	else
	call process%setup_beams_decay (decay_rest_frame, beam_structure)
	end if
	end subroutine process_setup_beams_beam_structure

	@ %def process_setup_beams_beam_structure
	@ Notify the user about beam setup.
	<<Process: process: TBP>>=
	procedure :: beams_startup_message => process_beams_startup_message
	<<Process: procedures>>=
	subroutine process_beams_startup_message (process, unit, beam_structure)
	class(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	type(beam_structure_t), intent(in), optional :: beam_structure
	call process%beam_config%startup_message (unit, beam_structure)
	end subroutine process_beams_startup_message

	@ %def process_beams_startup_message
	@ Initialize phase-space configuration by reading out the environment
	variables. We return the rebuild flags and store parameters in the blocks
	[[phs_par]] and [[mapping_defs]].

	The phase-space configuration object(s) are allocated by [[pcm]].
	<<Process: process: TBP>>=
	procedure :: init_phs_config => process_init_phs_config
	<<Process: procedures>>=
	subroutine process_init_phs_config (process)
	class(process_t), intent(inout) :: process

	type(var_list_t), pointer :: var_list
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defs

	var_list => process%env%get_var_list_ptr ()

	phs_par%m_threshold_s = &
	var_list%get_rval (var_str ("phs_threshold_s"))
	phs_par%m_threshold_t = &
	var_list%get_rval (var_str ("phs_threshold_t"))
	phs_par%off_shell = &
	var_list%get_ival (var_str ("phs_off_shell"))
	phs_par%keep_nonresonant = &
	var_list%get_lval (var_str ("?phs_keep_nonresonant"))
	phs_par%t_channel = &
	var_list%get_ival (var_str ("phs_t_channel"))

	mapping_defs%energy_scale = &
	var_list%get_rval (var_str ("phs_e_scale"))
	mapping_defs%invariant_mass_scale = &
	var_list%get_rval (var_str ("phs_m_scale"))
	mapping_defs%momentum_transfer_scale = &
	var_list%get_rval (var_str ("phs_q_scale"))
	mapping_defs%step_mapping = &
	var_list%get_lval (var_str ("?phs_step_mapping"))
	mapping_defs%step_mapping_exp = &
	var_list%get_lval (var_str ("?phs_step_mapping_exp"))
	mapping_defs%enable_s_mapping = &
	var_list%get_lval (var_str ("?phs_s_mapping"))

	associate (pcm => process%pcm)
	call pcm%init_phs_config (process%phs_entry, &
	process%meta, process%env, phs_par, mapping_defs)
	end associate

	end subroutine process_init_phs_config

	@ %def process_init_phs_config
	@ We complete the kinematics configuration after the beam setup, but before we
	configure the chain of structure functions. The reason is that we need the
	total energy [[sqrts]] for the kinematics, but the structure-function setup
	requires the number of channels, which depends on the kinematics
	configuration. For instance, the kinematics module may return the need for
	parameterizing an s-channel resonance.
	<<Process: process: TBP>>=
	procedure :: configure_phs => process_configure_phs
	<<Process: procedures>>=
	subroutine process_configure_phs (process, rebuild, ignore_mismatch, &
	combined_integration, subdir)
	class(process_t), intent(inout) :: process
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	logical, intent(in), optional :: combined_integration
	type(string_t), intent(in), optional :: subdir
	real(default) :: sqrts
	integer :: i, i_born, nlo_type
	class(phs_config_t), pointer :: phs_config_born
	sqrts = process%get_sqrts ()
	do i = 1, process%meta%n_components
	associate (component => process%component(i))
	if (component%active) then
	select type (pcm => process%pcm)
	type is (pcm_default_t)
	call component%configure_phs (sqrts, process%beam_config, &
	rebuild, ignore_mismatch, subdir)
	class is (pcm_nlo_t)
	nlo_type = component%config%get_nlo_type ()
	select case (nlo_type)
	case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
	call component%configure_phs (sqrts, process%beam_config, &
	rebuild, ignore_mismatch, subdir)
	call check_and_extend_phs (component)
	case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
	i_born = component%config%get_associated_born ()
	if (component%component_type /= COMP_REAL_FIN) &
	call check_and_extend_phs (component)
	call process%component(i_born)%get_phs_config &
	(phs_config_born)
	select type (config => component%phs_config)
	type is (phs_fks_config_t)
	select type (phs_config_born)
	type is (phs_wood_config_t)
	config%md5sum_born_config = &
	phs_config_born%md5sum_phs_config
	call config%set_born_config (phs_config_born)
	call config%set_mode (component%config%get_nlo_type ())
	end select
	end select
	call component%configure_phs (sqrts, &
	process%beam_config, rebuild, ignore_mismatch, subdir)
	end select
	class default
	call msg_bug ("process_configure_phs: unsupported PCM type")
	end select
	end if
	end associate
	end do
	contains
	subroutine check_and_extend_phs (component)
	type(process_component_t), intent(inout) :: component
	if (combined_integration) then
	select type (phs_config => component%phs_config)
	class is (phs_wood_config_t)
	phs_config%is_combined_integration = .true.
	call phs_config%increase_n_par ()
	end select
	end if
	end subroutine check_and_extend_phs
	end subroutine process_configure_phs

	@ %def process_configure_phs
	@
	<<Process: process: TBP>>=
	procedure :: print_phs_startup_message => process_print_phs_startup_message
	<<Process: procedures>>=
	subroutine process_print_phs_startup_message (process)
	class(process_t), intent(in) :: process
	integer :: i_component
	do i_component = 1, process%meta%n_components
	associate (component => process%component(i_component))
	if (component%active) then
	call component%phs_config%startup_message ()
	end if
	end associate
	end do
	end subroutine process_print_phs_startup_message

	@ %def process_print_phs_startup_message
	@ Insert the structure-function configuration data. First allocate the
	storage, then insert data one by one. The third procedure declares a
	mapping (of the MC input parameters) for a specific channel and
	structure-function combination.

	We take the number of channels from the corresponding entry in the
	[[config_data]] section.

	Otherwise, these a simple wrapper routines. The extra level in the
	call tree may allow for simple addressing of multiple concurrent beam
	configurations, not implemented currently.

	If we do not want structure functions, we simply do not call those procedures.
	<<Process: process: TBP>>=
	procedure :: init_sf_chain => process_init_sf_chain
	generic :: set_sf_channel => set_sf_channel_single
	procedure :: set_sf_channel_single => process_set_sf_channel
	generic :: set_sf_channel => set_sf_channel_array
	procedure :: set_sf_channel_array => process_set_sf_channel_array
	<<Process: procedures>>=
	subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
	class(process_t), intent(inout) :: process
	type(sf_config_t), dimension(:), intent(in) :: sf_config
	type(string_t), intent(in), optional :: sf_trace_file
	type(string_t) :: file
	if (present (sf_trace_file)) then
	if (sf_trace_file /= "") then
	file = sf_trace_file
	else
	file = process%get_id () // "_sftrace.dat"
	end if
	call process%beam_config%init_sf_chain (sf_config, file)
	else
	call process%beam_config%init_sf_chain (sf_config)
	end if
	end subroutine process_init_sf_chain

	subroutine process_set_sf_channel (process, c, sf_channel)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: c
	type(sf_channel_t), intent(in) :: sf_channel
	call process%beam_config%set_sf_channel (c, sf_channel)
	end subroutine process_set_sf_channel

	subroutine process_set_sf_channel_array (process, sf_channel)
	class(process_t), intent(inout) :: process
	type(sf_channel_t), dimension(:), intent(in) :: sf_channel
	integer :: c
	call process%beam_config%allocate_sf_channels (size (sf_channel))
	do c = 1, size (sf_channel)
	call process%beam_config%set_sf_channel (c, sf_channel(c))
	end do
	end subroutine process_set_sf_channel_array

	@ %def process_init_sf_chain
	@ %def process_set_sf_channel
	@ Notify about the structure-function setup.
	<<Process: process: TBP>>=
	procedure :: sf_startup_message => process_sf_startup_message
	<<Process: procedures>>=
	subroutine process_sf_startup_message (process, sf_string, unit)
	class(process_t), intent(in) :: process
	type(string_t), intent(in) :: sf_string
	integer, intent(in), optional :: unit
	call process%beam_config%sf_startup_message (sf_string, unit)
	end subroutine process_sf_startup_message

	@ %def process_sf_startup_message
	@ As soon as both the kinematics configuration and the
	structure-function setup are complete, we match parameterizations
	(channels) for both. The matching entries are (re)set in the
	[[component]] phase-space configuration, while the structure-function
	configuration is left intact.
	<<Process: process: TBP>>=
	procedure :: collect_channels => process_collect_channels
	<<Process: procedures>>=
	subroutine process_collect_channels (process, coll)
	class(process_t), intent(inout) :: process
	type(phs_channel_collection_t), intent(inout) :: coll
	integer :: i
	do i = 1, process%meta%n_components
	associate (component => process%component(i))
	if (component%active) &
	call component%collect_channels (coll)
	end associate
	end do
	end subroutine process_collect_channels

	@ %def process_collect_channels
	@ Independently, we should be able to check if any component does not
	contain phase-space parameters. Such a process can only be integrated
	if there are structure functions.
	<<Process: process: TBP>>=
	procedure :: contains_trivial_component => process_contains_trivial_component
	<<Process: procedures>>=
	function process_contains_trivial_component (process) result (flag)
	class(process_t), intent(in) :: process
	logical :: flag
	integer :: i
	flag = .true.
	do i = 1, process%meta%n_components
	associate (component => process%component(i))
	if (component%active) then
	if (component%get_n_phs_par () == 0) return
	end if
	end associate
	end do
	flag = .false.
	end function process_contains_trivial_component

	@ %def process_contains_trivial_component
	@
	<<Process: process: TBP>>=
	procedure :: get_master_component => process_get_master_component
	<<Process: procedures>>=
	function process_get_master_component (process, i_mci) result (i_component)
	integer :: i_component
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	integer :: i
	i_component = 0
	do i = 1, size (process%component)
	if (process%component(i)%i_mci == i_mci) then
	i_component = i
	return
	end if
	end do
	end function process_get_master_component


	@ %def process_get_master_component
	@ Determine the MC parameter set structure and the MCI configuration for each
	process component. We need data from the structure-function and phase-space
	setup, so those should be complete before this is called. We also
	make a random-number generator instance for each MCI group.
	<<Process: process: TBP>>=
	procedure :: setup_mci => process_setup_mci
	<<Process: procedures>>=
	subroutine process_setup_mci (process, dispatch_mci)
	class(process_t), intent(inout) :: process
	procedure(dispatch_mci_proc) :: dispatch_mci
	class(mci_t), allocatable :: mci_template
	integer :: i, i_mci
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci")
	associate (pcm => process%pcm)
	call pcm%call_dispatch_mci (dispatch_mci, &
	process%get_var_list_ptr (), process%meta%id, mci_template)
	call pcm%setup_mci (process%mci_entry)
	process%config%n_mci = pcm%n_mci
	process%component(:)%i_mci = pcm%i_mci(:)
	do i = 1, pcm%n_components
	i_mci = process%pcm%i_mci(i)
	if (i_mci > 0) then
	associate (component => process%component(i), &
	mci_entry => process%mci_entry(i_mci))
	call mci_entry%configure (mci_template, &
	process%meta%type, &
	i_mci, i, component, process%beam_config%n_sfpar, &
	process%rng_factory)
	call mci_entry%set_parameters (process%get_var_list_ptr ())
	end associate
	end if
	end do
	end associate
	end subroutine process_setup_mci

	@ %def process_setup_mci
	@ Set cuts. This is a parse node, namely the right-hand side of the [[cut]]
	assignment. When creating an instance, we compile this into an evaluation
	tree. The parse node may be null.
	<<Process: process: TBP>>=
	procedure :: set_cuts => process_set_cuts
	<<Process: procedures>>=
	subroutine process_set_cuts (process, ef_cuts)
	class(process_t), intent(inout) :: process
	class(expr_factory_t), intent(in) :: ef_cuts
	allocate (process%config%ef_cuts, source = ef_cuts)
	end subroutine process_set_cuts

	@ %def process_set_cuts
	@ Analogously for the other expressions.
	<<Process: process: TBP>>=
	procedure :: set_scale => process_set_scale
	procedure :: set_fac_scale => process_set_fac_scale
	procedure :: set_ren_scale => process_set_ren_scale
	procedure :: set_weight => process_set_weight
	<<Process: procedures>>=
	subroutine process_set_scale (process, ef_scale)
	class(process_t), intent(inout) :: process
	class(expr_factory_t), intent(in) :: ef_scale
	allocate (process%config%ef_scale, source = ef_scale)
	end subroutine process_set_scale

	subroutine process_set_fac_scale (process, ef_fac_scale)
	class(process_t), intent(inout) :: process
	class(expr_factory_t), intent(in) :: ef_fac_scale
	allocate (process%config%ef_fac_scale, source = ef_fac_scale)
	end subroutine process_set_fac_scale

	subroutine process_set_ren_scale (process, ef_ren_scale)
	class(process_t), intent(inout) :: process
	class(expr_factory_t), intent(in) :: ef_ren_scale
	allocate (process%config%ef_ren_scale, source = ef_ren_scale)
	end subroutine process_set_ren_scale

	subroutine process_set_weight (process, ef_weight)
	class(process_t), intent(inout) :: process
	class(expr_factory_t), intent(in) :: ef_weight
	allocate (process%config%ef_weight, source = ef_weight)
	end subroutine process_set_weight

	@ %def process_set_scale
	@ %def process_set_fac_scale
	@ %def process_set_ren_scale
	@ %def process_set_weight
	@
	\subsubsection{MD5 sum}
	The MD5 sum of the process object should reflect the state completely,
	including integration results. It is used for checking the integrity
	of event files. This global checksum includes checksums for the
	various parts. In particular, the MCI object receives a checksum that
	includes the configuration of all configuration parts relevant for an
	individual integration. This checksum is used for checking the
	integrity of integration grids.

	We do not need MD5 sums for the process terms, since these are
	generated from the component definitions.
	<<Process: process: TBP>>=
	procedure :: compute_md5sum => process_compute_md5sum
	<<Process: procedures>>=
	subroutine process_compute_md5sum (process)
	class(process_t), intent(inout) :: process
	integer :: i
	call process%config%compute_md5sum ()
	do i = 1, process%config%n_components
	associate (component => process%component(i))
	if (component%active) then
	call component%compute_md5sum ()
	end if
	end associate
	end do
	call process%beam_config%compute_md5sum ()
	do i = 1, process%config%n_mci
	call process%mci_entry(i)%compute_md5sum &
	(process%config, process%component, process%beam_config)
	end do
	end subroutine process_compute_md5sum

	@ %def process_compute_md5sum
	@
	<<Process: process: TBP>>=
	procedure :: sampler_test => process_sampler_test
	<<Process: procedures>>=
	subroutine process_sampler_test (process, sampler, n_calls, i_mci)
	class(process_t), intent(inout) :: process
	class(mci_sampler_t), intent(inout) :: sampler
	integer, intent(in) :: n_calls, i_mci
	call process%mci_entry(i_mci)%sampler_test (sampler, n_calls)
	end subroutine process_sampler_test

	@ %def process_sampler_test
	@ The finalizer should be called after all integration passes have been
	completed. It will, for instance, write a summary of the integration
	results.

	[[integrate_dummy]] does a ``dummy'' integration in the sense that
	nothing is done but just empty integration results appended.
	<<Process: process: TBP>>=
	procedure :: final_integration => process_final_integration
	procedure :: integrate_dummy => process_integrate_dummy
	<<Process: procedures>>=
	subroutine process_final_integration (process, i_mci)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	call process%mci_entry(i_mci)%final_integration ()
	end subroutine process_final_integration

	subroutine process_integrate_dummy (process)
	class(process_t), intent(inout) :: process
	type(integration_results_t) :: results
	integer :: u_log
	u_log = logfile_unit ()
	call results%init (process%meta%type)
	call results%display_init (screen = .true., unit = u_log)
	call results%new_pass ()
	call results%record (1, 0, 0._default, 0._default, 0._default)
	call results%display_final ()
	end subroutine process_integrate_dummy

	@ %def process_final_integration
	@ %def process_integrate_dummy
	@
	<<Process: process: TBP>>=
	procedure :: integrate => process_integrate
	<<Process: procedures>>=
	subroutine process_integrate (process, i_mci, mci_work, &
	mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, &
	pacify, nlo_type)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(mci_work_t), intent(inout) :: mci_work
	class(mci_sampler_t), intent(inout) :: mci_sampler
	integer, intent(in) :: n_it, n_calls
	logical, intent(in), optional :: adapt_grids, adapt_weights
	logical, intent(in), optional :: final
	logical, intent(in), optional :: pacify
	integer, intent(in), optional :: nlo_type
	associate (mci_entry => process%mci_entry(i_mci))
	call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, &
	adapt_grids, adapt_weights, final, pacify, &
	nlo_type = nlo_type)
	call mci_entry%results%display_pass (pacify)
	end associate
	end subroutine process_integrate

	@ %def process_integrate
	@
	<<Process: process: TBP>>=
	procedure :: generate_weighted_event => process_generate_weighted_event
	<<Process: procedures>>=
	subroutine process_generate_weighted_event (process, i_mci, mci_work, &
	mci_sampler, keep_failed_events)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(mci_work_t), intent(inout) :: mci_work
	class(mci_sampler_t), intent(inout) :: mci_sampler
	logical, intent(in) :: keep_failed_events
	associate (mci_entry => process%mci_entry(i_mci))
	call mci_entry%generate_weighted_event (mci_work%mci, &
	mci_sampler, keep_failed_events)
	end associate
	end subroutine process_generate_weighted_event

	@ %def process_generate_weighted_event
	<<Process: process: TBP>>=
	procedure :: generate_unweighted_event => process_generate_unweighted_event
	<<Process: procedures>>=
	subroutine process_generate_unweighted_event (process, i_mci, &
	mci_work, mci_sampler)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(mci_work_t), intent(inout) :: mci_work
	class(mci_sampler_t), intent(inout) :: mci_sampler
	associate (mci_entry => process%mci_entry(i_mci))
	call mci_entry%generate_unweighted_event &
	(mci_work%mci, mci_sampler)
	end associate
	end subroutine process_generate_unweighted_event

	@ %def process_generate_unweighted_event
	@ Display the final results for the sum of all components. This is useful,
	obviously, only if there is more than one component and not if a combined
	integration of all components together has been performed.
	<<Process: process: TBP>>=
	procedure :: display_summed_results => process_display_summed_results
	<<Process: procedures>>=
	subroutine process_display_summed_results (process, pacify)
	class(process_t), intent(inout) :: process
	logical, intent(in) :: pacify
	type(integration_results_t) :: results
	integer :: u_log
	u_log = logfile_unit ()
	call results%init (process%meta%type)
	call results%display_init (screen = .true., unit = u_log)
	call results%new_pass ()
	call results%record (1, 0, &
	process%get_integral (), &
	process%get_error (), &
	process%get_efficiency (), suppress = pacify)
	select type (pcm => process%pcm)
	class is (pcm_nlo_t)
	!!! Check that Born integral is there
	if (.not. pcm%settings%combined_integration .and. &
	process%component_can_be_integrated (1)) then
	call results%record_correction (process%get_correction (), &
	process%get_correction_error ())
	end if
	end select
	call results%display_final ()
	end subroutine process_display_summed_results

	@ %def process_display_summed_results
	@ Run LaTeX/Metapost to generate a ps/pdf file for the integration
	history. We (re)write the driver file -- just in case it has been
	missed before -- then we compile it.
	<<Process: process: TBP>>=
	procedure :: display_integration_history => &
	process_display_integration_history
	<<Process: procedures>>=
	subroutine process_display_integration_history &
	(process, i_mci, filename, os_data, eff_reset)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(string_t), intent(in) :: filename
	type(os_data_t), intent(in) :: os_data
	logical, intent(in), optional :: eff_reset
	call integration_results_write_driver &
	(process%mci_entry(i_mci)%results, filename, eff_reset)
	call integration_results_compile_driver &
	(process%mci_entry(i_mci)%results, filename, os_data)
	end subroutine process_display_integration_history

	@ %def subroutine process_display_integration_history
	@ Write a complete logfile (with hardcoded name based on the process ID).
	We do not write internal data.
	<<Process: process: TBP>>=
	procedure :: write_logfile => process_write_logfile
	<<Process: procedures>>=
	subroutine process_write_logfile (process, i_mci, filename)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(string_t), intent(in) :: filename
	type(time_t) :: time
	integer :: unit, u
	unit = free_unit ()
	open (unit = unit, file = char (filename), action = "write", &
	status = "replace")
	u = given_output_unit (unit)
	write (u, "(A)") repeat ("#", 79)
	call process%meta%write (u, .false.)
	write (u, "(A)") repeat ("#", 79)
	write (u, "(3x,A,ES17.10)") "Integral = ", &
	process%mci_entry(i_mci)%get_integral ()
	write (u, "(3x,A,ES17.10)") "Error = ", &
	process%mci_entry(i_mci)%get_error ()
	write (u, "(3x,A,ES17.10)") "Accuracy = ", &
	process%mci_entry(i_mci)%get_accuracy ()
	write (u, "(3x,A,ES17.10)") "Chi2 = ", &
	process%mci_entry(i_mci)%get_chi2 ()
	write (u, "(3x,A,ES17.10)") "Efficiency = ", &
	process%mci_entry(i_mci)%get_efficiency ()
	call process%mci_entry(i_mci)%get_time (time, 10000)
	if (time%is_known ()) then
	write (u, "(3x,A,1x,A)") "T(10k evt) = ", char (time%to_string_dhms ())
	else
	write (u, "(3x,A)") "T(10k evt) = [undefined]"
	end if
	call process%mci_entry(i_mci)%results%write (u)
	write (u, "(A)") repeat ("#", 79)
	call process%mci_entry(i_mci)%results%write_chain_weights (u)
	write (u, "(A)") repeat ("#", 79)
	call process%mci_entry(i_mci)%counter%write (u)
	write (u, "(A)") repeat ("#", 79)
	call process%mci_entry(i_mci)%mci%write_log_entry (u)
	write (u, "(A)") repeat ("#", 79)
	call process%beam_config%data%write (u)
	write (u, "(A)") repeat ("#", 79)
	if (allocated (process%config%ef_cuts)) then
	write (u, "(3x,A)") "Cut expression:"
	call process%config%ef_cuts%write (u)
	else
	write (u, "(3x,A)") "No cuts used."
	end if
	call write_separator (u)
	if (allocated (process%config%ef_scale)) then
	write (u, "(3x,A)") "Scale expression:"
	call process%config%ef_scale%write (u)
	else
	write (u, "(3x,A)") "No scale expression was given."
	end if
	call write_separator (u)
	if (allocated (process%config%ef_fac_scale)) then
	write (u, "(3x,A)") "Factorization scale expression:"
	call process%config%ef_fac_scale%write (u)
	else
	write (u, "(3x,A)") "No factorization scale expression was given."
	end if
	call write_separator (u)
	if (allocated (process%config%ef_ren_scale)) then
	write (u, "(3x,A)") "Renormalization scale expression:"
	call process%config%ef_ren_scale%write (u)
	else
	write (u, "(3x,A)") "No renormalization scale expression was given."
	end if
	call write_separator (u)
	if (allocated (process%config%ef_weight)) then
	call write_separator (u)
	write (u, "(3x,A)") "Weight expression:"
	call process%config%ef_weight%write (u)
	else
	write (u, "(3x,A)") "No weight expression was given."
	end if
	write (u, "(A)") repeat ("#", 79)
	write (u, "(1x,A)") "Summary of quantum-number states:"
	write (u, "(1x,A)") " + sign: allowed and contributing"
	write (u, "(1x,A)") " no + : switched off at runtime"
	call process%write_state_summary (u)
	write (u, "(A)") repeat ("#", 79)
	call process%env%write (u, show_var_list=.true., &
	show_model=.false., show_lib=.false., show_os_data=.false.)
	write (u, "(A)") repeat ("#", 79)
	close (u)
	end subroutine process_write_logfile

	@ %def process_write_logfile
	@ Display the quantum-number combinations of the process components, and their
	current status (allowed or switched off).
	<<Process: process: TBP>>=
	procedure :: write_state_summary => process_write_state_summary
	<<Process: procedures>>=
	subroutine process_write_state_summary (process, unit)
	class(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	integer :: i, i_component, u
	u = given_output_unit (unit)
	do i = 1, size (process%term)
	call write_separator (u)
	i_component = process%term(i)%i_component
	if (i_component /= 0) then
	call process%term(i)%write_state_summary &
	(process%get_core_term(i), unit)
	end if
	end do
	end subroutine process_write_state_summary

	@ %def process_write_state_summary
	@ Prepare event generation for the specified MCI entry. This implies, in
	particular, checking the phase-space file.
	<<Process: process: TBP>>=
	procedure :: prepare_simulation => process_prepare_simulation
	<<Process: procedures>>=
	subroutine process_prepare_simulation (process, i_mci)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	call process%mci_entry(i_mci)%prepare_simulation ()
	end subroutine process_prepare_simulation

	@ %def process_prepare_simulation
	@
	\subsubsection{Retrieve process data}
	Tell whether integral (and error) are known.
	<<Process: process: TBP>>=
	generic :: has_integral => has_integral_tot, has_integral_mci
	procedure :: has_integral_tot => process_has_integral_tot
	procedure :: has_integral_mci => process_has_integral_mci
	<<Process: procedures>>=
	function process_has_integral_mci (process, i_mci) result (flag)
	logical :: flag
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	if (allocated (process%mci_entry)) then
	flag = process%mci_entry(i_mci)%has_integral ()
	else
	flag = .false.
	end if
	end function process_has_integral_mci

	function process_has_integral_tot (process) result (flag)
	logical :: flag
	class(process_t), intent(in) :: process
	integer :: i, j, i_component
	if (allocated (process%mci_entry)) then
	flag = .true.
	do i = 1, size (process%mci_entry)
	do j = 1, size (process%mci_entry(i)%i_component)
	i_component = process%mci_entry(i)%i_component(j)
	if (process%component_can_be_integrated (i_component)) &
	flag = flag .and. process%mci_entry(i)%has_integral ()
	end do
	end do
	else
	flag = .false.
	end if
	end function process_has_integral_tot

	@ %def process_has_integral
	@
	Return the current integral and error obtained by the integrator [[i_mci]].
	<<Process: process: TBP>>=
	generic :: get_integral => get_integral_tot, get_integral_mci
	generic :: get_error => get_error_tot, get_error_mci
	generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci
	procedure :: get_integral_tot => process_get_integral_tot
	procedure :: get_integral_mci => process_get_integral_mci
	procedure :: get_error_tot => process_get_error_tot
	procedure :: get_error_mci => process_get_error_mci
	procedure :: get_efficiency_tot => process_get_efficiency_tot
	procedure :: get_efficiency_mci => process_get_efficiency_mci
	<<Process: procedures>>=
	function process_get_integral_mci (process, i_mci) result (integral)
	real(default) :: integral
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	integral = process%mci_entry(i_mci)%get_integral ()
	end function process_get_integral_mci

	function process_get_error_mci (process, i_mci) result (error)
	real(default) :: error
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	error = process%mci_entry(i_mci)%get_error ()
	end function process_get_error_mci

	function process_get_efficiency_mci (process, i_mci) result (efficiency)
	real(default) :: efficiency
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	efficiency = process%mci_entry(i_mci)%get_efficiency ()
	end function process_get_efficiency_mci

	function process_get_integral_tot (process) result (integral)
	real(default) :: integral
	class(process_t), intent(in) :: process
	integer :: i, j, i_component
	integral = zero
	if (allocated (process%mci_entry)) then
	do i = 1, size (process%mci_entry)
	do j = 1, size (process%mci_entry(i)%i_component)
	i_component = process%mci_entry(i)%i_component(j)
	if (process%component_can_be_integrated(i_component)) &
	integral = integral + process%mci_entry(i)%get_integral ()
	end do
	end do
	end if
	end function process_get_integral_tot

	function process_get_error_tot (process) result (error)
	real(default) :: variance
	class(process_t), intent(in) :: process
	real(default) :: error
	integer :: i, j, i_component
	variance = zero
	if (allocated (process%mci_entry)) then
	do i = 1, size (process%mci_entry)
	do j = 1, size (process%mci_entry(i)%i_component)
	i_component = process%mci_entry(i)%i_component(j)
	if (process%component_can_be_integrated(i_component)) &
	variance = variance + process%mci_entry(i)%get_error () ** 2
	end do
	end do
	end if
	error = sqrt (variance)
	end function process_get_error_tot

	function process_get_efficiency_tot (process) result (efficiency)
	real(default) :: efficiency
	class(process_t), intent(in) :: process
	real(default) :: den, eff, int
	integer :: i, j, i_component
	den = zero
	if (allocated (process%mci_entry)) then
	do i = 1, size (process%mci_entry)
	do j = 1, size (process%mci_entry(i)%i_component)
	i_component = process%mci_entry(i)%i_component(j)
	if (process%component_can_be_integrated(i_component)) then
	int = process%get_integral (i)
	if (int > 0) then
	eff = process%mci_entry(i)%get_efficiency ()
	if (eff > 0) then
	den = den + int / eff
	else
	efficiency = 0
	return
	end if
	end if
	end if
	end do
	end do
	end if
	if (den > 0) then
	efficiency = process%get_integral () / den
	else
	efficiency = 0
	end if
	end function process_get_efficiency_tot

	@ %def process_get_integral process_get_efficiency
	@ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO} / I_{LO}$. Then
	usual error propagation gives
	\begin{equation*}
	\sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2
	+ \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2
	= \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}.
	\end{equation*}
	<<Process: process: TBP>>=
	procedure :: get_correction => process_get_correction
	procedure :: get_correction_error => process_get_correction_error
	<<Process: procedures>>=
	function process_get_correction (process) result (ratio)
	real(default) :: ratio
	class(process_t), intent(in) :: process
	integer :: i_mci, i_component
	real(default) :: int_born, int_nlo
	int_nlo = zero
	int_born = process%mci_entry(1)%get_integral ()
	i_mci = 2
	do i_component = 2, size (process%component)
	if (process%component_can_be_integrated (i_component)) then
	int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
	i_mci = i_mci + 1
	end if
	end do
	ratio = int_nlo / int_born * 100
	end function process_get_correction

	function process_get_correction_error (process) result (error)
	real(default) :: error
	class(process_t), intent(in) :: process
	real(default) :: int_born, sum_int_nlo
	real(default) :: err_born, err2
	integer :: i_mci, i_component
	sum_int_nlo = zero; err2 = zero
	int_born = process%mci_entry(1)%get_integral ()
	err_born = process%mci_entry(1)%get_error ()
	i_mci = 2
	do i_component = 2, size (process%component)
	if (process%component_can_be_integrated (i_component)) then
	sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
	err2 = err2 + process%mci_entry(i_mci)%get_error()**2
	i_mci = i_mci + 1
	end if
	end do
	error = sqrt (err2 / int_born2 + sum_int_nlo2 * err_born2 / int_born4) * 100
	end function process_get_correction_error

	@ %def process_get_correction process_get_correction_error
	@
	<<Process: process: TBP>>=
	procedure :: lab_is_cm => process_lab_is_cm
	<<Process: procedures>>=
	pure function process_lab_is_cm (process) result (lab_is_cm)
	logical :: lab_is_cm
	class(process_t), intent(in) :: process
	lab_is_cm = process%beam_config%lab_is_cm
	! This asks beam_config for the frame
	end function process_lab_is_cm

	@ %def process_lab_is_cm
	@
	<<Process: process: TBP>>=
	procedure :: get_component_ptr => process_get_component_ptr
	<<Process: procedures>>=
	function process_get_component_ptr (process, i) result (component)
	type(process_component_t), pointer :: component
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i
	component => process%component(i)
	end function process_get_component_ptr

	@ %def process_get_component_ptr
	@
	<<Process: process: TBP>>=
	procedure :: get_qcd => process_get_qcd
	<<Process: procedures>>=
	function process_get_qcd (process) result (qcd)
	type(qcd_t) :: qcd
	class(process_t), intent(in) :: process
	qcd = process%config%get_qcd ()
	end function process_get_qcd

	@ %def process_get_qcd
	@
	<<Process: process: TBP>>=
	generic :: get_component_type => get_component_type_single
	procedure :: get_component_type_single => process_get_component_type_single
	<<Process: procedures>>=
	elemental function process_get_component_type_single &
	(process, i_component) result (comp_type)
	integer :: comp_type
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	comp_type = process%component(i_component)%component_type
	end function process_get_component_type_single

	@ %def process_get_component_type_single
	@
	<<Process: process: TBP>>=
	generic :: get_component_type => get_component_type_all
	procedure :: get_component_type_all => process_get_component_type_all
	<<Process: procedures>>=
	function process_get_component_type_all &
	(process) result (comp_type)
	integer, dimension(:), allocatable :: comp_type
	class(process_t), intent(in) :: process
	allocate (comp_type (size (process%component)))
	comp_type = process%component%component_type
	end function process_get_component_type_all

	@ %def process_get_component_type_all
	@
	<<Process: process: TBP>>=
	procedure :: get_component_i_terms => process_get_component_i_terms
	<<Process: procedures>>=
	function process_get_component_i_terms (process, i_component) result (i_term)
	integer, dimension(:), allocatable :: i_term
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	allocate (i_term (size (process%component(i_component)%i_term)))
	i_term = process%component(i_component)%i_term
	end function process_get_component_i_terms

	@ %def process_get_component_i_terms
	@
	<<Process: process: TBP>>=
	procedure :: get_n_allowed_born => process_get_n_allowed_born
	<<Process: procedures>>=
	function process_get_n_allowed_born (process, i_born) result (n_born)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_born
	integer :: n_born
	n_born = process%term(i_born)%n_allowed
	end function process_get_n_allowed_born

	@ %def process_get_n_allowed_born
	@ Workaround getter. Would be better to remove this.
	<<Process: process: TBP>>=
	procedure :: get_pcm_ptr => process_get_pcm_ptr
	<<Process: procedures>>=
	function process_get_pcm_ptr (process) result (pcm)
	class(pcm_t), pointer :: pcm
	class(process_t), intent(in), target :: process
	pcm => process%pcm
	end function process_get_pcm_ptr

	@ %def process_get_pcm_ptr
	<<Process: process: TBP>>=
	generic :: component_can_be_integrated => component_can_be_integrated_single
	generic :: component_can_be_integrated => component_can_be_integrated_all
	procedure :: component_can_be_integrated_single => process_component_can_be_integrated_single
	<<Process: procedures>>=
	function process_component_can_be_integrated_single (process, i_component) &
	result (active)
	logical :: active
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	logical :: combined_integration
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	combined_integration = pcm%settings%combined_integration
	class default
	combined_integration = .false.
	end select
	associate (component => process%component(i_component))
	active = component%can_be_integrated ()
	if (combined_integration) &
	active = active .and. component%component_type <= COMP_MASTER
	end associate
	end function process_component_can_be_integrated_single

	@ %def process_component_can_be_integrated_single
	@
	<<Process: process: TBP>>=
	procedure :: component_can_be_integrated_all => process_component_can_be_integrated_all
	<<Process: procedures>>=
	function process_component_can_be_integrated_all (process) result (val)
	logical, dimension(:), allocatable :: val
	class(process_t), intent(in) :: process
	integer :: i
	allocate (val (size (process%component)))
	do i = 1, size (process%component)
	val(i) = process%component_can_be_integrated (i)
	end do
	end function process_component_can_be_integrated_all

	@ %def process_component_can_be_integrated_all
	@
	<<Process: process: TBP>>=
	procedure :: reset_selected_cores => process_reset_selected_cores
	<<Process: procedures>>=
	pure subroutine process_reset_selected_cores (process)
	class(process_t), intent(inout) :: process
	process%pcm%component_selected = .false.
	end subroutine process_reset_selected_cores

	@ %def process_reset_selected_cores
	@
	<<Process: process: TBP>>=
	procedure :: select_components => process_select_components
	<<Process: procedures>>=
	pure subroutine process_select_components (process, indices)
	class(process_t), intent(inout) :: process
	integer, dimension(:), intent(in) :: indices
	associate (pcm => process%pcm)
	pcm%component_selected(indices) = .true.
	end associate
	end subroutine process_select_components

	@ %def process_select_components
	@
	<<Process: process: TBP>>=
	procedure :: component_is_selected => process_component_is_selected
	<<Process: procedures>>=
	pure function process_component_is_selected (process, index) result (val)
	logical :: val
	class(process_t), intent(in) :: process
	integer, intent(in) :: index
	associate (pcm => process%pcm)
	val = pcm%component_selected(index)
	end associate
	end function process_component_is_selected

	@ %def process_component_is_selected
	@
	<<Process: process: TBP>>=
	procedure :: get_coupling_powers => process_get_coupling_powers
	<<Process: procedures>>=
	pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power)
	class(process_t), intent(in) :: process
	integer, intent(out) :: alpha_power, alphas_power
	call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power)
	end subroutine process_get_coupling_powers

	@ %def process_get_coupling_powers
	@
	<<Process: process: TBP>>=
	procedure :: get_real_component => process_get_real_component
	<<Process: procedures>>=
	function process_get_real_component (process) result (i_real)
	integer :: i_real
	class(process_t), intent(in) :: process
	integer :: i_component
	type(process_component_def_t), pointer :: config => null ()
	i_real = 0
	do i_component = 1, size (process%component)
	config => process%get_component_def_ptr (i_component)
	if (config%get_nlo_type () == NLO_REAL) then
	i_real = i_component
	exit
	end if
	end do
	end function process_get_real_component

	@ %def process_get_real_component
	@
	<<Process: process: TBP>>=
	procedure :: extract_active_component_mci => process_extract_active_component_mci
	<<Process: procedures>>=
	function process_extract_active_component_mci (process) result (i_active)
	integer :: i_active
	class(process_t), intent(in) :: process
	integer :: i_mci, j, i_component, n_active
	call count_n_active ()
	if (n_active /= 1) i_active = 0
	contains
	subroutine count_n_active ()
	n_active = 0
	do i_mci = 1, size (process%mci_entry)
	associate (mci_entry => process%mci_entry(i_mci))
	do j = 1, size (mci_entry%i_component)
	i_component = mci_entry%i_component(j)
	associate (component => process%component (i_component))
	if (component%can_be_integrated ()) then
	i_active = i_mci
	n_active = n_active + 1
	end if
	end associate
	end do
	end associate
	end do
	end subroutine count_n_active
	end function process_extract_active_component_mci

	@ %def process_extract_active_component_mci
	@
	<<Process: process: TBP>>=
	procedure :: uses_real_partition => process_uses_real_partition
	<<Process: procedures>>=
	function process_uses_real_partition (process) result (val)
	logical :: val
	class(process_t), intent(in) :: process
	val = any (process%mci_entry%real_partition_type /= REAL_FULL)
	end function process_uses_real_partition

	@ %def process_uses_real_partition
	@ Return the MD5 sums that summarize the process component
	definitions. These values should be independent of parameters, beam
	details, expressions, etc. They can be used for checking the
	integrity of a process when reusing an old event file.
	<<Process: process: TBP>>=
	procedure :: get_md5sum_prc => process_get_md5sum_prc
	<<Process: procedures>>=
	function process_get_md5sum_prc (process, i_component) result (md5sum)
	character(32) :: md5sum
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	if (process%component(i_component)%active) then
	md5sum = process%component(i_component)%config%get_md5sum ()
	else
	md5sum = ""
	end if
	end function process_get_md5sum_prc

	@ %def process_get_md5sum_prc
	@ Return the MD5 sums that summarize the state of the MCI integrators.
	These values should encode all process data, integration and phase
	space configuration, etc., and the integration results. They can thus
	be used for checking the integrity of an event-generation setup when
	reusing an old event file.
	<<Process: process: TBP>>=
	procedure :: get_md5sum_mci => process_get_md5sum_mci
	<<Process: procedures>>=
	function process_get_md5sum_mci (process, i_mci) result (md5sum)
	character(32) :: md5sum
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	md5sum = process%mci_entry(i_mci)%get_md5sum ()
	end function process_get_md5sum_mci

	@ %def process_get_md5sum_mci
	@ Return the MD5 sum of the process configuration. This should encode
	the process setup, data, and expressions, but no integration results.
	<<Process: process: TBP>>=
	procedure :: get_md5sum_cfg => process_get_md5sum_cfg
	<<Process: procedures>>=
	function process_get_md5sum_cfg (process) result (md5sum)
	character(32) :: md5sum
	class(process_t), intent(in) :: process
	md5sum = process%config%md5sum
	end function process_get_md5sum_cfg

	@ %def process_get_md5sum_cfg
	@
	<<Process: process: TBP>>=
	procedure :: get_n_cores => process_get_n_cores
	<<Process: procedures>>=
	function process_get_n_cores (process) result (n)
	integer :: n
	class(process_t), intent(in) :: process
	n = process%pcm%n_cores
	end function process_get_n_cores

	@ %def process_get_n_cores
	@
	<<Process: process: TBP>>=
	procedure :: get_base_i_term => process_get_base_i_term
	<<Process: procedures>>=
	function process_get_base_i_term (process, i_component) result (i_term)
	integer :: i_term
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	i_term = process%component(i_component)%i_term(1)
	end function process_get_base_i_term

	@ %def process_get_base_i_term
	@
	<<Process: process: TBP>>=
	procedure :: get_core_term => process_get_core_term
	<<Process: procedures>>=
	function process_get_core_term (process, i_term) result (core)
	class(prc_core_t), pointer :: core
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_term
	integer :: i_core
	i_core = process%term(i_term)%i_core
	core => process%core_entry(i_core)%get_core_ptr ()
	end function process_get_core_term

	@ %def process_get_core_term
	@
	<<Process: process: TBP>>=
	procedure :: get_core_ptr => process_get_core_ptr
	<<Process: procedures>>=
	function process_get_core_ptr (process, i_core) result (core)
	class(prc_core_t), pointer :: core
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_core
	if (allocated (process%core_entry)) then
	core => process%core_entry(i_core)%get_core_ptr ()
	else
	core => null ()
	end if
	end function process_get_core_ptr

	@ %def process_get_core_ptr
	@
	<<Process: process: TBP>>=
	procedure :: get_term_ptr => process_get_term_ptr
	<<Process: procedures>>=
	function process_get_term_ptr (process, i) result (term)
	type(process_term_t), pointer :: term
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i
	term => process%term(i)
	end function process_get_term_ptr

	@ %def process_get_term_ptr
	@
	<<Process: process: TBP>>=
	procedure :: get_i_term => process_get_i_term
	<<Process: procedures>>=
	function process_get_i_term (process, i_core) result (i_term)
	integer :: i_term
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_core
	do i_term = 1, process%get_n_terms ()
	if (process%term(i_term)%i_core == i_core) return
	end do
	i_term = -1
	end function process_get_i_term

	@ %def process_get_i_term
	@
	<<Process: process: TBP>>=
	procedure :: get_i_core => process_get_i_core
	<<Process: procedures>>=
	integer function process_get_i_core (process, i_term) result (i_core)
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_term
	i_core = process%term(i_term)%i_core
	end function process_get_i_core

	@ %def process_get_i_core
	@
	<<Process: process: TBP>>=
	procedure :: set_i_mci_work => process_set_i_mci_work
	<<Process: procedures>>=
	subroutine process_set_i_mci_work (process, i_mci)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	process%mci_entry(i_mci)%i_mci = i_mci
	end subroutine process_set_i_mci_work

	@ %def process_set_i_mci_work
	@
	<<Process: process: TBP>>=
	procedure :: get_i_mci_work => process_get_i_mci_work
	<<Process: procedures>>=
	pure function process_get_i_mci_work (process, i_mci) result (i_mci_work)
	integer :: i_mci_work
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	i_mci_work = process%mci_entry(i_mci)%i_mci
	end function process_get_i_mci_work

	@ %def process_get_i_mci_work
	@
	<<Process: process: TBP>>=
	procedure :: get_i_sub => process_get_i_sub
	<<Process: procedures>>=
	elemental function process_get_i_sub (process, i_term) result (i_sub)
	integer :: i_sub
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_term
	i_sub = process%term(i_term)%i_sub
	end function process_get_i_sub

	@ %def process_get_i_sub
	@
	<<Process: process: TBP>>=
	procedure :: get_i_term_virtual => process_get_i_term_virtual
	<<Process: procedures>>=
	elemental function process_get_i_term_virtual (process) result (i_term)
	integer :: i_term
	class(process_t), intent(in) :: process
	integer :: i_component
	i_term = 0
	do i_component = 1, size (process%component)
	if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) &
	i_term = process%component(i_component)%i_term(1)
	end do
	end function process_get_i_term_virtual

	@ %def process_get_i_term_virtual
	@
	<<Process: process: TBP>>=
	generic :: component_is_active => component_is_active_single
	procedure :: component_is_active_single => process_component_is_active_single
	<<Process: procedures>>=
	elemental function process_component_is_active_single (process, i_comp) result (val)
	logical :: val
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_comp
	val = process%component(i_comp)%is_active ()
	end function process_component_is_active_single

	@ %def process_component_is_active_single
	@
	<<Process: process: TBP>>=
	generic :: component_is_active => component_is_active_all
	procedure :: component_is_active_all => process_component_is_active_all
	<<Process: procedures>>=
	pure function process_component_is_active_all (process) result (val)
	logical, dimension(:), allocatable :: val
	class(process_t), intent(in) :: process
	allocate (val (size (process%component)))
	val = process%component%is_active ()
	end function process_component_is_active_all

	@ %def process_component_is_active_all
	@
	\subsection{Default iterations}
	If the user does not specify the passes and iterations for
	integration, we should be able to give reasonable defaults. These
	depend on the process, therefore we implement the following procedures
	as methods of the process object. The algorithm is not very
	sophisticated yet, it may be improved by looking at the process in
	more detail.

	We investigate only the first process component, assuming that it
	characterizes the complexity of the process reasonable well.

	The number of passes is limited to two: one for adaption, one for
	integration.
	<<Process: process: TBP>>=
	procedure :: get_n_pass_default => process_get_n_pass_default
	procedure :: adapt_grids_default => process_adapt_grids_default
	procedure :: adapt_weights_default => process_adapt_weights_default
	<<Process: procedures>>=
	function process_get_n_pass_default (process) result (n_pass)
	class(process_t), intent(in) :: process
	integer :: n_pass
	integer :: n_eff
	type(process_component_def_t), pointer :: config
	config => process%component(1)%config
	n_eff = config%get_n_tot () - 2
	select case (n_eff)
	case (1)
	n_pass = 1
	case default
	n_pass = 2
	end select
	end function process_get_n_pass_default

	function process_adapt_grids_default (process, pass) result (flag)
	class(process_t), intent(in) :: process
	integer, intent(in) :: pass
	logical :: flag
	integer :: n_eff
	type(process_component_def_t), pointer :: config
	config => process%component(1)%config
	n_eff = config%get_n_tot () - 2
	select case (n_eff)
	case (1)
	flag = .false.
	case default
	select case (pass)
	case (1); flag = .true.
	case (2); flag = .false.
	case default
	call msg_bug ("adapt grids default: impossible pass index")
	end select
	end select
	end function process_adapt_grids_default

	function process_adapt_weights_default (process, pass) result (flag)
	class(process_t), intent(in) :: process
	integer, intent(in) :: pass
	logical :: flag
	integer :: n_eff
	type(process_component_def_t), pointer :: config
	config => process%component(1)%config
	n_eff = config%get_n_tot () - 2
	select case (n_eff)
	case (1)
	flag = .false.
	case default
	select case (pass)
	case (1); flag = .true.
	case (2); flag = .false.
	case default
	call msg_bug ("adapt weights default: impossible pass index")
	end select
	end select
	end function process_adapt_weights_default

	@ %def process_get_n_pass_default
	@ %def process_adapt_grids_default
	@ %def process_adapt_weights_default
	@ The number of iterations and calls per iteration depends on the
	number of outgoing particles.
	<<Process: process: TBP>>=
	procedure :: get_n_it_default => process_get_n_it_default
	procedure :: get_n_calls_default => process_get_n_calls_default
	<<Process: procedures>>=
	function process_get_n_it_default (process, pass) result (n_it)
	class(process_t), intent(in) :: process
	integer, intent(in) :: pass
	integer :: n_it
	integer :: n_eff
	type(process_component_def_t), pointer :: config
	config => process%component(1)%config
	n_eff = config%get_n_tot () - 2
	select case (pass)
	case (1)
	select case (n_eff)
	case (1); n_it = 1
	case (2); n_it = 3
	case (3); n_it = 5
	case (4:5); n_it = 10
	case (6); n_it = 15
	case (7:); n_it = 20
	end select
	case (2)
	select case (n_eff)
	case (:3); n_it = 3
	case (4:); n_it = 5
	end select
	end select
	end function process_get_n_it_default

	function process_get_n_calls_default (process, pass) result (n_calls)
	class(process_t), intent(in) :: process
	integer, intent(in) :: pass
	integer :: n_calls
	integer :: n_eff
	type(process_component_def_t), pointer :: config
	config => process%component(1)%config
	n_eff = config%get_n_tot () - 2
	select case (pass)
	case (1)
	select case (n_eff)
	case (1); n_calls = 100
	case (2); n_calls = 1000
	case (3); n_calls = 5000
	case (4); n_calls = 10000
	case (5); n_calls = 20000
	case (6:); n_calls = 50000
	end select
	case (2)
	select case (n_eff)
	case (:3); n_calls = 10000
	case (4); n_calls = 20000
	case (5); n_calls = 50000
	case (6); n_calls = 100000
	case (7:); n_calls = 200000
	end select
	end select
	end function process_get_n_calls_default

	@ %def process_get_n_it_default
	@ %def process_get_n_calls_default
	@
	\subsection{Constant process data}
	Manually set the Run ID (unit test only).
	<<Process: process: TBP>>=
	procedure :: set_run_id => process_set_run_id
	<<Process: procedures>>=
	subroutine process_set_run_id (process, run_id)
	class(process_t), intent(inout) :: process
	type(string_t), intent(in) :: run_id
	process%meta%run_id = run_id
	end subroutine process_set_run_id

	@ %def process_set_run_id
	@
	The following methods return basic process data that stay constant
	after initialization.

	The process and IDs.
	<<Process: process: TBP>>=
	procedure :: get_id => process_get_id
	procedure :: get_num_id => process_get_num_id
	procedure :: get_run_id => process_get_run_id
	procedure :: get_library_name => process_get_library_name
	<<Process: procedures>>=
	function process_get_id (process) result (id)
	class(process_t), intent(in) :: process
	type(string_t) :: id
	id = process%meta%id
	end function process_get_id

	function process_get_num_id (process) result (id)
	class(process_t), intent(in) :: process
	integer :: id
	id = process%meta%num_id
	end function process_get_num_id

	function process_get_run_id (process) result (id)
	class(process_t), intent(in) :: process
	type(string_t) :: id
	id = process%meta%run_id
	end function process_get_run_id

	function process_get_library_name (process) result (id)
	class(process_t), intent(in) :: process
	type(string_t) :: id
	id = process%meta%lib_name
	end function process_get_library_name

	@ %def process_get_id process_get_num_id
	@ %def process_get_run_id process_get_library_name
	@ The number of incoming particles.
	<<Process: process: TBP>>=
	procedure :: get_n_in => process_get_n_in
	<<Process: procedures>>=
	function process_get_n_in (process) result (n)
	class(process_t), intent(in) :: process
	integer :: n
	n = process%config%n_in
	end function process_get_n_in

	@ %def process_get_n_in
	@ The number of MCI data sets.
	<<Process: process: TBP>>=
	procedure :: get_n_mci => process_get_n_mci
	<<Process: procedures>>=
	function process_get_n_mci (process) result (n)
	class(process_t), intent(in) :: process
	integer :: n
	n = process%config%n_mci
	end function process_get_n_mci

	@ %def process_get_n_mci
	@ The number of process components, total.
	<<Process: process: TBP>>=
	procedure :: get_n_components => process_get_n_components
	<<Process: procedures>>=
	function process_get_n_components (process) result (n)
	class(process_t), intent(in) :: process
	integer :: n
	n = process%meta%n_components
	end function process_get_n_components

	@ %def process_get_n_components
	@ The number of process terms, total.
	<<Process: process: TBP>>=
	procedure :: get_n_terms => process_get_n_terms
	<<Process: procedures>>=
	function process_get_n_terms (process) result (n)
	class(process_t), intent(in) :: process
	integer :: n
	n = process%config%n_terms
	end function process_get_n_terms

	@ %def process_get_n_terms
	@ Return the indices of the components that belong to a
	specific MCI entry.
	<<Process: process: TBP>>=
	procedure :: get_i_component => process_get_i_component
	<<Process: procedures>>=
	subroutine process_get_i_component (process, i_mci, i_component)
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	integer, dimension(:), intent(out), allocatable :: i_component
	associate (mci_entry => process%mci_entry(i_mci))
	allocate (i_component (size (mci_entry%i_component)))
	i_component = mci_entry%i_component
	end associate
	end subroutine process_get_i_component

	@ %def process_get_i_component
	@ Return the ID of a specific component.
	<<Process: process: TBP>>=
	procedure :: get_component_id => process_get_component_id
	<<Process: procedures>>=
	function process_get_component_id (process, i_component) result (id)
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	type(string_t) :: id
	id = process%meta%component_id(i_component)
	end function process_get_component_id

	@ %def process_get_component_id
	@ Return a pointer to the definition of a specific component.
	<<Process: process: TBP>>=
	procedure :: get_component_def_ptr => process_get_component_def_ptr
	<<Process: procedures>>=
	function process_get_component_def_ptr (process, i_component) result (ptr)
	type(process_component_def_t), pointer :: ptr
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	ptr => process%config%process_def%get_component_def_ptr (i_component)
	end function process_get_component_def_ptr

	@ %def process_get_component_def_ptr
	@ These procedures extract and restore (by transferring the
	allocation) the process core. This is useful for changing process
	parameters from outside this module.
	<<Process: process: TBP>>=
	procedure :: extract_core => process_extract_core
	procedure :: restore_core => process_restore_core
	<<Process: procedures>>=
	subroutine process_extract_core (process, i_term, core)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_term
	class(prc_core_t), intent(inout), allocatable :: core
	integer :: i_core
	i_core = process%term(i_term)%i_core
	call move_alloc (from = process%core_entry(i_core)%core, to = core)
	end subroutine process_extract_core

	subroutine process_restore_core (process, i_term, core)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_term
	class(prc_core_t), intent(inout), allocatable :: core
	integer :: i_core
	i_core = process%term(i_term)%i_core
	call move_alloc (from = core, to = process%core_entry(i_core)%core)
	end subroutine process_restore_core

	@ %def process_extract_core
	@ %def process_restore_core
	@ The block of process constants.
	<<Process: process: TBP>>=
	procedure :: get_constants => process_get_constants
	<<Process: procedures>>=
	function process_get_constants (process, i_core) result (data)
	type(process_constants_t) :: data
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_core
	data = process%core_entry(i_core)%core%data
	end function process_get_constants

	@ %def process_get_constants
	@
	<<Process: process: TBP>>=
	procedure :: get_config => process_get_config
	<<Process: procedures>>=
	function process_get_config (process) result (config)
	type(process_config_data_t) :: config
	class(process_t), intent(in) :: process
	config = process%config
	end function process_get_config

	@ %def process_get_config
	@
	Construct an MD5 sum for the constant data, including the NLO type.

	For the NLO type [[NLO_MISMATCH]], we pretend that this was
	[[NLO_SUBTRACTION]] instead.

	TODO wk 2018: should not depend explicitly on NLO data.
	<<Process: process: TBP>>=
	procedure :: get_md5sum_constants => process_get_md5sum_constants
	<<Process: procedures>>=
	function process_get_md5sum_constants (process, i_component, &
	type_string, nlo_type) result (this_md5sum)
	character(32) :: this_md5sum
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	type(string_t), intent(in) :: type_string
	integer, intent(in) :: nlo_type
	type(process_constants_t) :: data
	integer :: unit
	call process%env%fill_process_constants (process%meta%id, i_component, data)
	unit = data%fill_unit_for_md5sum (.false.)
	write (unit, '(A)') char(type_string)
	select case (nlo_type)
	case (NLO_MISMATCH)
	write (unit, '(I0)') NLO_SUBTRACTION
	case default
	write (unit, '(I0)') nlo_type
	end select
	rewind (unit)
	this_md5sum = md5sum (unit)
	close (unit)
	end function process_get_md5sum_constants

	@ %def process_get_md5sum_constants
	@ Return the set of outgoing flavors that are associated with a particular
	term. We deduce this from the effective interaction.
	<<Process: process: TBP>>=
	procedure :: get_term_flv_out => process_get_term_flv_out
	<<Process: procedures>>=
	subroutine process_get_term_flv_out (process, i_term, flv)
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_term
	type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
	type(interaction_t), pointer :: int
	int => process%term(i_term)%int_eff
	if (.not. associated (int)) int => process%term(i_term)%int
	call interaction_get_flv_out (int, flv)
	end subroutine process_get_term_flv_out

	@ %def process_get_term_flv_out
	@ Return true if there is any unstable particle in any of the process
	terms. We decide this based on the provided model instance, not the
	one that is stored in the process object.
	<<Process: process: TBP>>=
	procedure :: contains_unstable => process_contains_unstable
	<<Process: procedures>>=
	function process_contains_unstable (process, model) result (flag)
	class(process_t), intent(in) :: process
	class(model_data_t), intent(in), target :: model
	logical :: flag
	integer :: i_term
	type(flavor_t), dimension(:,:), allocatable :: flv
	flag = .false.
	do i_term = 1, process%get_n_terms ()
	call process%get_term_flv_out (i_term, flv)
	call flv%set_model (model)
	flag = .not. all (flv%is_stable ())
	deallocate (flv)
	if (flag) return
	end do
	end function process_contains_unstable

	@ %def process_contains_unstable
	@ The nominal process energy.
	<<Process: process: TBP>>=
	procedure :: get_sqrts => process_get_sqrts
	<<Process: procedures>>=
	function process_get_sqrts (process) result (sqrts)
	class(process_t), intent(in) :: process
	real(default) :: sqrts
	sqrts = process%beam_config%data%get_sqrts ()
	end function process_get_sqrts

	@ %def process_get_sqrts
	@ The lab-frame beam energy/energies..
	<<Process: process: TBP>>=
	procedure :: get_energy => process_get_energy
	<<Process: procedures>>=
	function process_get_energy (process) result (e)
	class(process_t), intent(in) :: process
	real(default), dimension(:), allocatable :: e
	e = process%beam_config%data%get_energy ()
	end function process_get_energy

	@ %def process_get_energy
	@ The beam polarization in case of simple degrees.
	<<Process: process: TBP>>=
	procedure :: get_polarization => process_get_polarization
	<<Process: procedures>>=
	function process_get_polarization (process) result (pol)
	class(process_t), intent(in) :: process
	real(default), dimension(process%beam_config%data%n) :: pol
	pol = process%beam_config%data%get_polarization ()
	end function process_get_polarization

	@ %def process_get_polarization
	@
	<<Process: process: TBP>>=
	procedure :: get_meta => process_get_meta
	<<Process: procedures>>=
	function process_get_meta (process) result (meta)
	type(process_metadata_t) :: meta
	class(process_t), intent(in) :: process
	meta = process%meta
	end function process_get_meta

	@ %def process_get_meta
	<<Process: process: TBP>>=
	procedure :: has_matrix_element => process_has_matrix_element
	<<Process: procedures>>=
	function process_has_matrix_element (process, i, is_term_index) result (active)
	logical :: active
	class(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	logical, intent(in), optional :: is_term_index
	integer :: i_component
	logical :: is_term
	is_term = .false.
	if (present (i)) then
	if (present (is_term_index)) is_term = is_term_index
	if (is_term) then
	i_component = process%term(i)%i_component
	else
	i_component = i
	end if
	active = process%component(i_component)%active
	else
	active = any (process%component%active)
	end if
	end function process_has_matrix_element

	@ %def process_has_matrix_element
	@ Pointer to the beam data object.
	<<Process: process: TBP>>=
	procedure :: get_beam_data_ptr => process_get_beam_data_ptr
	<<Process: procedures>>=
	function process_get_beam_data_ptr (process) result (beam_data)
	class(process_t), intent(in), target :: process
	type(beam_data_t), pointer :: beam_data
	beam_data => process%beam_config%data
	end function process_get_beam_data_ptr

	@ %def process_get_beam_data_ptr
	@
	<<Process: process: TBP>>=
	procedure :: get_beam_config => process_get_beam_config
	<<Process: procedures>>=
	function process_get_beam_config (process) result (beam_config)
	type(process_beam_config_t) :: beam_config
	class(process_t), intent(in) :: process
	beam_config = process%beam_config
	end function process_get_beam_config

	@ %def process_get_beam_config
	@
	<<Process: process: TBP>>=
	procedure :: get_beam_config_ptr => process_get_beam_config_ptr
	<<Process: procedures>>=
	function process_get_beam_config_ptr (process) result (beam_config)
	type(process_beam_config_t), pointer :: beam_config
	class(process_t), intent(in), target :: process
	beam_config => process%beam_config
	end function process_get_beam_config_ptr

	@ %def process_get_beam_config_ptr
	@ Get the PDF set currently in use, if any.
	<<Process: process: TBP>>=
	procedure :: get_pdf_set => process_get_pdf_set
	<<Process: procedures>>=
	function process_get_pdf_set (process) result (pdf_set)
	class(process_t), intent(in) :: process
	integer :: pdf_set
	pdf_set = process%beam_config%get_pdf_set ()
	end function process_get_pdf_set

	@ %def process_get_pdf_set
	@
	<<Process: process: TBP>>=
	procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs
	<<Process: procedures>>=
	function process_pcm_contains_pdfs (process) result (has_pdfs)
	logical :: has_pdfs
	class(process_t), intent(in) :: process
	has_pdfs = process%pcm%has_pdfs
	end function process_pcm_contains_pdfs

	@ %def process_pcm_contains_pdfs
	@ Get the beam spectrum file currently in use, if any.
	<<Process: process: TBP>>=
	procedure :: get_beam_file => process_get_beam_file
	<<Process: procedures>>=
	function process_get_beam_file (process) result (file)
	class(process_t), intent(in) :: process
	type(string_t) :: file
	file = process%beam_config%get_beam_file ()
	end function process_get_beam_file

	@ %def process_get_beam_file
	@ Pointer to the process variable list.
	<<Process: process: TBP>>=
	procedure :: get_var_list_ptr => process_get_var_list_ptr
	<<Process: procedures>>=
	function process_get_var_list_ptr (process) result (ptr)
	class(process_t), intent(in), target :: process
	type(var_list_t), pointer :: ptr
	ptr => process%env%get_var_list_ptr ()
	end function process_get_var_list_ptr

	@ %def process_get_var_list_ptr
	@ Pointer to the common model.
	<<Process: process: TBP>>=
	procedure :: get_model_ptr => process_get_model_ptr
	<<Process: procedures>>=
	function process_get_model_ptr (process) result (ptr)
	class(process_t), intent(in) :: process
	class(model_data_t), pointer :: ptr
	ptr => process%config%model
	end function process_get_model_ptr

	@ %def process_get_model_ptr
	@ Use the embedded RNG factory to spawn a new random-number generator
	instance. (This modifies the state of the factory.)
	<<Process: process: TBP>>=
	procedure :: make_rng => process_make_rng
	<<Process: procedures>>=
	subroutine process_make_rng (process, rng)
	class(process_t), intent(inout) :: process
	class(rng_t), intent(out), allocatable :: rng
	if (allocated (process%rng_factory)) then
	call process%rng_factory%make (rng)
	else
	call msg_bug ("Process: make rng: factory not allocated")
	end if
	end subroutine process_make_rng

	@ %def process_make_rng
	@
	\subsection{Compute an amplitude}
	Each process variant should allow for computing an amplitude value
	directly, without generating a process instance.

	The process component is selected by the index [[i]]. The term within the
	process component is selected by [[j]]. The momentum
	combination is transferred as the array [[p]]. The function sets the specific
	quantum state via the indices of a flavor [[f]], helicity [[h]], and color
	[[c]] combination. Each index refers to the list of flavor, helicity, and
	color states, respectively, as stored in the process data.

	Optionally, we may set factorization and renormalization scale. If unset, the
	partonic c.m.\ energy is inserted.

	The function checks arguments for validity.
	For invalid arguments (quantum states), we return zero.
	<<Process: process: TBP>>=
	procedure :: compute_amplitude => process_compute_amplitude
	<<Process: procedures>>=
	function process_compute_amplitude &
	(process, i_core, i, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced) &
	result (amp)
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_core
	integer, intent(in) :: i, j
	type(vector4_t), dimension(:), intent(in) :: p
	integer, intent(in) :: f, h, c
	real(default), intent(in), optional :: fac_scale, ren_scale
	real(default), intent(in), allocatable, optional :: alpha_qcd_forced
	real(default) :: fscale, rscale
	real(default), allocatable :: aqcd_forced
	complex(default) :: amp
	class(prc_core_t), pointer :: core
	amp = 0
	if (0 < i .and. i <= process%meta%n_components) then
	if (process%component(i)%active) then
	associate (core => process%core_entry(i_core)%core)
	associate (data => core%data)
	if (size (p) == data%n_in + data%n_out &
	.and. 0 < f .and. f <= data%n_flv &
	.and. 0 < h .and. h <= data%n_hel &
	.and. 0 < c .and. c <= data%n_col) then
	if (present (fac_scale)) then
	fscale = fac_scale
	else
	fscale = sum (p(data%n_in+1:)) ** 1
	end if
	if (present (ren_scale)) then
	rscale = ren_scale
	else
	rscale = fscale
	end if
	if (present (alpha_qcd_forced)) then
	if (allocated (alpha_qcd_forced)) &
	allocate (aqcd_forced, source = alpha_qcd_forced)
	end if
	amp = core%compute_amplitude (j, p, f, h, c, &
	fscale, rscale, aqcd_forced)
	end if
	end associate
	end associate
	else
	amp = 0
	end if
	end if
	end function process_compute_amplitude

	@ %def process_compute_amplitude
	@ Sanity check for the process library. We abort the program if it
	has changed after process initialization.
	<<Process: process: TBP>>=
	procedure :: check_library_sanity => process_check_library_sanity
	<<Process: procedures>>=
	subroutine process_check_library_sanity (process)
	class(process_t), intent(in) :: process
	call process%env%check_lib_sanity (process%meta)
	end subroutine process_check_library_sanity

	@ %def process_check_library_sanity
	@ Reset the association to a process library.
	<<Process: process: TBP>>=
	procedure :: reset_library_ptr => process_reset_library_ptr
	<<Process: procedures>>=
	subroutine process_reset_library_ptr (process)
	class(process_t), intent(inout) :: process
	call process%env%reset_lib_ptr ()
	end subroutine process_reset_library_ptr

	@ %def process_reset_library_ptr
	@
	<<Process: process: TBP>>=
	procedure :: set_component_type => process_set_component_type
	<<Process: procedures>>=
	subroutine process_set_component_type (process, i_component, i_type)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_component, i_type
	process%component(i_component)%component_type = i_type
	end subroutine process_set_component_type

	@ %def process_set_component_type
	@
	<<Process: process: TBP>>=
	procedure :: set_counter_mci_entry => process_set_counter_mci_entry
	<<Process: procedures>>=
	subroutine process_set_counter_mci_entry (process, i_mci, counter)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: i_mci
	type(process_counter_t), intent(in) :: counter
	process%mci_entry(i_mci)%counter = counter
	end subroutine process_set_counter_mci_entry

	@ %def process_set_counter_mci_entry
	@ This is for suppression of numerical noise in the integration results
	stored in the [[process_mci_entry]] type. As the error and efficiency
	enter the MD5 sum, we recompute it.
	<<Process: process: TBP>>=
	procedure :: pacify => process_pacify
	<<Process: procedures>>=
	subroutine process_pacify (process, efficiency_reset, error_reset)
	class(process_t), intent(inout) :: process
	logical, intent(in), optional :: efficiency_reset, error_reset
	logical :: eff_reset, err_reset
	integer :: i
	eff_reset = .false.
	err_reset = .false.
	if (present (efficiency_reset)) eff_reset = efficiency_reset
	if (present (error_reset)) err_reset = error_reset
	if (allocated (process%mci_entry)) then
	do i = 1, size (process%mci_entry)
	call process%mci_entry(i)%results%pacify (efficiency_reset)
	if (allocated (process%mci_entry(i)%mci)) then
	associate (mci => process%mci_entry(i)%mci)
	if (process%mci_entry(i)%mci%error_known &
	.and. err_reset) &
	mci%error = 0
	if (process%mci_entry(i)%mci%efficiency_known &
	.and. eff_reset) &
	mci%efficiency = 1
	call mci%pacify (efficiency_reset, error_reset)
	call mci%compute_md5sum ()
	end associate
	end if
	end do
	end if
	end subroutine process_pacify

	@ %def process_pacify
	@ The following methods are used only in the unit tests; the access
	process internals directly that would otherwise be hidden.
	<<Process: process: TBP>>=
	procedure :: test_allocate_sf_channels
	procedure :: test_set_component_sf_channel
	procedure :: test_get_mci_ptr
	<<Process: procedures>>=
	subroutine test_allocate_sf_channels (process, n)
	class(process_t), intent(inout) :: process
	integer, intent(in) :: n
	call process%beam_config%allocate_sf_channels (n)
	end subroutine test_allocate_sf_channels

	subroutine test_set_component_sf_channel (process, c)
	class(process_t), intent(inout) :: process
	integer, dimension(:), intent(in) :: c
	call process%component(1)%phs_config%set_sf_channel (c)
	end subroutine test_set_component_sf_channel

	subroutine test_get_mci_ptr (process, mci)
	class(process_t), intent(in), target :: process
	class(mci_t), intent(out), pointer :: mci
	mci => process%mci_entry(1)%mci
	end subroutine test_get_mci_ptr

	@ %def test_allocate_sf_channels
	@ %def test_set_component_sf_channel
	@ %def test_get_mci_ptr
	@
	<<Process: process: TBP>>=
	procedure :: init_mci_work => process_init_mci_work
	<<Process: procedures>>=
	subroutine process_init_mci_work (process, mci_work, i)
	class(process_t), intent(in), target :: process
	type(mci_work_t), intent(out) :: mci_work
	integer, intent(in) :: i
	call mci_work%init (process%mci_entry(i))
	end subroutine process_init_mci_work

	@ %def process_init_mci_work
	@
	Prepare the process core with type [[test_me]], or otherwise the externally
	provided [[type_string]] version. The toy dispatchers as a procedure
	argument come handy, knowing that we need to support only the [[test_me]] and
	[[template]] matrix-element types.
	<<Process: process: TBP>>=
	procedure :: setup_test_cores => process_setup_test_cores
	<<Process: procedures>>=
	subroutine process_setup_test_cores (process, type_string)
	class(process_t), intent(inout) :: process
	class(prc_core_t), allocatable :: core
	type(string_t), intent(in), optional :: type_string
	if (present (type_string)) then
	select case (char (type_string))
	case ("template")
	call process%setup_cores (dispatch_template_core)
	case ("test_me")
	call process%setup_cores (dispatch_test_me_core)
	case default
	call msg_bug ("process setup test cores: unsupported type string")
	end select
	else
	call process%setup_cores (dispatch_test_me_core)
	end if
	end subroutine process_setup_test_cores

	subroutine dispatch_test_me_core (core, core_def, model, &
	helicity_selection, qcd, use_color_factors, has_beam_pol)
	use prc_test_core, only: test_t
	class(prc_core_t), allocatable, intent(inout) :: core
	class(prc_core_def_t), intent(in) :: core_def
	class(model_data_t), intent(in), target, optional :: model
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	type(qcd_t), intent(in), optional :: qcd
	logical, intent(in), optional :: use_color_factors
	logical, intent(in), optional :: has_beam_pol
	allocate (test_t :: core)
	end subroutine dispatch_test_me_core

	subroutine dispatch_template_core (core, core_def, model, &
	helicity_selection, qcd, use_color_factors, has_beam_pol)
	use prc_template_me, only: prc_template_me_t
	class(prc_core_t), allocatable, intent(inout) :: core
	class(prc_core_def_t), intent(in) :: core_def
	class(model_data_t), intent(in), target, optional :: model
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	type(qcd_t), intent(in), optional :: qcd
	logical, intent(in), optional :: use_color_factors
	logical, intent(in), optional :: has_beam_pol
	allocate (prc_template_me_t :: core)
	select type (core)
	type is (prc_template_me_t)
	call core%set_parameters (model)
	end select
	end subroutine dispatch_template_core

	@ %def process_setup_test_cores
	@
	<<Process: process: TBP>>=
	procedure :: get_connected_states => process_get_connected_states
	<<Process: procedures>>=
	function process_get_connected_states (process, i_component, &
	connected_terms) result (connected)
	type(connected_state_t), dimension(:), allocatable :: connected
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	type(connected_state_t), dimension(:), intent(in) :: connected_terms
	integer :: i, i_conn
	integer :: n_conn
	n_conn = 0
	do i = 1, process%get_n_terms ()
	if (process%term(i)%i_component == i_component) then
	n_conn = n_conn + 1
	end if
	end do
	allocate (connected (n_conn))
	i_conn = 1
	do i = 1, process%get_n_terms ()
	if (process%term(i)%i_component == i_component) then
	connected (i_conn) = connected_terms(i)
	i_conn = i_conn + 1
	end if
	end do
	end function process_get_connected_states

	@ %def process_get_connected_states
	@
	\subsection{NLO specifics}
	These subroutines (and the NLO specific properties they work on) could
	potentially be moved to [[pcm_nlo_t]] and used more generically in
	[[process_t]] with an appropriate interface in [[pcm_t]]

	TODO wk 2018: This is used only by event initialization, which deals with an incomplete
	process object.
	<<Process: process: TBP>>=
	procedure :: init_nlo_settings => process_init_nlo_settings
	<<Process: procedures>>=
	subroutine process_init_nlo_settings (process, var_list)
	class(process_t), intent(inout) :: process
	type(var_list_t), intent(in), target :: var_list
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	call pcm%init_nlo_settings (var_list)
	if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) &
	call pcm%settings%write ()
	class default
	call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!")
	end select
	end subroutine process_init_nlo_settings

	@ %def process_init_nlo_settings
	@
	<<Process: process: TBP>>=
	generic :: get_nlo_type_component => get_nlo_type_component_single
	procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single
	<<Process: procedures>>=
	elemental function process_get_nlo_type_component_single (process, i_component) result (val)
	integer :: val
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	val = process%component(i_component)%get_nlo_type ()
	end function process_get_nlo_type_component_single

	@ %def process_get_nlo_type_component_single
	@
	<<Process: process: TBP>>=
	generic :: get_nlo_type_component => get_nlo_type_component_all
	procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all
	<<Process: procedures>>=
	pure function process_get_nlo_type_component_all (process) result (val)
	integer, dimension(:), allocatable :: val
	class(process_t), intent(in) :: process
	allocate (val (size (process%component)))
	val = process%component%get_nlo_type ()
	end function process_get_nlo_type_component_all

	@ %def process_get_nlo_type_component_all
	@
	<<Process: process: TBP>>=
	procedure :: is_nlo_calculation => process_is_nlo_calculation
	<<Process: procedures>>=
	function process_is_nlo_calculation (process) result (nlo)
	logical :: nlo
	class(process_t), intent(in) :: process
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	nlo = .true.
	class default
	nlo = .false.
	end select
	end function process_is_nlo_calculation

	@ %def process_is_nlo_calculation
	@
	<<Process: process: TBP>>=
	procedure :: get_negative_sf => process_get_negative_sf
	<<Process: procedures>>=
	function process_get_negative_sf (process) result (neg_sf)
	logical :: neg_sf
	class(process_t), intent(in) :: process
	neg_sf = process%config%process_def%get_negative_sf ()
	end function process_get_negative_sf

	@ %def process_get_negative_sf
	@
	<<Process: process: TBP>>=
	procedure :: is_combined_nlo_integration &
	=> process_is_combined_nlo_integration
	<<Process: procedures>>=
	function process_is_combined_nlo_integration (process) result (combined)
	logical :: combined
	class(process_t), intent(in) :: process
	select type (pcm => process%pcm)
	type is (pcm_nlo_t)
	combined = pcm%settings%combined_integration
	class default
	combined = .false.
	end select
	end function process_is_combined_nlo_integration

	@ %def process_is_combined_nlo_integration
	@
	<<Process: process: TBP>>=
	procedure :: component_is_real_finite => process_component_is_real_finite
	<<Process: procedures>>=
	pure function process_component_is_real_finite (process, i_component) &
	result (val)
	logical :: val
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	val = process%component(i_component)%component_type == COMP_REAL_FIN
	end function process_component_is_real_finite

	@ %def process_component_is_real_finite
	@ Return nlo data of a process component
	<<Process: process: TBP>>=
	procedure :: get_component_nlo_type => process_get_component_nlo_type
	<<Process: procedures>>=
	elemental function process_get_component_nlo_type (process, i_component) &
	result (nlo_type)
	integer :: nlo_type
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	nlo_type = process%component(i_component)%config%get_nlo_type ()
	end function process_get_component_nlo_type

	@ %def process_get_component_nlo_type
	@ Return a pointer to the core that belongs to a component.
	<<Process: process: TBP>>=
	procedure :: get_component_core_ptr => process_get_component_core_ptr
	<<Process: procedures>>=
	function process_get_component_core_ptr (process, i_component) result (core)
	class(process_t), intent(in), target :: process
	integer, intent(in) :: i_component
	class(prc_core_t), pointer :: core
	integer :: i_core
	i_core = process%pcm%get_i_core(i_component)
	core => process%core_entry(i_core)%core
	end function process_get_component_core_ptr

	@ %def process_get_component_core_ptr
	@
	<<Process: process: TBP>>=
	procedure :: get_component_associated_born &
	=> process_get_component_associated_born
	<<Process: procedures>>=
	function process_get_component_associated_born (process, i_component) &
	result (i_born)
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	integer :: i_born
	i_born = process%component(i_component)%config%get_associated_born ()
	end function process_get_component_associated_born

	@ %def process_get_component_associated_born
	@
	<<Process: process: TBP>>=
	procedure :: get_first_real_component => process_get_first_real_component
	<<Process: procedures>>=
	function process_get_first_real_component (process) result (i_real)
	integer :: i_real
	class(process_t), intent(in) :: process
	i_real = process%component(1)%config%get_associated_real ()
	end function process_get_first_real_component

	@ %def process_get_first_real_component
	@
	<<Process: process: TBP>>=
	procedure :: get_first_real_term => process_get_first_real_term
	<<Process: procedures>>=
	function process_get_first_real_term (process) result (i_real)
	integer :: i_real
	class(process_t), intent(in) :: process
	integer :: i_component, i_term
	i_component = process%component(1)%config%get_associated_real ()
	i_real = 0
	do i_term = 1, size (process%term)
	if (process%term(i_term)%i_component == i_component) then
	i_real = i_term
	exit
	end if
	end do
	if (i_real == 0) call msg_fatal ("Did not find associated real term!")
	end function process_get_first_real_term

	@ %def process_get_first_real_term
	@
	<<Process: process: TBP>>=
	procedure :: get_associated_real_fin => process_get_associated_real_fin
	<<Process: procedures>>=
	elemental function process_get_associated_real_fin (process, i_component) result (i_real)
	integer :: i_real
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_component
	i_real = process%component(i_component)%config%get_associated_real_fin ()
	end function process_get_associated_real_fin

	@ %def process_get_associated_real_fin
	@
	<<Process: process: TBP>>=
	procedure :: select_i_term => process_select_i_term
	<<Process: procedures>>=
	pure function process_select_i_term (process, i_mci) result (i_term)
	integer :: i_term
	class(process_t), intent(in) :: process
	integer, intent(in) :: i_mci
	integer :: i_component, i_sub
	i_component = process%mci_entry(i_mci)%i_component(1)
	i_term = process%component(i_component)%i_term(1)
	i_sub = process%term(i_term)%i_sub
	if (i_sub > 0) &
	i_term = process%term(i_sub)%i_term_global
	end function process_select_i_term

	@ %def process_select_i_term
	@ Would be better to do this at the level of the writer of the core but
	one has to bring NLO information there.
	<<Process: process: TBP>>=
	procedure :: prepare_any_external_code &
	=> process_prepare_any_external_code
	<<Process: procedures>>=
	subroutine process_prepare_any_external_code (process)
	class(process_t), intent(inout), target :: process
	integer :: i
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
	"process_prepare_external_code")
	associate (pcm => process%pcm)
	do i = 1, pcm%n_cores
	call pcm%prepare_any_external_code ( &
	process%core_entry(i), i, &
	process%get_library_name (), &
	process%config%model, &
	process%env%get_var_list_ptr ())
	end do
	end associate
	end subroutine process_prepare_any_external_code

	@ %def process_prepare_any_external_code
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process config}
	<<[[process_config.f90]]>>=
	<<File header>>

	module process_config

	<<Use kinds>>
	<<Use strings>>
	use format_utils, only: write_separator
	use io_units
	use md5
	use os_interface
	use diagnostics
	use sf_base
	use sf_mappings
	use mappings, only: mapping_defaults_t
	use phs_forests, only: phs_parameters_t
	use sm_qcd
	use physics_defs
	use integration_results
	use model_data
	use models
	use interactions
	use quantum_numbers
	use flavors
	use helicities
	use colors
	use rng_base
	use state_matrices
	use process_libraries
	use process_constants
	use prc_core
	use prc_external
	use prc_openloops, only: prc_openloops_t
	use prc_threshold, only: prc_threshold_t
	use beams
	use dispatch_beams, only: dispatch_qcd
	use mci_base
	use beam_structures
	use phs_base
	use variables
	use expr_base
	use blha_olp_interfaces, only: prc_blha_t

	<<Standard module head>>

	<<Process config: public>>

	<<Process config: parameters>>

	<<Process config: types>>

	contains

	<<Process config: procedures>>

	end module process_config
	@ %def process_config
	@ Identifiers for the NLO setup.
	<<Process config: parameters>>=
	integer, parameter, public :: COMP_DEFAULT = 0
	integer, parameter, public :: COMP_REAL_FIN = 1
	integer, parameter, public :: COMP_MASTER = 2
	integer, parameter, public :: COMP_VIRT = 3
	integer, parameter, public :: COMP_REAL = 4
	integer, parameter, public :: COMP_REAL_SING = 5
	integer, parameter, public :: COMP_MISMATCH = 6
	integer, parameter, public :: COMP_PDF = 7
	integer, parameter, public :: COMP_SUB = 8
	integer, parameter, public :: COMP_RESUM = 9

	@
	\subsection{Output selection flags}
	We declare a number of identifiers for write methods, so they only
	displays selected parts. The identifiers can be supplied to the [[vlist]]
	array argument of the standard F2008 derived-type writer call.
	<<Process config: parameters>>=
	integer, parameter, public :: F_PACIFY = 1
	integer, parameter, public :: F_SHOW_VAR_LIST = 11
	integer, parameter, public :: F_SHOW_EXPRESSIONS = 12
	integer, parameter, public :: F_SHOW_LIB = 13
	integer, parameter, public :: F_SHOW_MODEL = 14
	integer, parameter, public :: F_SHOW_QCD = 15
	integer, parameter, public :: F_SHOW_OS_DATA = 16
	integer, parameter, public :: F_SHOW_RNG = 17
	integer, parameter, public :: F_SHOW_BEAMS = 18
	@ %def SHOW_VAR_LIST
	@ %def SHOW_EXPRESSIONS
	@
	This is a simple function that returns true if a flag value is present in
	[[v_list]], but not its negative. If neither is present, it returns
	[[default]].
	<<Process config: public>>=
	public :: flagged
	<<Process config: procedures>>=
	function flagged (v_list, id, def) result (flag)
	logical :: flag
	integer, dimension(:), intent(in) :: v_list
	integer, intent(in) :: id
	logical, intent(in), optional :: def
	logical :: default_result
	default_result = .false.; if (present (def)) default_result = def
	if (default_result) then
	flag = all (v_list /= -id)
	else
	flag = all (v_list /= -id) .and. any (v_list == id)
	end if
	end function flagged

	@ %def flagged
	@
	Related: if flag is set (unset), append [[value]] (its negative) to the
	[[v_list]], respectively. [[v_list]] must be allocated.
	<<Process config: public>>=
	public :: set_flag
	<<Process config: procedures>>=
	subroutine set_flag (v_list, value, flag)
	integer, dimension(:), intent(inout), allocatable :: v_list
	integer, intent(in) :: value
	logical, intent(in), optional :: flag
	if (present (flag)) then
	if (flag) then
	v_list = [v_list, value]
	else
	v_list = [v_list, -value]
	end if
	end if
	end subroutine set_flag

	@ %def set_flag
	@
	\subsection{Generic configuration data}
	This information concerns physical and technical properties of the
	process. It is fixed upon initialization, using data from the
	process specification and the variable list.

	The number [[n_in]] is the number of incoming beam particles,
	simultaneously the number of incoming partons, 1 for a decay and 2 for
	a scattering process. (The number of outgoing partons may depend on
	the process component.)

	The number [[n_components]] is the number of components that constitute
	the current process.

	The number [[n_terms]] is the number of distinct contributions to the
	scattering matrix that constitute the current process. Each component
	may generate several terms.

	The number [[n_mci]] is the number of independent MC
	integration configurations that this process uses. Distinct process
	components that share a MCI configuration may be combined pointwise.
	(Nevertheless, a given MC variable set may correspond to several
	``nearby'' kinematical configurations.) This is also the number of
	distinct sampling-function results that this process can generate.
	Process components that use distinct variable sets are added only once
	after an integration pass has completed.

	The [[model]] pointer identifies the physics model and its
	parameters. This is a pointer to an external object.

	Various [[parse_node_t]] objects are taken from the SINDARIN input.
	They encode expressions for evaluating cuts and scales. The
	workspaces for evaluating those expressions are set up in the
	[[effective_state]] subobjects. Note that these are really pointers,
	so the actual nodes are not stored inside the process object.

	The [[md5sum]] is taken and used to verify the process configuration
	when re-reading data from file.
	<<Process config: public>>=
	public :: process_config_data_t
	<<Process config: types>>=
	type :: process_config_data_t
	class(process_def_t), pointer :: process_def => null ()
	integer :: n_in = 0
	integer :: n_components = 0
	integer :: n_terms = 0
	integer :: n_mci = 0
	type(string_t) :: model_name
	class(model_data_t), pointer :: model => null ()
	type(qcd_t) :: qcd
	class(expr_factory_t), allocatable :: ef_cuts
	class(expr_factory_t), allocatable :: ef_scale
	class(expr_factory_t), allocatable :: ef_fac_scale
	class(expr_factory_t), allocatable :: ef_ren_scale
	class(expr_factory_t), allocatable :: ef_weight
	character(32) :: md5sum = ""
	contains
	<<Process config: process config data: TBP>>
	end type process_config_data_t

	@ %def process_config_data_t
	@ Here, we may compress the expressions for cuts etc.
	<<Process config: process config data: TBP>>=
	procedure :: write => process_config_data_write
	<<Process config: procedures>>=
	subroutine process_config_data_write (config, u, counters, model, expressions)
	class(process_config_data_t), intent(in) :: config
	integer, intent(in) :: u
	logical, intent(in) :: counters
	logical, intent(in) :: model
	logical, intent(in) :: expressions
	write (u, "(1x,A)") "Configuration data:"
	if (counters) then
	write (u, "(3x,A,I0)") "Number of incoming particles = ", &
	config%n_in
	write (u, "(3x,A,I0)") "Number of process components = ", &
	config%n_components
	write (u, "(3x,A,I0)") "Number of process terms = ", &
	config%n_terms
	write (u, "(3x,A,I0)") "Number of MCI configurations = ", &
	config%n_mci
	end if
	if (associated (config%model)) then
	write (u, "(3x,A,A)") "Model = ", char (config%model_name)
	if (model) then
	call write_separator (u)
	call config%model%write (u)
	call write_separator (u)
	end if
	else
	write (u, "(3x,A,A,A)") "Model = ", char (config%model_name), &
	" [not associated]"
	end if
	call config%qcd%write (u, show_md5sum = .false.)
	call write_separator (u)
	if (expressions) then
	if (allocated (config%ef_cuts)) then
	call write_separator (u)
	write (u, "(3x,A)") "Cut expression:"
	call config%ef_cuts%write (u)
	end if
	if (allocated (config%ef_scale)) then
	call write_separator (u)
	write (u, "(3x,A)") "Scale expression:"
	call config%ef_scale%write (u)
	end if
	if (allocated (config%ef_fac_scale)) then
	call write_separator (u)
	write (u, "(3x,A)") "Factorization scale expression:"
	call config%ef_fac_scale%write (u)
	end if
	if (allocated (config%ef_ren_scale)) then
	call write_separator (u)
	write (u, "(3x,A)") "Renormalization scale expression:"
	call config%ef_ren_scale%write (u)
	end if
	if (allocated (config%ef_weight)) then
	call write_separator (u)
	write (u, "(3x,A)") "Weight expression:"
	call config%ef_weight%write (u)
	end if
	else
	call write_separator (u)
	write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]"
	end if
	if (config%md5sum /= "") then
	call write_separator (u)
	write (u, "(3x,A,A,A)") "MD5 sum (config) = '", config%md5sum, "'"
	end if
	end subroutine process_config_data_write

	@ %def process_config_data_write
	@ Initialize. We use information from the process metadata and from
	the process library, given the process ID. We also store the
	currently active OS data set.

	The model pointer references the model data within the [[env]] record. That
	should be an instance of the global model.

	We initialize the QCD object, unless the environment information is unavailable
	(unit tests).

	The RNG factory object is imported by moving the allocation.
	<<Process config: process config data: TBP>>=
	procedure :: init => process_config_data_init
	<<Process config: procedures>>=
	subroutine process_config_data_init (config, meta, env)
	class(process_config_data_t), intent(out) :: config
	type(process_metadata_t), intent(in) :: meta
	type(process_environment_t), intent(in) :: env
	config%process_def => env%lib%get_process_def_ptr (meta%id)
	config%n_in = config%process_def%get_n_in ()
	config%n_components = size (meta%component_id)
	config%model => env%get_model_ptr ()
	config%model_name = config%model%get_name ()
	if (env%got_var_list ()) then
	call dispatch_qcd &
	(config%qcd, env%get_var_list_ptr (), env%get_os_data ())
	end if
	end subroutine process_config_data_init

	@ %def process_config_data_init
	@ Current implementation: nothing to finalize.
	<<Process config: process config data: TBP>>=
	procedure :: final => process_config_data_final
	<<Process config: procedures>>=
	subroutine process_config_data_final (config)
	class(process_config_data_t), intent(inout) :: config
	end subroutine process_config_data_final

	@ %def process_config_data_final
	@ Return a copy of the QCD data block.
	<<Process config: process config data: TBP>>=
	procedure :: get_qcd => process_config_data_get_qcd
	<<Process config: procedures>>=
	function process_config_data_get_qcd (config) result (qcd)
	class(process_config_data_t), intent(in) :: config
	type(qcd_t) :: qcd
	qcd = config%qcd
	end function process_config_data_get_qcd

	@ %def process_config_data_get_qcd
	@ Compute the MD5 sum of the configuration data. This encodes, in
	particular, the model and the expressions for cut, scales, weight,
	etc. It should not contain the IDs and number of components, etc.,
	since the MD5 sum should be useful for integrating individual
	components.

	This is done only once. If the MD5 sum is nonempty, the calculation
	is skipped.
	<<Process config: process config data: TBP>>=
	procedure :: compute_md5sum => process_config_data_compute_md5sum
	<<Process config: procedures>>=
	subroutine process_config_data_compute_md5sum (config)
	class(process_config_data_t), intent(inout) :: config
	integer :: u
	if (config%md5sum == "") then
	u = free_unit ()
	open (u, status = "scratch", action = "readwrite")
	call config%write (u, counters = .false., &
	model = .true., expressions = .true.)
	rewind (u)
	config%md5sum = md5sum (u)
	close (u)
	end if
	end subroutine process_config_data_compute_md5sum

	@ %def process_config_data_compute_md5sum
	@
	<<Process config: process config data: TBP>>=
	procedure :: get_md5sum => process_config_data_get_md5sum
	<<Process config: procedures>>=
	pure function process_config_data_get_md5sum (config) result (md5)
	character(32) :: md5
	class(process_config_data_t), intent(in) :: config
	md5 = config%md5sum
	end function process_config_data_get_md5sum

	@ %def process_config_data_get_md5sum
	@
	\subsection{Environment}
	This record stores a snapshot of the process environment at the point where
	the process object is created.

	Model and variable list are implemented as pointer, so they always have the
	[[target]] attribute.

	For unit-testing purposes, setting the var list is optional. If not set, the
	pointer is null.
	<<Process config: public>>=
	public :: process_environment_t
	<<Process config: types>>=
	type :: process_environment_t
	private
	type(model_t), pointer :: model => null ()
	type(var_list_t), pointer :: var_list => null ()
	logical :: var_list_is_set = .false.
	type(process_library_t), pointer :: lib => null ()
	type(beam_structure_t) :: beam_structure
	type(os_data_t) :: os_data
	contains
	<<Process config: process environment: TBP>>
	end type process_environment_t

	@ %def process_environment_t
	@ Model and local var list are snapshots and need a finalizer.
	<<Process config: process environment: TBP>>=
	procedure :: final => process_environment_final
	<<Process config: procedures>>=
	subroutine process_environment_final (env)
	class(process_environment_t), intent(inout) :: env
	if (associated (env%model)) then
	call env%model%final ()
	deallocate (env%model)
	end if
	if (associated (env%var_list)) then
	call env%var_list%final (follow_link=.true.)
	deallocate (env%var_list)
	end if
	end subroutine process_environment_final

	@ %def process_environment_final
	@ Output, DTIO compatible.
	<<Process config: process environment: TBP>>=
	procedure :: write => process_environment_write
	procedure :: write_formatted => process_environment_write_formatted
	! generic :: write (formatted) => write_formatted
	<<Process config: procedures>>=
	subroutine process_environment_write (env, unit, &
	show_var_list, show_model, show_lib, show_beams, show_os_data)
	class(process_environment_t), intent(in) :: env
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_var_list
	logical, intent(in), optional :: show_model
	logical, intent(in), optional :: show_lib
	logical, intent(in), optional :: show_beams
	logical, intent(in), optional :: show_os_data
	integer :: u, iostat
	integer, dimension(:), allocatable :: v_list
	character(0) :: iomsg
	u = given_output_unit (unit)
	allocate (v_list (0))
	call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
	call set_flag (v_list, F_SHOW_MODEL, show_model)
	call set_flag (v_list, F_SHOW_LIB, show_lib)
	call set_flag (v_list, F_SHOW_BEAMS, show_beams)
	call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
	call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
	end subroutine process_environment_write

	@ %def process_environment_write
	@ DTIO standard write.
	<<Process config: procedures>>=
	subroutine process_environment_write_formatted &
	(dtv, unit, iotype, v_list, iostat, iomsg)
	class(process_environment_t), intent(in) :: dtv
	integer, intent(in) :: unit
	character(*), intent(in) :: iotype
	integer, dimension(:), intent(in) :: v_list
	integer, intent(out) :: iostat
	character(*), intent(inout) :: iomsg
	associate (env => dtv)
	if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then
	write (unit, "(1x,A)") "Variable list:"
	if (associated (env%var_list)) then
	call write_separator (unit)
	call env%var_list%write (unit)
	else
	write (unit, "(3x,A)") "[not allocated]"
	end if
	call write_separator (unit)
	end if
	if (flagged (v_list, F_SHOW_MODEL, .true.)) then
	write (unit, "(1x,A)") "Model:"
	if (associated (env%model)) then
	call write_separator (unit)
	call env%model%write (unit)
	else
	write (unit, "(3x,A)") "[not allocated]"
	end if
	call write_separator (unit)
	end if
	if (flagged (v_list, F_SHOW_LIB, .true.)) then
	write (unit, "(1x,A)") "Process library:"
	if (associated (env%lib)) then
	call write_separator (unit)
	call env%lib%write (unit)
	else
	write (unit, "(3x,A)") "[not allocated]"
	end if
	end if
	if (flagged (v_list, F_SHOW_BEAMS, .true.)) then
	call write_separator (unit)
	call env%beam_structure%write (unit)
	end if
	if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then
	write (unit, "(1x,A)") "Operating-system data:"
	call write_separator (unit)
	call env%os_data%write (unit)
	end if
	end associate
	iostat = 0
	end subroutine process_environment_write_formatted

	@ %def process_environment_write_formatted
	@ Initialize: Make a snapshot of the provided model. Make a link to the
	current process library.

	Also make a snapshot of the variable list, if provided. If none is
	provided, there is an empty variable list nevertheless, so a pointer
	lookup does not return null.

	If no beam structure is provided, the beam-structure member is empty and will
	yield a number of zero beams when queried.
	<<Process config: process environment: TBP>>=
	procedure :: init => process_environment_init
	<<Process config: procedures>>=
	subroutine process_environment_init &
	(env, model, lib, os_data, var_list, beam_structure)
	class(process_environment_t), intent(out) :: env
	type(model_t), intent(in), target :: model
	type(process_library_t), intent(in), target :: lib
	type(os_data_t), intent(in) :: os_data
	type(var_list_t), intent(in), target, optional :: var_list
	type(beam_structure_t), intent(in), optional :: beam_structure
	allocate (env%model)
	call env%model%init_instance (model)
	env%lib => lib
	env%os_data = os_data
	allocate (env%var_list)
	if (present (var_list)) then
	call env%var_list%init_snapshot (var_list, follow_link=.true.)
	env%var_list_is_set = .true.
	end if
	if (present (beam_structure)) then
	env%beam_structure = beam_structure
	end if
	end subroutine process_environment_init

	@ %def process_environment_init
	@ Indicate whether a variable list has been provided upon initialization.
	<<Process config: process environment: TBP>>=
	procedure :: got_var_list => process_environment_got_var_list
	<<Process config: procedures>>=
	function process_environment_got_var_list (env) result (flag)
	class(process_environment_t), intent(in) :: env
	logical :: flag
	flag = env%var_list_is_set
	end function process_environment_got_var_list

	@ %def process_environment_got_var_list
	@ Return a pointer to the variable list.
	<<Process config: process environment: TBP>>=
	procedure :: get_var_list_ptr => process_environment_get_var_list_ptr
	<<Process config: procedures>>=
	function process_environment_get_var_list_ptr (env) result (var_list)
	class(process_environment_t), intent(in) :: env
	type(var_list_t), pointer :: var_list
	var_list => env%var_list
	end function process_environment_get_var_list_ptr

	@ %def process_environment_get_var_list_ptr
	@ Return a pointer to the model, if it exists.
	<<Process config: process environment: TBP>>=
	procedure :: get_model_ptr => process_environment_get_model_ptr
	<<Process config: procedures>>=
	function process_environment_get_model_ptr (env) result (model)
	class(process_environment_t), intent(in) :: env
	type(model_t), pointer :: model
	model => env%model
	end function process_environment_get_model_ptr

	@ %def process_environment_get_model_ptr
	@ Return the process library pointer.
	<<Process config: process environment: TBP>>=
	procedure :: get_lib_ptr => process_environment_get_lib_ptr
	<<Process config: procedures>>=
	function process_environment_get_lib_ptr (env) result (lib)
	class(process_environment_t), intent(inout) :: env
	type(process_library_t), pointer :: lib
	lib => env%lib
	end function process_environment_get_lib_ptr

	@ %def process_environment_get_lib_ptr
	@ Clear the process library pointer, in case the library is deleted.
	<<Process config: process environment: TBP>>=
	procedure :: reset_lib_ptr => process_environment_reset_lib_ptr
	<<Process config: procedures>>=
	subroutine process_environment_reset_lib_ptr (env)
	class(process_environment_t), intent(inout) :: env
	env%lib => null ()
	end subroutine process_environment_reset_lib_ptr

	@ %def process_environment_reset_lib_ptr
	@ Check whether the process library has changed, in case the library is
	recompiled, etc.
	<<Process config: process environment: TBP>>=
	procedure :: check_lib_sanity => process_environment_check_lib_sanity
	<<Process config: procedures>>=
	subroutine process_environment_check_lib_sanity (env, meta)
	class(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	if (associated (env%lib)) then
	if (env%lib%get_update_counter () /= meta%lib_update_counter) then
	call msg_fatal ("Process '" // char (meta%id) &
	// "': library has been recompiled after integration")
	end if
	end if
	end subroutine process_environment_check_lib_sanity

	@ %def process_environment_check_lib_sanity
	@ Fill the [[data]] block using the appropriate process-library access entry.
	<<Process config: process environment: TBP>>=
	procedure :: fill_process_constants => &
	process_environment_fill_process_constants
	<<Process config: procedures>>=
	subroutine process_environment_fill_process_constants &
	(env, id, i_component, data)
	class(process_environment_t), intent(in) :: env
	type(string_t), intent(in) :: id
	integer, intent(in) :: i_component
	type(process_constants_t), intent(out) :: data
	call env%lib%fill_constants (id, i_component, data)
	end subroutine process_environment_fill_process_constants

	@ %def process_environment_fill_process_constants
	@ Return the entire beam structure.
	<<Process config: process environment: TBP>>=
	procedure :: get_beam_structure => process_environment_get_beam_structure
	<<Process config: procedures>>=
	function process_environment_get_beam_structure (env) result (beam_structure)
	class(process_environment_t), intent(in) :: env
	type(beam_structure_t) :: beam_structure
	beam_structure = env%beam_structure
	end function process_environment_get_beam_structure

	@ %def process_environment_get_beam_structure
	@ Check the beam structure for PDFs.
	<<Process config: process environment: TBP>>=
	procedure :: has_pdfs => process_environment_has_pdfs
	<<Process config: procedures>>=
	function process_environment_has_pdfs (env) result (flag)
	class(process_environment_t), intent(in) :: env
	logical :: flag
	flag = env%beam_structure%has_pdf ()
	end function process_environment_has_pdfs

	@ %def process_environment_has_pdfs
	@ Check the beam structure for polarized beams.
	<<Process config: process environment: TBP>>=
	procedure :: has_polarized_beams => process_environment_has_polarized_beams
	<<Process config: procedures>>=
	function process_environment_has_polarized_beams (env) result (flag)
	class(process_environment_t), intent(in) :: env
	logical :: flag
	flag = env%beam_structure%has_polarized_beams ()
	end function process_environment_has_polarized_beams

	@ %def process_environment_has_polarized_beams
	@ Return a copy of the OS data block.
	<<Process config: process environment: TBP>>=
	procedure :: get_os_data => process_environment_get_os_data
	<<Process config: procedures>>=
	function process_environment_get_os_data (env) result (os_data)
	class(process_environment_t), intent(in) :: env
	type(os_data_t) :: os_data
	os_data = env%os_data
	end function process_environment_get_os_data

	@ %def process_environment_get_os_data
	@
	\subsection{Metadata}
	This information describes the process. It is fixed upon initialization.

	The [[id]] string is the name of the process object, as given by the
	user. The matrix element generator will use this string for naming
	Fortran procedures and types, so it should qualify as a Fortran name.

	The [[num_id]] is meaningful if nonzero. It is used for communication
	with external programs or file standards which do not support string IDs.

	The [[run_id]] string distinguishes among several runs for the same
	process. It identifies process instances with respect to adapted
	integration grids and similar run-specific data. The run ID is kept
	when copying processes for creating instances, however, so it does not
	distinguish event samples.

	The [[lib_name]] identifies the process library where the process
	definition and the process driver are located.

	The [[lib_index]] is the index of entry in the process library that
	corresponds to the current process.

	The [[component_id]] array identifies the individual process components.

	The [[component_description]] is an array of human-readable strings
	that characterize the process components, for instance [[a, b => c, d]].

	The [[active]] mask array marks those components which are active. The others
	are skipped.
	<<Process config: public>>=
	public :: process_metadata_t
	<<Process config: types>>=
	type :: process_metadata_t
	integer :: type = PRC_UNKNOWN
	type(string_t) :: id
	integer :: num_id = 0
	type(string_t) :: run_id
	type(string_t), allocatable :: lib_name
	integer :: lib_update_counter = 0
	integer :: lib_index = 0
	integer :: n_components = 0
	type(string_t), dimension(:), allocatable :: component_id
	type(string_t), dimension(:), allocatable :: component_description
	logical, dimension(:), allocatable :: active
	contains
	<<Process config: process metadata: TBP>>
	end type process_metadata_t

	@ %def process_metadata_t
	@ Output: ID and run ID.
	We write the variable list only upon request.
	<<Process config: process metadata: TBP>>=
	procedure :: write => process_metadata_write
	<<Process config: procedures>>=
	subroutine process_metadata_write (meta, u, screen)
	class(process_metadata_t), intent(in) :: meta
	integer, intent(in) :: u
	logical, intent(in) :: screen
	integer :: i
	select case (meta%type)
	case (PRC_UNKNOWN)
	if (screen) then
	write (msg_buffer, "(A)") "Process [undefined]"
	else
	write (u, "(1x,A)") "Process [undefined]"
	end if
	return
	case (PRC_DECAY)
	if (screen) then
	write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", &
	"'", char (meta%id), "'"
	else
	write (u, "(1x,A)", advance="no") "Process [decay]:"
	end if
	case (PRC_SCATTERING)
	if (screen) then
	write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", &
	"'", char (meta%id), "'"
	else
	write (u, "(1x,A)", advance="no") "Process [scattering]:"
	end if
	case default
	call msg_bug ("process_write: undefined process type")
	end select
	if (screen) then
	call msg_message ()
	else
	write (u, "(1x,A,A,A)") "'", char (meta%id), "'"
	end if
	if (meta%num_id /= 0) then
	if (screen) then
	write (msg_buffer, "(2x,A,I0)") "ID (num) = ", meta%num_id
	call msg_message ()
	else
	write (u, "(3x,A,I0)") "ID (num) = ", meta%num_id
	end if
	end if
	if (screen) then
	if (meta%run_id /= "") then
	write (msg_buffer, "(2x,A,A,A)") "Run ID = '", &
	char (meta%run_id), "'"
	call msg_message ()
	end if
	else
	write (u, "(3x,A,A,A)") "Run ID = '", char (meta%run_id), "'"
	end if
	if (allocated (meta%lib_name)) then
	if (screen) then
	write (msg_buffer, "(2x,A,A,A)") "Library name = '", &
	char (meta%lib_name), "'"
	call msg_message ()
	else
	write (u, "(3x,A,A,A)") "Library name = '", &
	char (meta%lib_name), "'"
	end if
	else
	if (screen) then
	write (msg_buffer, "(2x,A)") "Library name = [not associated]"
	call msg_message ()
	else
	write (u, "(3x,A)") "Library name = [not associated]"
	end if
	end if
	if (screen) then
	write (msg_buffer, "(2x,A,I0)") "Process index = ", meta%lib_index
	call msg_message ()
	else
	write (u, "(3x,A,I0)") "Process index = ", meta%lib_index
	end if
	if (allocated (meta%component_id)) then
	if (screen) then
	if (any (meta%active)) then
	write (msg_buffer, "(2x,A)") "Process components:"
	else
	write (msg_buffer, "(2x,A)") "Process components: [none]"
	end if
	call msg_message ()
	else
	write (u, "(3x,A)") "Process components:"
	end if
	do i = 1, size (meta%component_id)
	if (.not. meta%active(i)) cycle
	if (screen) then
	write (msg_buffer, "(4x,I0,9A)") i, ": '", &
	char (meta%component_id (i)), "': ", &
	char (meta%component_description (i))
	call msg_message ()
	else
	write (u, "(5x,I0,9A)") i, ": '", &
	char (meta%component_id (i)), "': ", &
	char (meta%component_description (i))
	end if
	end do
	end if
	if (screen) then
	write (msg_buffer, "(A)") repeat ("-", 72)
	call msg_message ()
	else
	call write_separator (u)
	end if
	end subroutine process_metadata_write

	@ %def process_metadata_write
	@ Short output: list components.
	<<Process config: process metadata: TBP>>=
	procedure :: show => process_metadata_show
	<<Process config: procedures>>=
	subroutine process_metadata_show (meta, u, model_name)
	class(process_metadata_t), intent(in) :: meta
	integer, intent(in) :: u
	type(string_t), intent(in) :: model_name
	integer :: i
	select case (meta%type)
	case (PRC_UNKNOWN)
	write (u, "(A)") "Process: [undefined]"
	return
	case default
	write (u, "(A)", advance="no") "Process:"
	end select
	write (u, "(1x,A)", advance="no") char (meta%id)
	select case (meta%num_id)
	case (0)
	case default
	write (u, "(1x,'(',I0,')')", advance="no") meta%num_id
	end select
	select case (char (model_name))
	case ("")
	case default
	write (u, "(1x,'[',A,']')", advance="no") char (model_name)
	end select
	write (u, *)
	if (allocated (meta%component_id)) then
	do i = 1, size (meta%component_id)
	if (meta%active(i)) then
	write (u, "(2x,I0,':',1x,A)") i, &
	char (meta%component_description (i))
	end if
	end do
	end if
	end subroutine process_metadata_show

	@ %def process_metadata_show
	@ Initialize. Find process ID and run ID.

	Also find the process ID in the process library and retrieve some metadata from
	there.
	<<Process config: process metadata: TBP>>=
	procedure :: init => process_metadata_init
	<<Process config: procedures>>=
	subroutine process_metadata_init (meta, id, lib, var_list)
	class(process_metadata_t), intent(out) :: meta
	type(string_t), intent(in) :: id
	type(process_library_t), intent(in), target :: lib
	type(var_list_t), intent(in) :: var_list
	select case (lib%get_n_in (id))
	case (1); meta%type = PRC_DECAY
	case (2); meta%type = PRC_SCATTERING
	case default
	call msg_bug ("Process '" // char (id) // "': impossible n_in")
	end select
	meta%id = id
	meta%run_id = var_list%get_sval (var_str ("$run_id"))
	allocate (meta%lib_name)
	meta%lib_name = lib%get_name ()
	meta%lib_update_counter = lib%get_update_counter ()
	if (lib%contains (id)) then
	meta%lib_index = lib%get_entry_index (id)
	meta%num_id = lib%get_num_id (id)
	call lib%get_component_list (id, meta%component_id)
	meta%n_components = size (meta%component_id)
	call lib%get_component_description_list &
	(id, meta%component_description)
	allocate (meta%active (meta%n_components), source = .true.)
	else
	call msg_fatal ("Process library does not contain process '" &
	// char (id) // "'")
	end if
	if (.not. lib%is_active ()) then
	call msg_bug ("Process init: inactive library not handled yet")
	end if
	end subroutine process_metadata_init

	@ %def process_metadata_init
	@ Mark a component as inactive.
	<<Process config: process metadata: TBP>>=
	procedure :: deactivate_component => process_metadata_deactivate_component
	<<Process config: procedures>>=
	subroutine process_metadata_deactivate_component (meta, i)
	class(process_metadata_t), intent(inout) :: meta
	integer, intent(in) :: i
	call msg_message ("Process component '" &
	// char (meta%component_id(i)) // "': matrix element vanishes")
	meta%active(i) = .false.
	end subroutine process_metadata_deactivate_component

	@ %def process_metadata_deactivate_component
	@
	\subsection{Phase-space configuration}
	A process can have a number of independent phase-space configuration entries,
	depending on the process definition and evaluation algorithm. Each entry
	holds various configuration-parameter data and the actual [[phs_config_t]]
	record, which can vary in concrete type.
	<<Process config: public>>=
	public :: process_phs_config_t
	<<Process config: types>>=
	type :: process_phs_config_t
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defs
	class(phs_config_t), allocatable :: phs_config
	contains
	<<Process config: process phs config: TBP>>
	end type process_phs_config_t

	@ %def process_phs_config_t
	@ Output, DTIO compatible.
	<<Process config: process phs config: TBP>>=
	procedure :: write => process_phs_config_write
	procedure :: write_formatted => process_phs_config_write_formatted
	! generic :: write (formatted) => write_formatted
	<<Process config: procedures>>=
	subroutine process_phs_config_write (phs_config, unit)
	class(process_phs_config_t), intent(in) :: phs_config
	integer, intent(in), optional :: unit
	integer :: u, iostat
	integer, dimension(:), allocatable :: v_list
	character(0) :: iomsg
	u = given_output_unit (unit)
	allocate (v_list (0))
	call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
	end subroutine process_phs_config_write

	@ %def process_phs_config_write
	@ DTIO standard write.
	<<Process config: procedures>>=
	subroutine process_phs_config_write_formatted &
	(dtv, unit, iotype, v_list, iostat, iomsg)
	class(process_phs_config_t), intent(in) :: dtv
	integer, intent(in) :: unit
	character(*), intent(in) :: iotype
	integer, dimension(:), intent(in) :: v_list
	integer, intent(out) :: iostat
	character(*), intent(inout) :: iomsg
	associate (phs_config => dtv)
	write (unit, "(1x, A)") "Phase-space configuration entry:"
	call phs_config%phs_par%write (unit)
	call phs_config%mapping_defs%write (unit)
	end associate
	iostat = 0
	end subroutine process_phs_config_write_formatted

	@ %def process_phs_config_write_formatted
	@
	\subsection{Beam configuration}
	The object [[data]] holds all details about the initial beam
	configuration. The allocatable array [[sf]] holds the structure-function
	configuration blocks. There are [[n_strfun]] entries in the
	structure-function chain (not counting the initial beam object). We
	maintain [[n_channel]] independent parameterizations of this chain.
	If this is greater than zero, we need a multi-channel sampling
	algorithm, where for each point one channel is selected to generate
	kinematics.

	The number of parameters that are required for generating a
	structure-function chain is [[n_sfpar]].

	The flag [[azimuthal_dependence]] tells whether the process setup is
	symmetric about the beam axis in the c.m.\ system. This implies that
	there is no transversal beam polarization. The flag [[lab_is_cm]] is
	obvious.
	<<Process config: public>>=
	public :: process_beam_config_t
	<<Process config: types>>=
	type :: process_beam_config_t
	type(beam_data_t) :: data
	integer :: n_strfun = 0
	integer :: n_channel = 1
	integer :: n_sfpar = 0
	type(sf_config_t), dimension(:), allocatable :: sf
	type(sf_channel_t), dimension(:), allocatable :: sf_channel
	logical :: azimuthal_dependence = .false.
	logical :: lab_is_cm = .true.
	character(32) :: md5sum = ""
	logical :: sf_trace = .false.
	type(string_t) :: sf_trace_file
	contains
	<<Process config: process beam config: TBP>>
	end type process_beam_config_t

	@ %def process_beam_config_t
	@ Here we write beam data only if they are actually used.

	The [[verbose]] flag is passed to the beam-data writer.
	<<Process config: process beam config: TBP>>=
	procedure :: write => process_beam_config_write
	<<Process config: procedures>>=
	subroutine process_beam_config_write (object, unit, verbose)
	class(process_beam_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i, c
	u = given_output_unit (unit)
	call object%data%write (u, verbose = verbose)
	if (object%data%initialized) then
	write (u, "(3x,A,L1)") "Azimuthal dependence = ", &
	object%azimuthal_dependence
	write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", &
	object%lab_is_cm
	if (object%md5sum /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", &
	object%md5sum, "'"
	end if
	if (allocated (object%sf)) then
	do i = 1, size (object%sf)
	call object%sf(i)%write (u)
	end do
	if (any_sf_channel_has_mapping (object%sf_channel)) then
	write (u, "(1x,A,L1)") "Structure-function mappings per channel:"
	do c = 1, object%n_channel
	write (u, "(3x,I0,':')", advance="no") c
	call object%sf_channel(c)%write (u)
	end do
	end if
	end if
	end if
	end subroutine process_beam_config_write

	@ %def process_beam_config_write
	@ The beam data have a finalizer. We assume that there is none for the
	structure-function data.
	<<Process config: process beam config: TBP>>=
	procedure :: final => process_beam_config_final
	<<Process config: procedures>>=
	subroutine process_beam_config_final (object)
	class(process_beam_config_t), intent(inout) :: object
	call object%data%final ()
	end subroutine process_beam_config_final

	@ %def process_beam_config_final
	@ Initialize the beam setup with a given beam structure object.
	<<Process config: process beam config: TBP>>=
	procedure :: init_beam_structure => process_beam_config_init_beam_structure
	<<Process config: procedures>>=
	subroutine process_beam_config_init_beam_structure &
	(beam_config, beam_structure, sqrts, model, decay_rest_frame)
	class(process_beam_config_t), intent(out) :: beam_config
	type(beam_structure_t), intent(in) :: beam_structure
	logical, intent(in), optional :: decay_rest_frame
	real(default), intent(in) :: sqrts
	class(model_data_t), intent(in), target :: model
	call beam_config%data%init_structure (beam_structure, &
	sqrts, model, decay_rest_frame)
	beam_config%lab_is_cm = beam_config%data%lab_is_cm
	end subroutine process_beam_config_init_beam_structure

	@ %def process_beam_config_init_beam_structure
	@ Initialize the beam setup for a scattering process with specified
	flavor combination, other properties taken from the beam structure
	object (if any).
	<<Process config: process beam config: TBP>>=
	procedure :: init_scattering => process_beam_config_init_scattering
	<<Process config: procedures>>=
	subroutine process_beam_config_init_scattering &
	(beam_config, flv_in, sqrts, beam_structure)
	class(process_beam_config_t), intent(out) :: beam_config
	type(flavor_t), dimension(2), intent(in) :: flv_in
	real(default), intent(in) :: sqrts
	type(beam_structure_t), intent(in), optional :: beam_structure
	if (present (beam_structure)) then
	if (beam_structure%polarized ()) then
	call beam_config%data%init_sqrts (sqrts, flv_in, &
	beam_structure%get_smatrix (), beam_structure%get_pol_f ())
	else
	call beam_config%data%init_sqrts (sqrts, flv_in)
	end if
	else
	call beam_config%data%init_sqrts (sqrts, flv_in)
	end if
	end subroutine process_beam_config_init_scattering

	@ %def process_beam_config_init_scattering
	@ Initialize the beam setup for a decay process with specified flavor,
	other properties taken from the beam structure object (if present).

	For a cascade decay, we set
	[[rest_frame]] to false, indicating a event-wise varying momentum.
	The beam data itself are initialized for the particle at rest.
	<<Process config: process beam config: TBP>>=
	procedure :: init_decay => process_beam_config_init_decay
	<<Process config: procedures>>=
	subroutine process_beam_config_init_decay &
	(beam_config, flv_in, rest_frame, beam_structure)
	class(process_beam_config_t), intent(out) :: beam_config
	type(flavor_t), dimension(1), intent(in) :: flv_in
	logical, intent(in), optional :: rest_frame
	type(beam_structure_t), intent(in), optional :: beam_structure
	if (present (beam_structure)) then
	if (beam_structure%polarized ()) then
	call beam_config%data%init_decay (flv_in, &
	beam_structure%get_smatrix (), beam_structure%get_pol_f (), &
	rest_frame = rest_frame)
	else
	call beam_config%data%init_decay (flv_in, rest_frame = rest_frame)
	end if
	else
	call beam_config%data%init_decay (flv_in, &
	rest_frame = rest_frame)
	end if
	beam_config%lab_is_cm = beam_config%data%lab_is_cm
	end subroutine process_beam_config_init_decay

	@ %def process_beam_config_init_decay
	@ Print an informative message.
	<<Process config: process beam config: TBP>>=
	procedure :: startup_message => process_beam_config_startup_message
	<<Process config: procedures>>=
	subroutine process_beam_config_startup_message &
	(beam_config, unit, beam_structure)
	class(process_beam_config_t), intent(in) :: beam_config
	integer, intent(in), optional :: unit
	type(beam_structure_t), intent(in), optional :: beam_structure
	integer :: u
	u = free_unit ()
	open (u, status="scratch", action="readwrite")
	if (present (beam_structure)) then
	call beam_structure%write (u)
	end if
	call beam_config%data%write (u)
	rewind (u)
	do
	read (u, "(1x,A)", end=1) msg_buffer
	call msg_message ()
	end do
	1 continue
	close (u)
	end subroutine process_beam_config_startup_message

	@ %def process_beam_config_startup_message
	@ Allocate the structure-function array.
	<<Process config: process beam config: TBP>>=
	procedure :: init_sf_chain => process_beam_config_init_sf_chain
	<<Process config: procedures>>=
	subroutine process_beam_config_init_sf_chain &
	(beam_config, sf_config, sf_trace_file)
	class(process_beam_config_t), intent(inout) :: beam_config
	type(sf_config_t), dimension(:), intent(in) :: sf_config
	type(string_t), intent(in), optional :: sf_trace_file
	integer :: i
	beam_config%n_strfun = size (sf_config)
	allocate (beam_config%sf (beam_config%n_strfun))
	do i = 1, beam_config%n_strfun
	associate (sf => sf_config(i))
	call beam_config%sf(i)%init (sf%i, sf%data)
	if (.not. sf%data%is_generator ()) then
	beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par ()
	end if
	end associate
	end do
	if (present (sf_trace_file)) then
	beam_config%sf_trace = .true.
	beam_config%sf_trace_file = sf_trace_file
	end if
	end subroutine process_beam_config_init_sf_chain

	@ %def process_beam_config_init_sf_chain
	@ Allocate the structure-function mapping channel array, given the
	requested number of channels.
	<<Process config: process beam config: TBP>>=
	procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels
	<<Process config: procedures>>=
	subroutine process_beam_config_allocate_sf_channels (beam_config, n_channel)
	class(process_beam_config_t), intent(inout) :: beam_config
	integer, intent(in) :: n_channel
	beam_config%n_channel = n_channel
	call allocate_sf_channels (beam_config%sf_channel, &
	n_channel = n_channel, &
	n_strfun = beam_config%n_strfun)
	end subroutine process_beam_config_allocate_sf_channels

	@ %def process_beam_config_allocate_sf_channels
	@ Set a structure-function mapping channel for an array of
	structure-function entries, for a single channel. (The default is no mapping.)
	<<Process config: process beam config: TBP>>=
	procedure :: set_sf_channel => process_beam_config_set_sf_channel
	<<Process config: procedures>>=
	subroutine process_beam_config_set_sf_channel (beam_config, c, sf_channel)
	class(process_beam_config_t), intent(inout) :: beam_config
	integer, intent(in) :: c
	type(sf_channel_t), intent(in) :: sf_channel
	beam_config%sf_channel(c) = sf_channel
	end subroutine process_beam_config_set_sf_channel

	@ %def process_beam_config_set_sf_channel
	@ Print an informative startup message.
	<<Process config: process beam config: TBP>>=
	procedure :: sf_startup_message => process_beam_config_sf_startup_message
	<<Process config: procedures>>=
	subroutine process_beam_config_sf_startup_message &
	(beam_config, sf_string, unit)
	class(process_beam_config_t), intent(in) :: beam_config
	type(string_t), intent(in) :: sf_string
	integer, intent(in), optional :: unit
	if (beam_config%n_strfun > 0) then
	call msg_message ("Beam structure: " // char (sf_string), unit = unit)
	write (msg_buffer, "(A,3(1x,I0,1x,A))") &
	"Beam structure:", &
	beam_config%n_channel, "channels,", &
	beam_config%n_sfpar, "dimensions"
	call msg_message (unit = unit)
	if (beam_config%sf_trace) then
	call msg_message ("Beam structure: tracing &
	&values in '" // char (beam_config%sf_trace_file) // "'")
	end if
	end if
	end subroutine process_beam_config_sf_startup_message

	@ %def process_beam_config_startup_message
	@ Return the PDF set currently in use, if any. This should be unique,
	so we scan the structure functions until we get a nonzero number.

	(This implies that if the PDF set is not unique (e.g., proton and
	photon structure used together), this does not work correctly.)
	<<Process config: process beam config: TBP>>=
	procedure :: get_pdf_set => process_beam_config_get_pdf_set
	<<Process config: procedures>>=
	function process_beam_config_get_pdf_set (beam_config) result (pdf_set)
	class(process_beam_config_t), intent(in) :: beam_config
	integer :: pdf_set
	integer :: i
	pdf_set = 0
	if (allocated (beam_config%sf)) then
	do i = 1, size (beam_config%sf)
	pdf_set = beam_config%sf(i)%get_pdf_set ()
	if (pdf_set /= 0) return
	end do
	end if
	end function process_beam_config_get_pdf_set

	@ %def process_beam_config_get_pdf_set
	@ Return the beam file.
	<<Process config: process beam config: TBP>>=
	procedure :: get_beam_file => process_beam_config_get_beam_file
	<<Process config: procedures>>=
	function process_beam_config_get_beam_file (beam_config) result (file)
	class(process_beam_config_t), intent(in) :: beam_config
	type(string_t) :: file
	integer :: i
	file = ""
	if (allocated (beam_config%sf)) then
	do i = 1, size (beam_config%sf)
	file = beam_config%sf(i)%get_beam_file ()
	if (file /= "") return
	end do
	end if
	end function process_beam_config_get_beam_file

	@ %def process_beam_config_get_beam_file
	@ Compute the MD5 sum for the complete beam setup. We rely on the
	default output of [[write]] to contain all relevant data.

	This is done only once, when the MD5 sum is still empty.
	<<Process config: process beam config: TBP>>=
	procedure :: compute_md5sum => process_beam_config_compute_md5sum
	<<Process config: procedures>>=
	subroutine process_beam_config_compute_md5sum (beam_config)
	class(process_beam_config_t), intent(inout) :: beam_config
	integer :: u
	if (beam_config%md5sum == "") then
	u = free_unit ()
	open (u, status = "scratch", action = "readwrite")
	call beam_config%write (u, verbose=.true.)
	rewind (u)
	beam_config%md5sum = md5sum (u)
	close (u)
	end if
	end subroutine process_beam_config_compute_md5sum

	@ %def process_beam_config_compute_md5sum
	@
	<<Process config: process beam config: TBP>>=
	procedure :: get_md5sum => process_beam_config_get_md5sum
	<<Process config: procedures>>=
	pure function process_beam_config_get_md5sum (beam_config) result (md5)
	character(32) :: md5
	class(process_beam_config_t), intent(in) :: beam_config
	md5 = beam_config%md5sum
	end function process_beam_config_get_md5sum

	@ %def process_beam_config_get_md5sum
	@
	<<Process config: process beam config: TBP>>=
	procedure :: has_structure_function => process_beam_config_has_structure_function
	<<Process config: procedures>>=
	pure function process_beam_config_has_structure_function (beam_config) result (has_sf)
	logical :: has_sf
	class(process_beam_config_t), intent(in) :: beam_config
	has_sf = beam_config%n_strfun > 0
	end function process_beam_config_has_structure_function

	@ %def process_beam_config_has_structure_function
	@
	\subsection{Process components}
	A process component is an individual contribution to a process
	(scattering or decay) which needs not be physical. The sum over all
	components should be physical.

	The [[index]] indentifies this component within its parent process.

	The actual process component is stored in the [[core]] subobject. We
	use a polymorphic subobject instead of an extension of
	[[process_component_t]], because the individual entries in the array
	of process components can have different types. In short,
	[[process_component_t]] is a wrapper for the actual process variants.

	If the [[active]] flag is false, we should skip this component. This happens
	if the associated process has vanishing matrix element.

	The index array [[i_term]] points to the individual terms generated by
	this component. The indices refer to the parent process.

	The index [[i_mci]] is the index of the MC integrator and parameter set which
	are associated to this process component.
	<<Process config: public>>=
	public :: process_component_t
	<<Process config: types>>=
	type :: process_component_t
	type(process_component_def_t), pointer :: config => null ()
	integer :: index = 0
	logical :: active = .false.
	integer, dimension(:), allocatable :: i_term
	integer :: i_mci = 0
	class(phs_config_t), allocatable :: phs_config
	character(32) :: md5sum_phs = ""
	integer :: component_type = COMP_DEFAULT
	contains
	<<Process config: process component: TBP>>
	end type process_component_t

	@ %def process_component_t
	@ Finalizer. The MCI template may (potentially) need a finalizer. The process
	configuration finalizer may include closing an open scratch file.
	<<Process config: process component: TBP>>=
	procedure :: final => process_component_final
	<<Process config: procedures>>=
	subroutine process_component_final (object)
	class(process_component_t), intent(inout) :: object
	if (allocated (object%phs_config)) then
	call object%phs_config%final ()
	end if
	end subroutine process_component_final

	@ %def process_component_final
	@ The meaning of [[verbose]] depends on the process variant.
	<<Process config: process component: TBP>>=
	procedure :: write => process_component_write
	<<Process config: procedures>>=
	subroutine process_component_write (object, unit)
	class(process_component_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%config)) then
	write (u, "(1x,A,I0)") "Component #", object%index
	call object%config%write (u)
	if (object%md5sum_phs /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (phs) = '", &
	object%md5sum_phs, "'"
	end if
	else
	write (u, "(1x,A)") "Process component: [not allocated]"
	end if
	if (.not. object%active) then
	write (u, "(1x,A)") "[Inactive]"
	return
	end if
	write (u, "(1x,A)") "Referenced data:"
	if (allocated (object%i_term)) then
	write (u, "(3x,A,999(1x,I0))") "Terms =", &
	object%i_term
	else
	write (u, "(3x,A)") "Terms = [undefined]"
	end if
	if (object%i_mci /= 0) then
	write (u, "(3x,A,I0)") "MC dataset = ", object%i_mci
	else
	write (u, "(3x,A)") "MC dataset = [undefined]"
	end if
	if (allocated (object%phs_config)) then
	call object%phs_config%write (u)
	end if
	end subroutine process_component_write

	@ %def process_component_write
	@ Initialize the component.
	<<Process config: process component: TBP>>=
	procedure :: init => process_component_init
	<<Process config: procedures>>=
	subroutine process_component_init (component, &
	i_component, env, meta, config, &
	active, &
	phs_config_template)
	class(process_component_t), intent(out) :: component
	integer, intent(in) :: i_component
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	type(process_config_data_t), intent(in) :: config
	logical, intent(in) :: active
	class(phs_config_t), intent(in), allocatable :: phs_config_template

	type(process_constants_t) :: data

	component%index = i_component
	component%config => &
	config%process_def%get_component_def_ptr (i_component)

	component%active = active
	if (component%active) then
	allocate (component%phs_config, source = phs_config_template)
	call env%fill_process_constants (meta%id, i_component, data)
	call component%phs_config%init (data, config%model)
	end if
	end subroutine process_component_init

	@ %def process_component_init
	@
	<<Process config: process component: TBP>>=
	procedure :: is_active => process_component_is_active
	<<Process config: procedures>>=
	elemental function process_component_is_active (component) result (active)
	logical :: active
	class(process_component_t), intent(in) :: component
	active = component%active
	end function process_component_is_active

	@ %def process_component_is_active
	@ Finalize the phase-space configuration.
	<<Process config: process component: TBP>>=
	procedure :: configure_phs => process_component_configure_phs
	<<Process config: procedures>>=
	subroutine process_component_configure_phs &
	(component, sqrts, beam_config, rebuild, &
	ignore_mismatch, subdir)
	class(process_component_t), intent(inout) :: component
	real(default), intent(in) :: sqrts
	type(process_beam_config_t), intent(in) :: beam_config
	logical, intent(in), optional :: rebuild
	logical, intent(in), optional :: ignore_mismatch
	type(string_t), intent(in), optional :: subdir
	logical :: no_strfun
	integer :: nlo_type
	no_strfun = beam_config%n_strfun == 0
	nlo_type = component%config%get_nlo_type ()
	call component%phs_config%configure (sqrts, &
	azimuthal_dependence = beam_config%azimuthal_dependence, &
	sqrts_fixed = no_strfun, &
	lab_is_cm = beam_config%lab_is_cm .and. no_strfun, &
	rebuild = rebuild, ignore_mismatch = ignore_mismatch, &
	nlo_type = nlo_type, &
	subdir = subdir)
	end subroutine process_component_configure_phs

	@ %def process_component_configure_phs
	@ The process component possesses two MD5 sums: the checksum of the
	component definition, which should be available when the component is
	initialized, and the phase-space MD5 sum, which is available after
	configuration.
	<<Process config: process component: TBP>>=
	procedure :: compute_md5sum => process_component_compute_md5sum
	<<Process config: procedures>>=
	subroutine process_component_compute_md5sum (component)
	class(process_component_t), intent(inout) :: component
	component%md5sum_phs = component%phs_config%get_md5sum ()
	end subroutine process_component_compute_md5sum

	@ %def process_component_compute_md5sum
	@ Match phase-space channels with structure-function channels, where
	applicable.

	This calls a method of the [[phs_config]] phase-space implementation.
	<<Process config: process component: TBP>>=
	procedure :: collect_channels => process_component_collect_channels
	<<Process config: procedures>>=
	subroutine process_component_collect_channels (component, coll)
	class(process_component_t), intent(inout) :: component
	type(phs_channel_collection_t), intent(inout) :: coll
	call component%phs_config%collect_channels (coll)
	end subroutine process_component_collect_channels

	@ %def process_component_collect_channels
	@
	<<Process config: process component: TBP>>=
	procedure :: get_config => process_component_get_config
	<<Process config: procedures>>=
	function process_component_get_config (component) &
	result (config)
	type(process_component_def_t) :: config
	class(process_component_t), intent(in) :: component
	config = component%config
	end function process_component_get_config

	@ %def process_component_get_config
	@
	<<Process config: process component: TBP>>=
	procedure :: get_md5sum => process_component_get_md5sum
	<<Process config: procedures>>=
	pure function process_component_get_md5sum (component) result (md5)
	type(string_t) :: md5
	class(process_component_t), intent(in) :: component
	md5 = component%config%get_md5sum () // component%md5sum_phs
	end function process_component_get_md5sum

	@ %def process_component_get_md5sum
	@ Return the number of phase-space parameters.
	<<Process config: process component: TBP>>=
	procedure :: get_n_phs_par => process_component_get_n_phs_par
	<<Process config: procedures>>=
	function process_component_get_n_phs_par (component) result (n_par)
	class(process_component_t), intent(in) :: component
	integer :: n_par
	n_par = component%phs_config%get_n_par ()
	end function process_component_get_n_phs_par

	@ %def process_component_get_n_phs_par
	@
	<<Process config: process component: TBP>>=
	procedure :: get_phs_config => process_component_get_phs_config
	<<Process config: procedures>>=
	subroutine process_component_get_phs_config (component, phs_config)
	class(process_component_t), intent(in), target :: component
	class(phs_config_t), intent(out), pointer :: phs_config
	phs_config => component%phs_config
	end subroutine process_component_get_phs_config

	@ %def process_component_get_phs_config
	@
	<<Process config: process component: TBP>>=
	procedure :: get_nlo_type => process_component_get_nlo_type
	<<Process config: procedures>>=
	elemental function process_component_get_nlo_type (component) result (nlo_type)
	integer :: nlo_type
	class(process_component_t), intent(in) :: component
	nlo_type = component%config%get_nlo_type ()
	end function process_component_get_nlo_type

	@ %def process_component_get_nlo_type
	@
	<<Process config: process component: TBP>>=
	procedure :: needs_mci_entry => process_component_needs_mci_entry
	<<Process config: procedures>>=
	function process_component_needs_mci_entry (component, combined_integration) result (value)
	logical :: value
	class(process_component_t), intent(in) :: component
	logical, intent(in), optional :: combined_integration
	value = component%active
	if (present (combined_integration)) then
	if (combined_integration) &
	value = value .and. component%component_type <= COMP_MASTER
	end if
	end function process_component_needs_mci_entry

	@ %def process_component_needs_mci_entry
	@
	<<Process config: process component: TBP>>=
	procedure :: can_be_integrated => process_component_can_be_integrated
	<<Process config: procedures>>=
	elemental function process_component_can_be_integrated (component) result (active)
	logical :: active
	class(process_component_t), intent(in) :: component
	active = component%config%can_be_integrated ()
	end function process_component_can_be_integrated

	@ %def process_component_can_be_integrated
	@
	\subsection{Process terms}
	For straightforward tree-level calculations, each process component
	corresponds to a unique elementary interaction. However, in the case
	of NLO calculations with subtraction terms, a process component may
	split into several separate contributions to the scattering, which are
	qualified by interactions with distinct kinematics and particle
	content. We represent their configuration as [[process_term_t]]
	objects, the actual instances will be introduced below as
	[[term_instance_t]]. In any case, the process term contains an
	elementary interaction with a definite quantum-number and momentum
	content.

	The index [[i_term_global]] identifies the term relative to the
	process.

	The index [[i_component]] identifies the process component which
	generates this term, relative to the parent process.

	The index [[i_term]] identifies the term relative to the process
	component (not the process).

	The [[data]] subobject holds all process constants.

	The number of allowed flavor/helicity/color combinations is stored as
	[[n_allowed]]. This is the total number of independent entries in the
	density matrix. For each combination, the index of the flavor,
	helicity, and color state is stored in the arrays [[flv]], [[hel]],
	and [[col]], respectively.

	The flag [[rearrange]] is true if we need to rearrange the particles of the
	hard interaction, to obtain the effective parton state.

	The interaction [[int]] holds the quantum state for the (resolved) hard
	interaction, the parent-child relations of the particles, and their momenta.
	The momenta are not filled yet; this is postponed to copies of [[int]] which
	go into the process instances.

	If recombination is in effect, we should allocate [[int_eff]] to describe the
	rearranged partonic state.

	This type is public only for use in a unit test.
	<<Process config: public>>=
	public :: process_term_t
	<<Process config: types>>=
	type :: process_term_t
	integer :: i_term_global = 0
	integer :: i_component = 0
	integer :: i_term = 0
	integer :: i_sub = 0
	integer :: i_core = 0
	integer :: n_allowed = 0
	type(process_constants_t) :: data
	real(default) :: alpha_s = 0
	integer, dimension(:), allocatable :: flv, hel, col
	integer :: n_sub, n_sub_color, n_sub_spin
	type(interaction_t) :: int
	type(interaction_t), pointer :: int_eff => null ()
	contains
	<<Process config: process term: TBP>>
	end type process_term_t

	@ %def process_term_t
	@ For the output, we skip the process constants and the tables of
	allowed quantum numbers. Those can also be read off from the
	interaction object.
	<<Process config: process term: TBP>>=
	procedure :: write => process_term_write
	<<Process config: procedures>>=
	subroutine process_term_write (term, unit)
	class(process_term_t), intent(in) :: term
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A,I0)") "Term #", term%i_term_global
	write (u, "(3x,A,I0)") "Process component index = ", &
	term%i_component
	write (u, "(3x,A,I0)") "Term index w.r.t. component = ", &
	term%i_term
	call write_separator (u)
	write (u, "(1x,A)") "Hard interaction:"
	call write_separator (u)
	call term%int%basic_write (u)
	end subroutine process_term_write

	@ %def process_term_write
	@ Write an account of all quantum number states and their current status.
	<<Process config: process term: TBP>>=
	procedure :: write_state_summary => process_term_write_state_summary
	<<Process config: procedures>>=
	subroutine process_term_write_state_summary (term, core, unit)
	class(process_term_t), intent(in) :: term
	class(prc_core_t), intent(in) :: core
	integer, intent(in), optional :: unit
	integer :: u, i, f, h, c
	type(state_iterator_t) :: it
	character :: sgn
	u = given_output_unit (unit)
	write (u, "(1x,A,I0)") "Term #", term%i_term_global
	call it%init (term%int%get_state_matrix_ptr ())
	do while (it%is_valid ())
	i = it%get_me_index ()
	f = term%flv(i)
	h = term%hel(i)
	if (allocated (term%col)) then
	c = term%col(i)
	else
	c = 1
	end if
	if (core%is_allowed (term%i_term, f, h, c)) then
	sgn = "+"
	else
	sgn = " "
	end if
	write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i
	call quantum_numbers_write (it%get_quantum_numbers (), u)
	write (u, *)
	call it%advance ()
	end do
	end subroutine process_term_write_state_summary

	@ %def process_term_write_state_summary
	@ Finalizer: the [[int]] and potentially [[int_eff]] components have a
	finalizer that we must call.
	<<Process config: process term: TBP>>=
	procedure :: final => process_term_final
	<<Process config: procedures>>=
	subroutine process_term_final (term)
	class(process_term_t), intent(inout) :: term
	call term%int%final ()
	end subroutine process_term_final

	@ %def process_term_final
	@ Initialize the term. We copy the process constants from the [[core]]
	object and set up the [[int]] hard interaction accordingly.

	The [[alpha_s]] value is useful for writing external event records. This is
	the constant value which may be overridden by an event-specific running value.
	If the model does not contain the strong coupling, the value is zero.

	The [[rearrange]] part is commented out; this or something equivalent
	could become relevant for NLO algorithms.
	<<Process config: process term: TBP>>=
	procedure :: init => process_term_init
	<<Process config: procedures>>=
	subroutine process_term_init &
	(term, i_term_global, i_component, i_term, core, model, &
	nlo_type, use_beam_pol, subtraction_method, &
	has_pdfs, n_emitters)
	class(process_term_t), intent(inout), target :: term
	integer, intent(in) :: i_term_global
	integer, intent(in) :: i_component
	integer, intent(in) :: i_term
	class(prc_core_t), intent(inout) :: core
	class(model_data_t), intent(in), target :: model
	integer, intent(in), optional :: nlo_type
	logical, intent(in), optional :: use_beam_pol
	type(string_t), intent(in), optional :: subtraction_method
	logical, intent(in), optional :: has_pdfs
	integer, intent(in), optional :: n_emitters
	class(modelpar_data_t), pointer :: alpha_s_ptr
	logical :: use_internal_color
	term%i_term_global = i_term_global
	term%i_component = i_component
	term%i_term = i_term
	call core%get_constants (term%data, i_term)
	alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas"))
	if (associated (alpha_s_ptr)) then
	term%alpha_s = alpha_s_ptr%get_real ()
	else
	term%alpha_s = -1
	end if
	use_internal_color = .false.
	if (present (subtraction_method)) &
	use_internal_color = (char (subtraction_method) == 'omega') &
	.or. (char (subtraction_method) == 'threshold')
	call term%setup_interaction (core, model, nlo_type = nlo_type, &
	pol_beams = use_beam_pol, use_internal_color = use_internal_color, &
	has_pdfs = has_pdfs, n_emitters = n_emitters)
	end subroutine process_term_init

	@ %def process_term_init
	@ We fetch the process constants which determine the quantum numbers and
	use those to create the interaction. The interaction contains
	incoming and outgoing particles, no virtuals. The incoming particles
	are parents of the outgoing ones.

	Keeping previous \whizard\ conventions, we invert the color assignment
	(but not flavor or helicity) for the incoming particles. When the
	color-flow square matrix is evaluated, this inversion is done again,
	so in the color-flow sequence we get the color assignments of the
	matrix element.

	\textbf{Why are these four subtraction entries for structure-function
	aware interactions?} Taking the soft or collinear limit of the real-emission
	matrix element, the behavior of the parton energy fractions has to be
	taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$
	are given by
	\begin{equation*}
	x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}}
	\sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}},
	\quad
	x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}}
	\sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}.
	\end{equation*}
	In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$
	and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$,
	it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$.
	Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds.
	We therefore have to distinguish four cases with the PDF assignments
	$f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$,
	$f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and
	$f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$.

	The [[n_emitters]] optional argument is provided by the caller if this term
	requires spin-correlated matrix elements, and thus involves additional
	subtractions.
	<<Process config: process term: TBP>>=
	procedure :: setup_interaction => process_term_setup_interaction
	<<Process config: procedures>>=
	subroutine process_term_setup_interaction (term, core, model, &
	nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
	class(process_term_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	class(model_data_t), intent(in), target :: model
	logical, intent(in), optional :: pol_beams
	logical, intent(in), optional :: has_pdfs
	integer, intent(in), optional :: nlo_type
	logical, intent(in), optional :: use_internal_color
	integer, intent(in), optional :: n_emitters
	integer :: n, n_tot
	type(flavor_t), dimension(:), allocatable :: flv
	type(color_t), dimension(:), allocatable :: col
	type(helicity_t), dimension(:), allocatable :: hel
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	logical :: is_pol, use_color
	integer :: nlo_t, n_sub
	is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams
	nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type
	n_tot = term%data%n_in + term%data%n_out
	call count_number_of_states ()
	term%n_allowed = n
	call compute_n_sub (n_emitters, has_pdfs)
	call fill_quantum_numbers ()
	call term%int%basic_init &
	(term%data%n_in, 0, term%data%n_out, set_relations = .true.)
	select type (core)
	class is (prc_blha_t)
	call setup_states_blha_olp ()
	type is (prc_threshold_t)
	call setup_states_threshold ()
	class is (prc_external_t)
	call setup_states_other_prc_external ()
	class default
	call setup_states_omega ()
	end select
	call term%int%freeze ()
	contains
	subroutine count_number_of_states ()
	integer :: f, h, c
	n = 0
	select type (core)
	class is (prc_external_t)
	do f = 1, term%data%n_flv
	do h = 1, term%data%n_hel
	do c = 1, term%data%n_col
	n = n + 1
	end do
	end do
	end do
	class default !!! Omega and all test cores
	do f = 1, term%data%n_flv
	do h = 1, term%data%n_hel
	do c = 1, term%data%n_col
	if (core%is_allowed (term%i_term, f, h, c)) n = n + 1
	end do
	end do
	end do
	end select
	end subroutine count_number_of_states

	subroutine compute_n_sub (n_emitters, has_pdfs)
	integer, intent(in), optional :: n_emitters
	logical, intent(in), optional :: has_pdfs
	logical :: can_have_sub
	integer :: n_sub_color, n_sub_spin
	use_color = .false.; if (present (use_internal_color)) &
	use_color = use_internal_color
	can_have_sub = nlo_t == NLO_VIRTUAL .or. &
	(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
	nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
	n_sub_color = 0; n_sub_spin = 0
	if (can_have_sub) then
	if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2
	if (nlo_t == NLO_REAL) then
	if (present (n_emitters)) then
	n_sub_spin = 6 * n_emitters
	end if
	end if
	end if
	n_sub = n_sub_color + n_sub_spin
	!!! For the virtual subtraction we also need the finite virtual contribution
	!!! corresponding to the $\epsilon^0$-pole
	if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1
	if (present (has_pdfs)) then
	if (has_pdfs &
	.and. ((nlo_t == NLO_REAL .and. can_have_sub) &
	.or. nlo_t == NLO_DGLAP)) then
	!!! necessary dummy, needs refactoring,
	!!! c.f. [[term_instance_evaluate_interaction_userdef_tree]]
	n_sub = n_sub + n_beams_rescaled
	end if
	end if
	term%n_sub = n_sub
	term%n_sub_color = n_sub_color
	term%n_sub_spin = n_sub_spin
	end subroutine compute_n_sub

	subroutine fill_quantum_numbers ()
	integer :: nn
	logical :: can_have_sub
	select type (core)
	class is (prc_external_t)
	can_have_sub = nlo_t == NLO_VIRTUAL .or. &
	(nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
	nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
	if (can_have_sub) then
	nn = (n_sub + 1) * n
	else
	nn = n
	end if
	class default
	nn = n
	end select
	allocate (term%flv (nn), term%col (nn), term%hel (nn))
	allocate (flv (n_tot), col (n_tot), hel (n_tot))
	allocate (qn (n_tot))
	end subroutine fill_quantum_numbers

	subroutine setup_states_blha_olp ()
	integer :: s, f, c, h, i
	i = 0
	associate (data => term%data)
	do s = 0, n_sub
	do f = 1, data%n_flv
	do h = 1, data%n_hel
	do c = 1, data%n_col
	i = i + 1
	term%flv(i) = f
	term%hel(i) = h
	!!! Dummy-initialization of color
	term%col(i) = c
	call flv%init (data%flv_state (:,f), model)
	call color_init_from_array (col, &
	data%col_state(:,:,c), data%ghost_flag(:,c))
	call col(1:data%n_in)%invert ()
	if (is_pol) then
	select type (core)
	type is (prc_openloops_t)
	call hel%init (data%hel_state (:,h))
	call qn%init (flv, hel, col, s)
	class default
	call msg_fatal ("Polarized beams only supported by OpenLoops")
	end select
	else
	call qn%init (flv, col, s)
	end if
	call qn%tag_hard_process ()
	call term%int%add_state (qn)
	end do
	end do
	end do
	end do
	end associate
	end subroutine setup_states_blha_olp

	subroutine setup_states_threshold ()
	integer :: s, f, c, h, i
	i = 0
	n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
	associate (data => term%data)
	do s = 0, n_sub
	do f = 1, term%data%n_flv
	do h = 1, data%n_hel
	do c = 1, data%n_col
	i = i + 1
	term%flv(i) = f
	term%hel(i) = h
	!!! Dummy-initialization of color
	term%col(i) = 1
	call flv%init (term%data%flv_state (:,f), model)
	if (is_pol) then
	call hel%init (data%hel_state (:,h))
	call qn%init (flv, hel, s)
	else
	call qn%init (flv, s)
	end if
	call qn%tag_hard_process ()
	call term%int%add_state (qn)
	end do
	end do
	end do
	end do
	end associate
	end subroutine setup_states_threshold

	subroutine setup_states_other_prc_external ()
	integer :: s, f, i, c, h
	if (is_pol) &
	call msg_fatal ("Polarized beams only supported by OpenLoops")
	i = 0
	!!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
	associate (data => term%data)
	do s = 0, n_sub
	do f = 1, data%n_flv
	do h = 1, data%n_hel
	do c = 1, data%n_col
	i = i + 1
	term%flv(i) = f
	term%hel(i) = h
	!!! Dummy-initialization of color
	term%col(i) = c
	call flv%init (data%flv_state (:,f), model)
	call color_init_from_array (col, &
	data%col_state(:,:,c), data%ghost_flag(:,c))
	call col(1:data%n_in)%invert ()
	call qn%init (flv, col, s)
	call qn%tag_hard_process ()
	call term%int%add_state (qn)
	end do
	end do
	end do
	end do
	end associate
	end subroutine setup_states_other_prc_external

	subroutine setup_states_omega ()
	integer :: f, h, c, i
	i = 0
	associate (data => term%data)
	do f = 1, data%n_flv
	do h = 1, data%n_hel
	do c = 1, data%n_col
	if (core%is_allowed (term%i_term, f, h, c)) then
	i = i + 1
	term%flv(i) = f
	term%hel(i) = h
	term%col(i) = c
	call flv%init (data%flv_state(:,f), model)
	call color_init_from_array (col, &
	data%col_state(:,:,c), &
	data%ghost_flag(:,c))
	call col(:data%n_in)%invert ()
	call hel%init (data%hel_state(:,h))
	call qn%init (flv, col, hel)
	call qn%tag_hard_process ()
	call term%int%add_state (qn)
	end if
	end do
	end do
	end do
	end associate
	end subroutine setup_states_omega

	end subroutine process_term_setup_interaction

	@ %def process_term_setup_interaction
	@
	<<Process config: process term: TBP>>=
	procedure :: get_process_constants => process_term_get_process_constants
	<<Process config: procedures>>=
	subroutine process_term_get_process_constants &
	(term, prc_constants)
	class(process_term_t), intent(inout) :: term
	type(process_constants_t), intent(out) :: prc_constants
	prc_constants = term%data
	end subroutine process_term_get_process_constants

	@ %def process_term_get_process_constants
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process call statistics}
	Very simple object for statistics. Could be moved to a more basic chapter.
	<<[[process_counter.f90]]>>=
	<<File header>>

	module process_counter

	use io_units

	<<Standard module head>>

	<<Process counter: public>>

	<<Process counter: parameters>>

	<<Process counter: types>>

	contains

	<<Process counter: procedures>>

	end module process_counter
	@ %def process_counter
	@ This object can record process calls, categorized by evaluation
	status. It is a part of the [[mci_entry]] component below.
	<<Process counter: public>>=
	public :: process_counter_t
	<<Process counter: types>>=
	type :: process_counter_t
	integer :: total = 0
	integer :: failed_kinematics = 0
	integer :: failed_cuts = 0
	integer :: has_passed = 0
	integer :: evaluated = 0
	integer :: complete = 0
	contains
	<<Process counter: process counter: TBP>>
	end type process_counter_t

	@ %def process_counter_t
	@ Here are the corresponding numeric codes:
	<<Process counter: parameters>>=
	integer, parameter, public :: STAT_UNDEFINED = 0
	integer, parameter, public :: STAT_INITIAL = 1
	integer, parameter, public :: STAT_ACTIVATED = 2
	integer, parameter, public :: STAT_BEAM_MOMENTA = 3
	integer, parameter, public :: STAT_FAILED_KINEMATICS = 4
	integer, parameter, public :: STAT_SEED_KINEMATICS = 5
	integer, parameter, public :: STAT_HARD_KINEMATICS = 6
	integer, parameter, public :: STAT_EFF_KINEMATICS = 7
	integer, parameter, public :: STAT_FAILED_CUTS = 8
	integer, parameter, public :: STAT_PASSED_CUTS = 9
	integer, parameter, public :: STAT_EVALUATED_TRACE = 10
	integer, parameter, public :: STAT_EVENT_COMPLETE = 11

	@ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED
	@ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS
	@ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS
	@ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE
	@ Output.
	<<Process counter: process counter: TBP>>=
	procedure :: write => process_counter_write
	<<Process counter: procedures>>=
	subroutine process_counter_write (object, unit)
	class(process_counter_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	if (object%total > 0) then
	write (u, "(1x,A)") "Call statistics (current run):"
	write (u, "(3x,A,I0)") "total = ", object%total
	write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics
	write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts
	write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed
	write (u, "(3x,A,I0)") "evaluated = ", object%evaluated
	else
	write (u, "(1x,A)") "Call statistics (current run): [no calls]"
	end if
	end subroutine process_counter_write

	@ %def process_counter_write
	@ Reset. Just enforce default initialization.
	<<Process counter: process counter: TBP>>=
	procedure :: reset => process_counter_reset
	<<Process counter: procedures>>=
	subroutine process_counter_reset (counter)
	class(process_counter_t), intent(out) :: counter
	counter%total = 0
	counter%failed_kinematics = 0
	counter%failed_cuts = 0
	counter%has_passed = 0
	counter%evaluated = 0
	counter%complete = 0
	end subroutine process_counter_reset

	@ %def process_counter_reset
	@ We record an event according to the lowest status code greater or
	equal to the actual status. This is actually done by the process
	instance; the process object just copies the instance counter.
	<<Process counter: process counter: TBP>>=
	procedure :: record => process_counter_record
	<<Process counter: procedures>>=
	subroutine process_counter_record (counter, status)
	class(process_counter_t), intent(inout) :: counter
	integer, intent(in) :: status
	if (status <= STAT_FAILED_KINEMATICS) then
	counter%failed_kinematics = counter%failed_kinematics + 1
	else if (status <= STAT_FAILED_CUTS) then
	counter%failed_cuts = counter%failed_cuts + 1
	else if (status <= STAT_PASSED_CUTS) then
	counter%has_passed = counter%has_passed + 1
	else
	counter%evaluated = counter%evaluated + 1
	end if
	counter%total = counter%total + 1
	end subroutine process_counter_record

	@ %def process_counter_record
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Multi-channel integration}
	<<[[process_mci.f90]]>>=
	<<File header>>

	module process_mci

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use diagnostics
	use physics_defs
	use md5
	use cputime
	use rng_base
	use mci_base
	use variables
	use integration_results
	use process_libraries
	use phs_base
	use process_counter
	use process_config


	<<Standard module head>>

	<<Process mci: public>>

	<<Process mci: parameters>>

	<<Process mci: types>>

	contains

	<<Process mci: procedures>>

	end module process_mci
	@ %def process_mci
	\subsection{Process MCI entry}
	The [[process_mci_entry_t]] block contains, for each process component that is
	integrated independently, the configuration data for its MC input parameters.
	Each input parameter set is handled by a [[mci_t]] integrator.

	The MC input parameter set is broken down into the parameters required by the
	structure-function chain and the parameters required by the phase space of the
	elementary process.

	The MD5 sum collects all information about the associated processes
	that may affect the integration. It does not contain the MCI object
	itself or integration results.

	MC integration is organized in passes. Each pass may consist of
	several iterations, and for each iteration there is a number of
	calls. We store explicitly the values that apply to the current
	pass. Previous values are archived in the [[results]] object.

	The [[counter]] receives the counter statistics from the associated
	process instance, for diagnostics.

	The [[results]] object records results, broken down in passes and iterations.
	<<Process mci: public>>=
	public :: process_mci_entry_t
	<<Process mci: types>>=
	type :: process_mci_entry_t
	integer :: i_mci = 0
	integer, dimension(:), allocatable :: i_component
	integer :: process_type = PRC_UNKNOWN
	integer :: n_par = 0
	integer :: n_par_sf = 0
	integer :: n_par_phs = 0
	character(32) :: md5sum = ""
	integer :: pass = 0
	integer :: n_it = 0
	integer :: n_calls = 0
	logical :: activate_timer = .false.
	real(default) :: error_threshold = 0
	class(mci_t), allocatable :: mci
	type(process_counter_t) :: counter
	type(integration_results_t) :: results
	logical :: negative_weights = .false.
	logical :: combined_integration = .false.
	integer :: real_partition_type = REAL_FULL
	contains
	<<Process mci: process mci entry: TBP>>
	end type process_mci_entry_t

	@ %def process_mci_entry_t
	@ Finalizer for the [[mci]] component.
	<<Process mci: process mci entry: TBP>>=
	procedure :: final => process_mci_entry_final
	<<Process mci: procedures>>=
	subroutine process_mci_entry_final (object)
	class(process_mci_entry_t), intent(inout) :: object
	if (allocated (object%mci)) call object%mci%final ()
	end subroutine process_mci_entry_final

	@ %def process_mci_entry_final
	@ Output. Write pass/iteration information only if set (the pass
	index is nonzero). Write the MCI block only if it exists (for some
	self-tests it does not). Write results only if there are any.
	<<Process mci: process mci entry: TBP>>=
	procedure :: write => process_mci_entry_write
	<<Process mci: procedures>>=
	subroutine process_mci_entry_write (object, unit, pacify)
	class(process_mci_entry_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: pacify
	integer :: u
	u = given_output_unit (unit)
	write (u, "(3x,A,I0)") "Associated components = ", object%i_component
	write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par
	write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf
	write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs
	if (object%pass > 0) then
	write (u, "(3x,A,I0)") "Current pass = ", object%pass
	write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it
	write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls
	end if
	if (object%md5sum /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'"
	end if
	if (allocated (object%mci)) then
	call object%mci%write (u)
	end if
	call object%counter%write (u)
	if (object%results%exist ()) then
	call object%results%write (u, suppress = pacify)
	call object%results%write_chain_weights (u)
	end if
	end subroutine process_mci_entry_write

	@ %def process_mci_entry_write
	@ Configure the MCI entry. This is intent(inout) since some specific settings
	may be done before this. The actual [[mci_t]] object is an instance of the
	[[mci_template]] argument, which determines the concrete types.

	In a unit-test context, the [[mci_template]] argument may be unallocated.

	We obtain the number of channels and the number of parameters, separately for
	the structure-function chain and for the associated process component. We
	assume that the phase-space object has already been configured.

	We assume that there is only one process component directly associated with a
	MCI entry.
	<<Process mci: process mci entry: TBP>>=
	procedure :: configure => process_mci_entry_configure
	<<Process mci: procedures>>=
	subroutine process_mci_entry_configure (mci_entry, mci_template, &
	process_type, i_mci, i_component, component, &
	n_sfpar, rng_factory)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	class(mci_t), intent(in), allocatable :: mci_template
	integer, intent(in) :: process_type
	integer, intent(in) :: i_mci
	integer, intent(in) :: i_component
	type(process_component_t), intent(in), target :: component
	integer, intent(in) :: n_sfpar
	class(rng_factory_t), intent(inout) :: rng_factory
	class(rng_t), allocatable :: rng
	associate (phs_config => component%phs_config)
	mci_entry%i_mci = i_mci
	call mci_entry%create_component_list (i_component, component%get_config ())
	mci_entry%n_par_sf = n_sfpar
	mci_entry%n_par_phs = phs_config%get_n_par ()
	mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs
	mci_entry%process_type = process_type
	if (allocated (mci_template)) then
	allocate (mci_entry%mci, source = mci_template)
	call mci_entry%mci%record_index (mci_entry%i_mci)
	call mci_entry%mci%set_dimensions &
	(mci_entry%n_par, phs_config%get_n_channel ())
	call mci_entry%mci%declare_flat_dimensions &
	(phs_config%get_flat_dimensions ())
	if (phs_config%provides_equivalences) then
	call mci_entry%mci%declare_equivalences &
	(phs_config%channel, mci_entry%n_par_sf)
	end if
	if (phs_config%provides_chains) then
	call mci_entry%mci%declare_chains (phs_config%chain)
	end if
	call rng_factory%make (rng)
	call mci_entry%mci%import_rng (rng)
	end if
	call mci_entry%results%init (process_type)
	end associate
	end subroutine process_mci_entry_configure

	@ %def process_mci_entry_configure
	@
	<<Process mci: parameters>>=
	integer, parameter, public :: REAL_FULL = 0
	integer, parameter, public :: REAL_SINGULAR = 1
	integer, parameter, public :: REAL_FINITE = 2
	@
	<<Process mci: process mci entry: TBP>>=
	procedure :: create_component_list => &
	process_mci_entry_create_component_list
	<<Process mci: procedures>>=
	subroutine process_mci_entry_create_component_list (mci_entry, &
	i_component, component_config)
	class (process_mci_entry_t), intent(inout) :: mci_entry
	integer, intent(in) :: i_component
	type(process_component_def_t), intent(in) :: component_config
	integer, dimension(:), allocatable :: i_list
	integer :: n
	integer, save :: i_rfin_offset = 0
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list")
	if (mci_entry%combined_integration) then
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
	"mci_entry%real_partition_type", mci_entry%real_partition_type)
	n = get_n_components (mci_entry%real_partition_type)
	allocate (i_list (n))
	select case (mci_entry%real_partition_type)
	case (REAL_FULL)
	i_list = component_config%get_association_list ()
	allocate (mci_entry%i_component (size (i_list)))
	mci_entry%i_component = i_list
	case (REAL_SINGULAR)
	i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN)
	allocate (mci_entry%i_component (size(i_list)))
	mci_entry%i_component = i_list
	case (REAL_FINITE)
	allocate (mci_entry%i_component (1))
	mci_entry%i_component(1) = &
	component_config%get_associated_real_fin () + i_rfin_offset
	i_rfin_offset = i_rfin_offset + 1
	end select
	else
	allocate (mci_entry%i_component (1))
	mci_entry%i_component(1) = i_component
	end if
	contains
	function get_n_components (real_partition_type) result (n_components)
	integer :: n_components
	integer, intent(in) :: real_partition_type
	select case (real_partition_type)
	case (REAL_FULL)
	n_components = size (component_config%get_association_list ())
	case (REAL_SINGULAR)
	n_components = size (component_config%get_association_list &
	(ASSOCIATED_REAL_FIN))
	end select
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "n_components", n_components)
	end function get_n_components
	end subroutine process_mci_entry_create_component_list

	@ %def process_mci_entry_create_component_list
	@ Set some additional parameters.
	<<Process mci: process mci entry: TBP>>=
	procedure :: set_parameters => process_mci_entry_set_parameters
	<<Process mci: procedures>>=
	subroutine process_mci_entry_set_parameters (mci_entry, var_list)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	type(var_list_t), intent(in) :: var_list
	integer :: integration_results_verbosity
	real(default) :: error_threshold
	integration_results_verbosity = &
	var_list%get_ival (var_str ("integration_results_verbosity"))
	error_threshold = &
	var_list%get_rval (var_str ("error_threshold"))
	mci_entry%activate_timer = &
	var_list%get_lval (var_str ("?integration_timer"))
	call mci_entry%results%set_verbosity (integration_results_verbosity)
	call mci_entry%results%set_error_threshold (error_threshold)
	end subroutine process_mci_entry_set_parameters

	@ %def process_mci_entry_set_parameters
	@ Compute an MD5 sum that summarizes all information that could
	influence integration results, for the associated process components.
	We take the process-configuration MD5 sum which represents parameters,
	cuts, etc., the MD5 sums for the process component definitions and
	their phase space objects (which should be configured), and the beam
	configuration MD5 sum. (The QCD setup is included in the process
	configuration data MD5 sum.)

	Done only once, when the MD5 sum is still empty.
	<<Process mci: process mci entry: TBP>>=
	procedure :: compute_md5sum => process_mci_entry_compute_md5sum
	<<Process mci: procedures>>=
	subroutine process_mci_entry_compute_md5sum (mci_entry, &
	config, component, beam_config)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	type(process_config_data_t), intent(in) :: config
	type(process_component_t), dimension(:), intent(in) :: component
	type(process_beam_config_t), intent(in) :: beam_config
	type(string_t) :: buffer
	integer :: i
	if (mci_entry%md5sum == "") then
	buffer = config%get_md5sum () // beam_config%get_md5sum ()
	do i = 1, size (component)
	if (component(i)%is_active ()) then
	buffer = buffer // component(i)%get_md5sum ()
	end if
	end do
	mci_entry%md5sum = md5sum (char (buffer))
	end if
	if (allocated (mci_entry%mci)) then
	call mci_entry%mci%set_md5sum (mci_entry%md5sum)
	end if
	end subroutine process_mci_entry_compute_md5sum

	@ %def process_mci_entry_compute_md5sum
	@ Test the MCI sampler by calling it a given number of time, discarding the
	results. The instance should be initialized.

	The [[mci_entry]] is [[intent(inout)]] because the integrator contains
	the random-number state.
	<<Process mci: process mci entry: TBP>>=
	procedure :: sampler_test => process_mci_entry_sampler_test
	<<Process mci: procedures>>=
	subroutine process_mci_entry_sampler_test (mci_entry, mci_sampler, n_calls)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	class(mci_sampler_t), intent(inout), target :: mci_sampler
	integer, intent(in) :: n_calls
	call mci_entry%mci%sampler_test (mci_sampler, n_calls)
	end subroutine process_mci_entry_sampler_test

	@ %def process_mci_entry_sampler_test
	@ Integrate.

	The [[integrate]] method counts as an integration pass; the pass count is
	increased by one. We transfer the pass parameters (number of iterations and
	number of calls) to the actual integration routine.

	The [[mci_entry]] is [[intent(inout)]] because the integrator contains
	the random-number state.

	Note: The results are written to screen and to logfile. This behavior
	is hardcoded.
	<<Process mci: process mci entry: TBP>>=
	procedure :: integrate => process_mci_entry_integrate
	procedure :: final_integration => process_mci_entry_final_integration
	<<Process mci: procedures>>=
	subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
	mci_sampler, n_it, n_calls, &
	adapt_grids, adapt_weights, final, pacify, &
	nlo_type)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	class(mci_instance_t), intent(inout) :: mci_instance
	class(mci_sampler_t), intent(inout) :: mci_sampler
	integer, intent(in) :: n_it
	integer, intent(in) :: n_calls
	logical, intent(in), optional :: adapt_grids
	logical, intent(in), optional :: adapt_weights
	logical, intent(in), optional :: final, pacify
	integer, intent(in), optional :: nlo_type
	integer :: u_log
	u_log = logfile_unit ()
	mci_entry%pass = mci_entry%pass + 1
	mci_entry%n_it = n_it
	mci_entry%n_calls = n_calls
	if (mci_entry%pass == 1) &
	call mci_entry%mci%startup_message (n_calls = n_calls)
	call mci_entry%mci%set_timer (active = mci_entry%activate_timer)
	call mci_entry%results%display_init (screen = .true., unit = u_log)
	call mci_entry%results%new_pass ()
	if (present (nlo_type)) then
	select case (nlo_type)
	case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
	mci_instance%negative_weights = .true.
	end select
	end if
	call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final)
	call mci_entry%mci%start_timer ()
	call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, &
	n_calls, mci_entry%results, pacify = pacify)
	call mci_entry%mci%stop_timer ()
	if (signal_is_pending ()) return
	end subroutine process_mci_entry_integrate

	subroutine process_mci_entry_final_integration (mci_entry)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	call mci_entry%results%display_final ()
	call mci_entry%time_message ()
	end subroutine process_mci_entry_final_integration

	@ %def process_mci_entry_integrate
	@ %def process_mci_entry_final_integration
	@ If appropriate, issue an informative message about the expected time
	for an event sample.
	<<Process mci: process mci entry: TBP>>=
	procedure :: get_time => process_mci_entry_get_time
	procedure :: time_message => process_mci_entry_time_message
	<<Process mci: procedures>>=
	subroutine process_mci_entry_get_time (mci_entry, time, sample)
	class(process_mci_entry_t), intent(in) :: mci_entry
	type(time_t), intent(out) :: time
	integer, intent(in) :: sample
	real(default) :: time_last_pass, efficiency, calls
	time_last_pass = mci_entry%mci%get_time ()
	calls = mci_entry%results%get_n_calls ()
	efficiency = mci_entry%mci%get_efficiency ()
	if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then
	time = nint (time_last_pass / calls / efficiency * sample)
	end if
	end subroutine process_mci_entry_get_time

	subroutine process_mci_entry_time_message (mci_entry)
	class(process_mci_entry_t), intent(in) :: mci_entry
	type(time_t) :: time
	integer :: sample
	sample = 10000
	call mci_entry%get_time (time, sample)
	if (time%is_known ()) then
	call msg_message ("Time estimate for generating 10000 events: " &
	// char (time%to_string_dhms ()))
	end if
	end subroutine process_mci_entry_time_message

	@ %def process_mci_entry_time_message
	@ Prepare event generation. (For the test integrator, this does nothing. It
	is relevant for the VAMP integrator.)
	<<Process mci: process mci entry: TBP>>=
	procedure :: prepare_simulation => process_mci_entry_prepare_simulation
	<<Process mci: procedures>>=
	subroutine process_mci_entry_prepare_simulation (mci_entry)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	call mci_entry%mci%prepare_simulation ()
	end subroutine process_mci_entry_prepare_simulation

	@ %def process_mci_entry_prepare_simulation
	@ Generate an event. The instance should be initialized,
	otherwise event generation is directed by the [[mci]] integrator
	subobject. The integrator instance is contained in a [[mci_work]]
	subobject of the process instance, which simultaneously serves as the
	sampler object. (We avoid the anti-aliasing rules if we assume that
	the sampling itself does not involve the integrator instance contained in the
	process instance.)

	Regarding weighted events, we only take events which are valid, which
	means that they have valid kinematics and have passed cuts.
	Therefore, we have a rejection loop. For unweighted events, the
	unweighting routine should already take care of this.

	The [[keep_failed]] flag determines whether events which failed cuts
	are nevertheless produced, to be recorded with zero weight.
	Alternatively, failed events are dropped, and this fact is recorded by
	the counter [[n_dropped]].
	<<Process mci: process mci entry: TBP>>=
	procedure :: generate_weighted_event => &
	process_mci_entry_generate_weighted_event
	procedure :: generate_unweighted_event => &
	process_mci_entry_generate_unweighted_event
	<<Process mci: procedures>>=
	subroutine process_mci_entry_generate_weighted_event (mci_entry, &
	mci_instance, mci_sampler, keep_failed)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	class(mci_instance_t), intent(inout) :: mci_instance
	class(mci_sampler_t), intent(inout) :: mci_sampler
	logical, intent(in) :: keep_failed
	logical :: generate_new
	generate_new = .true.
	call mci_instance%reset_n_event_dropped ()
	REJECTION: do while (generate_new)
	call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler)
	if (signal_is_pending ()) return
	if (.not. mci_sampler%is_valid()) then
	if (keep_failed) then
	generate_new = .false.
	else
	call mci_instance%record_event_dropped ()
	generate_new = .true.
	end if
	else
	generate_new = .false.
	end if
	end do REJECTION
	end subroutine process_mci_entry_generate_weighted_event

	subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler)
	class(process_mci_entry_t), intent(inout) :: mci_entry
	class(mci_instance_t), intent(inout) :: mci_instance
	class(mci_sampler_t), intent(inout) :: mci_sampler
	call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler)
	end subroutine process_mci_entry_generate_unweighted_event

	@ %def process_mci_entry_generate_weighted_event
	@ %def process_mci_entry_generate_unweighted_event
	@ Extract results.
	<<Process mci: process mci entry: TBP>>=
	procedure :: has_integral => process_mci_entry_has_integral
	procedure :: get_integral => process_mci_entry_get_integral
	procedure :: get_error => process_mci_entry_get_error
	procedure :: get_accuracy => process_mci_entry_get_accuracy
	procedure :: get_chi2 => process_mci_entry_get_chi2
	procedure :: get_efficiency => process_mci_entry_get_efficiency
	<<Process mci: procedures>>=
	function process_mci_entry_has_integral (mci_entry) result (flag)
	class(process_mci_entry_t), intent(in) :: mci_entry
	logical :: flag
	flag = mci_entry%results%exist ()
	end function process_mci_entry_has_integral

	function process_mci_entry_get_integral (mci_entry) result (integral)
	class(process_mci_entry_t), intent(in) :: mci_entry
	real(default) :: integral
	integral = mci_entry%results%get_integral ()
	end function process_mci_entry_get_integral

	function process_mci_entry_get_error (mci_entry) result (error)
	class(process_mci_entry_t), intent(in) :: mci_entry
	real(default) :: error
	error = mci_entry%results%get_error ()
	end function process_mci_entry_get_error

	function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
	class(process_mci_entry_t), intent(in) :: mci_entry
	real(default) :: accuracy
	accuracy = mci_entry%results%get_accuracy ()
	end function process_mci_entry_get_accuracy

	function process_mci_entry_get_chi2 (mci_entry) result (chi2)
	class(process_mci_entry_t), intent(in) :: mci_entry
	real(default) :: chi2
	chi2 = mci_entry%results%get_chi2 ()
	end function process_mci_entry_get_chi2

	function process_mci_entry_get_efficiency (mci_entry) result (efficiency)
	class(process_mci_entry_t), intent(in) :: mci_entry
	real(default) :: efficiency
	efficiency = mci_entry%results%get_efficiency ()
	end function process_mci_entry_get_efficiency

	@ %def process_mci_entry_get_integral process_mci_entry_get_error
	@ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2
	@ %def process_mci_entry_get_efficiency
	@ Return the MCI checksum. This may be the one used for
	configuration, but may also incorporate results, if they change the
	state of the integrator (adaptation).
	<<Process mci: process mci entry: TBP>>=
	procedure :: get_md5sum => process_mci_entry_get_md5sum
	<<Process mci: procedures>>=
	pure function process_mci_entry_get_md5sum (entry) result (md5sum)
	class(process_mci_entry_t), intent(in) :: entry
	character(32) :: md5sum
	md5sum = entry%mci%get_md5sum ()
	end function process_mci_entry_get_md5sum

	@ %def process_mci_entry_get_md5sum
	@
	\subsection{MC parameter set and MCI instance}
	For each process component that is associated with a multi-channel integration
	(MCI) object, the [[mci_work_t]] object contains the currently active
	parameter set. It also holds the implementation of the [[mci_instance_t]]
	that the integrator needs for doing its work.
	<<Process mci: public>>=
	public :: mci_work_t
	<<Process mci: types>>=
	type :: mci_work_t
	type(process_mci_entry_t), pointer :: config => null ()
	real(default), dimension(:), allocatable :: x
	class(mci_instance_t), pointer :: mci => null ()
	type(process_counter_t) :: counter
	logical :: keep_failed_events = .false.
	integer :: n_event_dropped = 0
	contains
	<<Process mci: mci work: TBP>>
	end type mci_work_t

	@ %def mci_work_t
	@ First write configuration data, then the current values.
	<<Process mci: mci work: TBP>>=
	procedure :: write => mci_work_write
	<<Process mci: procedures>>=
	subroutine mci_work_write (mci_work, unit, testflag)
	class(mci_work_t), intent(in) :: mci_work
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1x,A,I0,A)") "Active MCI instance #", &
	mci_work%config%i_mci, " ="
	write (u, "(2x)", advance="no")
	do i = 1, mci_work%config%n_par
	write (u, "(1x,F7.5)", advance="no") mci_work%x(i)
	if (i == mci_work%config%n_par_sf) &
	write (u, "(1x,'\|')", advance="no")
	end do
	write (u, *)
	if (associated (mci_work%mci)) then
	call mci_work%mci%write (u, pacify = testflag)
	call mci_work%counter%write (u)
	end if
	end subroutine mci_work_write

	@ %def mci_work_write
	@ The [[mci]] component may require finalization.
	<<Process mci: mci work: TBP>>=
	procedure :: final => mci_work_final
	<<Process mci: procedures>>=
	subroutine mci_work_final (mci_work)
	class(mci_work_t), intent(inout) :: mci_work
	if (associated (mci_work%mci)) then
	call mci_work%mci%final ()
	deallocate (mci_work%mci)
	end if
	end subroutine mci_work_final

	@ %def mci_work_final
	@ Initialize with the maximum length that we will need. Contents are
	not initialized.

	The integrator inside the [[mci_entry]] object is responsible for
	allocating and initializing its own instance, which is referred to by
	a pointer in the [[mci_work]] object.
	<<Process mci: mci work: TBP>>=
	procedure :: init => mci_work_init
	<<Process mci: procedures>>=
	subroutine mci_work_init (mci_work, mci_entry)
	class(mci_work_t), intent(out) :: mci_work
	type(process_mci_entry_t), intent(in), target :: mci_entry
	mci_work%config => mci_entry
	allocate (mci_work%x (mci_entry%n_par))
	if (allocated (mci_entry%mci)) then
	call mci_entry%mci%allocate_instance (mci_work%mci)
	call mci_work%mci%init (mci_entry%mci)
	end if
	end subroutine mci_work_init

	@ %def mci_work_init
	@ Set parameters explicitly, either all at once, or separately for the
	structure-function and process parts.
	<<Process mci: mci work: TBP>>=
	procedure :: set => mci_work_set
	procedure :: set_x_strfun => mci_work_set_x_strfun
	procedure :: set_x_process => mci_work_set_x_process
	<<Process mci: procedures>>=
	subroutine mci_work_set (mci_work, x)
	class(mci_work_t), intent(inout) :: mci_work
	real(default), dimension(:), intent(in) :: x
	mci_work%x = x
	end subroutine mci_work_set

	subroutine mci_work_set_x_strfun (mci_work, x)
	class(mci_work_t), intent(inout) :: mci_work
	real(default), dimension(:), intent(in) :: x
	mci_work%x(1 : mci_work%config%n_par_sf) = x
	end subroutine mci_work_set_x_strfun

	subroutine mci_work_set_x_process (mci_work, x)
	class(mci_work_t), intent(inout) :: mci_work
	real(default), dimension(:), intent(in) :: x
	mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x
	end subroutine mci_work_set_x_process

	@ %def mci_work_set
	@ %def mci_work_set_x_strfun
	@ %def mci_work_set_x_process
	@ Return the array of active components, i.e., those that correspond
	to the currently selected MC parameter set.
	<<Process mci: mci work: TBP>>=
	procedure :: get_active_components => mci_work_get_active_components
	<<Process mci: procedures>>=
	function mci_work_get_active_components (mci_work) result (i_component)
	class(mci_work_t), intent(in) :: mci_work
	integer, dimension(:), allocatable :: i_component
	allocate (i_component (size (mci_work%config%i_component)))
	i_component = mci_work%config%i_component
	end function mci_work_get_active_components

	@ %def mci_work_get_active_components
	@ Return the active parameters as a simple array with correct length.
	Do this separately for the structure-function parameters and the
	process parameters.
	<<Process mci: mci work: TBP>>=
	procedure :: get_x_strfun => mci_work_get_x_strfun
	procedure :: get_x_process => mci_work_get_x_process
	<<Process mci: procedures>>=
	pure function mci_work_get_x_strfun (mci_work) result (x)
	class(mci_work_t), intent(in) :: mci_work
	real(default), dimension(mci_work%config%n_par_sf) :: x
	x = mci_work%x(1 : mci_work%config%n_par_sf)
	end function mci_work_get_x_strfun

	pure function mci_work_get_x_process (mci_work) result (x)
	class(mci_work_t), intent(in) :: mci_work
	real(default), dimension(mci_work%config%n_par_phs) :: x
	x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par)
	end function mci_work_get_x_process

	@ %def mci_work_get_x_strfun
	@ %def mci_work_get_x_process
	@ Initialize and finalize event generation for the specified MCI
	entry. This also resets the counter.
	<<Process mci: mci work: TBP>>=
	procedure :: init_simulation => mci_work_init_simulation
	procedure :: final_simulation => mci_work_final_simulation
	<<Process mci: procedures>>=
	subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events)
	class(mci_work_t), intent(inout) :: mci_work
	real(default), intent(in), optional :: safety_factor
	logical, intent(in), optional :: keep_failed_events
	call mci_work%mci%init_simulation (safety_factor)
	call mci_work%counter%reset ()
	if (present (keep_failed_events)) &
	mci_work%keep_failed_events = keep_failed_events
	end subroutine mci_work_init_simulation

	subroutine mci_work_final_simulation (mci_work)
	class(mci_work_t), intent(inout) :: mci_work
	call mci_work%mci%final_simulation ()
	end subroutine mci_work_final_simulation

	@ %def mci_work_init_simulation
	@ %def mci_work_final_simulation
	@ Counter.
	<<Process mci: mci work: TBP>>=
	procedure :: reset_counter => mci_work_reset_counter
	procedure :: record_call => mci_work_record_call
	procedure :: get_counter => mci_work_get_counter
	<<Process mci: procedures>>=
	subroutine mci_work_reset_counter (mci_work)
	class(mci_work_t), intent(inout) :: mci_work
	call mci_work%counter%reset ()
	end subroutine mci_work_reset_counter

	subroutine mci_work_record_call (mci_work, status)
	class(mci_work_t), intent(inout) :: mci_work
	integer, intent(in) :: status
	call mci_work%counter%record (status)
	end subroutine mci_work_record_call

	pure function mci_work_get_counter (mci_work) result (counter)
	class(mci_work_t), intent(in) :: mci_work
	type(process_counter_t) :: counter
	counter = mci_work%counter
	end function mci_work_get_counter

	@ %def mci_work_reset_counter
	@ %def mci_work_record_call
	@ %def mci_work_get_counter
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process component manager}
	<<[[pcm.f90]]>>=
	<<File header>>

	module pcm

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use constants, only: zero, two
	use diagnostics
	use lorentz
	use phs_points, only: assignment(=)
	use io_units, only: free_unit
	use os_interface
	use process_constants, only: process_constants_t
	use physics_defs
	use model_data, only: model_data_t
	use models, only: model_t
	use interactions, only: interaction_t
	use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t
	use flavors, only: flavor_t
	use variables, only: var_list_t
	use nlo_data, only: nlo_settings_t
	use mci_base, only: mci_t
	use phs_base, only: phs_config_t
	use mappings, only: mapping_defaults_t
	use phs_forests, only: phs_parameters_t
	use phs_fks, only: isr_kinematics_t, real_kinematics_t
	use phs_fks, only: phs_identifier_t
	use dispatch_fks, only: dispatch_fks_s
	use fks_regions, only: region_data_t
	use nlo_data, only: fks_template_t
	use phs_fks, only: phs_fks_generator_t
	use phs_fks, only: dalitz_plot_t
	use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories
	use dispatch_phase_space, only: dispatch_phs
	use process_libraries, only: process_component_def_t
	use real_subtraction, only: real_subtraction_t, soft_mismatch_t
	use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG
	use real_subtraction, only: real_partition_t, powheg_damping_simple_t
	use real_subtraction, only: real_partition_fixed_order_t
	use virtual, only: virtual_t
	use dglap_remnant, only: dglap_remnant_t
	use prc_threshold, only: threshold_def_t
	use resonances, only: resonance_history_t, resonance_history_set_t
	use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
	use blha_config, only: blha_master_t
	use blha_olp_interfaces, only: prc_blha_t

	use pcm_base
	use process_config
	use process_mci, only: process_mci_entry_t
	use process_mci, only: REAL_SINGULAR, REAL_FINITE

	<<Standard module head>>

	<<Pcm: public>>

	<<Pcm: types>>

	contains

	<<Pcm: procedures>>

	end module pcm
	@ %def pcm
	@
	\subsection{Default process component manager}
	This is the configuration object which has the duty of allocating the
	corresponding instance. The default version is trivial.
	<<Pcm: public>>=
	public :: pcm_default_t
	<<Pcm: types>>=
	type, extends (pcm_t) :: pcm_default_t
	contains
	<<Pcm: pcm default: TBP>>
	end type pcm_default_t

	@ %def pcm_default_t
	<<Pcm: pcm default: TBP>>=
	procedure :: allocate_workspace => pcm_default_allocate_workspace
	<<Pcm: procedures>>=
	subroutine pcm_default_allocate_workspace (pcm, work)
	class(pcm_default_t), intent(in) :: pcm
	class(pcm_workspace_t), intent(inout), allocatable :: work
	allocate (pcm_default_workspace_t :: work)
	end subroutine pcm_default_allocate_workspace

	@ %def pcm_default_allocate_workspace
	@
	Finalizer: apply to core manager.
	<<Pcm: pcm default: TBP>>=
	procedure :: final => pcm_default_final
	<<Pcm: procedures>>=
	subroutine pcm_default_final (pcm)
	class(pcm_default_t), intent(inout) :: pcm
	end subroutine pcm_default_final

	@ %def pcm_default_final
	@
	<<Pcm: pcm default: TBP>>=
	procedure :: is_nlo => pcm_default_is_nlo
	<<Pcm: procedures>>=
	function pcm_default_is_nlo (pcm) result (is_nlo)
	logical :: is_nlo
	class(pcm_default_t), intent(in) :: pcm
	is_nlo = .false.
	end function pcm_default_is_nlo

	@ %def pcm_default_is_nlo
	@
	Initialize configuration data, using environment variables.
	<<Pcm: pcm default: TBP>>=
	procedure :: init => pcm_default_init
	<<Pcm: procedures>>=
	subroutine pcm_default_init (pcm, env, meta)
	class(pcm_default_t), intent(out) :: pcm
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	pcm%has_pdfs = env%has_pdfs ()
	call pcm%set_blha_defaults &
	(env%has_polarized_beams (), env%get_var_list_ptr ())
	pcm%os_data = env%get_os_data ()
	end subroutine pcm_default_init

	@ %def pcm_default_init
	@
	<<Pcm: types>>=
	type, extends (pcm_workspace_t) :: pcm_default_workspace_t
	contains
	<<Pcm: pcm instance default: TBP>>
	end type pcm_default_workspace_t

	@ %def pcm_default_workspace_t
	@
	<<Pcm: pcm instance default: TBP>>=
	procedure :: final => pcm_default_workspace_final
	<<Pcm: procedures>>=
	subroutine pcm_default_workspace_final (pcm_work)
	class(pcm_default_workspace_t), intent(inout) :: pcm_work
	end subroutine pcm_default_workspace_final

	@ %def pcm_default_workspace_final
	@
	<<Pcm: pcm instance default: TBP>>=
	procedure :: is_nlo => pcm_default_workspace_is_nlo
	<<Pcm: procedures>>=
	function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo)
	logical :: is_nlo
	class(pcm_default_workspace_t), intent(inout) :: pcm_work
	is_nlo = .false.
	end function pcm_default_workspace_is_nlo

	@ %def pcm_default_workspace_is_nlo
	@
	\subsection{Implementations for the default manager}
	Categorize components. Nothing to do here, all components are of Born type.
	<<Pcm: pcm default: TBP>>=
	procedure :: categorize_components => pcm_default_categorize_components
	<<Pcm: procedures>>=
	subroutine pcm_default_categorize_components (pcm, config)
	class(pcm_default_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	end subroutine pcm_default_categorize_components

	@ %def pcm_default_categorize_components
	@
	\subsubsection{Phase-space configuration}
	Default setup for tree processes: a single phase-space configuration that is
	valid for all components.
	<<Pcm: pcm default: TBP>>=
	procedure :: init_phs_config => pcm_default_init_phs_config
	<<Pcm: procedures>>=
	subroutine pcm_default_init_phs_config &
	(pcm, phs_entry, meta, env, phs_par, mapping_defs)
	class(pcm_default_t), intent(inout) :: pcm
	type(process_phs_config_t), &
	dimension(:), allocatable, intent(out) :: phs_entry
	type(process_metadata_t), intent(in) :: meta
	type(process_environment_t), intent(in) :: env
	type(mapping_defaults_t), intent(in) :: mapping_defs
	type(phs_parameters_t), intent(in) :: phs_par
	allocate (phs_entry (1))
	allocate (pcm%i_phs_config (pcm%n_components), source=1)
	call dispatch_phs (phs_entry(1)%phs_config, &
	env%get_var_list_ptr (), &
	env%get_os_data (), &
	meta%id, &
	mapping_defs, phs_par)
	end subroutine pcm_default_init_phs_config

	@ %def pcm_default_init_phs_config
	@
	\subsubsection{Core management}
	The default component manager assigns one core per component. We allocate and
	configure the core objects, using the process-component configuration data.
	<<Pcm: pcm default: TBP>>=
	procedure :: allocate_cores => pcm_default_allocate_cores
	<<Pcm: procedures>>=
	subroutine pcm_default_allocate_cores (pcm, config, core_entry)
	class(pcm_default_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
	type(process_component_def_t), pointer :: component_def
	integer :: i
	allocate (pcm%i_core (pcm%n_components), source = 0)
	pcm%n_cores = pcm%n_components
	allocate (core_entry (pcm%n_cores))
	do i = 1, pcm%n_cores
	pcm%i_core(i) = i
	core_entry(i)%i_component = i
	component_def => config%process_def%get_component_def_ptr (i)
	core_entry(i)%core_def => component_def%get_core_def_ptr ()
	core_entry(i)%active = component_def%can_be_integrated ()
	end do
	end subroutine pcm_default_allocate_cores

	@ %def pcm_default_allocate_cores
	@ Extra code is required for certain core types (threshold) or if BLHA uses an
	external OLP (Born only, this case) for getting its matrix elements.
	<<Pcm: pcm default: TBP>>=
	procedure :: prepare_any_external_code => &
	pcm_default_prepare_any_external_code
	<<Pcm: procedures>>=
	subroutine pcm_default_prepare_any_external_code &
	(pcm, core_entry, i_core, libname, model, var_list)
	class(pcm_default_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	integer, intent(in) :: i_core
	type(string_t), intent(in) :: libname
	type(model_data_t), intent(in), target :: model
	type(var_list_t), intent(in) :: var_list
	if (core_entry%active) then
	associate (core => core_entry%core)
	if (core%needs_external_code ()) then
	call core%prepare_external_code &
	(core%data%flv_state, &
	var_list, pcm%os_data, libname, model, i_core, .false.)
	end if
	call core%set_equivalent_flv_hel_indices ()
	end associate
	end if
	end subroutine pcm_default_prepare_any_external_code

	@ %def pcm_default_prepare_any_external_code
	@ Allocate and configure the BLHA record for a specific core, assuming that
	the core type requires it. In the default case, this is a Born
	configuration.
	<<Pcm: pcm default: TBP>>=
	procedure :: setup_blha => pcm_default_setup_blha
	<<Pcm: procedures>>=
	subroutine pcm_default_setup_blha (pcm, core_entry)
	class(pcm_default_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	allocate (core_entry%blha_config, source = pcm%blha_defaults)
	call core_entry%blha_config%set_born ()
	end subroutine pcm_default_setup_blha

	@ %def pcm_default_setup_blha
	@ Apply the configuration, using [[pcm]] data.
	<<Pcm: pcm default: TBP>>=
	procedure :: prepare_blha_core => pcm_default_prepare_blha_core
	<<Pcm: procedures>>=
	subroutine pcm_default_prepare_blha_core (pcm, core_entry, model)
	class(pcm_default_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	class(model_data_t), intent(in), target :: model
	integer :: n_in
	integer :: n_legs
	integer :: n_flv
	integer :: n_hel
	select type (core => core_entry%core)
	class is (prc_blha_t)
	associate (blha_config => core_entry%blha_config)
	n_in = core%data%n_in
	n_legs = core%data%get_n_tot ()
	n_flv = core%data%n_flv
	n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
	call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
	call core%init_driver (pcm%os_data)
	end associate
	end select
	end subroutine pcm_default_prepare_blha_core

	@ %def pcm_default_prepare_blha_core
	@ Read the method settings from the variable list and store them in the BLHA
	master. This version: no NLO flag.
	<<Pcm: pcm default: TBP>>=
	procedure :: set_blha_methods => pcm_default_set_blha_methods
	<<Pcm: procedures>>=
	subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
	class(pcm_default_t), intent(inout) :: pcm
	type(blha_master_t), intent(inout) :: blha_master
	type(var_list_t), intent(in) :: var_list
	call blha_master%set_methods (.false., var_list)
	end subroutine pcm_default_set_blha_methods

	@ %def pcm_default_set_blha_methods
	@ Produce the LO and NLO flavor-state tables (as far as available), as
	appropriate for BLHA configuration.

	The default version looks at the first process core only, to get the Born
	data. (Multiple cores are thus unsupported.) The NLO flavor table is left
	unallocated.
	<<Pcm: pcm default: TBP>>=
	procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states
	<<Pcm: procedures>>=
	subroutine pcm_default_get_blha_flv_states &
	(pcm, core_entry, flv_born, flv_real)
	class(pcm_default_t), intent(in) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	integer, dimension(:,:), allocatable, intent(out) :: flv_born
	integer, dimension(:,:), allocatable, intent(out) :: flv_real
	flv_born = core_entry(1)%core%data%flv_state
	end subroutine pcm_default_get_blha_flv_states

	@ %def pcm_default_get_blha_flv_states
	@ Allocate and configure the MCI (multi-channel integrator) records. There is
	one record per active process component. Second procedure: call the MCI
	dispatcher with default-setup arguments.
	<<Pcm: pcm default: TBP>>=
	procedure :: setup_mci => pcm_default_setup_mci
	procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci
	<<Pcm: procedures>>=
	subroutine pcm_default_setup_mci (pcm, mci_entry)
	class(pcm_default_t), intent(inout) :: pcm
	type(process_mci_entry_t), &
	dimension(:), allocatable, intent(out) :: mci_entry
	class(mci_t), allocatable :: mci_template
	integer :: i, i_mci
	pcm%n_mci = count (pcm%component_active)
	allocate (pcm%i_mci (pcm%n_components), source = 0)
	i_mci = 0
	do i = 1, pcm%n_components
	if (pcm%component_active(i)) then
	i_mci = i_mci + 1
	pcm%i_mci(i) = i_mci
	end if
	end do
	allocate (mci_entry (pcm%n_mci))
	end subroutine pcm_default_setup_mci

	subroutine pcm_default_call_dispatch_mci (pcm, &
	dispatch_mci, var_list, process_id, mci_template)
	class(pcm_default_t), intent(inout) :: pcm
	procedure(dispatch_mci_proc) :: dispatch_mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	class(mci_t), allocatable, intent(out) :: mci_template
	call dispatch_mci (mci_template, var_list, process_id)
	end subroutine pcm_default_call_dispatch_mci

	@ %def pcm_default_setup_mci
	@ %def pcm_default_call_dispatch_mci
	@ Nothing left to do for the default algorithm.
	<<Pcm: pcm default: TBP>>=
	procedure :: complete_setup => pcm_default_complete_setup
	<<Pcm: procedures>>=
	subroutine pcm_default_complete_setup (pcm, core_entry, component, model)
	class(pcm_default_t), intent(inout) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	type(process_component_t), dimension(:), intent(inout) :: component
	type(model_t), intent(in), target :: model
	end subroutine pcm_default_complete_setup

	@ %def pcm_default_complete_setup
	@
	\subsubsection{Component management}
	Initialize a single component. We require all process-configuration blocks,
	and specific templates for the phase-space and integrator configuration.

	We also provide the current component index [[i]] and the [[active]] flag.

	In the default mode, all components are marked as master components.
	<<Pcm: pcm default: TBP>>=
	procedure :: init_component => pcm_default_init_component
	<<Pcm: procedures>>=
	subroutine pcm_default_init_component &
	(pcm, component, i, active, &
	phs_config, env, meta, config)
	class(pcm_default_t), intent(in) :: pcm
	type(process_component_t), intent(out) :: component
	integer, intent(in) :: i
	logical, intent(in) :: active
	class(phs_config_t), allocatable, intent(in) :: phs_config
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	type(process_config_data_t), intent(in) :: config
	call component%init (i, &
	env, meta, config, &
	active, &
	phs_config)
	component%component_type = COMP_MASTER
	end subroutine pcm_default_init_component

	@ %def pcm_default_init_component
	@
	\subsection{NLO process component manager}
	The NLO-aware version of the process-component manager.

	This is the configuration object, which has the duty of allocating the
	corresponding instance. This is the nontrivial NLO version.
	<<Pcm: public>>=
	public :: pcm_nlo_t
	<<Pcm: types>>=
	type, extends (pcm_t) :: pcm_nlo_t
	type(string_t) :: id
	logical :: combined_integration = .false.
	logical :: vis_fks_regions = .false.
	integer, dimension(:), allocatable :: nlo_type
	integer, dimension(:), allocatable :: nlo_type_core
	integer, dimension(:), allocatable :: component_type
	integer :: i_born = 0
	integer :: i_real = 0
	integer :: i_sub = 0
	type(nlo_settings_t) :: settings
	type(region_data_t) :: region_data
	logical :: use_real_partition = .false.
	logical :: use_real_singular = .false.
	real(default) :: real_partition_scale = 0
	class(real_partition_t), allocatable :: real_partition
	type(dalitz_plot_t) :: dalitz_plot
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born
	contains
	<<Pcm: pcm nlo: TBP>>
	end type pcm_nlo_t

	@ %def pcm_nlo_t
	@
	Initialize configuration data, using environment variables.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: init => pcm_nlo_init
	<<Pcm: procedures>>=
	subroutine pcm_nlo_init (pcm, env, meta)
	class(pcm_nlo_t), intent(out) :: pcm
	type(process_metadata_t), intent(in) :: meta
	type(process_environment_t), intent(in) :: env
	type(var_list_t), pointer :: var_list
	type(fks_template_t) :: fks_template
	pcm%id = meta%id
	pcm%has_pdfs = env%has_pdfs ()
	var_list => env%get_var_list_ptr ()
	call dispatch_fks_s (fks_template, var_list)
	call pcm%settings%init (var_list, fks_template)
	pcm%combined_integration = &
	var_list%get_lval (var_str ('?combined_nlo_integration'))
	select case (char (var_list%get_sval (var_str ("$real_partition_mode"))))
	case ("default", "off")
	pcm%use_real_partition = .false.
	pcm%use_real_singular = .false.
	case ("all", "on", "singular")
	pcm%use_real_partition = .true.
	pcm%use_real_singular = .true.
	case ("finite")
	pcm%use_real_partition = .true.
	pcm%use_real_singular = .false.
	case default
	call msg_fatal ("The real partition mode can only be " // &
	"default, off, all, on, singular or finite.")
	end select
	pcm%real_partition_scale = &
	var_list%get_rval (var_str ("real_partition_scale"))
	pcm%vis_fks_regions = &
	var_list%get_lval (var_str ("?vis_fks_regions"))
	call pcm%set_blha_defaults &
	(env%has_polarized_beams (), env%get_var_list_ptr ())
	pcm%os_data = env%get_os_data ()
	end subroutine pcm_nlo_init

	@ %def pcm_nlo_init
	@ Init/rewrite NLO settings without the FKS template.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings
	<<Pcm: procedures>>=
	subroutine pcm_nlo_init_nlo_settings (pcm, var_list)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(var_list_t), intent(in), target :: var_list
	call pcm%settings%init (var_list)
	end subroutine pcm_nlo_init_nlo_settings

	@ %def pcm_nlo_init_nlo_settings
	@
	As appropriate for the NLO/FKS algorithm, the category defined by the
	process, is called [[nlo_type]]. We refine this by setting the component
	category [[component_type]] separately.

	The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only
	if the algorithm uses combined integration. Otherwise, they are set to
	[[COMP_DEFAULT]].

	The component type [[COMP_REAL]] is further distinguished between
	[[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real
	partitions. The former acts as a reference component for the latter, and we
	always assume that it is the first real component.

	Each component is assigned its own core. Exceptions: the finite-real
	component gets the same core as the singular-real component. The mismatch
	component gets the same core as the subtraction component.

	TODO wk 2018: this convention for real components can be improved. Check whether
	all component types should be assigned, not just for combined
	integration.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: categorize_components => pcm_nlo_categorize_components
	<<Pcm: procedures>>=
	subroutine pcm_nlo_categorize_components (pcm, config)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	type(process_component_def_t), pointer :: component_def
	integer :: i
	allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED)
	allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT)
	do i = 1, pcm%n_components
	component_def => config%process_def%get_component_def_ptr (i)
	pcm%nlo_type(i) = component_def%get_nlo_type ()
	if (pcm%combined_integration) then
	select case (pcm%nlo_type(i))
	case (BORN)
	pcm%i_born = i
	pcm%component_type(i) = COMP_MASTER
	case (NLO_REAL)
	pcm%component_type(i) = COMP_REAL
	case (NLO_VIRTUAL)
	pcm%component_type(i) = COMP_VIRT
	case (NLO_MISMATCH)
	pcm%component_type(i) = COMP_MISMATCH
	case (NLO_DGLAP)
	pcm%component_type(i) = COMP_PDF
	case (NLO_SUBTRACTION)
	pcm%component_type(i) = COMP_SUB
	pcm%i_sub = i
	end select
	else
	select case (pcm%nlo_type(i))
	case (BORN)
	pcm%i_born = i
	pcm%component_type(i) = COMP_MASTER
	case (NLO_REAL)
	pcm%component_type(i) = COMP_REAL
	case (NLO_VIRTUAL)
	pcm%component_type(i) = COMP_VIRT
	case (NLO_MISMATCH)
	pcm%component_type(i) = COMP_MISMATCH
	case (NLO_SUBTRACTION)
	pcm%i_sub = i
	end select
	end if
	end do
	call refine_real_type ( &
	pack ([(i, i=1, pcm%n_components)], &
	pcm%component_type==COMP_REAL))
	contains
	subroutine refine_real_type (i_real)
	integer, dimension(:), intent(in) :: i_real
	pcm%i_real = i_real(1)
	if (pcm%use_real_partition) then
	pcm%component_type (i_real(1)) = COMP_REAL_SING
	pcm%component_type (i_real(2:)) = COMP_REAL_FIN
	end if
	end subroutine refine_real_type
	end subroutine pcm_nlo_categorize_components

	@ %def pcm_nlo_categorize_components
	@
	\subsubsection{Phase-space initial configuration}
	Setup for the NLO/PHS processes: two phase-space configurations, (1)
	Born/wood, (2) real correction/FKS. All components use either one of these
	two configurations.

	TODO wk 2018: The [[first_real_component]] identifier is really ugly.
	Nothing should rely on the ordering.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: init_phs_config => pcm_nlo_init_phs_config
	<<Pcm: procedures>>=
	subroutine pcm_nlo_init_phs_config &
	(pcm, phs_entry, meta, env, phs_par, mapping_defs)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(process_phs_config_t), &
	dimension(:), allocatable, intent(out) :: phs_entry
	type(process_metadata_t), intent(in) :: meta
	type(process_environment_t), intent(in) :: env
	type(mapping_defaults_t), intent(in) :: mapping_defs
	type(phs_parameters_t), intent(in) :: phs_par
	integer :: i
	logical :: first_real_component
	allocate (phs_entry (2))
	call dispatch_phs (phs_entry(1)%phs_config, &
	env%get_var_list_ptr (), &
	env%get_os_data (), &
	meta%id, &
	mapping_defs, phs_par, &
	var_str ("wood"))
	call dispatch_phs (phs_entry(2)%phs_config, &
	env%get_var_list_ptr (), &
	env%get_os_data (), &
	meta%id, &
	mapping_defs, phs_par, &
	var_str ("fks"))
	allocate (pcm%i_phs_config (pcm%n_components), source=0)
	first_real_component = .true.
	do i = 1, pcm%n_components
	select case (pcm%nlo_type(i))
	case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
	pcm%i_phs_config(i) = 1
	case (NLO_REAL)
	if (pcm%use_real_partition) then
	if (pcm%use_real_singular) then
	if (first_real_component) then
	pcm%i_phs_config(i) = 2
	first_real_component = .false.
	else
	pcm%i_phs_config(i) = 1
	end if
	else
	pcm%i_phs_config(i) = 1
	end if
	else
	pcm%i_phs_config(i) = 2
	end if
	case (NLO_MISMATCH, NLO_DGLAP, GKS)
	pcm%i_phs_config(i) = 2
	end select
	end do
	end subroutine pcm_nlo_init_phs_config

	@ %def pcm_nlo_init_phs_config
	@
	\subsubsection{Core management}
	Allocate the core (matrix-element interface) objects that we will need for
	evaluation. Every component gets an associated core, except for the
	real-finite and mismatch components (if any). Those components are associated
	with their previous corresponding real-singular and subtraction cores,
	respectively.

	After cores are allocated, configure the region-data block that is maintained
	by the NLO process-component manager.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: allocate_cores => pcm_nlo_allocate_cores
	<<Pcm: procedures>>=
	subroutine pcm_nlo_allocate_cores (pcm, config, core_entry)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(process_config_data_t), intent(in) :: config
	type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
	type(process_component_def_t), pointer :: component_def
	integer :: i, i_core
	allocate (pcm%i_core (pcm%n_components), source = 0)
	pcm%n_cores = pcm%n_components &
	- count (pcm%component_type(:) == COMP_REAL_FIN) &
	- count (pcm%component_type(:) == COMP_MISMATCH)
	allocate (core_entry (pcm%n_cores))
	allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN)
	i_core = 0
	do i = 1, pcm%n_components
	select case (pcm%component_type(i))
	case default
	i_core = i_core + 1
	pcm%i_core(i) = i_core
	pcm%nlo_type_core(i_core) = pcm%nlo_type(i)
	core_entry(i_core)%i_component = i
	component_def => config%process_def%get_component_def_ptr (i)
	core_entry(i_core)%core_def => component_def%get_core_def_ptr ()
	select case (pcm%nlo_type(i))
	case default
	core_entry(i)%active = component_def%can_be_integrated ()
	case (NLO_REAL, NLO_SUBTRACTION)
	core_entry(i)%active = .true.
	end select
	case (COMP_REAL_FIN)
	pcm%i_core(i) = pcm%i_core(pcm%i_real)
	case (COMP_MISMATCH)
	pcm%i_core(i) = pcm%i_core(pcm%i_sub)
	end select
	end do
	end subroutine pcm_nlo_allocate_cores

	@ %def pcm_nlo_allocate_cores
	@ Extra code is required for certain core types (threshold) or if BLHA uses an
	external OLP for getting its matrix elements. OMega matrix elements, by
	definition, do not need extra code. NLO-virtual or subtraction
	matrix elements always need extra code.

	More precisely: for the Born and virtual matrix element, the extra code is
	accessed only if the component is active. The radiation (real) and the
	subtraction corrections (singular and finite), extra code is accessed in any
	case.

	The flavor state is taken from the [[region_data]] table in the [[pcm]]
	record. We use the Born and real flavor-state tables as appropriate.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: prepare_any_external_code => &
	pcm_nlo_prepare_any_external_code
	<<Pcm: procedures>>=
	subroutine pcm_nlo_prepare_any_external_code &
	(pcm, core_entry, i_core, libname, model, var_list)
	class(pcm_nlo_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	integer, intent(in) :: i_core
	type(string_t), intent(in) :: libname
	type(model_data_t), intent(in), target :: model
	type(var_list_t), intent(in) :: var_list
	integer, dimension(:,:), allocatable :: flv_born, flv_real
	integer :: i
	call pcm%region_data%get_all_flv_states (flv_born, flv_real)
	if (core_entry%active) then
	associate (core => core_entry%core)
	if (core%needs_external_code ()) then
	select case (pcm%nlo_type (core_entry%i_component))
	case default
	call core%data%set_flv_state (flv_born)
	case (NLO_REAL)
	call core%data%set_flv_state (flv_real)
	end select
	call core%prepare_external_code &
	(core%data%flv_state, &
	var_list, pcm%os_data, libname, model, i_core, .true.)
	end if
	call core%set_equivalent_flv_hel_indices ()
	end associate
	end if
	end subroutine pcm_nlo_prepare_any_external_code

	@ %def pcm_nlo_prepare_any_external_code
	@ Allocate and configure the BLHA record for a specific core, assuming that
	the core type requires it. The configuration depends on the NLO type of the
	core.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: setup_blha => pcm_nlo_setup_blha
	<<Pcm: procedures>>=
	subroutine pcm_nlo_setup_blha (pcm, core_entry)
	class(pcm_nlo_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	allocate (core_entry%blha_config, source = pcm%blha_defaults)
	select case (pcm%nlo_type(core_entry%i_component))
	case (BORN)
	call core_entry%blha_config%set_born ()
	case (NLO_REAL)
	call core_entry%blha_config%set_real_trees ()
	case (NLO_VIRTUAL)
	call core_entry%blha_config%set_loop ()
	case (NLO_SUBTRACTION)
	call core_entry%blha_config%set_subtraction ()
	call core_entry%blha_config%set_internal_color_correlations ()
	case (NLO_DGLAP)
	call core_entry%blha_config%set_dglap ()
	end select
	end subroutine pcm_nlo_setup_blha

	@ %def pcm_nlo_setup_blha
	@ After phase-space configuration data and core entries are available, we fill
	tables and compute the remaining NLO data that will steer the integration
	and subtraction algorithm.

	There are three parts: recognize a threshold-type process core (if it exists),
	prepare the region-data tables (always), and prepare for real partitioning (if
	requested).

	The real-component phase space acts as the source for resonance-history
	information, required for the region data.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: complete_setup => pcm_nlo_complete_setup
	<<Pcm: procedures>>=
	subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	type(process_component_t), dimension(:), intent(inout) :: component
	type(model_t), intent(in), target :: model
	integer :: alpha_power, alphas_power
	call pcm%handle_threshold_core (core_entry)
	call component(1)%config%get_coupling_powers (alpha_power, alphas_power)
	call pcm%setup_region_data &
	(core_entry, component(pcm%i_real)%phs_config, model, alpha_power, alphas_power)
	call pcm%setup_real_partition ()
	end subroutine pcm_nlo_complete_setup

	@ %def pcm_nlo_complete_setup
	@ Apply the BLHA configuration to a core object, using the region data from
	[[pcm]] for determining the particle content.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core
	<<Pcm: procedures>>=
	subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model)
	class(pcm_nlo_t), intent(in) :: pcm
	type(core_entry_t), intent(inout) :: core_entry
	class(model_data_t), intent(in), target :: model
	integer :: n_in
	integer :: n_legs
	integer :: n_flv
	integer :: n_hel
	select type (core => core_entry%core)
	class is (prc_blha_t)
	associate (blha_config => core_entry%blha_config)
	n_in = core%data%n_in
	select case (pcm%nlo_type(core_entry%i_component))
	case (NLO_REAL)
	n_legs = pcm%region_data%get_n_legs_real ()
	n_flv = pcm%region_data%get_n_flv_real ()
	case default
	n_legs = pcm%region_data%get_n_legs_born ()
	n_flv = pcm%region_data%get_n_flv_born ()
	end select
	n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
	call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
	call core%init_driver (pcm%os_data)
	end associate
	end select
	end subroutine pcm_nlo_prepare_blha_core

	@ %def pcm_nlo_prepare_blha_core
	@ Read the method settings from the variable list and store them in the BLHA
	master. This version: NLO flag set.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: set_blha_methods => pcm_nlo_set_blha_methods
	<<Pcm: procedures>>=
	subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(blha_master_t), intent(inout) :: blha_master
	type(var_list_t), intent(in) :: var_list
	call blha_master%set_methods (.true., var_list)
	call pcm%blha_defaults%set_loop_method (blha_master)
	end subroutine pcm_nlo_set_blha_methods

	@ %def pcm_nlo_set_blha_methods
	@ Produce the LO and NLO flavor-state tables (as far as available), as
	appropriate for BLHA configuration.

	The NLO version copies the tables from the region data inside [[pcm]]. The
	core array is not needed.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states
	<<Pcm: procedures>>=
	subroutine pcm_nlo_get_blha_flv_states &
	(pcm, core_entry, flv_born, flv_real)
	class(pcm_nlo_t), intent(in) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	integer, dimension(:,:), allocatable, intent(out) :: flv_born
	integer, dimension(:,:), allocatable, intent(out) :: flv_real
	call pcm%region_data%get_all_flv_states (flv_born, flv_real)
	end subroutine pcm_nlo_get_blha_flv_states

	@ %def pcm_nlo_get_blha_flv_states
	@ Allocate and configure the MCI (multi-channel integrator) records. The
	relation depends on the [[combined_integration]] setting. If we integrate
	components separately, each component gets its own record, except for the
	subtraction component. If we do the combination, there is one record for
	the master (Born) component and a second one for the real-finite component,
	if present.

	Each entry acquires some NLO-specific initialization. Generic configuration
	follows later.

	Second procedure: call the MCI dispatcher with NLO-setup arguments.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: setup_mci => pcm_nlo_setup_mci
	procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci
	<<Pcm: procedures>>=
	subroutine pcm_nlo_setup_mci (pcm, mci_entry)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(process_mci_entry_t), &
	dimension(:), allocatable, intent(out) :: mci_entry
	class(mci_t), allocatable :: mci_template
	integer :: i, i_mci
	if (pcm%combined_integration) then
	pcm%n_mci = 1 &
	+ count (pcm%component_active(:) &
	& .and. pcm%component_type(:) == COMP_REAL_FIN)
	allocate (pcm%i_mci (pcm%n_components), source = 0)
	do i = 1, pcm%n_components
	if (pcm%component_active(i)) then
	select case (pcm%component_type(i))
	case (COMP_MASTER)
	pcm%i_mci(i) = 1
	case (COMP_REAL_FIN)
	pcm%i_mci(i) = 2
	end select
	end if
	end do
	else
	pcm%n_mci = count (pcm%component_active(:) &
	& .and. pcm%nlo_type(:) /= NLO_SUBTRACTION)
	allocate (pcm%i_mci (pcm%n_components), source = 0)
	i_mci = 0
	do i = 1, pcm%n_components
	if (pcm%component_active(i)) then
	select case (pcm%nlo_type(i))
	case default
	i_mci = i_mci + 1
	pcm%i_mci(i) = i_mci
	case (NLO_SUBTRACTION)
	end select
	end if
	end do
	end if
	allocate (mci_entry (pcm%n_mci))
	mci_entry(:)%combined_integration = pcm%combined_integration
	if (pcm%use_real_partition) then
	do i = 1, pcm%n_components
	i_mci = pcm%i_mci(i)
	if (i_mci > 0) then
	select case (pcm%component_type(i))
	case (COMP_REAL_FIN)
	mci_entry(i_mci)%real_partition_type = REAL_FINITE
	case default
	mci_entry(i_mci)%real_partition_type = REAL_SINGULAR
	end select
	end if
	end do
	end if
	end subroutine pcm_nlo_setup_mci

	subroutine pcm_nlo_call_dispatch_mci (pcm, &
	dispatch_mci, var_list, process_id, mci_template)
	class(pcm_nlo_t), intent(inout) :: pcm
	procedure(dispatch_mci_proc) :: dispatch_mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	class(mci_t), allocatable, intent(out) :: mci_template
	call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.)
	end subroutine pcm_nlo_call_dispatch_mci

	@ %def pcm_nlo_setup_mci
	@ %def pcm_nlo_call_dispatch_mci
	@ Check for a threshold core and adjust the configuration accordingly, before
	singular region data are considered.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core
	<<Pcm: procedures>>=
	subroutine pcm_nlo_handle_threshold_core (pcm, core_entry)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	integer :: i
	do i = 1, size (core_entry)
	select type (core => core_entry(i)%core_def)
	type is (threshold_def_t)
	pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD
	return
	end select
	end do
	end subroutine pcm_nlo_handle_threshold_core

	@ %def pcm_nlo_handle_threshold_core
	@ Configure the singular-region tables based on the process data for the Born
	and Real (singular) cores, using also the appropriate FKS phase-space
	configuration object.

	In passing, we may create a table of resonance histories that are relevant for
	the singular-region configuration.

	TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout).
	<<Pcm: pcm nlo: TBP>>=
	procedure :: setup_region_data => pcm_nlo_setup_region_data
	<<Pcm: procedures>>=
	subroutine pcm_nlo_setup_region_data &
	(pcm, core_entry, phs_config, model, alpha_power, alphas_power)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(core_entry_t), dimension(:), intent(in) :: core_entry
	class(phs_config_t), intent(inout) :: phs_config
	type(model_t), intent(in), target :: model
	type(process_constants_t) :: data_born, data_real
	integer, dimension (:,:), allocatable :: flavor_born, flavor_real
	type(resonance_history_t), dimension(:), allocatable :: resonance_histories
	type(var_list_t), pointer :: var_list
	integer, intent(in) :: alpha_power, alphas_power
	logical :: success
	data_born = core_entry(pcm%i_core(pcm%i_born))%core%data
	data_real = core_entry(pcm%i_core(pcm%i_real))%core%data
	call data_born%get_flv_state (flavor_born)
	call data_real%get_flv_state (flavor_real)
	call pcm%region_data%init &
	(data_born%n_in, model, flavor_born, flavor_real, &
	pcm%settings%nlo_correction_type, alpha_power, alphas_power)
	associate (template => pcm%settings%fks_template)
	if (template%mapping_type == FKS_RESONANCES) then
	select type (phs_config)
	type is (phs_fks_config_t)
	call get_filtered_resonance_histories (phs_config, &
	data_born%n_in, flavor_born, model, &
	template%excluded_resonances, &
	resonance_histories, success)
	end select
	if (.not. success) template%mapping_type = FKS_DEFAULT
	end if
	call pcm%region_data%setup_fks_mappings (template, data_born%n_in)
	!!! Check again, mapping_type might have changed
	if (template%mapping_type == FKS_RESONANCES) then
	call pcm%region_data%set_resonance_mappings (resonance_histories)
	call pcm%region_data%init_resonance_information ()
	pcm%settings%use_resonance_mappings = .true.
	end if
	end associate
	if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
	call pcm%region_data%set_isr_pseudo_regions ()
	call pcm%region_data%split_up_interference_regions_for_threshold ()
	end if
	call pcm%region_data%compute_number_of_phase_spaces ()
	call pcm%region_data%set_i_phs_to_i_con ()
	call pcm%region_data%write_to_file &
	(pcm%id, pcm%vis_fks_regions, pcm%os_data)
	if (debug_active (D_SUBTRACTION)) &
	call pcm%region_data%check_consistency (.true.)
	end subroutine pcm_nlo_setup_region_data

	@ %def pcm_nlo_setup_region_data
	@ After region data are set up, we allocate and configure the
	[[real_partition]] objects, if requested.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: setup_real_partition => pcm_nlo_setup_real_partition
	<<Pcm: procedures>>=
	subroutine pcm_nlo_setup_real_partition (pcm)
	class(pcm_nlo_t), intent(inout) :: pcm
	if (pcm%use_real_partition) then
	if (.not. allocated (pcm%real_partition)) then
	allocate (real_partition_fixed_order_t :: pcm%real_partition)
	select type (partition => pcm%real_partition)
	type is (real_partition_fixed_order_t)
	call pcm%region_data%get_all_ftuples (partition%fks_pairs)
	partition%scale = pcm%real_partition_scale
	end select
	end if
	end if
	end subroutine pcm_nlo_setup_real_partition

	@ %def pcm_nlo_setup_real_partition
	@
	Initialize a single component. We require all process-configuration blocks,
	and specific templates for the phase-space and integrator configuration.

	We also provide the current component index [[i]] and the [[active]] flag.
	For a subtraction component, the [[active]] flag is overridden.

	In the nlo mode, the component types have been determined before.

	TODO wk 2018: the component type need not be stored in the component; we may remove
	this when everything is controlled by [[pcm]].
	<<Pcm: pcm nlo: TBP>>=
	procedure :: init_component => pcm_nlo_init_component
	<<Pcm: procedures>>=
	subroutine pcm_nlo_init_component &
	(pcm, component, i, active, &
	phs_config, env, meta, config)
	class(pcm_nlo_t), intent(in) :: pcm
	type(process_component_t), intent(out) :: component
	integer, intent(in) :: i
	logical, intent(in) :: active
	class(phs_config_t), allocatable, intent(in) :: phs_config
	type(process_environment_t), intent(in) :: env
	type(process_metadata_t), intent(in) :: meta
	type(process_config_data_t), intent(in) :: config
	logical :: activate
	select case (pcm%nlo_type(i))
	case default; activate = active
	case (NLO_SUBTRACTION); activate = .false.
	end select
	call component%init (i, &
	env, meta, config, &
	activate, &
	phs_config)
	component%component_type = pcm%component_type(i)
	end subroutine pcm_nlo_init_component

	@ %def pcm_nlo_init_component
	@
	Override the base method: record the active components in the PCM object, and
	report inactive components (except for the subtraction component).
	<<Pcm: pcm nlo: TBP>>=
	procedure :: record_inactive_components => pcm_nlo_record_inactive_components
	<<Pcm: procedures>>=
	subroutine pcm_nlo_record_inactive_components (pcm, component, meta)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(process_component_t), dimension(:), intent(in) :: component
	type(process_metadata_t), intent(inout) :: meta
	integer :: i
	pcm%component_active = component%active
	do i = 1, pcm%n_components
	select case (pcm%nlo_type(i))
	case (NLO_SUBTRACTION)
	case default
	if (.not. component(i)%active) call meta%deactivate_component (i)
	end select
	end do
	end subroutine pcm_nlo_record_inactive_components

	@ %def pcm_nlo_record_inactive_components
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: core_is_radiation => pcm_nlo_core_is_radiation
	<<Pcm: procedures>>=
	function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad)
	logical :: is_rad
	class(pcm_nlo_t), intent(in) :: pcm
	integer, intent(in) :: i_core
	is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core)
	end function pcm_nlo_core_is_radiation

	@ %def pcm_nlo_core_is_radiation
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born
	<<Pcm: procedures>>=
	function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv)
	integer :: n_flv
	class(pcm_nlo_t), intent(in) :: pcm_nlo
	n_flv = pcm_nlo%region_data%n_flv_born
	end function pcm_nlo_get_n_flv_born

	@ %def pcm_nlo_get_n_flv_born
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real
	<<Pcm: procedures>>=
	function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv)
	integer :: n_flv
	class(pcm_nlo_t), intent(in) :: pcm_nlo
	n_flv = pcm_nlo%region_data%n_flv_real
	end function pcm_nlo_get_n_flv_real

	@ %def pcm_nlo_get_n_flv_real
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_n_alr => pcm_nlo_get_n_alr
	<<Pcm: procedures>>=
	function pcm_nlo_get_n_alr (pcm) result (n_alr)
	integer :: n_alr
	class(pcm_nlo_t), intent(in) :: pcm
	n_alr = pcm%region_data%n_regions
	end function pcm_nlo_get_n_alr

	@ %def pcm_nlo_get_n_alr
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_flv_states => pcm_nlo_get_flv_states
	<<Pcm: procedures>>=
	function pcm_nlo_get_flv_states (pcm, born) result (flv)
	integer, dimension(:,:), allocatable :: flv
	class(pcm_nlo_t), intent(in) :: pcm
	logical, intent(in) :: born
	if (born) then
	flv = pcm%region_data%get_flv_states_born ()
	else
	flv = pcm%region_data%get_flv_states_real ()
	end if
	end function pcm_nlo_get_flv_states

	@ %def pcm_nlo_get_flv_states
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_qn => pcm_nlo_get_qn
	<<Pcm: procedures>>=
	function pcm_nlo_get_qn (pcm, born) result (qn)
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	class(pcm_nlo_t), intent(in) :: pcm
	logical, intent(in) :: born
	if (born) then
	qn = pcm%qn_born
	else
	qn = pcm%qn_real
	end if
	end function pcm_nlo_get_qn

	@ %def pcm_nlo_get_qn
	@ Check if there are massive emitters. Since the mass-structure of all
	underlying Born configurations have to be the same (\textbf{This does
	not have to be the case when different components are generated at LO})
	, we just use the first one to determine this.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter
	<<Pcm: procedures>>=
	function pcm_nlo_has_massive_emitter (pcm) result (val)
	logical :: val
	class(pcm_nlo_t), intent(in) :: pcm
	integer :: i
	val = .false.
	associate (reg_data => pcm%region_data)
	do i = reg_data%n_in + 1, reg_data%n_legs_born
	if (any (i == reg_data%emitters)) &
	val = val .or. reg_data%flv_born(1)%massive(i)
	end do
	end associate
	end function pcm_nlo_has_massive_emitter

	@ %def pcm_nlo_has_massive_emitter
	@ Returns an array which specifies if the particle at position [[i]] is massive.
	<<Pcm: pcm nlo: TBP>>=
	procedure :: get_mass_info => pcm_nlo_get_mass_info
	<<Pcm: procedures>>=
	function pcm_nlo_get_mass_info (pcm, i_flv) result (massive)
	class(pcm_nlo_t), intent(in) :: pcm
	integer, intent(in) :: i_flv
	logical, dimension(:), allocatable :: massive
	allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive)))
	massive = pcm%region_data%flv_born(i_flv)%massive
	end function pcm_nlo_get_mass_info

	@ %def pcm_nlo_get_mass_info
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: allocate_workspace => pcm_nlo_allocate_workspace
	<<Pcm: procedures>>=
	subroutine pcm_nlo_allocate_workspace (pcm, work)
	class(pcm_nlo_t), intent(in) :: pcm
	class(pcm_workspace_t), intent(inout), allocatable :: work
	allocate (pcm_nlo_workspace_t :: work)
	end subroutine pcm_nlo_allocate_workspace

	@ %def pcm_nlo_allocate_workspace
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: init_qn => pcm_nlo_init_qn
	<<Pcm: procedures>>=
	subroutine pcm_nlo_init_qn (pcm, model)
	class(pcm_nlo_t), intent(inout) :: pcm
	class(model_data_t), intent(in) :: model
	integer, dimension(:,:), allocatable :: flv_states
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	allocate (flv_states (pcm%region_data%n_legs_born, pcm%region_data%n_flv_born))
	flv_states = pcm%get_flv_states (.true.)
	allocate (pcm%qn_born (size (flv_states, dim = 1), size (flv_states, dim = 2)))
	allocate (flv (size (flv_states, dim = 1)))
	allocate (qn (size (flv_states, dim = 1)))
	do i = 1, pcm%get_n_flv_born ()
	call flv%init (flv_states (:,i), model)
	call qn%init (flv)
	pcm%qn_born(:,i) = qn
	end do
	deallocate (flv); deallocate (qn)
	deallocate (flv_states)
	allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real))
	flv_states = pcm%get_flv_states (.false.)
	allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2)))
	allocate (flv (size (flv_states, dim = 1)))
	allocate (qn (size (flv_states, dim = 1)))
	do i = 1, pcm%get_n_flv_real ()
	call flv%init (flv_states (:,i), model)
	call qn%init (flv)
	pcm%qn_real(:,i) = qn
	end do
	end subroutine pcm_nlo_init_qn

	@ %def pcm_nlo_init_qn
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching
	<<Pcm: procedures>>=
	subroutine pcm_nlo_allocate_ps_matching (pcm)
	class(pcm_nlo_t), intent(inout) :: pcm
	if (.not. allocated (pcm%real_partition)) then
	allocate (powheg_damping_simple_t :: pcm%real_partition)
	end if
	end subroutine pcm_nlo_allocate_ps_matching

	@ %def pcm_nlo_allocate_ps_matching
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot
	<<Pcm: procedures>>=
	subroutine pcm_nlo_activate_dalitz_plot (pcm, filename)
	class(pcm_nlo_t), intent(inout) :: pcm
	type(string_t), intent(in) :: filename
	call pcm%dalitz_plot%init (free_unit (), filename, .false.)
	call pcm%dalitz_plot%write_header ()
	end subroutine pcm_nlo_activate_dalitz_plot

	@ %def pcm_nlo_activate_dalitz_plot
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot
	<<Pcm: procedures>>=
	subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p)
	class(pcm_nlo_t), intent(inout) :: pcm
	integer, intent(in) :: emitter
	type(vector4_t), intent(in), dimension(:) :: p
	real(default) :: k0_n, k0_np1
	k0_n = p(emitter)%p(0)
	k0_np1 = p(size(p))%p(0)
	call pcm%dalitz_plot%register (k0_n, k0_np1)
	end subroutine pcm_nlo_register_dalitz_plot

	@ %def pcm_nlo_register_dalitz_plot
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator
	<<Pcm: procedures>>=
	subroutine pcm_nlo_setup_phs_generator (pcm, pcm_work, generator, &
	sqrts, mode, singular_jacobian)
	class(pcm_nlo_t), intent(in) :: pcm
	type(phs_fks_generator_t), intent(inout) :: generator
	type(pcm_nlo_workspace_t), intent(in), target :: pcm_work
	real(default), intent(in) :: sqrts
	integer, intent(in), optional:: mode
	logical, intent(in), optional :: singular_jacobian
	logical :: yorn
	yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian
	call generator%connect_kinematics (pcm_work%isr_kinematics, &
	pcm_work%real_kinematics, pcm%has_massive_emitter ())
	generator%n_in = pcm%region_data%n_in
	call generator%set_sqrts_hat (sqrts)
	call generator%set_emitters (pcm%region_data%emitters)
	call generator%setup_masses (pcm%region_data%n_legs_born)
	generator%is_massive = pcm%get_mass_info (1)
	generator%singular_jacobian = yorn
	if (present (mode)) generator%mode = mode
	call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, &
	pcm%settings%fks_template%y_max)
	end subroutine pcm_nlo_setup_phs_generator

	@ %def pcm_nlo_setup_phs_generator
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: final => pcm_nlo_final
	<<Pcm: procedures>>=
	subroutine pcm_nlo_final (pcm)
	class(pcm_nlo_t), intent(inout) :: pcm
	if (allocated (pcm%real_partition)) deallocate (pcm%real_partition)
	call pcm%dalitz_plot%final ()
	end subroutine pcm_nlo_final

	@ %def pcm_nlo_final
	@
	<<Pcm: pcm nlo: TBP>>=
	procedure :: is_nlo => pcm_nlo_is_nlo
	<<Pcm: procedures>>=
	function pcm_nlo_is_nlo (pcm) result (is_nlo)
	logical :: is_nlo
	class(pcm_nlo_t), intent(in) :: pcm
	is_nlo = .true.
	end function pcm_nlo_is_nlo

	@ %def pcm_nlo_is_nlo
	@ As a first implementation, it acts as a wrapper for the NLO controller
	object and the squared matrix-element collector.
	<<Pcm: public>>=
	public :: pcm_nlo_workspace_t
	<<Pcm: types>>=
	type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t
	type(real_kinematics_t), pointer :: real_kinematics => null ()
	type(isr_kinematics_t), pointer :: isr_kinematics => null ()
	type(real_subtraction_t) :: real_sub
	type(virtual_t) :: virtual
	type(soft_mismatch_t) :: soft_mismatch
	type(dglap_remnant_t) :: dglap_remnant
	integer, dimension(:), allocatable :: i_mci_to_real_component
	contains
	<<Pcm: pcm instance: TBP>>
	end type pcm_nlo_workspace_t

	@ %def pcm_nlo_workspace_t
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event
	procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_radiation_event (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	pcm_work%real_sub%radiation_event = .true.
	pcm_work%real_sub%subtraction_event = .false.
	end subroutine pcm_nlo_workspace_set_radiation_event

	subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	pcm_work%real_sub%radiation_event = .false.
	pcm_work%real_sub%subtraction_event = .true.
	end subroutine pcm_nlo_workspace_set_subtraction_event

	@ %def pcm_nlo_workspace_set_radiation_event
	@ %def pcm_nlo_workspace_set_subtraction_event
	<<Pcm: pcm instance: TBP>>=
	procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_disable_subtraction (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	pcm_work%real_sub%subtraction_deactivated = .true.
	end subroutine pcm_nlo_workspace_disable_subtraction

	@ %def pcm_nlo_workspace_disable_subtraction
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_config => pcm_nlo_workspace_init_config
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, active_components, &
	nlo_types, energy, i_real_fin, model)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	logical, intent(in), dimension(:) :: active_components
	integer, intent(in), dimension(:) :: nlo_types
	real(default), intent(in), dimension(:) :: energy
	integer, intent(in) :: i_real_fin
	class(model_data_t), intent(in) :: model
	integer :: i_component
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_nlo_workspace_init_config")
	call pcm_work%init_real_and_isr_kinematics (pcm, energy)
	select type (pcm)
	type is (pcm_nlo_t)
	do i_component = 1, size (active_components)
	if (active_components(i_component) .or. pcm%settings%combined_integration) then
	select case (nlo_types(i_component))
	case (NLO_REAL)
	if (i_component /= i_real_fin) then
	call pcm_work%setup_real_component (pcm, &
	pcm%settings%fks_template%subtraction_disabled)
	end if
	case (NLO_VIRTUAL)
	call pcm_work%init_virtual (pcm, model)
	case (NLO_MISMATCH)
	call pcm_work%init_soft_mismatch (pcm)
	case (NLO_DGLAP)
	call pcm_work%init_dglap_remnant (pcm)
	end select
	end if
	end do
	end select
	end subroutine pcm_nlo_workspace_init_config

	@ %def pcm_nlo_workspace_init_config
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, &
	subtraction_disabled)
	class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
	class(pcm_t), intent(in) :: pcm
	logical, intent(in) :: subtraction_disabled
	select type (pcm)
	type is (pcm_nlo_t)
	call pcm_work%init_real_subtraction (pcm)
	if (subtraction_disabled) call pcm_work%disable_subtraction ()
	end select
	end subroutine pcm_nlo_workspace_setup_real_component

	@ %def pcm_nlo_workspace_setup_real_component
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_real_and_isr_kinematics => &
	pcm_nlo_workspace_init_real_and_isr_kinematics
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_real_and_isr_kinematics (pcm_work, pcm, energy)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	real(default), dimension(:), intent(in) :: energy
	integer :: n_contr
	allocate (pcm_work%real_kinematics)
	allocate (pcm_work%isr_kinematics)
	select type (pcm)
	type is (pcm_nlo_t)
	associate (region_data => pcm%region_data)
	if (allocated (region_data%alr_contributors)) then
	n_contr = size (region_data%alr_contributors)
	else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
	n_contr = 2
	else
	n_contr = 1
	end if
	call pcm_work%real_kinematics%init &
	(region_data%n_legs_real, region_data%n_phs, &
	region_data%n_regions, n_contr)
	if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
	call pcm_work%real_kinematics%init_onshell &
	(region_data%n_legs_real, region_data%n_phs)
	pcm_work%isr_kinematics%n_in = region_data%n_in
	end associate
	end select
	pcm_work%isr_kinematics%beam_energy = energy
	end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics

	@ %def pcm_nlo_workspace_init_real_and_isr_kinematics
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_real_and_isr_kinematics => &
	pcm_nlo_workspace_set_real_and_isr_kinematics
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_real_and_isr_kinematics (pcm_work, phs_identifiers, sqrts)
	class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
	type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
	real(default), intent(in) :: sqrts
	call pcm_work%real_sub%set_real_kinematics &
	(pcm_work%real_kinematics)
	call pcm_work%real_sub%set_isr_kinematics &
	(pcm_work%isr_kinematics)
	end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics

	@ %def pcm_nlo_workspace_set_real_and_isr_kinematics
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm)
	class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
	class(pcm_t), intent(in) :: pcm
	select type (pcm)
	type is (pcm_nlo_t)
	associate (region_data => pcm%region_data)
	call pcm_work%real_sub%init (region_data, pcm%settings)
	if (allocated (pcm%settings%selected_alr)) then
	associate (selected_alr => pcm%settings%selected_alr)
	if (any (selected_alr < 0)) then
	call msg_fatal ("Fixed alpha region must be non-negative!")
	else if (any (selected_alr > region_data%n_regions)) then
	call msg_fatal ("Fixed alpha region is larger than the total"&
	&" number of singular regions!")
	else
	allocate (pcm_work%real_sub%selected_alr (size (selected_alr)))
	pcm_work%real_sub%selected_alr = selected_alr
	end if
	end associate
	end if
	end associate
	end select
	end subroutine pcm_nlo_workspace_init_real_subtraction

	@ %def pcm_nlo_workspace_init_real_subtraction
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_momenta_and_scales_virtual => &
	pcm_nlo_workspace_set_momenta_and_scales_virtual
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual (pcm_work, p, &
	ren_scale, fac_scale, es_scale)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), allocatable, intent(in) :: ren_scale
	real(default), intent(in) :: fac_scale
	real(default), allocatable, intent(in) :: es_scale
	associate (virtual => pcm_work%virtual)
	call virtual%set_ren_scale (ren_scale)
	call virtual%set_fac_scale (p, fac_scale)
	call virtual%set_ellis_sexton_scale (es_scale)
	end associate
	end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual

	@ %def pcm_nlo_workspace_set_momenta_and_scales_virtual
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	real(default), intent(in) :: fac_scale
	pcm_work%isr_kinematics%fac_scale = fac_scale
	end subroutine pcm_nlo_workspace_set_fac_scale

	@ %def pcm_nlo_workspace_set_fac_scale
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_momenta => pcm_nlo_workspace_set_momenta
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_momenta (pcm_work, p_born, p_real, i_phs, cms)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	type(vector4_t), dimension(:), intent(in) :: p_born, p_real
	integer, intent(in) :: i_phs
	logical, intent(in), optional :: cms
	logical :: yorn
	yorn = .false.; if (present (cms)) yorn = cms
	associate (kinematics => pcm_work%real_kinematics)
	if (yorn) then
	if (.not. kinematics%p_born_cms%initialized) &
	call kinematics%p_born_cms%init (size (p_born), 1)
	if (.not. kinematics%p_real_cms%initialized) &
	call kinematics%p_real_cms%init (size (p_real), 1)
	kinematics%p_born_cms%phs_point(1) = p_born
	kinematics%p_real_cms%phs_point(i_phs) = p_real
	else
	if (.not. kinematics%p_born_lab%initialized) &
	call kinematics%p_born_lab%init (size (p_born), 1)
	if (.not. kinematics%p_real_lab%initialized) &
	call kinematics%p_real_lab%init (size (p_real), 1)
	kinematics%p_born_lab%phs_point(1) = p_born
	kinematics%p_real_lab%phs_point(i_phs) = p_real
	end if
	end associate
	end subroutine pcm_nlo_workspace_set_momenta

	@ %def pcm_nlo_workspace_set_momenta
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: get_momenta => pcm_nlo_workspace_get_momenta
	<<Pcm: procedures>>=
	function pcm_nlo_workspace_get_momenta (pcm_work, pcm, &
	i_phs, born_phsp, cms) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(pcm_nlo_workspace_t), intent(in) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	integer, intent(in) :: i_phs
	logical, intent(in) :: born_phsp
	logical, intent(in), optional :: cms
	logical :: yorn
	yorn = .false.; if (present (cms)) yorn = cms
	select type (pcm)
	type is (pcm_nlo_t)
	if (born_phsp) then
	if (yorn) then
	p = pcm_work%real_kinematics%p_born_cms%phs_point(1)
	else
	p =pcm_work%real_kinematics%p_born_lab%phs_point(1)
	end if
	else
	if (yorn) then
	p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs)
	else
	p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs)
	end if
	end if
	end select
	end function pcm_nlo_workspace_get_momenta

	@ %def pcm_nlo_workspace_get_momenta
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max
	<<Pcm: procedures>>=
	function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max)
	real(default) :: xi_max
	class(pcm_nlo_workspace_t), intent(in) :: pcm_work
	integer, intent(in) :: alr
	integer :: i_phs
	i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr)
	xi_max = pcm_work%real_kinematics%xi_max (i_phs)
	end function pcm_nlo_workspace_get_xi_max

	@ %def pcm_nlo_workspace_get_xi_max
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	real(default), intent(in), dimension(:) :: x_tot
	integer :: n_par
	n_par = size (x_tot)
	if (n_par < 3) then
	pcm_work%real_kinematics%x_rad = zero
	else
	pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
	end if
	end subroutine pcm_nlo_workspace_set_x_rad

	@ %def pcm_nlo_workspace_set_x_rad
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_virtual => pcm_nlo_workspace_init_virtual
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model)
	class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
	class(pcm_t), intent(in) :: pcm
	class(model_data_t), intent(in) :: model
	select type (pcm)
	type is (pcm_nlo_t)
	associate (region_data => pcm%region_data)
	call pcm_work%virtual%init (region_data%get_flv_states_born (), &
	region_data%n_in, pcm%settings, model, pcm%has_pdfs)
	end associate
	end select
	end subroutine pcm_nlo_workspace_init_virtual

	@ %def pcm_nlo_workspace_init_virtual
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: disable_virtual_subtraction => pcm_nlo_workspace_disable_virtual_subtraction
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	end subroutine pcm_nlo_workspace_disable_virtual_subtraction

	@ %def pcm_nlo_workspace_disable_virtual_subtraction
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, &
	alpha_coupling, separate_uborns, sqme_virt)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	type(vector4_t), intent(in), dimension(:) :: p
	real(default), dimension(2), intent(in) :: alpha_coupling
	logical, intent(in) :: separate_uborns
	real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
	type(vector4_t), dimension(:), allocatable :: pp
	associate (virtual => pcm_work%virtual)
	allocate (pp (size (p)))
	if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
	pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1)
	else
	pp = p
	end if
	select type (pcm)
	type is (pcm_nlo_t)
	if (separate_uborns) then
	allocate (sqme_virt (pcm%get_n_flv_born ()))
	else
	allocate (sqme_virt (1))
	end if
	sqme_virt = zero
	call virtual%evaluate (pcm%region_data, &
	alpha_coupling, pp, separate_uborns, sqme_virt)
	end select
	end associate
	end subroutine pcm_nlo_workspace_compute_sqme_virt

	@ %def pcm_nlo_workspace_compute_sqme_virt
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, &
	alpha_s, separate_uborns, sqme_mism)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	real(default), intent(in) :: alpha_s
	logical, intent(in) :: separate_uborns
	real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
	select type (pcm)
	type is (pcm_nlo_t)
	if (separate_uborns) then
	allocate (sqme_mism (pcm%get_n_flv_born ()))
	else
	allocate (sqme_mism (1))
	end if
	sqme_mism = zero
	sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s)
	end select
	end subroutine pcm_nlo_workspace_compute_sqme_mismatch

	@ %def pcm_nlo_workspace_compute_sqme_mismatch
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: compute_sqme_dglap_remnant => pcm_nlo_workspace_compute_sqme_dglap_remnant
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, pcm, &
	alpha_coupling, separate_uborns, sqme_dglap)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	real(default), dimension(2), intent(in) :: alpha_coupling
	logical, intent(in) :: separate_uborns
	real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
	select type (pcm)
	type is (pcm_nlo_t)
	if (separate_uborns) then
	allocate (sqme_dglap (pcm%get_n_flv_born ()))
	else
	allocate (sqme_dglap (1))
	end if
	end select
	sqme_dglap = zero
	call pcm_work%dglap_remnant%evaluate (alpha_coupling, separate_uborns, sqme_dglap)
	end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant

	@ %def pcm_nlo_workspace_compute_sqme_dglap_remnant
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: set_fixed_order_event_mode => pcm_nlo_workspace_set_fixed_order_event_mode
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS
	end subroutine pcm_nlo_workspace_set_fixed_order_event_mode

	<<Pcm: pcm instance: TBP>>=
	procedure :: set_powheg_mode => pcm_nlo_workspace_set_powheg_mode
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_set_powheg_mode (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	pcm_work%real_sub%purpose = POWHEG
	end subroutine pcm_nlo_workspace_set_powheg_mode

	@ %def pcm_nlo_workspace_set_fixed_order_event_mode
	@ %def pcm_nlo_workspace_set_powheg_mode
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	select type (pcm)
	type is (pcm_nlo_t)
	call pcm_work%soft_mismatch%init (pcm%region_data, &
	pcm_work%real_kinematics, pcm%settings%factorization_mode)
	end select
	end subroutine pcm_nlo_workspace_init_soft_mismatch

	@ %def pcm_nlo_workspace_init_soft_mismatch
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	class(pcm_t), intent(in) :: pcm
	select type (pcm)
	type is (pcm_nlo_t)
	call pcm_work%dglap_remnant%init ( &
	pcm%settings, &
	pcm%region_data, &
	pcm_work%isr_kinematics)
	end select
	end subroutine pcm_nlo_workspace_init_dglap_remnant

	@ %def pcm_nlo_workspace_init_dglap_remnant
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: is_fixed_order_nlo_events &
	=> pcm_nlo_workspace_is_fixed_order_nlo_events
	<<Pcm: procedures>>=
	function pcm_nlo_workspace_is_fixed_order_nlo_events (pcm_work) result (is_fnlo)
	logical :: is_fnlo
	class(pcm_nlo_workspace_t), intent(in) :: pcm_work
	is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS
	end function pcm_nlo_workspace_is_fixed_order_nlo_events

	@ %def pcm_nlo_workspace_is_fixed_order_nlo_events
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: final => pcm_nlo_workspace_final
	<<Pcm: procedures>>=
	subroutine pcm_nlo_workspace_final (pcm_work)
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	call pcm_work%real_sub%final ()
	call pcm_work%virtual%final ()
	call pcm_work%soft_mismatch%final ()
	call pcm_work%dglap_remnant%final ()
	if (associated (pcm_work%real_kinematics)) then
	call pcm_work%real_kinematics%final ()
	nullify (pcm_work%real_kinematics)
	end if
	if (associated (pcm_work%isr_kinematics)) then
	nullify (pcm_work%isr_kinematics)
	end if
	end subroutine pcm_nlo_workspace_final

	@ %def pcm_nlo_workspace_final
	@
	<<Pcm: pcm instance: TBP>>=
	procedure :: is_nlo => pcm_nlo_workspace_is_nlo
	<<Pcm: procedures>>=
	function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo)
	logical :: is_nlo
	class(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	is_nlo = .true.
	end function pcm_nlo_workspace_is_nlo

	@ %def pcm_nlo_workspace_is_nlo
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Kinematics instance}
	In this data type we combine all objects (instances) necessary for
	generating (or recovering) a kinematical configuration. The
	components work together as an implementation of multi-channel phase
	space.

	[[sf_chain]] is an instance of the structure-function chain. It is
	used both for generating kinematics and, after the proper scale has
	been determined, evaluating the structure function entries.

	[[phs]] is an instance of the phase space for the elementary process.

	The array [[f]] contains the products of the Jacobians that originate
	from parameter mappings in the structure-function chain or in the
	phase space. We allocate this explicitly if either [[sf_chain]] or
	[[phs]] are explicitly allocated, otherwise we can take over a pointer.

	All components are implemented as pointers to (anonymous) targets.
	For each component, there is a flag that tells whether this component
	is to be regarded as a proper component (`owned' by the object) or as
	a pointer.
	@
	<<[[kinematics.f90]]>>=
	<<File header>>

	module kinematics

	<<Use kinds>>
	<<Use debug>>
	use format_utils, only: write_separator
	use diagnostics
	use io_units
	use lorentz
	use phs_points, only: assignment(=), size
	use physics_defs
	use sf_base
	use phs_base
	use interactions
	use mci_base
	use phs_fks
	use fks_regions
	use process_config
	use process_mci
	use pcm_base, only: pcm_t, pcm_workspace_t
	use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
	use ttv_formfactors, only: m1s_to_mpole

	<<Standard module head>>

	<<Kinematics: public>>

	<<Kinematics: types>>

	contains

	<<Kinematics: procedures>>

	end module kinematics
	@ %def kinematics
	<<Kinematics: public>>=
	public :: kinematics_t
	<<Kinematics: types>>=
	type :: kinematics_t
	integer :: n_in = 0
	integer :: n_channel = 0
	integer :: selected_channel = 0
	type(sf_chain_instance_t), pointer :: sf_chain => null ()
	class(phs_t), pointer :: phs => null ()
	real(default), dimension(:), pointer :: f => null ()
	real(default) :: phs_factor
	logical :: sf_chain_allocated = .false.
	logical :: phs_allocated = .false.
	logical :: f_allocated = .false.
	integer :: emitter = -1
	integer :: i_phs = 0
	integer :: i_con = 0
	logical :: only_cm_frame = .false.
	logical :: new_seed = .true.
	logical :: threshold = .false.
	contains
	<<Kinematics: kinematics: TBP>>
	end type kinematics_t

	@ %def kinematics_t
	@ Output. Show only those components which are marked as owned.
	<<Kinematics: kinematics: TBP>>=
	procedure :: write => kinematics_write
	<<Kinematics: procedures>>=
	subroutine kinematics_write (object, unit)
	class(kinematics_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, c
	u = given_output_unit (unit)
	if (object%f_allocated) then
	write (u, "(1x,A)") "Flux * PHS volume:"
	write (u, "(2x,ES19.12)") object%phs_factor
	write (u, "(1x,A)") "Jacobian factors per channel:"
	do c = 1, size (object%f)
	write (u, "(3x,I0,':',1x,ES14.7)", advance="no") c, object%f(c)
	if (c == object%selected_channel) then
	write (u, "(1x,A)") "[selected]"
	else
	write (u, *)
	end if
	end do
	end if
	if (object%sf_chain_allocated) then
	call write_separator (u)
	call object%sf_chain%write (u)
	end if
	if (object%phs_allocated) then
	call write_separator (u)
	call object%phs%write (u)
	end if
	end subroutine kinematics_write

	@ %def kinematics_write
	@ Finalizer. Delete only those components which are marked as owned.
	<<Kinematics: kinematics: TBP>>=
	procedure :: final => kinematics_final
	<<Kinematics: procedures>>=
	subroutine kinematics_final (object)
	class(kinematics_t), intent(inout) :: object
	if (object%sf_chain_allocated) then
	call object%sf_chain%final ()
	deallocate (object%sf_chain)
	object%sf_chain_allocated = .false.
	end if
	if (object%phs_allocated) then
	call object%phs%final ()
	deallocate (object%phs)
	object%phs_allocated = .false.
	end if
	if (object%f_allocated) then
	deallocate (object%f)
	object%f_allocated = .false.
	end if
	end subroutine kinematics_final

	@ %def kinematics_final
	@ Configure the kinematics object. This consists of several
	configuration steps which correspond to individual procedures. In
	essence, we configure the structure-function part, the partonic
	phase-space part, and various NLO items.

	TODO wk 19-03-01: This includes some region-data setup within [[pcm]],
	hence [[pcm]] is intent(inout). This should be moved elsewhere, so
	[[pcm]] can become strictly intent(in).
	<<Kinematics: kinematics: TBP>>=
	procedure :: configure => kinematics_configure
	<<Kinematics: procedures>>=
	subroutine kinematics_configure (kin, pcm, pcm_work, &
	sf_chain, beam_config, phs_config, nlo_type, is_i_sub)
	class(kinematics_t), intent(out) :: kin
	class(pcm_t), intent(inout) :: pcm
	class(pcm_workspace_t), intent(in) :: pcm_work
	type(sf_chain_t), intent(in), target :: sf_chain
	type(process_beam_config_t), intent(in), target :: beam_config
	class(phs_config_t), intent(in), target :: phs_config
	integer, intent(in) :: nlo_type
	logical, intent(in) :: is_i_sub
	logical :: extended_sf
	extended_sf = nlo_type == NLO_DGLAP .or. (nlo_type == NLO_REAL .and. is_i_sub)
	call kin%init_sf_chain (sf_chain, beam_config, &
	extended_sf = pcm%has_pdfs .and. extended_sf)
	!!! Add one for additional Born matrix element
	call kin%init_phs (phs_config)
	call kin%set_nlo_info (nlo_type)
	select type (phs => kin%phs)
	type is (phs_fks_t)
	call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL))
	select type (pcm)
	type is (pcm_nlo_t)
	call pcm%region_data%init_phs_identifiers (phs%phs_identifiers)
	!!! The triple select type pyramid of doom
	select type (pcm_work)
	type is (pcm_nlo_workspace_t)
	if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) &
	call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
	pcm_work%real_kinematics%alr_to_i_phs)
	end select
	end select
	end select
	end subroutine kinematics_configure

	@ %def kinematics_configure
	@ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter.
	<<Kinematics: kinematics: TBP>>=
	procedure :: set_nlo_info => kinematics_set_nlo_info
	<<Kinematics: procedures>>=
	subroutine kinematics_set_nlo_info (k, nlo_type)
	class(kinematics_t), intent(inout) :: k
	integer, intent(in) :: nlo_type
	if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true.
	end subroutine kinematics_set_nlo_info

	@ %def kinematics_set_nlo_info
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: set_threshold => kinematics_set_threshold
	<<Kinematics: procedures>>=
	subroutine kinematics_set_threshold (kin, factorization_mode)
	class(kinematics_t), intent(inout) :: kin
	integer, intent(in) :: factorization_mode
	kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD
	end subroutine kinematics_set_threshold

	@ %def kinematics_set_threshold
	@ Allocate the structure-function chain instance, initialize it as a
	copy of the [[sf_chain]] template, and prepare it for evaluation.

	The [[sf_chain]] remains a target because the (usually constant) beam momenta
	are taken from there.
	<<Kinematics: kinematics: TBP>>=
	procedure :: init_sf_chain => kinematics_init_sf_chain
	<<Kinematics: procedures>>=
	subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf)
	class(kinematics_t), intent(inout) :: k
	type(sf_chain_t), intent(in), target :: sf_chain
	type(process_beam_config_t), intent(in) :: config
	logical, intent(in), optional :: extended_sf
	integer :: n_strfun, n_channel
	integer :: c
	k%n_in = config%data%get_n_in ()
	n_strfun = config%n_strfun
	n_channel = config%n_channel
	allocate (k%sf_chain)
	k%sf_chain_allocated = .true.
	call k%sf_chain%init (sf_chain, n_channel)
	if (n_strfun /= 0) then
	do c = 1, n_channel
	call k%sf_chain%set_channel (c, config%sf_channel(c))
	end do
	end if
	call k%sf_chain%link_interactions ()
	call k%sf_chain%exchange_mask ()
	call k%sf_chain%init_evaluators (extended_sf = extended_sf)
	end subroutine kinematics_init_sf_chain

	@ %def kinematics_init_sf_chain
	@ Allocate and initialize the phase-space part and the array of
	Jacobian factors.
	<<Kinematics: kinematics: TBP>>=
	procedure :: init_phs => kinematics_init_phs
	<<Kinematics: procedures>>=
	subroutine kinematics_init_phs (k, config)
	class(kinematics_t), intent(inout) :: k
	class(phs_config_t), intent(in), target :: config
	k%n_channel = config%get_n_channel ()
	call config%allocate_instance (k%phs)
	call k%phs%init (config)
	k%phs_allocated = .true.
	allocate (k%f (k%n_channel))
	k%f = 0
	k%f_allocated = .true.
	end subroutine kinematics_init_phs

	@ %def kinematics_init_phs
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: evaluate_radiation_kinematics => kinematics_evaluate_radiation_kinematics
	<<Kinematics: procedures>>=
	subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
	class(kinematics_t), intent(inout) :: k
	real(default), intent(in), dimension(:) :: r_in
	select type (phs => k%phs)
	type is (phs_fks_t)
	if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
	call phs%generate_radiation_variables &
	(r_in(phs%n_r_born + 1 : phs%n_r_born + 3), threshold = k%threshold)
	call phs%compute_cms_energy ()
	end if
	end select
	end subroutine kinematics_evaluate_radiation_kinematics

	@ %def kinematics_evaluate_radiation_kinematics
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: generate_fsr_in => kinematics_generate_fsr_in
	<<Kinematics: procedures>>=
	subroutine kinematics_generate_fsr_in (kin)
	class(kinematics_t), intent(inout) :: kin
	select type (phs => kin%phs)
	type is (phs_fks_t)
	call phs%generate_fsr_in ()
	end select
	end subroutine kinematics_generate_fsr_in

	@ %def kinematics_generate_fsr_in
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta
	<<Kinematics: procedures>>=
	subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type)
	class(kinematics_t), intent(inout) :: k
	type(region_data_t), intent(in) :: reg_data
	integer, intent(in) :: nlo_type
	logical :: use_contributors
	use_contributors = allocated (reg_data%alr_contributors)
	select type (phs => k%phs)
	type is (phs_fks_t)
	if (use_contributors) then
	call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors)
	else if (k%threshold) then
	if (.not. is_subtraction_component (k%emitter, nlo_type)) &
	call phs%compute_xi_ref_momenta_threshold ()
	else
	call phs%compute_xi_ref_momenta ()
	end if
	end select
	end subroutine kinematics_compute_xi_ref_momenta

	@ %def kinematics_compute_xi_ref_momenta
	@ Generate kinematics, given a phase-space channel and a MC
	parameter set. The main result is the momentum array [[p]], but we
	also fill the momentum entries in the structure-function chain and the
	Jacobian-factor array [[f]]. Regarding phase space, we fill only the
	parameter arrays for the selected channel.
	<<Kinematics: kinematics: TBP>>=
	procedure :: compute_selected_channel => kinematics_compute_selected_channel
	<<Kinematics: procedures>>=
	subroutine kinematics_compute_selected_channel &
	(k, mci_work, phs_channel, p, success)
	class(kinematics_t), intent(inout) :: k
	type(mci_work_t), intent(in) :: mci_work
	integer, intent(in) :: phs_channel
	type(vector4_t), dimension(:), intent(out) :: p
	logical, intent(out) :: success
	integer :: sf_channel
	k%selected_channel = phs_channel
	sf_channel = k%phs%config%get_sf_channel (phs_channel)
	call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ())
	call k%sf_chain%get_out_momenta (p(1:k%n_in))
	call k%phs%set_incoming_momenta (p(1:k%n_in))
	call k%phs%compute_flux ()
	call k%phs%select_channel (phs_channel)
	call k%phs%evaluate_selected_channel (phs_channel, &
	mci_work%get_x_process ())

	select type (phs => k%phs)
	type is (phs_fks_t)
	if (debug_on) call msg_debug2 (D_REAL, "phase space is phs_FKS")
	if (phs%q_defined) then
	call phs%get_born_momenta (p)
	if (debug_on) then
	call msg_debug2 (D_REAL, "q is defined")
	call msg_debug2 (D_REAL, "get_born_momenta called")
	end if
	k%phs_factor = phs%get_overall_factor ()
	success = .true.
	else
	k%phs_factor = 0
	success = .false.
	end if
	class default
	if (phs%q_defined) then
	call k%phs%get_outgoing_momenta (p(k%n_in + 1 :))
	k%phs_factor = k%phs%get_overall_factor ()
	success = .true.
	else
	k%phs_factor = 0
	success = .false.
	end if
	end select
	end subroutine kinematics_compute_selected_channel

	@ %def kinematics_compute_selected_channel
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: redo_sf_chain => kinematics_redo_sf_chain
	<<Kinematics: procedures>>=
	subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel)
	class(kinematics_t), intent(inout) :: kin
	type(mci_work_t), intent(in) :: mci_work
	integer, intent(in) :: phs_channel
	real(default), dimension(:), allocatable :: x
	integer :: sf_channel, n
	real(default) :: xi, y
	n = size (mci_work%get_x_strfun ())
	if (n > 0) then
	allocate (x(n))
	x = mci_work%get_x_strfun ()
	sf_channel = kin%phs%config%get_sf_channel (phs_channel)
	call kin%sf_chain%compute_kinematics (sf_channel, x)
	end if
	end subroutine kinematics_redo_sf_chain

	@ %def kinematics_redo_sf_chain
	@ Complete kinematics by filling the non-selected phase-space parameter
	arrays.
	<<Kinematics: kinematics: TBP>>=
	procedure :: compute_other_channels => kinematics_compute_other_channels
	<<Kinematics: procedures>>=
	subroutine kinematics_compute_other_channels (k, mci_work, phs_channel)
	class(kinematics_t), intent(inout) :: k
	type(mci_work_t), intent(in) :: mci_work
	integer, intent(in) :: phs_channel
	integer :: c, c_sf
	call k%phs%evaluate_other_channels (phs_channel)
	do c = 1, k%n_channel
	c_sf = k%phs%config%get_sf_channel (c)
	k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
	end do
	end subroutine kinematics_compute_other_channels

	@ %def kinematics_compute_other_channels
	@ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which
	become the incoming (seed) momenta of the hard interaction.

	This is a stripped down-version of the above which we use when
	recovering kinematics. Momenta are known, but no MC parameters yet.

	(We do not use the [[get_out_momenta]] method of the chain, since this
	relies on the structure-function interactions, which are not necessary
	filled here. We do rely on the momenta of the last evaluator in the
	chain, however.)
	<<Kinematics: kinematics: TBP>>=
	procedure :: get_incoming_momenta => kinematics_get_incoming_momenta
	<<Kinematics: procedures>>=
	subroutine kinematics_get_incoming_momenta (k, p)
	class(kinematics_t), intent(in) :: k
	type(vector4_t), dimension(:), intent(out) :: p
	type(interaction_t), pointer :: int
	integer :: i
	int => k%sf_chain%get_out_int_ptr ()
	do i = 1, k%n_in
	p(i) = int%get_momentum (k%sf_chain%get_out_i (i))
	end do
	end subroutine kinematics_get_incoming_momenta

	@ %def kinematics_get_incoming_momenta
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: get_boost_to_lab => kinematics_get_boost_to_lab
	<<Kinematics: procedures>>=
	function kinematics_get_boost_to_lab (kin) result (lt)
	type(lorentz_transformation_t) :: lt
	class(kinematics_t), intent(in) :: kin
	lt = kin%phs%get_lorentz_transformation ()
	end function kinematics_get_boost_to_lab

	@ %def kinematics_get_boost_to_lab
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: get_boost_to_cms => kinematics_get_boost_to_cms
	<<Kinematics: procedures>>=
	function kinematics_get_boost_to_cms (kin) result (lt)
	type(lorentz_transformation_t) :: lt
	class(kinematics_t), intent(in) :: kin
	lt = inverse (kin%phs%get_lorentz_transformation ())
	end function kinematics_get_boost_to_cms

	@ %def kinematics_get_boost_to_cms
	@ This inverts the remainder of the above [[compute]] method. We know
	the momenta and recover the rest, as far as needed. If we select a
	channel, we can complete the inversion and reconstruct the
	MC parameter set.
	<<Kinematics: kinematics: TBP>>=
	procedure :: recover_mcpar => kinematics_recover_mcpar
	<<Kinematics: procedures>>=
	subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p)
	class(kinematics_t), intent(inout) :: k
	type(mci_work_t), intent(inout) :: mci_work
	integer, intent(in) :: phs_channel
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: c, c_sf
	real(default), dimension(:), allocatable :: x_sf, x_phs
	c = phs_channel
	c_sf = k%phs%config%get_sf_channel (c)
	k%selected_channel = c
	call k%sf_chain%recover_kinematics (c_sf)
	call k%phs%set_incoming_momenta (p(1:k%n_in))
	call k%phs%compute_flux ()
	call k%phs%set_outgoing_momenta (p(k%n_in+1:))
	call k%phs%inverse ()
	do c = 1, k%n_channel
	c_sf = k%phs%config%get_sf_channel (c)
	k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
	end do
	k%phs_factor = k%phs%get_overall_factor ()
	c = phs_channel
	c_sf = k%phs%config%get_sf_channel (c)
	allocate (x_sf (k%sf_chain%config%get_n_bound ()))
	allocate (x_phs (k%phs%config%get_n_par ()))
	call k%phs%select_channel (c)
	call k%sf_chain%get_mcpar (c_sf, x_sf)
	call k%phs%get_mcpar (c, x_phs)
	call mci_work%set_x_strfun (x_sf)
	call mci_work%set_x_process (x_phs)
	end subroutine kinematics_recover_mcpar

	@ %def kinematics_recover_mcpar
	@ This first part of [[recover_mcpar]]: just handle the sfchain.
	<<Kinematics: kinematics: TBP>>=
	procedure :: recover_sfchain => kinematics_recover_sfchain
	<<Kinematics: procedures>>=
	subroutine kinematics_recover_sfchain (k, channel, p)
	class(kinematics_t), intent(inout) :: k
	integer, intent(in) :: channel
	type(vector4_t), dimension(:), intent(in) :: p
	k%selected_channel = channel
	call k%sf_chain%recover_kinematics (channel)
	end subroutine kinematics_recover_sfchain

	@ %def kinematics_recover_sfchain
	@ Retrieve the MC input parameter array for a specific channel. We assume
	that the kinematics is complete, so this is known for all channels.
	<<Kinematics: kinematics: TBP>>=
	procedure :: get_mcpar => kinematics_get_mcpar
	<<Kinematics: procedures>>=
	subroutine kinematics_get_mcpar (k, phs_channel, r)
	class(kinematics_t), intent(in) :: k
	integer, intent(in) :: phs_channel
	real(default), dimension(:), intent(out) :: r
	integer :: sf_channel, n_par_sf, n_par_phs
	sf_channel = k%phs%config%get_sf_channel (phs_channel)
	n_par_phs = k%phs%config%get_n_par ()
	n_par_sf = k%sf_chain%config%get_n_bound ()
	if (n_par_sf > 0) then
	call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf))
	end if
	if (n_par_phs > 0) then
	call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:))
	end if
	end subroutine kinematics_get_mcpar

	@ %def kinematics_get_mcpar
	@ Evaluate the structure function chain, assuming that kinematics is known.

	The status must be precisely [[SF_DONE_KINEMATICS]]. We thus avoid
	evaluating the chain twice via different pointers to the same target.
	<<Kinematics: kinematics: TBP>>=
	procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain
	<<Kinematics: procedures>>=
	subroutine kinematics_evaluate_sf_chain (k, fac_scale, negative_sf, sf_rescale)
	class(kinematics_t), intent(inout) :: k
	real(default), intent(in) :: fac_scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(inout), optional :: sf_rescale
	select case (k%sf_chain%get_status ())
	case (SF_DONE_KINEMATICS)
	call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, sf_rescale = sf_rescale)
	end select
	end subroutine kinematics_evaluate_sf_chain

	@ %def kinematics_evaluate_sf_chain
	@ Recover beam momenta, i.e., return the beam momenta stored in the
	current [[sf_chain]] to their source. This is a side effect.
	<<Kinematics: kinematics: TBP>>=
	procedure :: return_beam_momenta => kinematics_return_beam_momenta
	<<Kinematics: procedures>>=
	subroutine kinematics_return_beam_momenta (k)
	class(kinematics_t), intent(in) :: k
	call k%sf_chain%return_beam_momenta ()
	end subroutine kinematics_return_beam_momenta

	@ %def kinematics_return_beam_momenta
	@ Check wether the phase space is configured in the center-of-mass frame.
	Relevant for using the proper momenta input for BLHA matrix elements.
	<<Kinematics: kinematics: TBP>>=
	procedure :: lab_is_cm => kinematics_lab_is_cm
	<<Kinematics: procedures>>=
	function kinematics_lab_is_cm (k) result (lab_is_cm)
	logical :: lab_is_cm
	class(kinematics_t), intent(in) :: k
	lab_is_cm = k%phs%config%lab_is_cm
	end function kinematics_lab_is_cm

	@ %def kinematics_lab_is_cm
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction
	<<Kinematics: procedures>>=
	subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out)
	class(kinematics_t), intent(inout) :: k
	type(vector4_t), intent(in), dimension(:) :: p_in
	type(vector4_t), intent(out), dimension(:), allocatable :: p_out
	allocate (p_out (size (p_in)))
	if (k%threshold) then
	select type (phs => k%phs)
	type is (phs_fks_t)
	p_out = phs%get_onshell_projected_momenta ()
	end select
	else
	p_out = p_in
	end if
	end subroutine kinematics_modify_momenta_for_subtraction

	@ %def kinematics_modify_momenta_for_subtraction
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: threshold_projection => kinematics_threshold_projection
	<<Kinematics: procedures>>=
	subroutine kinematics_threshold_projection (k, pcm_work, nlo_type)
	class(kinematics_t), intent(inout) :: k
	type(pcm_nlo_workspace_t), intent(inout) :: pcm_work
	integer, intent(in) :: nlo_type
	real(default) :: sqrts, mtop
	type(lorentz_transformation_t) :: L_to_cms
	type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell
	integer :: n_tot
	n_tot = k%phs%get_n_tot ()
	allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1))))
	select type (phs => k%phs)
	type is (phs_fks_t)
	p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1)
	class default
	p_tot(1 : k%n_in) = phs%p
	p_tot(k%n_in + 1 : n_tot) = phs%q
	end select
	sqrts = sum (p_tot (1:k%n_in))**1
	mtop = m1s_to_mpole (sqrts)
	L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop)
	call pcm_work%real_kinematics%p_born_cms%set_momenta (1, p_tot)
	p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1)
	call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
	pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell
	if (debug2_active (D_THRESHOLD)) then
	print *, 'On-shell projected Born: '
	call vector4_write_set (p_onshell)
	end if
	end subroutine kinematics_threshold_projection

	@ %def kinematics_threshold_projection
	@
	<<Kinematics: kinematics: TBP>>=
	procedure :: evaluate_radiation => kinematics_evaluate_radiation
	<<Kinematics: procedures>>=
	subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
	class(kinematics_t), intent(inout) :: k
	type(vector4_t), intent(in), dimension(:) :: p_in
	type(vector4_t), intent(out), dimension(:), allocatable :: p_out
	logical, intent(out) :: success
	type(vector4_t), dimension(:), allocatable :: p_real
	type(vector4_t), dimension(:), allocatable :: p_born
	real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi
	select type (phs => k%phs)
	type is (phs_fks_t)
	allocate (p_born (size (p_in)))
	if (k%threshold) then
	p_born = phs%get_onshell_projected_momenta ()
	else
	p_born = p_in
	end if
	if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then
	p_born = inverse (k%phs%lt_cm_to_lab) * p_born
	end if
	call phs%compute_xi_max (p_born, k%threshold)
	if (k%emitter >= 0) then
	allocate (p_real (size (p_born) + 1))
	allocate (p_out (size (p_born) + 1))
	if (k%emitter <= k%n_in) then
	call phs%generate_isr (k%i_phs, p_real)
	else
	if (k%threshold) then
	jac_rand_dummy = 1._default
	call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), &
	phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
	k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, &
	y_offshell)
	call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, &
	phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
	xi_max_offshell)
	xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde
	phi = phs%generator%real_kinematics%phi
	call phs%generate_fsr (k%emitter, k%i_phs, p_real, &
	xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.)
	call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real)
	call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real)
	if (debug2_active (D_SUBTRACTION)) &
	call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs)
	else if (k%i_con > 0) then
	call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con)
	else
	call phs%generate_fsr (k%emitter, k%i_phs, p_real)
	end if
	end if
	success = check_scalar_products (p_real)
	if (debug2_active (D_SUBTRACTION)) then
	call msg_debug2 (D_SUBTRACTION, "Real phase-space: ")
	call vector4_write_set (p_real)
	end if
	p_out = p_real
	else
	allocate (p_out (size (p_in))); p_out = p_in
	success = .true.
	end if
	end select
	contains
	subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs)
	integer, intent(in) :: emitter, i_phs
	integer :: ii_phs, this_emitter
	select type (phs => k%phs)
	type is (phs_fks_t)
	do ii_phs = 1, size (phs%phs_identifiers)
	this_emitter = phs%phs_identifiers(ii_phs)%emitter
	if (ii_phs /= i_phs .and. this_emitter /= emitter) &
	call phs%generate_fsr_threshold (this_emitter, i_phs)
	end do
	end select
	end subroutine
	end subroutine kinematics_evaluate_radiation

	@ %def kinematics_evaluate_radiation
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Instances}

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

	module instances

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use format_utils, only: write_separator
	use constants
	use diagnostics
	use os_interface
	use numeric_utils
	use lorentz
	use mci_base
	use particles
	use sm_qcd, only: qcd_t
	use interactions
	use quantum_numbers
	use model_data
	use helicities
	use flavors
	use beam_structures
	use variables
	use pdg_arrays, only: is_quark
	use sf_base
	use physics_defs
	use process_constants
	use process_libraries
	use state_matrices
	use integration_results
	use phs_base
	use prc_core, only: prc_core_t, prc_core_state_t

	!!! We should depend less on these modules (move it to pcm_nlo_t e.g.)
	use phs_wood, only: phs_wood_t
	use phs_fks
	use blha_olp_interfaces, only: prc_blha_t
	use blha_config, only: BLHA_AMP_COLOR_C
	use prc_external, only: prc_external_t, prc_external_state_t
	use prc_threshold, only: prc_threshold_t
	use blha_olp_interfaces, only: blha_result_array_size
	use prc_openloops, only: prc_openloops_t, openloops_state_t
	use prc_recola, only: prc_recola_t
	use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag

	use ttv_formfactors, only: m1s_to_mpole
	!!! local modules
	use parton_states
	use process_counter
	use pcm_base
	use pcm
	use process_config
	use process_mci
	use process
	use kinematics

	<<Standard module head>>

	<<Instances: public>>

	<<Instances: types>>

	<<Instances: interfaces>>

	contains

	<<Instances: procedures>>

	end module instances
	@ %def instances
	@
	\subsection{Term instance}
	A [[term_instance_t]] object contains all data that describe a term. Each
	process component consists of one or more distinct terms which may differ in
	kinematics, but whose squared transition matrices have to be added pointwise.

	The [[active]] flag is set when this term is connected to an active
	process component. Inactive terms are skipped for kinematics and evaluation.

	The [[amp]] array stores the amplitude values when we get them from evaluating
	the associated matrix-element code.

	The [[int_hard]] interaction describes the elementary hard process.
	It receives the momenta and the amplitude entries for each sampling point.

	The [[isolated]] object holds the effective parton state for the
	elementary interaction. The amplitude entries are
	computed from [[int_hard]].

	The [[connected]] evaluator set
	convolutes this scattering matrix with the beam (and possibly
	structure-function) density matrix.

	The [[checked]] flag is set once we have applied cuts on this term.
	The result of this is stored in the [[passed]] flag.

	Although each [[term_instance]] carries a [[weight]], this currently
	always keeps the value $1$ and is only used to be given to routines
	to fulfill their signature.
	<<Instances: types>>=
	type :: term_instance_t
	type(process_term_t), pointer :: config => null ()
	class(pcm_t), pointer :: pcm => null ()
	class(pcm_workspace_t), pointer :: pcm_work => null ()
	logical :: active = .false.
	complex(default), dimension(:), allocatable :: amp
	type(interaction_t) :: int_hard
	type(isolated_state_t) :: isolated
	type(connected_state_t) :: connected
	class(prc_core_state_t), allocatable :: core_state
	logical :: checked = .false.
	logical :: passed = .false.
	real(default) :: scale = 0
	real(default), allocatable :: fac_scale
	real(default), allocatable :: ren_scale
	real(default), allocatable :: es_scale
	real(default), allocatable :: alpha_qcd_forced
	real(default) :: weight = 1
	type(vector4_t), dimension(:), allocatable :: p_seed
	type(vector4_t), dimension(:), allocatable :: p_hard
	integer :: nlo_type = BORN
	integer, dimension(:), allocatable :: same_kinematics
	logical :: negative_sf = .false.
	contains
	<<Instances: term instance: TBP>>
	end type term_instance_t

	@ %def term_instance_t
	@
	<<Instances: term instance: TBP>>=
	procedure :: write => term_instance_write
	<<Instances: procedures>>=
	subroutine term_instance_write (term, unit, kin, show_eff_state, testflag)
	class(term_instance_t), intent(in) :: term
	integer, intent(in), optional :: unit
	type(kinematics_t), intent(in), optional :: kin
	logical, intent(in), optional :: show_eff_state
	logical, intent(in), optional :: testflag
	real(default) :: fac_scale, ren_scale
	integer :: u
	logical :: state
	u = given_output_unit (unit)
	state = .true.; if (present (show_eff_state)) state = show_eff_state
	if (term%active) then
	if (associated (term%config)) then
	write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, &
	" (component #", term%config%i_component, ")"
	else
	write (u, "(1x,A)") "Term [undefined]"
	end if
	else
	write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, &
	" [inactive]"
	end if
	if (term%checked) then
	write (u, "(3x,A,L1)") "passed cuts = ", term%passed
	end if
	if (term%passed) then
	write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale
	write (u, "(3x,A,ES19.12)") "factorization scale = ", term%get_fac_scale ()
	write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%get_ren_scale ()
	if (allocated (term%alpha_qcd_forced)) then
	write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", &
	term%alpha_qcd_forced
	end if
	write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight
	end if
	!!! This used to be a member of term_instance
	if (present (kin)) then
	call kin%write (u)
	end if
	call write_separator (u)
	write (u, "(1x,A)") "Amplitude (transition matrix of the &
	&hard interaction):"
	call write_separator (u)
	call term%int_hard%basic_write (u, testflag = testflag)
	if (state .and. term%isolated%has_trace) then
	call write_separator (u)
	write (u, "(1x,A)") "Evaluators for the hard interaction:"
	call term%isolated%write (u, testflag = testflag)
	end if
	if (state .and. term%connected%has_trace) then
	call write_separator (u)
	write (u, "(1x,A)") "Evaluators for the connected process:"
	call term%connected%write (u, testflag = testflag)
	end if
	end subroutine term_instance_write

	@ %def term_instance_write
	@ The interactions and evaluators must be finalized.
	<<Instances: term instance: TBP>>=
	procedure :: final => term_instance_final
	<<Instances: procedures>>=
	subroutine term_instance_final (term)
	class(term_instance_t), intent(inout) :: term
	if (allocated (term%amp)) deallocate (term%amp)
	if (allocated (term%core_state)) deallocate (term%core_state)
	if (allocated (term%ren_scale)) deallocate (term%ren_scale)
	if (allocated (term%fac_scale)) deallocate (term%fac_scale)
	if (allocated (term%es_scale)) deallocate (term%es_scale)
	if (allocated (term%alpha_qcd_forced)) &
	deallocate (term%alpha_qcd_forced)
	if (allocated (term%p_seed)) deallocate(term%p_seed)
	if (allocated (term%p_hard)) deallocate (term%p_hard)
	call term%connected%final ()
	call term%isolated%final ()
	call term%int_hard%final ()
	term%pcm => null ()
	term%pcm_work => null ()
	end subroutine term_instance_final

	@ %def term_instance_final
	@ For a new term object, we configure the structure-function
	interface, the phase space, the matrix-element (interaction)
	interface, etc.
	<<Instances: term instance: TBP>>=
	procedure :: configure => term_instance_configure
	<<Instances: procedures>>=
	subroutine term_instance_configure (term_instance, process, i, pcm_work, sf_chain, kin)
	class(term_instance_t), intent(out), target :: term_instance
	type(process_t), intent(in), target :: process
	integer, intent(in) :: i
	class(pcm_workspace_t), intent(in), target :: pcm_work
	type(sf_chain_t), intent(in), target :: sf_chain
	type(kinematics_t), intent(inout), target :: kin
	type(process_term_t) :: term
	integer :: i_component
	logical :: requires_extended_sf
	term = process%get_term_ptr (i)
	i_component = term%i_component
	if (i_component /= 0) then
	call term_instance%init &
	(process%get_pcm_ptr (), pcm_work, process%get_nlo_type_component (i_component))
	requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. &
	(term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i)
	call term_instance%setup_dynamics (process, i, kin, &
	real_finite = process%component_is_real_finite (i_component))
	select type (phs => kin%phs)
	type is (phs_fks_t)
	call term_instance%set_emitter (kin)
	call term_instance%setup_fks_kinematics (kin, &
	process%get_var_list_ptr (), &
	process%get_beam_config_ptr ())
	end select
	select type (pcm => term_instance%pcm)
	type is (pcm_nlo_t)
	call kin%set_threshold (pcm%settings%factorization_mode)
	end select
	call term_instance%setup_expressions (process%get_meta (), process%get_config ())
	end if
	end subroutine term_instance_configure

	@ %def term_instance_configure
	@ First part of term-instance configuration: initialize by assigning pointers to the
	overall [[pcm]] and the associated [[pcm_workspace]] objects.
	<<Instances: term instance: TBP>>=
	procedure :: init => term_instance_init
	<<Instances: procedures>>=
	subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type)
	class(term_instance_t), intent(out) :: term_instance
	class(pcm_t), intent(in), target :: pcm
	class(pcm_workspace_t), intent(in), target :: pcm_work
	integer, intent(in) :: nlo_type
	term_instance%pcm => pcm
	term_instance%pcm_work => pcm_work
	term_instance%nlo_type = nlo_type
	end subroutine term_instance_init

	@ %def term_instance_init
	@ The second part of term-instance configuration concerns dynamics, i.e., the
	interface to the matrix-element (interaction), and the parton-state
	objects that combine all kinematics and matrix-element data for evaluation.

	The hard interaction (incoming momenta) is linked to the structure
	function instance. In the isolated state, we either set pointers to
	both, or we create modified copies ([[rearrange]]) as effective
	structure-function chain and interaction, respectively.

	Finally, we set up the [[subevt]] component that will be used for
	evaluating observables, collecting particles from the trace evaluator
	in the effective connected state. Their quantum numbers must be
	determined by following back source links and set explicitly, since
	they are already eliminated in that trace.

	The [[rearrange]] parts are still commented out; they could become
	relevant for a NLO algorithm.
	<<Instances: term instance: TBP>>=
	procedure :: setup_dynamics => term_instance_setup_dynamics
	<<Instances: procedures>>=
	subroutine term_instance_setup_dynamics (term, process, i_term, kin, real_finite)
	class(term_instance_t), intent(inout), target :: term
	type(process_t), intent(in), target:: process
	integer, intent(in) :: i_term
	type(kinematics_t), intent(in) :: kin
	logical, intent(in), optional :: real_finite
	class(prc_core_t), pointer :: core => null ()
	type(process_beam_config_t) :: beam_config
	type(interaction_t), pointer :: sf_chain_int
	type(interaction_t), pointer :: src_int
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
	type(state_matrix_t), pointer :: state_matrix
	type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
	integer, dimension(:,:), allocatable :: flv_born, flv_real
	type(flavor_t), dimension(:,:), allocatable :: flv_pdf
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf
	integer :: n_in, n_vir, n_out, n_tot, n_sub
	integer :: n_flv_born, n_flv_real, n_flv_total
	integer :: i, j
	logical :: me_already_squared, keep_fs_flavors
	logical :: decrease_n_tot
	logical :: requires_extended_sf
	me_already_squared = .false.
	keep_fs_flavors = .false.
	term%config => process%get_term_ptr (i_term)
	term%int_hard = term%config%int
	core => process%get_core_term (i_term)
	term%negative_sf = process%get_negative_sf ()
	call core%allocate_workspace (term%core_state)
	select type (core)
	class is (prc_external_t)
	call reduce_interaction (term%int_hard, &
	core%includes_polarization (), .true., .false.)
	me_already_squared = .true.
	allocate (term%amp (term%int_hard%get_n_matrix_elements ()))
	class default
	allocate (term%amp (term%config%n_allowed))
	end select
	if (allocated (term%core_state)) then
	select type (core_state => term%core_state)
	type is (openloops_state_t)
	call core_state%init_threshold (process%get_model_ptr ())
	end select
	end if
	term%amp = cmplx (0, 0, default)
	decrease_n_tot = term%nlo_type == NLO_REAL .and. &
	term%config%i_term_global /= term%config%i_sub
	if (present (real_finite)) then
	if (real_finite) decrease_n_tot = .false.
	end if
	if (decrease_n_tot) then
	allocate (term%p_seed (term%int_hard%get_n_tot () - 1))
	else
	allocate (term%p_seed (term%int_hard%get_n_tot ()))
	end if
	allocate (term%p_hard (term%int_hard%get_n_tot ()))
	sf_chain_int => kin%sf_chain%get_out_int_ptr ()
	n_in = term%int_hard%get_n_in ()
	do j = 1, n_in
	i = kin%sf_chain%get_out_i (j)
	call term%int_hard%set_source_link (j, sf_chain_int, i)
	end do
	call term%isolated%init (kin%sf_chain, term%int_hard)
	allocate (mask_in (n_in))
	mask_in = kin%sf_chain%get_out_mask ()
	select type (phs => kin%phs)
	type is (phs_wood_t)
	if (me_already_squared) then
	call term%isolated%setup_identity_trace &
	(core, mask_in, .true., .false.)
	else
	call term%isolated%setup_square_trace &
	(core, mask_in, term%config%col, .false.)
	end if
	type is (phs_fks_t)
	select case (phs%mode)
	case (PHS_MODE_ADDITIONAL_PARTICLE)
	if (me_already_squared) then
	call term%isolated%setup_identity_trace &
	(core, mask_in, .true., .false.)
	else
	keep_fs_flavors = term%config%data%n_flv > 1
	call term%isolated%setup_square_trace &
	(core, mask_in, term%config%col, &
	keep_fs_flavors)
	end if
	case (PHS_MODE_COLLINEAR_REMNANT)
	if (me_already_squared) then
	call term%isolated%setup_identity_trace &
	(core, mask_in, .true., .false.)
	else
	call term%isolated%setup_square_trace &
	(core, mask_in, term%config%col, .false.)
	end if
	end select
	class default
	call term%isolated%setup_square_trace &
	(core, mask_in, term%config%col, .false.)
	end select
	if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. &
	term%config%i_term_global == term%config%i_sub) .or. &
	term%nlo_type == NLO_MISMATCH) then
	n_sub = term%get_n_sub ()
	else if (term%nlo_type == NLO_DGLAP) then
	n_sub = n_beams_rescaled + term%get_n_sub ()
	else
	!!! No integration of real subtraction in interactions yet
	n_sub = 0
	end if
	keep_fs_flavors = keep_fs_flavors .or. me_already_squared
	requires_extended_sf = term%nlo_type == NLO_DGLAP .or. &
	(term%is_subtraction () .and. process%pcm_contains_pdfs ())
	call term%connected%setup_connected_trace (term%isolated, &
	undo_helicities = undo_helicities (core, me_already_squared), &
	keep_fs_flavors = keep_fs_flavors, &
	requires_extended_sf = requires_extended_sf)
	associate (int_eff => term%isolated%int_eff)
	state_matrix => int_eff%get_state_matrix_ptr ()
	n_tot = int_eff%get_n_tot ()
	flv_int = quantum_numbers_get_flavor &
	(state_matrix%get_quantum_number (1))
	allocate (f_in (n_in))
	f_in = flv_int(1:n_in)
	deallocate (flv_int)
	end associate
	n_in = term%connected%trace%get_n_in ()
	n_vir = term%connected%trace%get_n_vir ()
	n_out = term%connected%trace%get_n_out ()
	allocate (f_out (n_out))
	do j = 1, n_out
	call term%connected%trace%find_source &
	(n_in + n_vir + j, src_int, i)
	if (associated (src_int)) then
	state_matrix => src_int%get_state_matrix_ptr ()
	flv_src = quantum_numbers_get_flavor &
	(state_matrix%get_quantum_number (1))
	f_out(j) = flv_src(i)
	deallocate (flv_src)
	end if
	end do

	beam_config = process%get_beam_config ()

	call term%connected%setup_subevt (term%isolated%sf_chain_eff, &
	beam_config%data%flv, f_in, f_out)
	call term%connected%setup_var_list &
	(process%get_var_list_ptr (), beam_config%data)
	! Does connected%trace never have any helicity qn?
	call term%init_interaction_qn_index (core, term%connected%trace, n_sub, &
	process%get_model_ptr (), is_polarized = .false.)
	call term%init_interaction_qn_index (core, term%int_hard, n_sub, process%get_model_ptr ())
	if (requires_extended_sf) then
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	n_in = pcm%region_data%get_n_in ()
	flv_born = pcm%region_data%get_flv_states_born ()
	flv_real = pcm%region_data%get_flv_states_real ()
	n_flv_born = pcm%region_data%get_n_flv_born ()
	n_flv_real = pcm%region_data%get_n_flv_real ()
	n_flv_total = n_flv_born + n_flv_real
	allocate (flv_pdf(n_in, n_flv_total), &
	qn_pdf(n_in, n_flv_total))
	call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :))
	call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :))
	call qn_pdf%init (flv_pdf)
	call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real)
	end select
	end if
	contains

	function undo_helicities (core, me_squared) result (val)
	logical :: val
	class(prc_core_t), intent(in) :: core
	logical, intent(in) :: me_squared
	select type (core)
	class is (prc_external_t)
	val = me_squared .and. .not. core%includes_polarization ()
	class default
	val = .false.
	end select
	end function undo_helicities

	subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, &
	keep_colors)
	type(interaction_t), intent(inout) :: int
	logical, intent(in) :: polarized_beams
	logical, intent(in) :: keep_fs_flavors, keep_colors
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	logical, dimension(:), allocatable :: mask_f, mask_c, mask_h
	integer :: n_tot, n_in
	n_in = int%get_n_in (); n_tot = int%get_n_tot ()
	allocate (qn_mask (n_tot))
	allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot))
	mask_c = .not. keep_colors
	mask_f (1 : n_in) = .false.
	if (keep_fs_flavors) then
	mask_f (n_in + 1 : ) = .false.
	else
	mask_f (n_in + 1 : ) = .true.
	end if
	if (polarized_beams) then
	mask_h (1 : n_in) = .false.
	else
	mask_h (1 : n_in) = .true.
	end if
	mask_h (n_in + 1 : ) = .true.
	call qn_mask%init (mask_f, mask_c, mask_h)
	call int%reduce_state_matrix (qn_mask, keep_order = .true.)
	end subroutine reduce_interaction
	end subroutine term_instance_setup_dynamics

	@ %def term_instance_setup_dynamics
	@ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
	<<Instances: public>>=
	public :: setup_interaction_qn_index
	<<Instances: procedures>>=
	subroutine setup_interaction_qn_index (int, data, qn_config, n_sub, is_polarized)
	class(interaction_t), intent(inout) :: int
	class(process_constants_t), intent(in) :: data
	type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config
	integer, intent(in) :: n_sub
	logical, intent(in) :: is_polarized
	integer :: i
	type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
	if (is_polarized) then
	call setup_interaction_qn_hel (int, data, qn_hel)
	call int%init_qn_index (qn_config, n_sub, qn_hel)
	call int%set_qn_index_helicity_flip (.true.)
	else
	call int%init_qn_index (qn_config, n_sub)
	end if
	end subroutine setup_interaction_qn_index

	@ %def setup_interaction_qn_index
	@ Set up beam polarisation quantum numbers, if beam polarisation is required.

	We retrieve the full helicity information from [[term%config%data]] and reduce
	the information only to the inital state. Afterwards, we uniquify the initial
	state polarization by a applying an index (hash) table.

	The helicity information is fed into an array of quantum numbers to assign
	flavor, helicity and subtraction indices correctly to their matrix element.
	<<Instances: public>>=
	public :: setup_interaction_qn_hel
	<<Instances: procedures>>=
	subroutine setup_interaction_qn_hel (int, data, qn_hel)
	class(interaction_t), intent(in) :: int
	class(process_constants_t), intent(in) :: data
	type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel
	type(helicity_t), dimension(:), allocatable :: hel
	integer, dimension(:), allocatable :: index_table
	integer, dimension(:, :), allocatable :: hel_state
	integer :: i, j, n_hel_unique
	associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ())
	allocate (hel_state (n_tot, data%get_n_hel ()), &
	source = data%hel_state)
	allocate (index_table (data%get_n_hel ()), &
	source = 0)
	forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0
	n_hel_unique = 0
	HELICITY: do i = 1, data%get_n_hel ()
	do j = 1, data%get_n_hel ()
	if (index_table (j) == 0) then
	index_table(j) = i; n_hel_unique = n_hel_unique + 1
	cycle HELICITY
	else if (all (hel_state(:, i) == &
	hel_state(:, index_table(j)))) then
	cycle HELICITY
	end if
	end do
	end do HELICITY
	allocate (qn_hel (n_tot, n_hel_unique))
	allocate (hel (n_tot))
	do j = 1, n_hel_unique
	call hel%init (hel_state(:, index_table(j)))
	call qn_hel(:, j)%init (hel)
	end do
	end associate
	end subroutine setup_interaction_qn_hel

	@ %def setup_interaction_qn_hel
	@
	<<Instances: term instance: TBP>>=
	procedure :: init_interaction_qn_index => term_instance_init_interaction_qn_index
	<<Instances: procedures>>=
	subroutine term_instance_init_interaction_qn_index (term, core, int, n_sub, &
	model, is_polarized)
	class(term_instance_t), intent(inout), target :: term
	class(prc_core_t), intent(in) :: core
	class(interaction_t), intent(inout) :: int
	integer, intent(in) :: n_sub
	class(model_data_t), intent(in) :: model
	logical, intent(in), optional :: is_polarized
	logical :: polarized
	type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
	integer, dimension(:,:), allocatable :: flv_born
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	select type (core)
	class is (prc_external_t)
	if (present (is_polarized)) then
	polarized = is_polarized
	else
	polarized = core%includes_polarization ()
	end if
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	associate (is_born => .not. (term%nlo_type == NLO_REAL .and. &
	.not. term%is_subtraction ()))
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	qn_config = pcm%get_qn (is_born)
	end select
	call setup_interaction_qn_index (int, term%config%data, &
	qn_config, n_sub, polarized)
	end associate
	class default
	call term%config%data%get_flv_state (flv_born)
	allocate (flv (size (flv_born, dim = 1)))
	allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2)))
	do i = 1, core%data%n_flv
	call flv%init (flv_born(:,i), model)
	call qn_config(:, i)%init (flv)
	end do
	call setup_interaction_qn_index (int, term%config%data, &
	qn_config, n_sub, polarized)
	end select
	class default
	call int%init_qn_index ()
	end select
	end subroutine term_instance_init_interaction_qn_index

	@ %def term_instance_init_interaction_qn_index
	@
	<<Instances: term instance: TBP>>=
	procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_setup_fks_kinematics (term, kin, var_list, beam_config)
	class(term_instance_t), intent(inout), target :: term
	type(kinematics_t), intent(inout) :: kin
	type(var_list_t), intent(in) :: var_list
	type(process_beam_config_t), intent(in) :: beam_config
	integer :: mode
	logical :: singular_jacobian
	if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. &
	term%nlo_type == NLO_MISMATCH)) return
	singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian"))
	if (term%nlo_type == NLO_REAL) then
	mode = check_generator_mode (GEN_REAL_PHASE_SPACE)
	else if (term%nlo_type == NLO_MISMATCH) then
	mode = check_generator_mode (GEN_SOFT_MISMATCH)
	else
	mode = PHS_MODE_UNDEFINED
	end if
	select type (phs => kin%phs)
	type is (phs_fks_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	call pcm%setup_phs_generator (pcm_work, &
	phs%generator, phs%config%sqrts, mode, singular_jacobian)
	if (beam_config%has_structure_function ()) then
	pcm_work%isr_kinematics%isr_mode = SQRTS_VAR
	else
	pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED
	end if
	if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_work%isr_kinematics%isr_mode)
	end select
	end select
	class default
	call msg_fatal ("Phase space should be an FKS phase space!")
	end select
	contains
	function check_generator_mode (gen_mode_default) result (gen_mode)
	integer :: gen_mode
	integer, intent(in) :: gen_mode_default
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	associate (settings => pcm%settings)
	if (settings%test_coll_limit .and. settings%test_anti_coll_limit) &
	call msg_fatal ("You cannot check the collinear and anti-collinear limit "&
	&"at the same time!")
	if (settings%test_soft_limit .and. .not. settings%test_coll_limit &
	.and. .not. settings%test_anti_coll_limit) then
	gen_mode = GEN_SOFT_LIMIT_TEST
	else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then
	gen_mode = GEN_COLL_LIMIT_TEST
	else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then
	gen_mode = GEN_ANTI_COLL_LIMIT_TEST
	else if (settings%test_soft_limit .and. settings%test_coll_limit) then
	gen_mode = GEN_SOFT_COLL_LIMIT_TEST
	else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then
	gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST
	else
	gen_mode = gen_mode_default
	end if
	end associate
	end select
	end function check_generator_mode
	end subroutine term_instance_setup_fks_kinematics

	@ %def term_instance_setup_fks_kinematics
	@ Set up seed kinematics, starting from the MC parameter set given as
	argument. As a result, the [[k_seed]] kinematics object is evaluated
	(except for the structure-function matrix-element evaluation, which we
	postpone until we know the factorization scale), and we have a valid
	[[p_seed]] momentum array.
	<<Instances: term instance: TBP>>=
	procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_compute_seed_kinematics &
	(term, kin, mci_work, phs_channel, success)
	class(term_instance_t), intent(inout), target :: term
	type(kinematics_t), intent(inout) :: kin
	type(mci_work_t), intent(in) :: mci_work
	integer, intent(in) :: phs_channel
	logical, intent(out) :: success
	call kin%compute_selected_channel &
	(mci_work, phs_channel, term%p_seed, success)
	end subroutine term_instance_compute_seed_kinematics

	@ %def term_instance_compute_seed_kinematics
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_projections => term_instance_evaluate_projections
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_projections (term, kin)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	if (kin%threshold .and. term%nlo_type > BORN) then
	if (debug2_active (D_THRESHOLD)) &
	print *, 'Evaluate on-shell projection: ', &
	char (component_status (term%nlo_type))
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	call kin%threshold_projection (pcm_work, term%nlo_type)
	end select
	end if
	end subroutine term_instance_evaluate_projections

	@ %def term_instance_evaluate_projections
	@ Compute the momenta in the hard interactions, one for each term that
	constitutes this process component. In simple cases this amounts to
	just copying momenta. In more advanced cases, we may generate
	distinct sets of momenta from the seed kinematics.

	The interactions in the term instances are accessed individually. We may
	choose to calculate all terms at once together with the seed kinematics, use
	[[component%core_state]] for storage, and just fill the interactions here.
	<<Instances: term instance: TBP>>=
	procedure :: compute_hard_kinematics => &
	term_instance_compute_hard_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_compute_hard_kinematics &
	(term, kin, recover, skip_term, success)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	integer, intent(in), optional :: skip_term
	logical, intent(in), optional :: recover
	logical, intent(out) :: success
	type(vector4_t), dimension(:), allocatable :: p
	if (allocated (term%core_state)) &
	call term%core_state%reset_new_kinematics ()
	if (present (skip_term)) then
	if (term%config%i_term_global == skip_term) return
	end if

	if (present (recover)) then
	if (recover) return
	end if
	if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then
	call kin%evaluate_radiation (term%p_seed, p, success)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (pcm%dalitz_plot%active) then
	if (kin%emitter > kin%n_in) then
	if (p(kin%emitter)**2 > tiny_07) &
	call pcm%register_dalitz_plot (kin%emitter, p)
	end if
	end if
	end select
	else if (is_subtraction_component (kin%emitter, term%nlo_type)) then
	call kin%modify_momenta_for_subtraction (term%p_seed, p)
	success = .true.
	else
	allocate (p (size (term%p_seed))); p = term%p_seed
	success = .true.
	end if
	call term%int_hard%set_momenta (p)
	if (debug_on) then
	call msg_debug2 (D_REAL, "inside compute_hard_kinematics")
	if (debug2_active (D_REAL)) call vector4_write_set (p)
	end if
	end subroutine term_instance_compute_hard_kinematics

	@ %def term_instance_compute_hard_kinematics
	@ Here, we invert this. We fetch the incoming momenta which reside
	in the appropriate [[sf_chain]] object, stored within the [[k_seed]]
	subobject. On the other hand, we have the outgoing momenta of the
	effective interaction. We rely on the process core to compute the
	remaining seed momenta and to fill the momenta within the hard
	interaction. (The latter is trivial if hard and effective interaction
	coincide.)

	After this is done, the incoming momenta in the trace evaluator that
	corresponds to the hard (effective) interaction, are still
	left undefined. We remedy this by calling [[receive_kinematics]] once.
	<<Instances: term instance: TBP>>=
	procedure :: recover_seed_kinematics => &
	term_instance_recover_seed_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_recover_seed_kinematics (term, kin, p_seed_ref)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(in) :: kin
	integer :: n_in
	type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref
	n_in = kin%n_in
	call kin%get_incoming_momenta (term%p_seed(1:n_in))
	associate (int_eff => term%isolated%int_eff)
	call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.)
	if (present (p_seed_ref)) then
	term%p_seed(n_in + 1 : ) = p_seed_ref
	else
	term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
	end if
	end associate
	call term%isolated%receive_kinematics ()
	end subroutine term_instance_recover_seed_kinematics

	@ %def term_instance_recover_seed_kinematics
	@ Compute the integration parameters for all channels except the selected
	one.
	JRR: Obsolete now.
	<<XXX Instances: term instance: TBP>>=
	procedure :: compute_other_channels => &
	term_instance_compute_other_channels
	<<XXX Instances: procedures>>=
	subroutine term_instance_compute_other_channels &
	(term, mci_work, phs_channel)
	class(term_instance_t), intent(inout), target :: term
	type(mci_work_t), intent(in) :: mci_work
	integer, intent(in) :: phs_channel
	call term%k_term%compute_other_channels (mci_work, phs_channel)
	end subroutine term_instance_compute_other_channels

	@ %def term_instance_compute_other_channels
	@ Recover beam momenta, i.e., return the beam momenta as currently
	stored in the kinematics subobject to their source. This is a side effect.
	JRR: Obsolete now.
	<<XXX Instances: term instance: TBP>>=
	procedure :: return_beam_momenta => term_instance_return_beam_momenta
	<<XXX Instances: procedures>>=
	subroutine term_instance_return_beam_momenta (term)
	class(term_instance_t), intent(in) :: term
	call term%k_term%return_beam_momenta ()
	end subroutine term_instance_return_beam_momenta

	@ %def term_instance_return_beam_momenta
	@
	Applies the real partition by computing the real partition function $F(\Phi)$
	and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or
	$\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$.
	<<Instances: term instance: TBP>>=
	procedure :: apply_real_partition => term_instance_apply_real_partition
	<<Instances: procedures>>=
	subroutine term_instance_apply_real_partition (term, kin, process)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(in) :: kin
	type(process_t), intent(in) :: process
	real(default) :: f, sqme
	integer :: i_component
	integer :: i_amp, n_amps, qn_index
	logical :: is_subtraction
	i_component = term%config%i_component
	if (process%component_is_selected (i_component) .and. &
	process%get_component_nlo_type (i_component) == NLO_REAL) then
	is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING &
	.and. kin%emitter < 0
	if (is_subtraction) return
	select case (process%get_component_type (i_component))
	case (COMP_REAL_FIN)
	call term%connected%trace%set_duplicate_flv_zero()
	end select
	select type (pcm => process%get_pcm_ptr ())
	type is (pcm_nlo_t)
	f = pcm%real_partition%get_f (term%p_hard)
	end select
	n_amps = term%connected%trace%get_n_matrix_elements ()
	do i_amp = 1, n_amps
	qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0)
	sqme = real (term%connected%trace%get_matrix_element (qn_index))
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select case (process%get_component_type (i_component))
	case (COMP_REAL_FIN, COMP_REAL_SING)
	select case (process%get_component_type (i_component))
	case (COMP_REAL_FIN)
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite")
	sqme = sqme * (one - f)
	case (COMP_REAL_SING)
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular")
	sqme = sqme * f
	end select
	end select
	end select
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme)
	call term%connected%trace%set_matrix_element (qn_index, cmplx (sqme, zero, default))
	end do
	end if
	end subroutine term_instance_apply_real_partition

	@ %def term_instance_apply_real_partition
	@
	<<Instances: term instance: TBP>>=
	procedure :: get_p_hard => term_instance_get_p_hard
	<<Instances: procedures>>=
	pure function term_instance_get_p_hard (term_instance) result (p_hard)
	type(vector4_t), dimension(:), allocatable :: p_hard
	class(term_instance_t), intent(in) :: term_instance
	allocate (p_hard (size (term_instance%p_hard)))
	p_hard = term_instance%p_hard
	end function term_instance_get_p_hard

	@ %def term_instance_get_p_hard
	@
	<<Instances: term instance: TBP>>=
	procedure :: set_emitter => term_instance_set_emitter
	<<Instances: procedures>>=
	subroutine term_instance_set_emitter (term, kin)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	integer :: i_phs
	logical :: set_emitter
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select type (phs => kin%phs)
	type is (phs_fks_t)
	!!! Without resonances, i_alr = i_phs
	i_phs = term%config%i_term
	kin%i_phs = i_phs
	set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL
	if (set_emitter) then
	kin%emitter = phs%phs_identifiers(i_phs)%emitter
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (allocated (pcm%region_data%i_phs_to_i_con)) &
	kin%i_con = pcm%region_data%i_phs_to_i_con (i_phs)
	end select
	end if
	end select
	end select
	end subroutine term_instance_set_emitter

	@ %def term_instance_set_emitter
	@ For initializing the expressions, we need the local variable list and the
	parse trees.
	<<Instances: term instance: TBP>>=
	procedure :: setup_expressions => term_instance_setup_expressions
	<<Instances: procedures>>=
	subroutine term_instance_setup_expressions (term, meta, config)
	class(term_instance_t), intent(inout), target :: term
	type(process_metadata_t), intent(in), target :: meta
	type(process_config_data_t), intent(in) :: config
	if (allocated (config%ef_cuts)) &
	call term%connected%setup_cuts (config%ef_cuts)
	if (allocated (config%ef_scale)) &
	call term%connected%setup_scale (config%ef_scale)
	if (allocated (config%ef_fac_scale)) &
	call term%connected%setup_fac_scale (config%ef_fac_scale)
	if (allocated (config%ef_ren_scale)) &
	call term%connected%setup_ren_scale (config%ef_ren_scale)
	if (allocated (config%ef_weight)) &
	call term%connected%setup_weight (config%ef_weight)
	end subroutine term_instance_setup_expressions

	@ %def term_instance_setup_expressions
	@ Prepare the extra evaluators that we need for processing events.

	The matrix elements we get from OpenLoops and GoSam are already squared
	and summed over color and helicity. They should not be squared again.
	<<Instances: term instance: TBP>>=
	procedure :: setup_event_data => term_instance_setup_event_data
	<<Instances: procedures>>=
	subroutine term_instance_setup_event_data (term, kin, core, model)
	class(term_instance_t), intent(inout), target :: term
	type(kinematics_t), intent(in) :: kin
	class(prc_core_t), intent(in) :: core
	class(model_data_t), intent(in), target :: model
	integer :: n_in
	logical :: mask_color
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
	n_in = term%int_hard%get_n_in ()
	allocate (mask_in (n_in))
	mask_in = kin%sf_chain%get_out_mask ()
	call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	mask_color = pcm_work%is_fixed_order_nlo_events ()
	class default
	mask_color = .false.
	end select
	call setup_connected (term%connected, term%isolated, core, &
	term%nlo_type, mask_color)
	contains
	subroutine setup_isolated (isolated, core, model, mask, color)
	type(isolated_state_t), intent(inout), target :: isolated
	class(prc_core_t), intent(in) :: core
	class(model_data_t), intent(in), target :: model
	type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask
	integer, intent(in), dimension(:) :: color
	select type (core)
	class is (prc_blha_t)
	call isolated%matrix%init_identity(isolated%int_eff)
	isolated%has_matrix = .true.
	class default
	call isolated%setup_square_matrix (core, model, mask, color)
	end select
	!!! TODO (PS-09-10-20) We should not square the flows
	!!! if they come from BLHA either
	call isolated%setup_square_flows (core, model, mask)
	end subroutine setup_isolated

	subroutine setup_connected (connected, isolated, core, nlo_type, mask_color)
	type(connected_state_t), intent(inout), target :: connected
	type(isolated_state_t), intent(in), target :: isolated
	class(prc_core_t), intent(in) :: core
	integer, intent(in) :: nlo_type
	logical, intent(in) :: mask_color
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	call connected%setup_connected_matrix (isolated)
	if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL &
	.and. term%config%i_term_global == term%config%i_sub) &
	.or. term%nlo_type == NLO_DGLAP) then
	!!! We do not care about the subtraction matrix elements in
	!!! connected%matrix, because all entries there are supposed
	!!! to be squared. To be able to match with flavor quantum numbers,
	!!! we remove the subtraction quantum entries from the state matrix.
	allocate (mask (connected%matrix%get_n_tot()))
	call mask%set_sub (1)
	call connected%matrix%reduce_state_matrix (mask, keep_order = .true.)
	end if
	call term%init_interaction_qn_index (core, connected%matrix, 0, model, &
	is_polarized = .false.)
	select type (core)
	class is (prc_blha_t)
	call connected%setup_connected_flows &
	(isolated, mask_color = mask_color)
	class default
	call connected%setup_connected_flows (isolated)
	end select
	call connected%setup_state_flv (isolated%get_n_out ())
	end subroutine setup_connected
	end subroutine term_instance_setup_event_data

	@ %def term_instance_setup_event_data
	@ Color-correlated matrix elements should be obtained from
	the external BLHA provider. According to the standard, the
	matrix elements output is a one-dimensional array. For FKS
	subtraction, we require the matrix $B_{ij}$. BLHA prescribes
	a mapping $(i, j) \to k$, where $k$ is the index of the matrix
	element in the output array. It focusses on the off-diagonal entries,
	i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes
	this mapping. The diagonal entries can simply be obtained as
	the product of the Born matrix element and either $C_A$ or $C_F$,
	which is achieved by [[blha_color_c_fill_diag]].
	For simple processes, i.e. those with only one color line, it is
	$B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing
	color correlations by a multiplication of the Born matrix element with $C_F$.
	It is triggered by the [[use_internal_color_correlations]] flag and should
	be used only for testing purposes. However, it is also used for
	the threshold computation where the process is well-defined and fixed.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_color_correlations => &
	term_instance_evaluate_color_correlations
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_color_correlations (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	integer :: i_flv_born
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (debug_on) call msg_debug2 (D_SUBTRACTION, &
	"term_instance_evaluate_color_correlations: " // &
	"use_internal_color_correlations:", &
	pcm%settings%use_internal_color_correlations)
	if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ())
	do i_flv_born = 1, pcm%region_data%n_flv_born
	select case (term%nlo_type)
	case (NLO_REAL)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	pcm_work%real_sub%sqme_born (i_flv_born), &
	pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born))
	case (NLO_MISMATCH)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	pcm_work%soft_mismatch%sqme_born (i_flv_born), &
	pcm_work%soft_mismatch%sqme_born_color_c (:, :, i_flv_born))
	case (NLO_VIRTUAL)
	!!! This is just a copy of the above with a different offset and can for sure be unified
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	-one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born))
	case (NLO_DGLAP)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	pcm_work%dglap_remnant%sqme_born (i_flv_born), &
	pcm_work%dglap_remnant%sqme_color_c_extra (:, :, i_flv_born))
	end select
	end do
	end select
	end select
	contains
	function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij)
	integer, intent(in) :: n_tot, factorization_mode
	integer, intent(in), dimension(:) :: flv
	real(default), dimension(n_tot, n_tot) :: beta_ij
	if (factorization_mode == NO_FACTORIZATION) then
	beta_ij = get_trivial_cf_factors_default (n_tot, flv)
	else
	beta_ij = get_trivial_cf_factors_threshold (n_tot, flv)
	end if
	end function get_trivial_cf_factors

	function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij)
	integer, intent(in) :: n_tot
	integer, intent(in), dimension(:) :: flv
	real(default), dimension(n_tot, n_tot) :: beta_ij
	integer :: i, j
	beta_ij = zero
	if (count (is_quark (flv)) == 2) then
	do i = 1, n_tot
	do j = 1, n_tot
	if (is_quark(flv(i)) .and. is_quark(flv(j))) then
	if (i == j) then
	beta_ij(i,j)= -cf
	else
	beta_ij(i,j) = cf
	end if
	end if
	end do
	end do
	end if
	end function get_trivial_cf_factors_default

	function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij)
	integer, intent(in) :: n_tot
	integer, intent(in), dimension(:) :: flv
	real(default), dimension(n_tot, n_tot) :: beta_ij
	integer :: i
	beta_ij = zero
	do i = 1, 4
	beta_ij(i,i) = -cf
	end do
	beta_ij(1,2) = cf; beta_ij(2,1) = cf
	beta_ij(3,4) = cf; beta_ij(4,3) = cf
	end function get_trivial_cf_factors_threshold

	subroutine transfer_me_array_to_bij (pcm, i_flv, &
	sqme_born, sqme_color_c)
	type(pcm_nlo_t), intent(in) :: pcm
	integer, intent(in) :: i_flv
	real(default), intent(in) :: sqme_born
	real(default), dimension(:,:), intent(inout) :: sqme_color_c
	logical :: special_case_interferences
	integer :: i_color_c, i_sub, n_offset
	real(default), dimension(:), allocatable :: sqme
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij")
	if (pcm%settings%use_internal_color_correlations) then
	!!! A negative value for sqme_born indicates that the Born matrix
	!!! element is multiplied at a different place, e.g. in the case
	!!! of the virtual component
	sqme_color_c = get_trivial_cf_factors &
	(pcm%region_data%get_n_legs_born (), &
	pcm%region_data%get_flv_states_born (i_flv), &
	pcm%settings%factorization_mode)
	if (sqme_born > zero) then
	sqme_color_c = sqme_born * sqme_color_c
	else if (sqme_born == zero) then
	sqme_color_c = zero
	end if
	else
	special_case_interferences = pcm%region_data%nlo_correction_type == "EW"
	n_offset = 0
	if (term%nlo_type == NLO_VIRTUAL) then
	n_offset = 1
	else if (pcm%has_pdfs .and. (term%is_subtraction () &
	.or. term%nlo_type == NLO_DGLAP)) then
	n_offset = n_beams_rescaled
	end if
	allocate (sqme (term%get_n_sub_color ()), source = zero)
	do i_sub = 1, term%get_n_sub_color ()
	sqme(i_sub) = real(term%connected%trace%get_matrix_element ( &
	term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset)), &
	default)
	end do
	call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, &
	sqme, sqme_color_c)
	call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( &
	term%connected%trace%get_qn_index (i_flv, i_sub = 0)), default), &
	pcm%region_data%get_flv_states_born (i_flv), &
	sqme_color_c, special_case_interferences)
	end if
	end subroutine transfer_me_array_to_bij
	end subroutine term_instance_evaluate_color_correlations

	@ %def term_instance_evaluate_color_correlations
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_charge_correlations => &
	term_instance_evaluate_charge_correlations
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_charge_correlations (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	integer :: i_flv_born
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	do i_flv_born = 1, pcm%region_data%n_flv_born
	select case (term%nlo_type)
	case (NLO_REAL)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	pcm_work%real_sub%sqme_born (i_flv_born), &
	pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born))
	case (NLO_MISMATCH)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	pcm_work%soft_mismatch%sqme_born (i_flv_born), &
	pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
	case (NLO_VIRTUAL)
	call transfer_me_array_to_bij (pcm, i_flv_born, &
	one, pcm_work%virtual%sqme_charge_c (:, :, i_flv_born))
	end select
	end do
	end select
	end select
	contains
	subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c)
	type(pcm_nlo_t), intent(in) :: pcm
	integer, intent(in) :: i_flv
	real(default), intent(in) :: sqme_born
	real(default), dimension(:,:), intent(inout) :: sqme_charge_c
	integer :: n_legs_born, i, j
	real(default), dimension(:), allocatable :: sigma
	real(default), dimension(:), allocatable :: Q
	n_legs_born = pcm%region_data%n_legs_born
	associate (flv_born => pcm%region_data%flv_born(i_flv))
	allocate (sigma (n_legs_born), Q (size (flv_born%charge)))
	Q = flv_born%charge
	sigma(1:flv_born%n_in) = -one
	sigma(flv_born%n_in + 1: ) = one
	end associate
	do i = 1, n_legs_born
	do j = 1, n_legs_born
	sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one)
	end do
	end do
	sqme_charge_c = sqme_charge_c * sqme_born
	end subroutine transfer_me_array_to_bij
	end subroutine term_instance_evaluate_charge_correlations

	@ %def term_instance_evaluate_charge_correlations
	@ The information about spin correlations is not stored in the [[nlo_settings]] because
	it is only available after the [[fks_regions]] have been created.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_spin_correlations (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	integer :: i_flv, i_sub, i_emitter, emitter
	integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j
	real(default), dimension(1:3, 1:3) :: sqme_spin_c
	real(default), dimension(:), allocatable :: sqme_spin_c_all
	real(default), dimension(:), allocatable :: sqme_spin_c_arr
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
	"term_instance_evaluate_spin_correlations")
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	if (pcm_work%real_sub%requires_spin_correlations () &
	.and. term%nlo_type == NLO_REAL) then
	select type (core)
	type is (prc_openloops_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	n_flv = term%connected%trace%get_qn_index_n_flv ()
	n_sub_color = term%get_n_sub_color ()
	n_sub_spin = term%get_n_sub_spin ()
	n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled
	allocate (sqme_spin_c_arr(6))
	do i_flv = 1, n_flv
	allocate (sqme_spin_c_all(n_sub_spin))
	do i_sub = 1, n_sub_spin
	sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element &
	(term%connected%trace%get_qn_index (i_flv, &
	i_sub = i_sub + n_offset + n_sub_color)), default)
	end do
	do i_emitter = 1, pcm%region_data%n_emitters
	emitter = pcm%region_data%emitters(i_emitter)
	if (emitter > 0) then
	call split_array (sqme_spin_c_all, sqme_spin_c_arr)
	do j = 1, size (sqme_spin_c, dim=2)
	do i = j, size (sqme_spin_c, dim=1)
	!!! Restoring the symmetric matrix packed into a 1-dim array
	!!! c.f. [[prc_openloops_compute_sqme_spin_c]]
	sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2)
	if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j)
	end do
	end do
	pcm_work%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c
	end if
	end do
	deallocate (sqme_spin_c_all)
	end do
	end select
	class default
	call msg_fatal ("Spin correlations so far only supported by OpenLoops.")
	end select
	end if
	end select
	end subroutine term_instance_evaluate_spin_correlations

	@ %def term_instance_evaluate_spin_correlations
	@@
	<<Instances: term instance: TBP>>=
	procedure :: apply_fks => term_instance_apply_fks
	<<Instances: procedures>>=
	subroutine term_instance_apply_fks (term, kin, alpha_s_sub, alpha_qed_sub)
	class(term_instance_t), intent(inout) :: term
	class(kinematics_t), intent(inout) :: kin
	real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
	real(default), dimension(:), allocatable :: sqme
	integer :: i, i_phs, emitter
	logical :: is_subtraction
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (term%connected%has_matrix) then
	allocate (sqme (pcm%get_n_alr ()))
	else
	allocate (sqme (1))
	end if
	sqme = zero
	select type (phs => kin%phs)
	type is (phs_fks_t)
	if (pcm%has_pdfs .and. &
	pcm%settings%use_internal_color_correlations) then
	call msg_fatal ("Color correlations for proton processes " // &
	"so far only supported by OpenLoops.")
	end if
	call pcm_work%set_real_and_isr_kinematics &
	(phs%phs_identifiers, kin%phs%get_sqrts ())
	if (kin%emitter < 0) then
	call pcm_work%set_subtraction_event ()
	do i_phs = 1, pcm%region_data%n_phs
	emitter = phs%phs_identifiers(i_phs)%emitter
	call pcm_work%real_sub%compute (emitter, &
	i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
	end do
	else
	call pcm_work%set_radiation_event ()
	emitter = kin%emitter; i_phs = kin%i_phs
	do i = 1, term%connected%trace%get_qn_index_n_flv ()
	pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = &
	real (term%connected%trace%get_matrix_element ( &
	term%connected%trace%get_qn_index (i)))
	end do
	call pcm_work%real_sub%compute (emitter, i_phs, alpha_s_sub, &
	alpha_qed_sub, term%connected%has_matrix, sqme)
	end if
	end select
	end select
	end select
	if (term%connected%has_trace) &
	call term%connected%trace%set_only_matrix_element &
	(1, cmplx (sum(sqme), 0, default))
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	is_subtraction = kin%emitter < 0
	if (term%connected%has_matrix) &
	call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
	pcm%get_qn (is_subtraction), &
	pcm%region_data%get_flavor_indices (is_subtraction), &
	term%connected%matrix)
	if (term%connected%has_flows) &
	call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
	pcm%get_qn (is_subtraction), &
	pcm%region_data%get_flavor_indices (is_subtraction), &
	term%connected%flows)
	end select
	end subroutine term_instance_apply_fks

	@ %def term_instance_apply_fks
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in) :: alpha_s, alpha_qed
	real(default), dimension(2) :: alpha_coupling
	type(vector4_t), dimension(:), allocatable :: p_born
	real(default), dimension(:), allocatable :: sqme_virt
	integer :: i_flv
	if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal &
	("Trying to evaluate virtual matrix element with unsuited term_instance.")
	if (debug2_active (D_VIRTUAL)) then
	call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements")
	print *, 'ren_scale: ', term%get_ren_scale ()
	print *, 'fac_scale: ', term%get_fac_scale ()
	if (allocated (term%es_scale)) then
	print *, 'ES scale: ', term%es_scale
	else
	print *, 'ES scale: ', term%get_ren_scale ()
	end if
	end if
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	alpha_coupling = [alpha_s, alpha_qed]
	if (debug2_active (D_VIRTUAL)) then
	print *, 'alpha_s: ', alpha_coupling (1)
	print *, 'alpha_qed: ', alpha_coupling (2)
	end if
	allocate (p_born (pcm%region_data%n_legs_born))
	if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
	p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1)
	else
	p_born = term%int_hard%get_momenta ()
	end if
	call pcm_work%set_momenta_and_scales_virtual &
	(p_born, term%ren_scale, term%get_fac_scale (), &
	term%es_scale)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	associate (virtual => pcm_work%virtual)
	do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
	virtual%sqme_born(i_flv) = &
	real (term%connected%trace%get_matrix_element ( &
	term%connected%trace%get_qn_index (i_flv, i_sub = 0)))
	virtual%sqme_virt_fin(i_flv) = &
	real (term%connected%trace%get_matrix_element ( &
	term%connected%trace%get_qn_index (i_flv, i_sub = 1)))
	end do
	end associate
	end select
	call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, alpha_coupling, &
	term%connected%has_matrix, sqme_virt)
	call term%connected%trace%set_only_matrix_element &
	(1, cmplx (sum(sqme_virt), 0, default))
	if (term%connected%has_matrix) &
	call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%matrix)
	if (term%connected%has_flows) &
	call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%flows)
	end select
	end select
	end subroutine term_instance_evaluate_sqme_virt

	@ %def term_instance_evaluate_sqme_virt
	@ Needs generalization to electroweak corrections.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in) :: alpha_s
	real(default), dimension(:), allocatable :: sqme_mism
	if (term%nlo_type /= NLO_MISMATCH) call msg_fatal &
	("Trying to evaluate soft mismatch with unsuited term_instance.")
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	call pcm_work%compute_sqme_mismatch &
	(term%pcm, alpha_s, term%connected%has_matrix, sqme_mism)
	end select
	call term%connected%trace%set_only_matrix_element &
	(1, cmplx (sum (sqme_mism) * term%weight, 0, default))
	if (term%connected%has_matrix) then
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (term%connected%has_matrix) &
	call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%matrix)
	if (term%connected%has_flows) &
	call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%flows)
	end select
	end if
	end subroutine term_instance_evaluate_sqme_mismatch

	@ %def term_instance_evaluate_sqme_mismatch
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in) :: alpha_s, alpha_qed
	real(default), dimension(2) :: alpha_coupling
	real(default), dimension(:), allocatable :: sqme_dglap
	integer :: i_flv
	if (term%nlo_type /= NLO_DGLAP) call msg_fatal &
	("Trying to evaluate DGLAP remnant with unsuited term_instance.")
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap")
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	alpha_coupling = [alpha_s,alpha_qed]
	if (debug2_active (D_PROCESS_INTEGRATION)) then
	associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born)
	print *, "size(sqme_born) = ", size (pcm_work%dglap_remnant%sqme_born)
	call term%connected%trace%write ()
	end associate
	end if
	call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, &
	term%connected%has_matrix, sqme_dglap)
	end select
	end select
	call term%connected%trace%set_only_matrix_element &
	(1, cmplx (sum (sqme_dglap) * term%weight, 0, default))
	if (term%connected%has_matrix) then
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%matrix)
	if (term%connected%has_flows) then
	call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
	pcm%get_qn (.true.), &
	remove_duplicates_from_int_array ( &
	pcm%region_data%get_flavor_indices (.true.)), &
	term%connected%flows)
	end if
	end select
	end if
	end subroutine term_instance_evaluate_sqme_dglap

	@ %def term_instance_evaluate_sqme_dglap
	@ Reset the term instance: clear the parton-state expressions and deactivate.
	<<Instances: term instance: TBP>>=
	procedure :: reset => term_instance_reset
	<<Instances: procedures>>=
	subroutine term_instance_reset (term)
	class(term_instance_t), intent(inout) :: term
	call term%connected%reset_expressions ()
	if (allocated (term%alpha_qcd_forced)) deallocate (term%alpha_qcd_forced)
	term%active = .false.
	end subroutine term_instance_reset

	@ %def term_instance_reset
	@ Force an $\alpha_s$ value that should be used in the matrix-element
	calculation.
	<<Instances: term instance: TBP>>=
	procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced
	<<Instances: procedures>>=
	subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in) :: alpha_qcd
	if (allocated (term%alpha_qcd_forced)) then
	term%alpha_qcd_forced = alpha_qcd
	else
	allocate (term%alpha_qcd_forced, source = alpha_qcd)
	end if
	end subroutine term_instance_set_alpha_qcd_forced

	@ %def term_instance_set_alpha_qcd_forced
	@ Complete the kinematics computation for the effective parton states.

	We assume that the [[compute_hard_kinematics]] method of the process
	component instance has already been called, so the [[int_hard]]
	contains the correct hard kinematics. The duty of this procedure is
	first to compute the effective kinematics and store this in the
	[[int_eff]] effective interaction inside the [[isolated]] parton
	state. The effective kinematics may differ from the kinematics in the hard
	interaction. It may involve parton recombination or parton splitting.
	The [[rearrange_partons]] method is responsible for this part.

	We may also call a method to compute the effective structure-function
	chain at this point. This is not implemented yet.

	In the simple case that no rearrangement is necessary, as indicated by
	the [[rearrange]] flag, the effective interaction is a pointer to the
	hard interaction, and we can skip the rearrangement method. Similarly
	for the effective structure-function chain.

	The final step of kinematics setup is to transfer the effective
	kinematics to the evaluators and to the [[subevt]].
	<<Instances: term instance: TBP>>=
	procedure :: compute_eff_kinematics => &
	term_instance_compute_eff_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_compute_eff_kinematics (term)
	class(term_instance_t), intent(inout) :: term
	term%checked = .false.
	term%passed = .false.
	call term%isolated%receive_kinematics ()
	call term%connected%receive_kinematics ()
	end subroutine term_instance_compute_eff_kinematics

	@ %def term_instance_compute_eff_kinematics
	@ Inverse. Reconstruct the connected state from the momenta in the
	trace evaluator (which we assume to be set), then reconstruct the
	isolated state as far as possible. The second part finalizes the
	momentum configuration, using the incoming seed momenta
	<<Instances: term instance: TBP>>=
	procedure :: recover_hard_kinematics => &
	term_instance_recover_hard_kinematics
	<<Instances: procedures>>=
	subroutine term_instance_recover_hard_kinematics (term)
	class(term_instance_t), intent(inout) :: term
	term%checked = .false.
	term%passed = .false.
	call term%connected%send_kinematics ()
	call term%isolated%send_kinematics ()
	end subroutine term_instance_recover_hard_kinematics

	@ %def term_instance_recover_hard_kinematics
	@ Check the term whether it passes cuts and, if successful, evaluate
	scales and weights. The factorization scale is also given to the term
	kinematics, enabling structure-function evaluation.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_expressions => &
	term_instance_evaluate_expressions
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_expressions (term, scale_forced)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in), allocatable, optional :: scale_forced
	call term%connected%evaluate_expressions (term%passed, &
	term%scale, term%fac_scale, term%ren_scale, term%weight, &
	scale_forced, force_evaluation = .true.)
	term%checked = .true.
	end subroutine term_instance_evaluate_expressions

	@ %def term_instance_evaluate_expressions
	@ Evaluate the trace: first evaluate the hard interaction, then the trace
	evaluator. We use the [[evaluate_interaction]] method of the process
	component which generated this term. The [[subevt]] and cut expressions are
	not yet filled.

	The [[component]] argument is intent(inout) because the [[compute_amplitude]]
	method may modify the [[core_state]] workspace object.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_interaction => term_instance_evaluate_interaction
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_interaction (term, core, kin)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(in), pointer :: core
	type(kinematics_t), intent(inout) :: kin
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
	"term_instance_evaluate_interaction")
	if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then
	term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta ()
	else
	term%p_hard = term%int_hard%get_momenta ()
	end if
	select type (core)
	class is (prc_external_t)
	call term%evaluate_interaction_userdef (core, kin)
	class default
	call term%evaluate_interaction_default (core)
	end select
	call term%int_hard%set_matrix_element (term%amp)
	end subroutine term_instance_evaluate_interaction

	@ %def term_instance_evaluate_interaction
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_interaction_default &
	=> term_instance_evaluate_interaction_default
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_interaction_default (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(in) :: core
	real(default) :: fac_scale, ren_scale
	integer :: i
	if (allocated (term%fac_scale)) then
	fac_scale = term%fac_scale
	else
	fac_scale = term%scale
	end if
	if (allocated (term%ren_scale)) then
	ren_scale = term%ren_scale
	else
	ren_scale = term%scale
	end if
	do i = 1, term%config%n_allowed
	term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, &
	term%config%flv(i), term%config%hel(i), term%config%col(i), &
	fac_scale, ren_scale, term%alpha_qcd_forced, &
	term%core_state)
	end do
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	call pcm_work%set_fac_scale (fac_scale)
	end select
	end subroutine term_instance_evaluate_interaction_default

	@ %def term_instance_evaluate_interaction_default
	@
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_interaction_userdef &
	=> term_instance_evaluate_interaction_userdef
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_interaction_userdef (term, core, kin)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	type(kinematics_t), intent(inout) :: kin
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
	"term_instance_evaluate_interaction_userdef")
	select type (core_state => term%core_state)
	type is (openloops_state_t)
	select type (core)
	type is (prc_openloops_t)
	call core%compute_alpha_s (core_state, term%get_ren_scale ())
	if (allocated (core_state%threshold_data)) &
	call evaluate_threshold_parameters (core_state, core, kin%phs%get_sqrts ())
	end select
	class is (prc_external_state_t)
	select type (core)
	class is (prc_external_t)
	call core%compute_alpha_s (core_state, term%get_ren_scale ())
	end select
	end select
	call evaluate_threshold_interaction ()
	if (term%nlo_type == NLO_VIRTUAL) then
	call term%evaluate_interaction_userdef_loop (core)
	else
	call term%evaluate_interaction_userdef_tree (core)
	end if
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	call pcm_work%set_fac_scale (term%get_fac_scale ())
	end select

	contains
	subroutine evaluate_threshold_parameters (core_state, core, sqrts)
	type(openloops_state_t), intent(inout) :: core_state
	type(prc_openloops_t), intent(inout) :: core
	real(default), intent(in) :: sqrts
	real(default) :: mtop, wtop
	mtop = m1s_to_mpole (sqrts)
	wtop = core_state%threshold_data%compute_top_width &
	(mtop, core_state%alpha_qcd)
	call core%set_mass_and_width (6, mtop, wtop)
	end subroutine

	subroutine evaluate_threshold_interaction ()
	integer :: leg
	select type (core)
	type is (prc_threshold_t)
	if (term%nlo_type > BORN) then
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	if (kin%emitter >= 0) then
	call core%set_offshell_momenta &
	(pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
	leg = thr_leg (kin%emitter)
	call core%set_leg (leg)
	call core%set_onshell_momenta &
	(pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
	else
	call core%set_leg (0)
	call core%set_offshell_momenta &
	(pcm_work%real_kinematics%p_born_cms%get_momenta(1))
	end if
	end select
	else
	call core%set_leg (-1)
	call core%set_offshell_momenta (term%p_hard)
	end if
	end select
	end subroutine evaluate_threshold_interaction
	end subroutine term_instance_evaluate_interaction_userdef

	@ %def term_instance_evaluate_interaction_userdef
	@ Retrieve the matrix elements from a matrix element provider and place them
	into [[term%amp]].

	For the handling of NLO calculations, FKS applies a book keeping handling
	flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in
	order to calculate the subtraction terms. Therefore, we have to insert the
	calculated matrix elements correctly into the state matrix where each entry
	corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of
	quantum numbers provided by FKS to the hard process [[int_hard]].

	The calculated matrix elements are insert into [[term%amp]] in the following
	way. The first [[n_born]] particles are the matrix element of the hard process.
	In non-trivial beams, we store another [[n_beams_rescaled]] copies of these
	matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant
	from times before the method [[term_instance_set_sf_factors]] and these entries are
	not used anymore. However, eliminating these entries involves deeper changes in how
	the connection tables for the evaluator product are set up and should therefore be
	part of a larger refactoring of the interactions \& state matrices.
	The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements,
	with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being
	spin-correlated Born matrix elements.

	If two or more flavor structures would produce the same amplitude we only compute
	one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
	to improve performance.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_interaction_userdef_tree &
	=> term_instance_evaluate_interaction_userdef_tree
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_interaction_userdef_tree (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(inout) :: core
	real(default) :: sqme
	real(default), dimension(:), allocatable :: sqme_color_c
	real(default), dimension(:), allocatable :: sqme_spin_c
	real(default), dimension(6) :: sqme_spin_c_tmp
	integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off
	integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, i_spin_c, i_spin_c_eqv
	integer :: i_flv_eqv, i_hel_eqv
	integer :: emitter, i_emitter
	logical :: bad_point, bp
	logical, dimension(:,:), allocatable :: eqv_me_evaluated
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
	"term_instance_evaluate_interaction_userdef_tree")
	allocate (sqme_color_c (blha_result_array_size &
	(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
	n_flv = term%int_hard%get_qn_index_n_flv ()
	n_hel = term%int_hard%get_qn_index_n_hel ()
	n_sub_color = term%get_n_sub_color ()
	n_sub_spin = term%get_n_sub_spin ()
	allocate (eqv_me_evaluated(n_flv,n_hel))
	eqv_me_evaluated = .false.
	do i_flv = 1, n_flv
	do i_hel = 1, n_hel
	i_flv_eqv = core%data%eqv_flv_index(i_flv)
	i_hel_eqv = core%data%eqv_hel_index(i_hel)
	if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
	select type (core)
	class is (prc_external_t)
	call core%update_alpha_s (term%core_state, term%get_ren_scale ())
	call core%compute_sqme (i_flv, i_hel, term%p_hard, &
	term%get_ren_scale (), sqme, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	associate (i_int => term%int_hard%get_qn_index &
	(i_flv = i_flv, i_hel = i_hel, i_sub = 0))
	term%amp(i_int) = cmplx (sqme, 0, default)
	end associate
	end select
	n_pdf_off = 0
	if (term%pcm%has_pdfs .and. &
	(term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
	n_pdf_off = n_pdf_off + n_beams_rescaled
	do i_sub = 1, n_pdf_off
	term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
	term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
	end do
	end if
	if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
	sqme_color_c = zero
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (pcm%settings%nlo_correction_type == "EW" .and. &
	pcm%region_data%alphas_power > 0) then
	select type (core)
	class is (prc_blha_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), sqme_color_c, &
	bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	class is (prc_recola_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), sqme_color_c, &
	bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	end select
	end if
	end select
	do i_sub = 1, n_sub_color
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel, i_sub + n_pdf_off)
	term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
	end do
	end if
	if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
	term%nlo_type == NLO_MISMATCH) then
	sqme_color_c = zero
	select type (core)
	class is (prc_blha_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	class is (prc_recola_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	end select
	do i_sub = 1, n_sub_color
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel, i_sub + n_pdf_off)
	term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
	end do
	if (n_sub_spin > 0) then
	bad_point = .false.
	allocate (sqme_spin_c(0))
	select type (core)
	type is (prc_openloops_t)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	do i_emitter = 1, pcm%region_data%n_emitters
	emitter = pcm%region_data%emitters(i_emitter)
	if (emitter > 0) then
	call core%compute_sqme_spin_c &
	(i_flv, &
	i_hel, &
	emitter, &
	term%p_hard, &
	term%get_ren_scale (), &
	sqme_spin_c_tmp, &
	bp)
	sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp]
	bad_point = bad_point .or. bp
	end if
	end do
	end select
	do i_sub = 1, n_sub_spin
	i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
	i_sub + n_pdf_off + n_sub_color)
	term%amp(i_spin_c) = cmplx &
	(sqme_spin_c(i_sub), 0, default)
	end do
	end select
	deallocate (sqme_spin_c)
	end if
	end if
	eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
	else
	associate (i_int => term%int_hard%get_qn_index &
	(i_flv = i_flv, i_hel = i_hel, i_sub = 0), &
	i_int_eqv => term%int_hard%get_qn_index &
	(i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0))
	term%amp(i_int) = term%amp(i_int_eqv)
	end associate
	n_pdf_off = 0
	if (term%pcm%has_pdfs .and. &
	(term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
	n_pdf_off = n_pdf_off + n_beams_rescaled
	do i_sub = 1, n_pdf_off
	term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
	term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
	end do
	end if
	if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then
	do i_sub = 1, n_sub_color
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel, i_sub + n_pdf_off)
	i_color_c_eqv = term%int_hard%get_qn_index &
	(i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
	term%amp(i_color_c) = term%amp(i_color_c_eqv)
	end do
	end if
	if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
	term%nlo_type == NLO_MISMATCH) then
	do i_sub = 1, n_sub_color
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel, i_sub + n_pdf_off)
	i_color_c_eqv = term%int_hard%get_qn_index &
	(i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
	term%amp(i_color_c) = term%amp(i_color_c_eqv)
	end do
	do i_sub = 1, n_sub_spin
	i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
	i_sub + n_pdf_off + n_sub_color)
	i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, &
	i_sub + n_pdf_off + n_sub_color)
	term%amp(i_spin_c) = term%amp(i_spin_c_eqv)
	end do
	end if
	end if
	end do
	end do
	end subroutine term_instance_evaluate_interaction_userdef_tree

	@ %def term_instance_evaluate_interaction_userdef_tree
	@ Same as for [[term_instance_evaluate_interaction_userdef_tree]], but
	for the integrated-subtraction and finite one-loop terms. We only need
	color-correlated Born matrix elements, but an additional entry per
	flavor structure for the finite one-loop contribution. We thus have
	$2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and
	[[i_hel]] combination.

	If two or more flavor structures would produce the same amplitude we only compute
	one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
	to improve performance.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_interaction_userdef_loop &
	=> term_instance_evaluate_interaction_userdef_loop
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_interaction_userdef_loop (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(in) :: core
	integer :: n_hel, n_sub, n_flv
	integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv
	integer :: i_flv_eqv, i_hel_eqv
	real(default), dimension(4) :: sqme_virt
	real(default), dimension(:), allocatable :: sqme_color_c
	real(default) :: es_scale
	logical :: bad_point
	logical, dimension(:,:), allocatable :: eqv_me_evaluated
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
	"term_instance_evaluate_interaction_userdef_loop")
	allocate (sqme_color_c (blha_result_array_size &
	(term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
	n_flv = term%int_hard%get_qn_index_n_flv ()
	n_hel = term%int_hard%get_qn_index_n_hel ()
	n_sub = term%int_hard%get_qn_index_n_sub ()
	allocate (eqv_me_evaluated(n_flv,n_hel))
	eqv_me_evaluated = .false.
	i_virt = 1
	do i_flv = 1, n_flv
	do i_hel = 1, n_hel
	i_flv_eqv = core%data%eqv_flv_index(i_flv)
	i_hel_eqv = core%data%eqv_hel_index(i_hel)
	if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
	select type (core)
	class is (prc_external_t)
	if (allocated (term%es_scale)) then
	es_scale = term%es_scale
	else
	es_scale = term%get_ren_scale ()
	end if
	call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
	term%get_ren_scale (), es_scale, &
	term%pcm%blha_defaults%loop_method, &
	sqme_virt, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	end select
	associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
	i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt))
	term%amp(i_loop) = cmplx (sqme_virt(3), 0, default)
	term%amp(i_born) = cmplx (sqme_virt(4), 0, default)
	end associate
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	select type (core)
	class is (prc_blha_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), &
	sqme_color_c, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	do i_sub = 1 + i_virt, n_sub
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel = i_hel, i_sub = i_sub)
	! Index shift: i_sub - i_virt
	term%amp(i_color_c) = &
	cmplx (sqme_color_c(i_sub - i_virt), 0, default)
	end do
	type is (prc_recola_t)
	call core%compute_sqme_color_c_raw (i_flv, i_hel, &
	term%p_hard, term%get_ren_scale (), sqme_color_c, bad_point)
	call term%pcm_work%set_bad_point (bad_point)
	do i_sub = 1 + i_virt, n_sub
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel = i_hel, i_sub = i_sub)
	! Index shift: i_sub - i_virt
	term%amp(i_color_c) = &
	cmplx (sqme_color_c(i_sub - i_virt), 0, default)
	end do
	end select
	end select
	eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
	else
	associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
	i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), &
	i_born_eqv => term%int_hard%get_qn_index &
	(i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), &
	i_loop_eqv => term%int_hard%get_qn_index &
	(i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1))
	term%amp(i_loop) = term%amp(i_loop_eqv)
	term%amp(i_born) = term%amp(i_born_eqv)
	end associate
	do i_sub = 1 + i_virt, n_sub
	i_color_c = term%int_hard%get_qn_index &
	(i_flv, i_hel = i_hel, i_sub = i_sub)
	i_color_c_eqv = term%int_hard%get_qn_index &
	(i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub)
	! Index shift: i_sub - i_virt
	term%amp(i_color_c) = term%amp(i_color_c_eqv)
	end do
	end if
	end do
	end do
	end subroutine term_instance_evaluate_interaction_userdef_loop

	@ %def term_instance_evaluate_interaction_userdef_loop
	@ Evaluate the trace. First evaluate the
	structure-function chain (i.e., the density matrix of the incoming
	partons). Do this twice, in case the sf-chain instances within
	[[kin]] and [[isolated]] differ. Next, evaluate the hard
	interaction, then compute the convolution with the initial state.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_trace => term_instance_evaluate_trace
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_trace (term, kin)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	real(default) :: fac_scale
	if (allocated (term%fac_scale)) then
	fac_scale = term%fac_scale
	else
	fac_scale = term%scale
	end if
	call kin%evaluate_sf_chain (fac_scale, term%negative_sf)
	call term%evaluate_scaled_sf_chains (kin)
	call term%isolated%evaluate_sf_chain (fac_scale)
	call term%isolated%evaluate_trace ()
	call term%connected%evaluate_trace ()
	end subroutine term_instance_evaluate_trace

	@ %def term_instance_evaluate_trace
	@ Include rescaled structure functions due to NLO calculation.
	We rescale the structure function for the real subtraction [[sf_rescale_collinear]],
	the collinear counter terms [[sf_rescale_dglap_t]] and for the case, in which we have
	an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]].\\
	References: arXiv:0709.2092, (2.35)-(2.42).\\
	Obviously, it is completely irrelevant, which beam is treated.
	It becomes problematic when handling [[e, p]]-beams.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_scaled_sf_chains (term, kin)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	class(sf_rescale_t), allocatable :: sf_rescale
	if (.not. term%pcm%has_pdfs) return
	if (term%nlo_type == NLO_REAL) then
	if (term%is_subtraction ()) then
	allocate (sf_rescale_collinear_t :: sf_rescale)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (sf_rescale)
	type is (sf_rescale_collinear_t)
	call sf_rescale%set (pcm_work%real_kinematics%xi_tilde)
	end select
	end select
	call kin%sf_chain%evaluate (term%get_fac_scale (), &
	term%negative_sf, sf_rescale)
	deallocate (sf_rescale)
	else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then
	allocate (sf_rescale_real_t :: sf_rescale)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (sf_rescale)
	type is (sf_rescale_real_t)
	call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * &
	pcm_work%real_kinematics%xi_max (kin%i_phs), &
	pcm_work%real_kinematics%y (kin%i_phs))
	end select
	end select
	call kin%sf_chain%evaluate (term%get_fac_scale (), &
	term%negative_sf, sf_rescale)
	deallocate (sf_rescale)
	else
	call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf)
	end if
	else if (term%nlo_type == NLO_DGLAP) then
	allocate (sf_rescale_dglap_t :: sf_rescale)
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (sf_rescale)
	type is (sf_rescale_dglap_t)
	call sf_rescale%set (pcm_work%isr_kinematics%z)
	end select
	end select
	call kin%sf_chain%evaluate (term%get_fac_scale (), &
	term%negative_sf, sf_rescale)
	deallocate (sf_rescale)
	end if
	end subroutine term_instance_evaluate_scaled_sf_chains

	@ %def term_instance_evaluate_scaled_sf_chains
	@ Evaluate the extra data that we need for processing the object as a
	physical event.
	<<Instances: term instance: TBP>>=
	procedure :: evaluate_event_data => term_instance_evaluate_event_data
	<<Instances: procedures>>=
	subroutine term_instance_evaluate_event_data (term)
	class(term_instance_t), intent(inout) :: term
	logical :: only_momenta
	only_momenta = term%nlo_type > BORN
	call term%isolated%evaluate_event_data (only_momenta)
	call term%connected%evaluate_event_data (only_momenta)
	end subroutine term_instance_evaluate_event_data

	@ %def term_instance_evaluate_event_data
	@
	<<Instances: term instance: TBP>>=
	procedure :: set_fac_scale => term_instance_set_fac_scale
	<<Instances: procedures>>=
	subroutine term_instance_set_fac_scale (term, fac_scale)
	class(term_instance_t), intent(inout) :: term
	real(default), intent(in) :: fac_scale
	term%fac_scale = fac_scale
	end subroutine term_instance_set_fac_scale

	@ %def term_instance_set_fac_scale
	@ Return data that might be useful for external processing. The
	factorization scale and renormalization scale are identical to the
	general scale if not explicitly set:
	<<Instances: term instance: TBP>>=
	procedure :: get_fac_scale => term_instance_get_fac_scale
	procedure :: get_ren_scale => term_instance_get_ren_scale
	<<Instances: procedures>>=
	function term_instance_get_fac_scale (term) result (fac_scale)
	class(term_instance_t), intent(in) :: term
	real(default) :: fac_scale
	if (allocated (term%fac_scale)) then
	fac_scale = term%fac_scale
	else
	fac_scale = term%scale
	end if
	end function term_instance_get_fac_scale

	function term_instance_get_ren_scale (term) result (ren_scale)
	class(term_instance_t), intent(in) :: term
	real(default) :: ren_scale
	if (allocated (term%ren_scale)) then
	ren_scale = term%ren_scale
	else
	ren_scale = term%scale
	end if
	end function term_instance_get_ren_scale

	@ %def term_instance_get_fac_scale term_instance_get_ren_scale
	@ We take the strong coupling from the process core. The value is calculated
	when a new event is requested, so we should call it only after the event has
	been evaluated. If it is not available there (a negative number is returned),
	we take the value stored in the term configuration, which should be determined
	by the model. If the model does not provide a value, the result is zero.
	<<Instances: term instance: TBP>>=
	procedure :: get_alpha_s => term_instance_get_alpha_s
	<<Instances: procedures>>=
	function term_instance_get_alpha_s (term, core) result (alpha_s)
	class(term_instance_t), intent(in) :: term
	class(prc_core_t), intent(in) :: core
	real(default) :: alpha_s
	alpha_s = core%get_alpha_s (term%core_state)
	if (alpha_s < zero) alpha_s = term%config%alpha_s
	end function term_instance_get_alpha_s

	@ %def term_instance_get_alpha_s
	@ The second helicity for [[helicities]] comes with a minus sign
	because OpenLoops inverts the helicity index of antiparticles.
	<<Instances: term instance: TBP>>=
	procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops
	<<Instances: procedures>>=
	subroutine term_instance_get_helicities_for_openloops (term, helicities)
	class(term_instance_t), intent(in) :: term
	integer, dimension(:,:), allocatable, intent(out) :: helicities
	type(helicity_t), dimension(:), allocatable :: hel
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	type(quantum_numbers_mask_t) :: qn_mask
	integer :: h, i, j, n_in
	call qn_mask%set_sub (1)
	call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn)
	n_in = term%int_hard%get_n_in ()
	allocate (helicities (size (qn, dim=1), n_in))
	allocate (hel (n_in))
	do i = 1, size (qn, dim=1)
	do j = 1, n_in
	hel(j) = qn(i, j)%get_helicity ()
	call hel(j)%diagonalize ()
	call hel(j)%get_indices (h, h)
	helicities (i, j) = h
	end do
	end do
	end subroutine term_instance_get_helicities_for_openloops

	@ %def term_instance_get_helicities_for_openloops
	@
	<<Instances: term instance: TBP>>=
	procedure :: get_i_term_global => term_instance_get_i_term_global
	<<Instances: procedures>>=
	elemental function term_instance_get_i_term_global (term) result (i_term)
	integer :: i_term
	class(term_instance_t), intent(in) :: term
	i_term = term%config%i_term_global
	end function term_instance_get_i_term_global

	@ %def term_instance_get_i_term_global
	@
	<<Instances: term instance: TBP>>=
	procedure :: is_subtraction => term_instance_is_subtraction
	<<Instances: procedures>>=
	elemental function term_instance_is_subtraction (term) result (sub)
	logical :: sub
	class(term_instance_t), intent(in) :: term
	sub = term%config%i_term_global == term%config%i_sub
	end function term_instance_is_subtraction

	@ %def term_instance_is_subtraction
	@ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]].
	<<Instances: term instance: TBP>>=
	procedure :: get_n_sub => term_instance_get_n_sub
	procedure :: get_n_sub_color => term_instance_get_n_sub_color
	procedure :: get_n_sub_spin => term_instance_get_n_sub_spin
	<<Instances: procedures>>=
	function term_instance_get_n_sub (term) result (n_sub)
	integer :: n_sub
	class(term_instance_t), intent(in) :: term
	n_sub = term%config%n_sub
	end function term_instance_get_n_sub

	function term_instance_get_n_sub_color (term) result (n_sub_color)
	integer :: n_sub_color
	class(term_instance_t), intent(in) :: term
	n_sub_color = term%config%n_sub_color
	end function term_instance_get_n_sub_color

	function term_instance_get_n_sub_spin (term) result (n_sub_spin)
	integer :: n_sub_spin
	class(term_instance_t), intent(in) :: term
	n_sub_spin = term%config%n_sub_spin
	end function term_instance_get_n_sub_spin

	@ %def term_instance_get_n_sub
	@ %def term_instance_get_n_sub_color
	@ %def term_instance_get_n_sub_spin
	@
	\subsection{The process instance}
	NOTE: The description below represents the intended structure after
	refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies.

	A process instance contains all process data that depend on the
	sampling point and thus change often. In essence, it is an event
	record at the elementary (parton) level. We do not call it such, to
	avoid confusion with the actual event records. If decays are
	involved, the latter are compositions of several elementary processes
	(i.e., their instances).

	We implement the process instance as an extension of the
	[[mci_sampler_t]] that we need for computing integrals and generate
	events.

	The base type contains: the [[integrand]], the [[selected_channel]],
	the two-dimensional array [[x]] of parameters, and the one-dimensional
	array [[f]] of Jacobians. These subobjects are public and used for
	communicating with the multi-channel integrator.

	The [[process]] pointer accesses the process of which this record is
	an instance. It is required whenever the calculation needs invariant
	configuration data, therefore the process should stay in memory for
	the whole lifetime of its instances.

	The [[pcm]] pointer is a shortcut to the [[pcm]] (process-component
	manager) component of the associated process, which we need wherever
	the calculation depends on the overall algorithm.

	The [[pcm_work]] component is the workspace for the [[pcm]] object
	referenced above.

	The [[evaluation_status]] code is used to check the current status.
	In particular, failure at various stages is recorded there.

	The [[count]] object records process evaluations, broken down
	according to status.

	The [[sqme]] value is the single real number that results from
	evaluating and tracing the kinematics and matrix elements. This
	is the number that is handed over to an integration routine.

	The [[weight]] value is the event weight. It is defined when an event
	has been generated from the process instance, either weighted or
	unweighted. The value is the [[sqme]] value times Jacobian weights
	from the integration, or unity, respectively.

	The [[i_mci]] index chooses a subset of components that are associated with
	a common parameter set and integrator, i.e., that are added coherently.

	The [[sf_chain]] subobject is a realization of the beam and
	structure-function configuration in the [[process]] object. It is not
	used for calculation directly but serves as the template for the
	sf-chain instances that are contained in the [[component]] objects.

	The [[kinematics]] array contains the set of phase-space points that
	are associated with the current calculation. The entries may correspond
	to different process components and terms. (TODO wk 19-02-22: Not implemented yet.)

	TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude
	data. The [[term]] data set may be reduced to just results, or
	be removed altogether.

	The [[term]] subobjects are workspace for evaluating kinematics,
	matrix elements, cuts etc. The array entries correspond to the [[term]]
	configuration entries in the associated process object.

	The [[mci_work]] subobject contains the array of real input parameters (random
	numbers) that generates the kinematical point. It also contains the workspace
	for the MC integrators. The active entry of the [[mci_work]] array is
	selected by the [[i_mci]] index above.

	The [[hook]] pointer accesses a list of after evaluate objects which are
	evalutated after the matrix element.
	<<Instances: public>>=
	public :: process_instance_t
	<<Instances: types>>=
	type, extends (mci_sampler_t) :: process_instance_t
	type(process_t), pointer :: process => null ()
	class(pcm_t), pointer :: pcm => null ()
	class(pcm_workspace_t), allocatable :: pcm_work
	integer :: evaluation_status = STAT_UNDEFINED
	real(default) :: sqme = 0
	real(default) :: weight = 0
	real(default) :: excess = 0
	integer :: n_dropped = 0
	integer :: i_mci = 0
	integer :: selected_channel = 0
	type(sf_chain_t) :: sf_chain
	type(kinematics_t), dimension(:), allocatable :: kin
	type(term_instance_t), dimension(:), allocatable :: term
	type(mci_work_t), dimension(:), allocatable :: mci_work
	class(process_instance_hook_t), pointer :: hook => null ()
	contains
	<<Instances: process instance: TBP>>
	end type process_instance_t

	@ %def process_instance
	@
	Wrapper type for storing pointers to process instance objects in arrays.
	<<Instances: public>>=
	public :: process_instance_ptr_t
	<<Instances: types>>=
	type :: process_instance_ptr_t
	type(process_instance_t), pointer :: p => null ()
	end type process_instance_ptr_t

	@ %def process_instance_ptr_t
	@ The process hooks are first-in-last-out list of objects which are evaluated
	after the phase space and matrixelement are evaluated. It is possible to
	retrieve the sampler object and read the sampler information.

	The hook object are part of the [[process_instance]] and therefore, share a
	common lifetime. A data transfer, after the usual lifetime of the
	[[process_instance]], is not provided, as such the finalisation procedure has to take care
	of this! E.g. write the object to file from which later the collected
	information can then be retrieved.
	<<Instances: public>>=
	public :: process_instance_hook_t
	<<Instances: types>>=
	type, abstract :: process_instance_hook_t
	class(process_instance_hook_t), pointer :: next => null ()
	contains
	procedure(process_instance_hook_init), deferred :: init
	procedure(process_instance_hook_final), deferred :: final
	procedure(process_instance_hook_evaluate), deferred :: evaluate
	end type process_instance_hook_t

	@ %def process_instance_hook_t
	@ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the
	[[evaluate]] procedure.

	The [[init]] procedures accesses [[var_list]] and current [[instance]] object.
	<<Instances: public>>=
	public :: process_instance_hook_final, process_instance_hook_evaluate
	<<Instances: interfaces>>=
	abstract interface
	subroutine process_instance_hook_init (hook, var_list, instance)
	import :: process_instance_hook_t, var_list_t, process_instance_t
	class(process_instance_hook_t), intent(inout), target :: hook
	type(var_list_t), intent(in) :: var_list
	class(process_instance_t), intent(in), target :: instance
	end subroutine process_instance_hook_init

	subroutine process_instance_hook_final (hook)
	import :: process_instance_hook_t
	class(process_instance_hook_t), intent(inout) :: hook
	end subroutine process_instance_hook_final

	subroutine process_instance_hook_evaluate (hook, instance)
	import :: process_instance_hook_t, process_instance_t
	class(process_instance_hook_t), intent(inout) :: hook
	class(process_instance_t), intent(in), target :: instance
	end subroutine process_instance_hook_evaluate
	end interface

	@ %def process_instance_hook_final, process_instance_hook_evaluate
	@ The output routine contains a header with the most relevant
	information about the process, copied from
	[[process_metadata_write]]. We mark the active components by an asterisk.

	The next section is the MC parameter input. The following sections
	are written only if the evaluation status is beyond setting the
	parameters, or if the [[verbose]] option is set.
	<<Instances: process instance: TBP>>=
	procedure :: write_header => process_instance_write_header
	procedure :: write => process_instance_write
	<<Instances: procedures>>=
	subroutine process_instance_write_header (object, unit, testflag)
	class(process_instance_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	call write_separator (u, 2)
	if (associated (object%process)) then
	call object%process%write_meta (u, testflag)
	else
	write (u, "(1x,A)") "Process instance [undefined process]"
	return
	end if
	write (u, "(3x,A)", advance = "no") "status = "
	select case (object%evaluation_status)
	case (STAT_INITIAL); write (u, "(A)") "initialized"
	case (STAT_ACTIVATED); write (u, "(A)") "activated"
	case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set"
	case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics"
	case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics"
	case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics"
	case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics"
	case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts"
	case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts"
	case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace"
	call write_separator (u)
	write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
	case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete"
	call write_separator (u)
	write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme
	write (u, "(3x,A,ES19.12)") "weight = ", object%weight
	if (.not. vanishes (object%excess)) &
	write (u, "(3x,A,ES19.12)") "excess = ", object%excess
	case default; write (u, "(A)") "undefined"
	end select
	if (object%i_mci /= 0) then
	call write_separator (u)
	call object%mci_work(object%i_mci)%write (u, testflag)
	end if
	call write_separator (u, 2)
	end subroutine process_instance_write_header

	subroutine process_instance_write (object, unit, testflag)
	class(process_instance_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u, i
	u = given_output_unit (unit)
	call object%write_header (u)
	if (object%evaluation_status >= STAT_BEAM_MOMENTA) then
	call object%sf_chain%write (u)
	call write_separator (u, 2)
	if (object%evaluation_status >= STAT_SEED_KINEMATICS) then
	if (object%evaluation_status >= STAT_HARD_KINEMATICS) then
	call write_separator (u, 2)
	write (u, "(1x,A)") "Active terms:"
	if (any (object%term%active)) then
	do i = 1, size (object%term)
	if (object%term(i)%active) then
	call write_separator (u)
	call object%term(i)%write (u, &
	kin = object%kin(i), &
	show_eff_state = &
	object%evaluation_status >= STAT_EFF_KINEMATICS, &
	testflag = testflag)
	end if
	end do
	end if
	end if
	call write_separator (u, 2)
	end if
	end if
	end subroutine process_instance_write

	@ %def process_instance_write_header
	@ %def process_instance_write
	@ Initialization connects the instance with a process. All initial
	information is transferred from the process object. The process
	object contains templates for the interaction subobjects (beam and
	term), but no evaluators. The initialization routine
	creates evaluators for the matrix element trace, other evaluators
	are left untouched.

	Before we start generating, we double-check if the process library
	has been updated after the process was initializated
	([[check_library_sanity]]). This may happen if between integration
	and event generation the library has been recompiled, so all links
	become broken.

	The [[instance]] object must have the [[target]] attribute (also in
	any caller) since the initialization routine assigns various pointers
	to subobject of [[instance]].
	<<Instances: process instance: TBP>>=
	procedure :: init => process_instance_init
	<<Instances: procedures>>=
	subroutine process_instance_init (instance, process)
	class(process_instance_t), intent(out), target :: instance
	type(process_t), intent(inout), target :: process
	integer :: i
	class(pcm_t), pointer :: pcm
	type(process_term_t), pointer :: term
	type(var_list_t), pointer :: var_list
	integer :: i_born, i_real, i_real_fin, i_component
	if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init")
	instance%process => process
	instance%pcm => process%get_pcm_ptr ()
	call instance%process%check_library_sanity ()
	call instance%setup_sf_chain (process%get_beam_config_ptr ())
	allocate (instance%mci_work (process%get_n_mci ()))
	do i = 1, size (instance%mci_work)
	call instance%process%init_mci_work (instance%mci_work(i), i)
	end do
	call instance%process%reset_selected_cores ()
	pcm => instance%process%get_pcm_ptr ()
	call pcm%allocate_workspace (instance%pcm_work)
	select type (pcm)
	type is (pcm_nlo_t)
	!!! The process is kept when the integration is finalized, but not the
	!!! process_instance. Thus, we check whether pcm has been initialized
	!!! but set up the pcm_work each time.
	i_real_fin = process%get_associated_real_fin (1)
	if (.not. pcm%initialized) then
	i_born = pcm%get_i_core (pcm%i_born)
	i_real = pcm%get_i_core (pcm%i_real)
	call pcm%init_qn (process%get_model_ptr ())
	if (i_real_fin > 0) call pcm%allocate_ps_matching ()
	var_list => process%get_var_list_ptr ()
	if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) &
	call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot")))
	end if
	pcm%initialized = .true.
	select type (pcm_work => instance%pcm_work)
	type is (pcm_nlo_workspace_t)
	call pcm_work%init_config (pcm, &
	process%component_can_be_integrated (), &
	process%get_nlo_type_component (), process%get_energy (), &
	i_real_fin, process%get_model_ptr ())
	end select
	end select
	! TODO wk-03-01 n_terms will eventually acquire a different meaning
	allocate (instance%kin (process%get_n_terms ()))
	do i = 1, process%get_n_terms ()
	term => process%get_term_ptr (i)
	i_component = term%i_component
	call instance%kin(i)%configure (pcm, instance%pcm_work, &
	instance%sf_chain, &
	process%get_beam_config_ptr (), &
	process%get_phs_config (i_component), &
	process%get_nlo_type_component (i_component), &
	term%i_sub == i)
	end do
	! TODO wk-03-01 n_terms will eventually acquire a different meaning
	allocate (instance%term (process%get_n_terms ()))
	do i = 1, process%get_n_terms ()
	call instance%term(i)%configure (process, i, instance%pcm_work, &
	instance%sf_chain, instance%kin(i))
	end do
	call instance%set_i_mci_to_real_component ()
	call instance%find_same_kinematics ()
	instance%evaluation_status = STAT_INITIAL
	end subroutine process_instance_init

	@ %def process_instance_init
	@
	@ Finalize all subobjects that may contain allocated pointers.
	<<Instances: process instance: TBP>>=
	procedure :: final => process_instance_final
	<<Instances: procedures>>=
	subroutine process_instance_final (instance)
	class(process_instance_t), intent(inout) :: instance
	class(process_instance_hook_t), pointer :: current
	integer :: i
	instance%process => null ()
	if (allocated (instance%mci_work)) then
	do i = 1, size (instance%mci_work)
	call instance%mci_work(i)%final ()
	end do
	deallocate (instance%mci_work)
	end if
	call instance%sf_chain%final ()
	if (allocated (instance%kin)) then
	do i = 1, size (instance%kin)
	call instance%kin(i)%final ()
	end do
	deallocate (instance%kin)
	end if
	if (allocated (instance%term)) then
	do i = 1, size (instance%term)
	call instance%term(i)%final ()
	end do
	deallocate (instance%term)
	end if
	call instance%pcm_work%final ()
	instance%evaluation_status = STAT_UNDEFINED
	do while (associated (instance%hook))
	current => instance%hook
	call current%final ()
	instance%hook => current%next
	deallocate (current)
	end do
	instance%hook => null ()
	end subroutine process_instance_final

	@ %def process_instance_final
	@ Revert the process instance to initial state. We do not deallocate
	anything, just reset the state index and deactivate all components and
	terms.

	We do not reset the choice of the MCI set [[i_mci]] unless this is
	required explicitly.
	<<Instances: process instance: TBP>>=
	procedure :: reset => process_instance_reset
	<<Instances: procedures>>=
	subroutine process_instance_reset (instance, reset_mci)
	class(process_instance_t), intent(inout), target :: instance
	logical, intent(in), optional :: reset_mci
	integer :: i
	call instance%process%reset_selected_cores ()
	do i = 1, size (instance%term)
	call instance%term(i)%reset ()
	end do
	instance%term%checked = .false.
	instance%term%passed = .false.
	instance%kin%new_seed = .true.
	if (present (reset_mci)) then
	if (reset_mci) instance%i_mci = 0
	end if
	instance%selected_channel = 0
	instance%evaluation_status = STAT_INITIAL
	end subroutine process_instance_reset

	@ %def process_instance_reset
	@
	\subsubsection{Integration and event generation}
	The sampler test should just evaluate the squared matrix element [[n_calls]]
	times, discarding the results, and return. This can be done before
	integration, e.g., for timing estimates.
	<<Instances: process instance: TBP>>=
	procedure :: sampler_test => process_instance_sampler_test
	<<Instances: procedures>>=
	subroutine process_instance_sampler_test (instance, i_mci, n_calls)
	class(process_instance_t), intent(inout), target :: instance
	integer, intent(in) :: i_mci
	integer, intent(in) :: n_calls
	integer :: i_mci_work
	i_mci_work = instance%process%get_i_mci_work (i_mci)
	call instance%choose_mci (i_mci_work)
	call instance%reset_counter ()
	call instance%process%sampler_test (instance, n_calls, i_mci_work)
	call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
	end subroutine process_instance_sampler_test

	@ %def process_instance_sampler_test
	@ Generate a weighted event. We select one of the available MCI
	integrators by its index [[i_mci]] and thus generate an event for the
	associated (group of) process component(s). The arguments exactly
	correspond to the initializer and finalizer above.

	The resulting event is stored in the [[process_instance]] object,
	which also holds the workspace of the integrator.

	Note: The [[process]] object contains the random-number state, which
	changes for each event.
	Otherwise, all volatile data are inside the [[instance]] object.
	<<Instances: process instance: TBP>>=
	procedure :: generate_weighted_event => process_instance_generate_weighted_event
	<<Instances: procedures>>=
	subroutine process_instance_generate_weighted_event (instance, i_mci)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	integer :: i_mci_work
	i_mci_work = instance%process%get_i_mci_work (i_mci)
	call instance%choose_mci (i_mci_work)
	associate (mci_work => instance%mci_work(i_mci_work))
	call instance%process%generate_weighted_event &
	(i_mci_work, mci_work, instance, &
	instance%keep_failed_events ())
	end associate
	end subroutine process_instance_generate_weighted_event

	@ %def process_instance_generate_weighted_event
	@
	<<Instances: process instance: TBP>>=
	procedure :: generate_unweighted_event => process_instance_generate_unweighted_event
	<<Instances: procedures>>=
	subroutine process_instance_generate_unweighted_event (instance, i_mci)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	integer :: i_mci_work
	i_mci_work = instance%process%get_i_mci_work (i_mci)
	call instance%choose_mci (i_mci_work)
	associate (mci_work => instance%mci_work(i_mci_work))
	call instance%process%generate_unweighted_event &
	(i_mci_work, mci_work, instance)
	end associate
	end subroutine process_instance_generate_unweighted_event

	@ %def process_instance_generate_unweighted_event
	@
	This replaces the event generation methods for the situation that the
	process instance object has been filled by other means (i.e., reading
	and/or recalculating its contents). We just have to fill in missing
	MCI data, especially the event weight.
	<<Instances: process instance: TBP>>=
	procedure :: recover_event => process_instance_recover_event
	<<Instances: procedures>>=
	subroutine process_instance_recover_event (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i_mci
	i_mci = instance%i_mci
	call instance%process%set_i_mci_work (i_mci)
	associate (mci_instance => instance%mci_work(i_mci)%mci)
	call mci_instance%fetch (instance, instance%selected_channel)
	end associate
	end subroutine process_instance_recover_event

	@ %def process_instance_recover_event
	@
	@ Activate the components and terms that correspond to a currently
	selected MCI parameter set.
	<<Instances: process instance: TBP>>=
	procedure :: activate => process_instance_activate
	<<Instances: procedures>>=
	subroutine process_instance_activate (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i, j
	integer, dimension(:), allocatable :: i_term
	associate (mci_work => instance%mci_work(instance%i_mci))
	call instance%process%select_components (mci_work%get_active_components ())
	end associate
	associate (process => instance%process)
	do i = 1, instance%process%get_n_components ()
	if (instance%process%component_is_selected (i)) then
	allocate (i_term (size (process%get_component_i_terms (i))))
	i_term = process%get_component_i_terms (i)
	do j = 1, size (i_term)
	instance%term(i_term(j))%active = .true.
	end do
	end if
	if (allocated (i_term)) deallocate (i_term)
	end do
	end associate
	instance%evaluation_status = STAT_ACTIVATED
	end subroutine process_instance_activate

	@ %def process_instance_activate
	@
	<<Instances: process instance: TBP>>=
	procedure :: find_same_kinematics => process_instance_find_same_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_find_same_kinematics (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i_term1, i_term2, k, n_same
	do i_term1 = 1, size (instance%term)
	if (.not. allocated (instance%term(i_term1)%same_kinematics)) then
	n_same = 1 !!! Index group includes the index of its term_instance
	do i_term2 = 1, size (instance%term)
	if (i_term1 == i_term2) cycle
	if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1
	end do
	allocate (instance%term(i_term1)%same_kinematics (n_same))
	associate (same_kinematics1 => instance%term(i_term1)%same_kinematics)
	same_kinematics1 = 0
	k = 1
	do i_term2 = 1, size (instance%term)
	if (compare_md5s (i_term1, i_term2)) then
	same_kinematics1(k) = i_term2
	k = k + 1
	end if
	end do
	do k = 1, size (same_kinematics1)
	if (same_kinematics1(k) == i_term1) cycle
	i_term2 = same_kinematics1(k)
	allocate (instance%term(i_term2)%same_kinematics (n_same))
	instance%term(i_term2)%same_kinematics = same_kinematics1
	end do
	end associate
	end if
	end do
	contains
	function compare_md5s (i, j) result (same)
	logical :: same
	integer, intent(in) :: i, j
	character(32) :: md5sum_1, md5sum_2
	integer :: mode_1, mode_2
	mode_1 = 0; mode_2 = 0
	select type (phs => instance%kin(i)%phs%config)
	type is (phs_fks_config_t)
	md5sum_1 = phs%md5sum_born_config
	mode_1 = phs%mode
	class default
	md5sum_1 = phs%md5sum_phs_config
	end select
	select type (phs => instance%kin(j)%phs%config)
	type is (phs_fks_config_t)
	md5sum_2 = phs%md5sum_born_config
	mode_2 = phs%mode
	class default
	md5sum_2 = phs%md5sum_phs_config
	end select
	same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2)
	end function compare_md5s
	end subroutine process_instance_find_same_kinematics

	@ %def process_instance_find_same_kinematics
	@
	<<Instances: process instance: TBP>>=
	procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_transfer_same_kinematics (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	integer :: i, i_term_same
	associate (same_kinematics => instance%term(i_term)%same_kinematics)
	do i = 1, size (same_kinematics)
	i_term_same = same_kinematics(i)
	instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed
	associate (phs => instance%kin(i_term_same)%phs)
	call phs%set_lorentz_transformation &
	(instance%kin(i_term)%phs%get_lorentz_transformation ())
	select type (phs)
	type is (phs_fks_t)
	call phs%set_momenta (instance%term(i_term_same)%p_seed)
	if (i_term_same /= i_term) then
	call phs%set_reference_frames (.false.)
	end if
	end select
	end associate
	instance%kin(i_term_same)%new_seed = .false.
	end do
	end associate
	end subroutine process_instance_transfer_same_kinematics

	@ %def process_instance_transfer_same_kinematics
	@
	<<Instances: process instance: TBP>>=
	procedure :: redo_sf_chains => process_instance_redo_sf_chains
	<<Instances: procedures>>=
	subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in), dimension(:) :: i_term
	integer, intent(in) :: phs_channel
	integer :: i
	do i = 1, size (i_term)
	call instance%kin(i_term(i))%redo_sf_chain &
	(instance%mci_work(instance%i_mci), phs_channel)
	end do
	end subroutine process_instance_redo_sf_chains

	@ %def process_instance_redo_sf_chains
	@ Integrate the process, using a previously initialized process
	instance. We select one of the available MCI integrators by its index
	[[i_mci]] and thus integrate over (structure functions and) phase
	space for the associated (group of) process component(s).
	<<Instances: process instance: TBP>>=
	procedure :: integrate => process_instance_integrate
	<<Instances: procedures>>=
	subroutine process_instance_integrate (instance, i_mci, n_it, n_calls, &
	adapt_grids, adapt_weights, final, pacify)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	integer, intent(in) :: n_it
	integer, intent(in) :: n_calls
	logical, intent(in), optional :: adapt_grids
	logical, intent(in), optional :: adapt_weights
	logical, intent(in), optional :: final, pacify
	integer :: nlo_type, i_mci_work
	nlo_type = instance%process%get_component_nlo_type (i_mci)
	i_mci_work = instance%process%get_i_mci_work (i_mci)
	call instance%choose_mci (i_mci_work)
	call instance%reset_counter ()
	associate (mci_work => instance%mci_work(i_mci_work), &
	process => instance%process)
	call process%integrate (i_mci_work, mci_work, &
	instance, n_it, n_calls, adapt_grids, adapt_weights, &
	final, pacify, nlo_type = nlo_type)
	call process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
	end associate
	end subroutine process_instance_integrate

	@ %def process_instance_integrate
	@ Subroutine of the initialization above: initialize the beam and
	structure-function chain template. We establish pointers to the
	configuration data, so [[beam_config]] must have a [[target]]
	attribute.

	The resulting chain is not used directly for calculation. It will
	acquire instances which are stored in the process-component instance
	objects.
	<<Instances: process instance: TBP>>=
	procedure :: setup_sf_chain => process_instance_setup_sf_chain
	<<Instances: procedures>>=
	subroutine process_instance_setup_sf_chain (instance, config)
	class(process_instance_t), intent(inout) :: instance
	type(process_beam_config_t), intent(in), target :: config
	integer :: n_strfun
	n_strfun = config%n_strfun
	if (n_strfun /= 0) then
	call instance%sf_chain%init (config%data, config%sf)
	else
	call instance%sf_chain%init (config%data)
	end if
	if (config%sf_trace) then
	call instance%sf_chain%setup_tracing (config%sf_trace_file)
	end if
	end subroutine process_instance_setup_sf_chain

	@ %def process_instance_setup_sf_chain
	@ This initialization routine should be called only for process
	instances which we intend as a source for physical events. It
	initializes the evaluators in the parton states of the terms. They
	describe the (semi-)exclusive transition matrix and the distribution
	of color flow for the partonic process, convoluted with the beam and
	structure-function chain.

	If the model is not provided explicitly, we may use the model instance that
	belongs to the process. However, an explicit model allows us to override
	particle settings.
	<<Instances: process instance: TBP>>=
	procedure :: setup_event_data => process_instance_setup_event_data
	<<Instances: procedures>>=
	subroutine process_instance_setup_event_data (instance, model, i_core)
	class(process_instance_t), intent(inout), target :: instance
	class(model_data_t), intent(in), optional, target :: model
	integer, intent(in), optional :: i_core
	class(model_data_t), pointer :: current_model
	integer :: i
	class(prc_core_t), pointer :: core => null ()
	if (present (model)) then
	current_model => model
	else
	current_model => instance%process%get_model_ptr ()
	end if
	do i = 1, size (instance%term)
	associate (term => instance%term(i), kin => instance%kin(i))
	if (associated (term%config)) then
	core => instance%process%get_core_term (i)
	call term%setup_event_data (kin, core, current_model)
	end if
	end associate
	end do
	core => null ()
	end subroutine process_instance_setup_event_data

	@ %def process_instance_setup_event_data
	@ Choose a MC parameter set and the corresponding integrator.
	The choice persists beyond calls of the [[reset]] method above. This method
	is automatically called here.
	<<Instances: process instance: TBP>>=
	procedure :: choose_mci => process_instance_choose_mci
	<<Instances: procedures>>=
	subroutine process_instance_choose_mci (instance, i_mci)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	instance%i_mci = i_mci
	call instance%reset ()
	end subroutine process_instance_choose_mci

	@ %def process_instance_choose_mci
	@ Explicitly set a MC parameter set. Works only if we are in initial
	state. We assume that the length of the parameter set is correct.

	After setting the parameters, activate the components and terms that
	correspond to the chosen MC parameter set.

	The [[warmup_flag]] is used when a dummy phase-space point is computed
	for the warmup of e.g. OpenLoops helicities. The setting of the
	the [[evaluation_status]] has to be avoided then.
	<<Instances: process instance: TBP>>=
	procedure :: set_mcpar => process_instance_set_mcpar
	<<Instances: procedures>>=
	subroutine process_instance_set_mcpar (instance, x, warmup_flag)
	class(process_instance_t), intent(inout) :: instance
	real(default), dimension(:), intent(in) :: x
	logical, intent(in), optional :: warmup_flag
	logical :: activate
	activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag
	if (instance%evaluation_status == STAT_INITIAL) then
	associate (mci_work => instance%mci_work(instance%i_mci))
	call mci_work%set (x)
	end associate
	if (activate) call instance%activate ()
	end if
	end subroutine process_instance_set_mcpar

	@ %def process_instance_set_mcpar
	@ Receive the beam momentum/momenta from a source interaction. This
	applies to a cascade decay process instance, where the `beam' momentum
	varies event by event.

	The master beam momentum array is contained in the main structure
	function chain subobject [[sf_chain]]. The sf-chain instance that
	reside in the components will take their beam momenta from there.

	The procedure transforms the instance status into
	[[STAT_BEAM_MOMENTA]]. For process instance with fixed beam, this
	intermediate status is skipped.
	<<Instances: process instance: TBP>>=
	procedure :: receive_beam_momenta => process_instance_receive_beam_momenta
	<<Instances: procedures>>=
	subroutine process_instance_receive_beam_momenta (instance)
	class(process_instance_t), intent(inout) :: instance
	if (instance%evaluation_status >= STAT_INITIAL) then
	call instance%sf_chain%receive_beam_momenta ()
	instance%evaluation_status = STAT_BEAM_MOMENTA
	end if
	end subroutine process_instance_receive_beam_momenta

	@ %def process_instance_receive_beam_momenta
	@ Set the beam momentum/momenta explicitly. Otherwise, analogous to
	the previous procedure.
	<<Instances: process instance: TBP>>=
	procedure :: set_beam_momenta => process_instance_set_beam_momenta
	<<Instances: procedures>>=
	subroutine process_instance_set_beam_momenta (instance, p)
	class(process_instance_t), intent(inout) :: instance
	type(vector4_t), dimension(:), intent(in) :: p
	if (instance%evaluation_status >= STAT_INITIAL) then
	call instance%sf_chain%set_beam_momenta (p)
	instance%evaluation_status = STAT_BEAM_MOMENTA
	end if
	end subroutine process_instance_set_beam_momenta

	@ %def process_instance_set_beam_momenta
	@ Recover the initial beam momenta (those in the [[sf_chain]]
	component), given a valid (recovered) [[sf_chain_instance]] in one of
	the active components. We need to do this only if the lab frame is
	not the c.m.\ frame, otherwise those beams would be fixed anyway.
	<<Instances: process instance: TBP>>=
	procedure :: recover_beam_momenta => process_instance_recover_beam_momenta
	<<Instances: procedures>>=
	subroutine process_instance_recover_beam_momenta (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	if (.not. instance%process%lab_is_cm ()) then
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	call instance%kin(i_term)%return_beam_momenta ()
	end if
	end if
	end subroutine process_instance_recover_beam_momenta

	@ %def process_instance_recover_beam_momenta
	@ Explicitly choose MC integration channel. We assume here that the channel
	count is identical for all active components.
	<<Instances: process instance: TBP>>=
	procedure :: select_channel => process_instance_select_channel
	<<Instances: procedures>>=
	subroutine process_instance_select_channel (instance, channel)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: channel
	instance%selected_channel = channel
	end subroutine process_instance_select_channel

	@ %def process_instance_select_channel
	@ First step of process evaluation: set up seed kinematics. That is, for each
	active process component, compute a momentum array from the MC input
	parameters.

	If [[skip_term]] is set, we skip the component that accesses this
	term. We can assume that the associated data have already been
	recovered, and we are just computing the rest.
	<<Instances: process instance: TBP>>=
	procedure :: compute_seed_kinematics => &
	process_instance_compute_seed_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_compute_seed_kinematics &
	(instance, recover, skip_term)
	class(process_instance_t), intent(inout) :: instance
	logical, intent(in), optional :: recover
	integer, intent(in), optional :: skip_term
	integer :: channel, skip_component, i, j
	logical :: success
	integer, dimension(:), allocatable :: i_term
	channel = instance%selected_channel
	if (channel == 0) then
	call msg_bug ("Compute seed kinematics: undefined integration channel")
	end if
	if (present (skip_term)) then
	skip_component = instance%term(skip_term)%config%i_component
	else
	skip_component = 0
	end if
	if (present (recover)) then
	if (recover) return
	end if
	if (instance%evaluation_status >= STAT_ACTIVATED) then
	success = .true.
	do i = 1, instance%process%get_n_components ()
	if (i == skip_component) cycle
	if (instance%process%component_is_selected (i)) then
	allocate (i_term (size (instance%process%get_component_i_terms (i))))
	i_term = instance%process%get_component_i_terms (i)
	do j = 1, size (i_term)
	associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j)))
	if (kin%new_seed) then
	call term%compute_seed_kinematics (kin, &
	instance%mci_work(instance%i_mci), channel, success)
	call instance%transfer_same_kinematics (i_term(j))
	end if
	if (.not. success) exit
	select type (pcm => instance%pcm)
	class is (pcm_nlo_t)
	call term%evaluate_projections (kin)
	call kin%evaluate_radiation_kinematics &
	(instance%mci_work(instance%i_mci)%get_x_process ())
	call kin%generate_fsr_in ()
	call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
	end select
	end associate
	end do
	end if
	if (allocated (i_term)) deallocate (i_term)
	end do
	if (success) then
	instance%evaluation_status = STAT_SEED_KINEMATICS
	else
	instance%evaluation_status = STAT_FAILED_KINEMATICS
	end if
	end if
	associate (mci_work => instance%mci_work(instance%i_mci))
	select type (pcm_work => instance%pcm_work)
	class is (pcm_nlo_workspace_t)
	call pcm_work%set_x_rad (mci_work%get_x_process ())
	end select
	end associate
	end subroutine process_instance_compute_seed_kinematics

	@ %def process_instance_compute_seed_kinematics
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_x_process => process_instance_get_x_process
	<<Instances: procedures>>=
	pure function process_instance_get_x_process (instance) result (x)
	real(default), dimension(:), allocatable :: x
	class(process_instance_t), intent(in) :: instance
	allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ())))
	x = instance%mci_work(instance%i_mci)%get_x_process ()
	end function process_instance_get_x_process

	@ %def process_instance_get_x_process
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_active_component_type => process_instance_get_active_component_type
	<<Instances: procedures>>=
	pure function process_instance_get_active_component_type (instance) &
	result (nlo_type)
	integer :: nlo_type
	class(process_instance_t), intent(in) :: instance
	nlo_type = instance%process%get_component_nlo_type (instance%i_mci)
	end function process_instance_get_active_component_type

	@ %def process_instance_get_active_component_type
	@ Inverse: recover missing parts of the kinematics from the momentum
	configuration, which we know for a single term and component. Given
	a channel, reconstruct the MC parameter set.
	<<Instances: process instance: TBP>>=
	procedure :: recover_mcpar => process_instance_recover_mcpar
	<<Instances: procedures>>=
	subroutine process_instance_recover_mcpar (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	integer :: channel, i
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	channel = instance%selected_channel
	if (channel == 0) then
	call msg_bug ("Recover MC parameters: undefined integration channel")
	end if
	call instance%kin(i_term)%recover_mcpar &
	(instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed)
	if (instance%term(i_term)%nlo_type == NLO_REAL) then
	do i = 1, size (instance%term)
	if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
	if (instance%term(i)%active) then
	call instance%kin(i)%recover_mcpar &
	(instance%mci_work(instance%i_mci), channel, &
	instance%term(i)%p_seed)
	end if
	end if
	end do
	end if
	end if
	end subroutine process_instance_recover_mcpar

	@ %def process_instance_recover_mcpar
	@ This is part of [[recover_mcpar]], extracted for the case when there is
	no phase space and parameters to recover, but we still need the structure
	function kinematics for evaluation.
	<<Instances: process instance: TBP>>=
	procedure :: recover_sfchain => process_instance_recover_sfchain
	<<Instances: procedures>>=
	subroutine process_instance_recover_sfchain (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	integer :: channel
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	channel = instance%selected_channel
	if (channel == 0) then
	call msg_bug ("Recover sfchain: undefined integration channel")
	end if
	call instance%kin(i_term)%recover_sfchain (channel, instance%term(i_term)%p_seed)
	end if
	end subroutine process_instance_recover_sfchain

	@ %def process_instance_recover_sfchain
	@ Second step of process evaluation: compute all momenta, for all active
	components, from the seed kinematics.
	<<Instances: process instance: TBP>>=
	procedure :: compute_hard_kinematics => &
	process_instance_compute_hard_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_compute_hard_kinematics (instance, recover, skip_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in), optional :: skip_term
	logical, intent(in), optional :: recover
	integer :: i
	logical :: success
	success = .true.
	if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
	do i = 1, size (instance%term)
	associate (term => instance%term(i), kin => instance%kin(i))
	if (term%active) then
	call term%compute_hard_kinematics &
	(kin, recover, skip_term, success)
	if (.not. success) exit
	!!! Ren scale is zero when this is commented out! Understand!
	if (term%nlo_type == NLO_REAL) &
	call kin%redo_sf_chain (instance%mci_work(instance%i_mci), &
	instance%selected_channel)
	end if
	end associate
	end do
	if (success) then
	instance%evaluation_status = STAT_HARD_KINEMATICS
	else
	instance%evaluation_status = STAT_FAILED_KINEMATICS
	end if
	end if
	end subroutine process_instance_compute_hard_kinematics

	@ %def process_instance_setup_compute_hard_kinematics
	@ Inverse: recover seed kinematics. We know the beam momentum
	configuration and the outgoing momenta of the effective interaction,
	for one specific term.
	<<Instances: process instance: TBP>>=
	procedure :: recover_seed_kinematics => &
	process_instance_recover_seed_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_recover_seed_kinematics (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	type(vector4_t), dimension(:), allocatable :: p_seed_ref
	integer :: i
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term))
	if (instance%term(i_term)%nlo_type == NLO_REAL) then
	allocate (p_seed_ref (instance%term(i_term)%isolated%int_eff%get_n_out ()))
	p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta &
	(outgoing = .true.)
	do i = 1, size (instance%term)
	if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then
	if (instance%term(i)%active) then
	call instance%term(i)%recover_seed_kinematics &
	(instance%kin(i), p_seed_ref)
	end if
	end if
	end do
	end if
	end if
	end subroutine process_instance_recover_seed_kinematics

	@ %def process_instance_recover_seed_kinematics
	@ Third step of process evaluation: compute the effective momentum
	configurations, for all active terms, from the hard kinematics.
	<<Instances: process instance: TBP>>=
	procedure :: compute_eff_kinematics => &
	process_instance_compute_eff_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_compute_eff_kinematics (instance, skip_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in), optional :: skip_term
	integer :: i
	if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then
	do i = 1, size (instance%term)
	if (present (skip_term)) then
	if (i == skip_term) cycle
	end if
	if (instance%term(i)%active) then
	call instance%term(i)%compute_eff_kinematics ()
	end if
	end do
	instance%evaluation_status = STAT_EFF_KINEMATICS
	end if
	end subroutine process_instance_compute_eff_kinematics

	@ %def process_instance_setup_compute_eff_kinematics
	@ Inverse: recover the hard kinematics from effective kinematics for
	one term, then compute effective kinematics for the other terms.
	<<Instances: process instance: TBP>>=
	procedure :: recover_hard_kinematics => &
	process_instance_recover_hard_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_recover_hard_kinematics (instance, i_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	integer :: i
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	call instance%term(i_term)%recover_hard_kinematics ()
	do i = 1, size (instance%term)
	if (i /= i_term) then
	if (instance%term(i)%active) then
	call instance%term(i)%compute_eff_kinematics ()
	end if
	end if
	end do
	instance%evaluation_status = STAT_EFF_KINEMATICS
	end if
	end subroutine process_instance_recover_hard_kinematics

	@ %def recover_hard_kinematics
	@ Fourth step of process evaluation: check cuts for all terms. Where
	successful, compute any scales and weights. Otherwise, deactive the term.
	If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]].

	The argument [[scale_forced]], if present, will override the scale calculation
	in the term expressions.
	<<Instances: process instance: TBP>>=
	procedure :: evaluate_expressions => &
	process_instance_evaluate_expressions
	<<Instances: procedures>>=
	subroutine process_instance_evaluate_expressions (instance, scale_forced)
	class(process_instance_t), intent(inout) :: instance
	real(default), intent(in), allocatable, optional :: scale_forced
	integer :: i
	logical :: passed_real
	if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
	do i = 1, size (instance%term)
	if (instance%term(i)%active) then
	call instance%term(i)%evaluate_expressions (scale_forced)
	end if
	end do
	call evaluate_real_scales_and_cuts ()
	call set_ellis_sexton_scale ()
	if (.not. passed_real) then
	instance%evaluation_status = STAT_FAILED_CUTS
	else
	if (any (instance%term%passed)) then
	instance%evaluation_status = STAT_PASSED_CUTS
	else
	instance%evaluation_status = STAT_FAILED_CUTS
	end if
	end if
	end if
	contains
	subroutine evaluate_real_scales_and_cuts ()
	integer :: i
	passed_real = .true.
	select type (pcm => instance%pcm)
	type is (pcm_nlo_t)
	do i = 1, size (instance%term)
	if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then
	if (pcm%settings%cut_all_real_sqmes) &
	passed_real = passed_real .and. instance%term(i)%passed
	if (pcm%settings%use_born_scale) &
	call replace_scales (instance%term(i))
	end if
	end do
	end select
	end subroutine evaluate_real_scales_and_cuts

	subroutine replace_scales (this_term)
	type(term_instance_t), intent(inout) :: this_term
	integer :: i_sub
	i_sub = this_term%config%i_sub
	if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then
	this_term%ren_scale = instance%term(i_sub)%ren_scale
	this_term%fac_scale = instance%term(i_sub)%fac_scale
	end if
	end subroutine replace_scales

	subroutine set_ellis_sexton_scale ()
	real(default) :: es_scale
	type(var_list_t), pointer :: var_list
	integer :: i
	var_list => instance%process%get_var_list_ptr ()
	es_scale = var_list%get_rval (var_str ("ellis_sexton_scale"))
	do i = 1, size (instance%term)
	if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then
	if (es_scale > zero) then
	if (allocated (instance%term(i)%es_scale)) then
	instance%term(i)%es_scale = es_scale
	else
	allocate (instance%term(i)%es_scale, source=es_scale)
	end if
	end if
	end if
	end do
	end subroutine set_ellis_sexton_scale
	end subroutine process_instance_evaluate_expressions

	@ %def process_instance_evaluate_expressions
	@ Fifth step of process evaluation: fill the parameters for the non-selected
	channels, that have not been used for seeding. We should do this after
	evaluating cuts, since we may save some expensive calculations if the phase
	space point fails the cuts.

	If [[skip_term]] is set, we skip the component that accesses this
	term. We can assume that the associated data have already been
	recovered, and we are just computing the rest.
	<<Instances: process instance: TBP>>=
	procedure :: compute_other_channels => &
	process_instance_compute_other_channels
	<<Instances: procedures>>=
	subroutine process_instance_compute_other_channels (instance, skip_term)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in), optional :: skip_term
	integer :: channel, skip_component, i, j
	integer, dimension(:), allocatable :: i_term
	channel = instance%selected_channel
	if (channel == 0) then
	call msg_bug ("Compute other channels: undefined integration channel")
	end if
	if (present (skip_term)) then
	skip_component = instance%term(skip_term)%config%i_component
	else
	skip_component = 0
	end if
	if (instance%evaluation_status >= STAT_PASSED_CUTS) then
	do i = 1, instance%process%get_n_components ()
	if (i == skip_component) cycle
	if (instance%process%component_is_selected (i)) then
	allocate (i_term (size (instance%process%get_component_i_terms (i))))
	i_term = instance%process%get_component_i_terms (i)
	do j = 1, size (i_term)
	call instance%kin(i_term(j))%compute_other_channels &
	(instance%mci_work(instance%i_mci), channel)
	end do
	end if
	if (allocated (i_term)) deallocate (i_term)
	end do
	end if
	end subroutine process_instance_compute_other_channels

	@ %def process_instance_compute_other_channels
	@ If not done otherwise, we flag the kinematics as new for the core state,
	such that the routine below will actually compute the matrix element and not
	just look it up.
	<<Instances: process instance: TBP>>=
	procedure :: reset_core_kinematics => process_instance_reset_core_kinematics
	<<Instances: procedures>>=
	subroutine process_instance_reset_core_kinematics (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i
	if (instance%evaluation_status >= STAT_PASSED_CUTS) then
	do i = 1, size (instance%term)
	associate (term => instance%term(i))
	if (term%active .and. term%passed) then
	if (allocated (term%core_state)) &
	call term%core_state%reset_new_kinematics ()
	end if
	end associate
	end do
	end if
	end subroutine process_instance_reset_core_kinematics

	@ %def process_instance_reset_core_kinematics
	@ Sixth step of process evaluation: evaluate the matrix elements, and compute
	the trace (summed over quantum numbers) for all terms. Finally, sum up the
	terms, iterating over all active process components.
	<<Instances: process instance: TBP>>=
	procedure :: evaluate_trace => process_instance_evaluate_trace
	<<Instances: procedures>>=
	subroutine process_instance_evaluate_trace (instance, recover)
	class(process_instance_t), intent(inout) :: instance
	logical, intent(in), optional :: recover
	class(prc_core_t), pointer :: core => null ()
	integer :: i, i_real_fin, i_core
	real(default) :: alpha_s, alpha_qed
	class(prc_core_t), pointer :: core_sub => null ()
	class(model_data_t), pointer :: model => null ()
	logical :: has_pdfs
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace")
	has_pdfs = instance%process%pcm_contains_pdfs ()
	instance%sqme = zero
	call instance%reset_matrix_elements ()
	if (instance%evaluation_status >= STAT_PASSED_CUTS) then
	do i = 1, size (instance%term)
	associate (term => instance%term(i), kin => instance%kin(i))
	if (term%active .and. term%passed) then
	core => instance%process%get_core_term (i)
	select type (pcm => instance%process%get_pcm_ptr ())
	class is (pcm_nlo_t)
	i_core = pcm%get_i_core (pcm%i_sub)
	core_sub => instance%process%get_core_ptr (i_core)
	end select
	call term%evaluate_interaction (core, kin)
	call term%evaluate_trace (kin)
	i_real_fin = instance%process%get_associated_real_fin (1)
	if (instance%process%uses_real_partition ()) &
	call term%apply_real_partition (kin, instance%process)
	if (term%config%i_component /= i_real_fin) then
	if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) &
	.or. term%nlo_type == NLO_MISMATCH &
	.or. term%nlo_type == NLO_DGLAP) &
	call term%set_born_sqmes (core)
	if (term%is_subtraction () .or. &
	term%nlo_type == NLO_DGLAP) &
	call term%set_sf_factors (kin, has_pdfs)
	if (term%nlo_type > BORN) then
	if (.not. (term%nlo_type == NLO_REAL .and. &
	kin%emitter >= 0)) then
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
	char (pcm%settings%nlo_correction_type) == "Full") &
	call term%evaluate_color_correlations (core_sub)
	if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
	char (pcm%settings%nlo_correction_type) == "Full") then
	call term%evaluate_charge_correlations (core_sub)
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	associate (reg_data => pcm%region_data)
	if (reg_data%alphas_power > 0) &
	call term%evaluate_color_correlations (core_sub)
	end associate
	end select
	end if
	end select
	end if
	if (term%is_subtraction ()) then
	call term%evaluate_spin_correlations (core_sub)
	end if
	end if
	alpha_s = core%get_alpha_s (term%core_state)
	alpha_qed = core%get_alpha_qed (term%core_state)
	if (term%nlo_type > BORN) then
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	if (alpha_qed == -1 .and. (&
	char (pcm%settings%nlo_correction_type) == "EW" .or. &
	char (pcm%settings%nlo_correction_type) == "Full")) then
	call msg_bug("Attempting to compute EW corrections with alpha_qed = -1")
	end if
	end select
	end if
	if (present (recover)) then
	if (recover) return
	end if
	select case (term%nlo_type)
	case (NLO_REAL)
	call term%apply_fks (kin, alpha_s, alpha_qed)
	case (NLO_VIRTUAL)
	call term%evaluate_sqme_virt (alpha_s, alpha_qed)
	case (NLO_MISMATCH)
	call term%evaluate_sqme_mismatch (alpha_s)
	case (NLO_DGLAP)
	call term%evaluate_sqme_dglap (alpha_s, alpha_qed)
	end select
	end if
	end if
	core_sub => null ()
	instance%sqme = instance%sqme + real (sum (&
	term%connected%trace%get_matrix_element () * &
	term%weight))
	end associate
	end do
	core => null ()
	if (instance%pcm_work%is_valid ()) then
	instance%evaluation_status = STAT_EVALUATED_TRACE
	else
	instance%evaluation_status = STAT_FAILED_KINEMATICS
	end if
	else
	!!! Failed kinematics or failed cuts: set sqme to zero
	instance%sqme = zero
	end if
	end subroutine process_instance_evaluate_trace

	@ %def process_instance_evaluate_trace
	<<Instances: term instance: TBP>>=
	procedure :: set_born_sqmes => term_instance_set_born_sqmes
	<<Instances: procedures>>=
	subroutine term_instance_set_born_sqmes (term, core)
	class(term_instance_t), intent(inout) :: term
	class(prc_core_t), intent(in) :: core
	integer :: i_flv, ii_flv
	real(default) :: sqme
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
	ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
	sqme = real (term%connected%trace%get_matrix_element (ii_flv))
	select case (term%nlo_type)
	case (NLO_REAL)
	pcm_work%real_sub%sqme_born(i_flv) = sqme
	case (NLO_MISMATCH)
	pcm_work%soft_mismatch%sqme_born(i_flv) = sqme
	case (NLO_DGLAP)
	pcm_work%dglap_remnant%sqme_born(i_flv) = sqme
	end select
	end do
	end select
	end subroutine term_instance_set_born_sqmes

	@ %def term_instance_set_born_sqmes
	@ Calculates and then saves the ratio of the value of the (rescaled) real
	structure function chain of each ISR alpha region over the value of the
	corresponding underlying born flavor structure.
	In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2
	in that region for the (soft-)collinear limits.
	If the emitter is 1 or 2 in some cases, e. g. for EW corrections where a photon in the
	proton is required, there can be the possibility of soft radiation off the initial state.
	For that purpose the unrescaled ratio is needed and as a default we always save these
	numbers in [[sf_factors(:, 0)]].
	Altough this procedure is implying functionality for general structure functions,
	it should be reviewed for anything else besides PDFs, as there might be complications
	in the details. The general idea of getting the ratio in this way should hold up in
	these cases as well, however.
	<<Instances: term instance: TBP>>=
	procedure :: set_sf_factors => term_instance_set_sf_factors
	<<Instances: procedures>>=
	subroutine term_instance_set_sf_factors (term, kin, has_pdfs)
	class(term_instance_t), intent(inout) :: term
	type(kinematics_t), intent(inout) :: kin
	logical, intent(in) :: has_pdfs
	type(interaction_t), pointer :: sf_chain_int
	real(default) :: factor_born, factor_real
	integer :: n_in, alr, em
	integer :: i_born, i_real
	select type (pcm_work => term%pcm_work)
	type is (pcm_nlo_workspace_t)
	if (.not. has_pdfs) then
	pcm_work%real_sub%sf_factors = one
	return
	end if
	select type (pcm => term%pcm)
	type is (pcm_nlo_t)
	sf_chain_int => kin%sf_chain%get_out_int_ptr ()
	associate (reg_data => pcm%region_data)
	n_in = reg_data%get_n_in ()
	do alr = 1, reg_data%n_regions
	em = reg_data%regions(alr)%emitter
	if (em <= n_in) then
	i_born = reg_data%regions(alr)%uborn_index
	i_real = reg_data%regions(alr)%real_index
	factor_born = sf_chain_int%get_matrix_element &
	(sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0))
	factor_real = sf_chain_int%get_matrix_element &
	(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
	call set_factor (pcm_work, alr, em, factor_born, factor_real)
	if (em == 0) then
	do em = 1, 2
	factor_real = sf_chain_int%get_matrix_element &
	(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
	call set_factor (pcm_work, alr, em, factor_born, factor_real)
	end do
	else
	factor_real = sf_chain_int%get_matrix_element &
	(sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0))
	call set_factor (pcm_work, alr, 0, factor_born, factor_real)
	end if
	end if
	end do
	end associate
	end select
	end select
	contains
	subroutine set_factor (pcm_work, alr, em, factor_born, factor_real)
	type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work
	integer, intent(in) :: alr, em
	real(default), intent(in) :: factor_born, factor_real
	real(default) :: factor
	if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then
	factor = zero
	else
	factor = factor_real / factor_born
	end if
	select case (term%nlo_type)
	case (NLO_REAL)
	pcm_work%real_sub%sf_factors(alr, em) = factor
	case (NLO_DGLAP)
	pcm_work%dglap_remnant%sf_factors(alr, em) = factor
	end select
	end subroutine
	end subroutine term_instance_set_sf_factors

	@ %def term_instance_set_sf_factors
	@
	<<Instances: process instance: TBP>>=
	procedure :: apply_real_partition => process_instance_apply_real_partition
	<<Instances: procedures>>=
	subroutine process_instance_apply_real_partition (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i_component, i_term
	integer, dimension(:), allocatable :: i_terms
	associate (process => instance%process)
	i_component = process%get_first_real_component ()
	if (process%component_is_selected (i_component) .and. &
	process%get_component_nlo_type (i_component) == NLO_REAL) then
	allocate (i_terms (size (process%get_component_i_terms (i_component))))
	i_terms = process%get_component_i_terms (i_component)
	do i_term = 1, size (i_terms)
	call instance%term(i_terms(i_term))%apply_real_partition ( &
	instance%kin(i_terms(i_term)), &
	process)
	end do
	end if
	if (allocated (i_terms)) deallocate (i_terms)
	end associate
	end subroutine process_instance_apply_real_partition

	@ %def process_instance_apply_real_partition
	@
	<<Instances: process instance: TBP>>=
	procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component
	<<Instances: procedures>>=
	subroutine process_instance_set_i_mci_to_real_component (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i_mci, i_component
	type(process_component_t), pointer :: component => null ()
	select type (pcm_work => instance%pcm_work)
	type is (pcm_nlo_workspace_t)
	if (allocated (pcm_work%i_mci_to_real_component)) then
	call msg_warning ("i_mci_to_real_component already allocated - replace it")
	deallocate (pcm_work%i_mci_to_real_component)
	end if
	allocate (pcm_work%i_mci_to_real_component (size (instance%mci_work)))
	do i_mci = 1, size (instance%mci_work)
	do i_component = 1, instance%process%get_n_components ()
	component => instance%process%get_component_ptr (i_component)
	if (component%i_mci /= i_mci) cycle
	select case (component%component_type)
	case (COMP_MASTER, COMP_REAL)
	pcm_work%i_mci_to_real_component (i_mci) = &
	component%config%get_associated_real ()
	case (COMP_REAL_FIN)
	pcm_work%i_mci_to_real_component (i_mci) = &
	component%config%get_associated_real_fin ()
	case (COMP_REAL_SING)
	pcm_work%i_mci_to_real_component (i_mci) = &
	component%config%get_associated_real_sing ()
	end select
	end do
	end do
	component => null ()
	end select
	end subroutine process_instance_set_i_mci_to_real_component

	@ %def process_instance_set_i_mci_to_real_component
	@ Final step of process evaluation: evaluate the matrix elements, and compute
	the trace (summed over quantum numbers) for all terms. Finally, sum up the
	terms, iterating over all active process components.

	If [[weight]] is provided, we already know the kinematical event
	weight (the MCI weight which depends on the kinematics sampling
	algorithm, but not on the matrix element), so we do not need to take
	it from the MCI record.
	<<Instances: process instance: TBP>>=
	procedure :: evaluate_event_data => process_instance_evaluate_event_data
	<<Instances: procedures>>=
	subroutine process_instance_evaluate_event_data (instance, weight)
	class(process_instance_t), intent(inout) :: instance
	real(default), intent(in), optional :: weight
	integer :: i
	if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
	do i = 1, size (instance%term)
	associate (term => instance%term(i))
	if (term%active) then
	call term%evaluate_event_data ()
	end if
	end associate
	end do
	if (present (weight)) then
	instance%weight = weight
	else
	instance%weight = &
	instance%mci_work(instance%i_mci)%mci%get_event_weight ()
	instance%excess = &
	instance%mci_work(instance%i_mci)%mci%get_event_excess ()
	end if
	instance%n_dropped = &
	instance%mci_work(instance%i_mci)%mci%get_n_event_dropped ()
	instance%evaluation_status = STAT_EVENT_COMPLETE
	else
	!!! failed kinematics etc.: set weight to zero
	instance%weight = zero
	!!! Maybe we want to process and keep the event nevertheless
	if (instance%keep_failed_events ()) then
	do i = 1, size (instance%term)
	associate (term => instance%term(i))
	if (term%active) then
	call term%evaluate_event_data ()
	end if
	end associate
	end do
	! do i = 1, size (instance%term)
	! instance%term(i)%fac_scale = zero
	! end do
	instance%evaluation_status = STAT_EVENT_COMPLETE
	end if
	end if
	end subroutine process_instance_evaluate_event_data

	@ %def process_instance_evaluate_event_data
	@ Computes the real-emission matrix element for externally supplied momenta
	for the term instance with index [[i_term]] and a phase space point set with
	index [[i_phs]]. In addition, for the real emission, each term instance
	corresponds to one emitter. Also, e.g. for Powheg, there is the possibility
	to supply an external $\alpha_s$.
	<<Instances: process instance: TBP>>=
	procedure :: compute_sqme_rad => process_instance_compute_sqme_rad
	<<Instances: procedures>>=
	subroutine process_instance_compute_sqme_rad &
	(instance, i_term, i_phs, is_subtraction, alpha_s_external)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term, i_phs
	logical, intent(in) :: is_subtraction
	real(default), intent(in), optional :: alpha_s_external
	class(prc_core_t), pointer :: core
	integer :: i_real_fin
	logical :: has_pdfs
	has_pdfs = instance%process%pcm_contains_pdfs ()
	if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad")
	select type (pcm_work => instance%pcm_work)
	type is (pcm_nlo_workspace_t)
	associate (term => instance%term(i_term), kin => instance%kin(i_term))
	core => instance%process%get_core_term (i_term)
	if (is_subtraction) then
	call pcm_work%set_subtraction_event ()
	else
	call pcm_work%set_radiation_event ()
	end if
	call term%int_hard%set_momenta (pcm_work%get_momenta &
	(term%pcm, i_phs = i_phs, born_phsp = is_subtraction))
	if (allocated (term%core_state)) &
	call term%core_state%reset_new_kinematics ()
	if (present (alpha_s_external)) &
	call term%set_alpha_qcd_forced (alpha_s_external)
	call term%compute_eff_kinematics ()
	call term%evaluate_expressions ()
	call term%evaluate_interaction (core, kin)
	call term%evaluate_trace (kin)
	if (term%is_subtraction ()) then
	call term%set_sf_factors (kin, has_pdfs)
	select type (pcm => instance%pcm)
	type is (pcm_nlo_t)
	if (char (pcm%settings%nlo_correction_type) == "QCD" .or. &
	char (pcm%settings%nlo_correction_type) == "Full") &
	call term%evaluate_color_correlations (core)
	if (char (pcm%settings%nlo_correction_type) == "EW" .or. &
	char (pcm%settings%nlo_correction_type) == "Full") &
	call term%evaluate_charge_correlations (core)
	end select
	call term%evaluate_spin_correlations (core)
	end if
	i_real_fin = instance%process%get_associated_real_fin (1)
	if (term%config%i_component /= i_real_fin) &
	call term%apply_fks (kin, core%get_alpha_s (term%core_state), &
	core%get_alpha_qed (term%core_state))
	if (instance%process%uses_real_partition ()) &
	call instance%apply_real_partition ()
	end associate
	end select
	core => null ()
	end subroutine process_instance_compute_sqme_rad

	@ %def process_instance_compute_sqme_rad
	@ For unweighted event generation, we should reset the reported event
	weight to unity (signed) or zero. The latter case is appropriate for
	an event which failed for whatever reason.
	<<Instances: process instance: TBP>>=
	procedure :: normalize_weight => process_instance_normalize_weight
	<<Instances: procedures>>=
	subroutine process_instance_normalize_weight (instance)
	class(process_instance_t), intent(inout) :: instance
	if (.not. vanishes (instance%weight)) then
	instance%weight = sign (1._default, instance%weight)
	end if
	end subroutine process_instance_normalize_weight

	@ %def process_instance_normalize_weight
	@ This is a convenience routine that performs the computations of the
	steps 1 to 5 in a single step. The arguments are the input for
	[[set_mcpar]]. After this, the evaluation status should be either
	[[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]].

	Before calling this, we should call [[choose_mci]].
	<<Instances: process instance: TBP>>=
	procedure :: evaluate_sqme => process_instance_evaluate_sqme
	<<Instances: procedures>>=
	subroutine process_instance_evaluate_sqme (instance, channel, x)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: channel
	real(default), dimension(:), intent(in) :: x
	call instance%reset ()
	call instance%set_mcpar (x)
	call instance%select_channel (channel)
	call instance%compute_seed_kinematics ()
	call instance%compute_hard_kinematics ()
	call instance%compute_eff_kinematics ()
	call instance%evaluate_expressions ()
	call instance%compute_other_channels ()
	call instance%evaluate_trace ()
	end subroutine process_instance_evaluate_sqme

	@ %def process_instance_evaluate_sqme
	@ This is the inverse. Assuming that the final trace evaluator
	contains a valid momentum configuration, recover kinematics
	and recalculate the matrix elements and their trace.

	To be precise, we first recover kinematics for the given term and
	associated component, then recalculate from that all other terms and
	active components. The [[channel]] is not really required to obtain
	the matrix element, but it allows us to reconstruct the exact MC
	parameter set that corresponds to the given phase space point.

	Before calling this, we should call [[choose_mci]].
	<<Instances: process instance: TBP>>=
	procedure :: recover => process_instance_recover
	<<Instances: procedures>>=
	subroutine process_instance_recover &
	(instance, channel, i_term, update_sqme, recover_phs, scale_forced)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: channel
	integer, intent(in) :: i_term
	logical, intent(in) :: update_sqme
	logical, intent(in) :: recover_phs
	real(default), intent(in), allocatable, optional :: scale_forced
	logical :: skip_phs, recover
	call instance%activate ()
	instance%evaluation_status = STAT_EFF_KINEMATICS
	call instance%recover_hard_kinematics (i_term)
	call instance%recover_seed_kinematics (i_term)
	call instance%select_channel (channel)
	recover = instance%pcm_work%is_nlo ()
	if (recover_phs) then
	call instance%recover_mcpar (i_term)
	call instance%recover_beam_momenta (i_term)
	call instance%compute_seed_kinematics &
	(recover = recover, skip_term = i_term)
	call instance%compute_hard_kinematics &
	(recover = recover, skip_term = i_term)
	call instance%compute_eff_kinematics (i_term)
	call instance%compute_other_channels (i_term)
	else
	call instance%recover_sfchain (i_term)
	end if
	call instance%evaluate_expressions (scale_forced)
	if (update_sqme) then
	call instance%reset_core_kinematics ()
	call instance%evaluate_trace (recover)
	end if
	end subroutine process_instance_recover

	@ %def process_instance_recover
	@ The [[evaluate]] method is required by the [[sampler_t]] base type of which
	the process instance is an extension.

	The requirement is that after the process instance is evaluated, the
	integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are
	exposed by the [[sampler_t]] object.

	We allow for the additional [[hook]] to be called, if associated, for outlying
	object to access information from the current state of the [[sampler]].
	<<Instances: process instance: TBP>>=
	procedure :: evaluate => process_instance_evaluate
	<<Instances: procedures>>=
	subroutine process_instance_evaluate (sampler, c, x_in, val, x, f)
	class(process_instance_t), intent(inout) :: sampler
	integer, intent(in) :: c
	real(default), dimension(:), intent(in) :: x_in
	real(default), intent(out) :: val
	real(default), dimension(:,:), intent(out) :: x
	real(default), dimension(:), intent(out) :: f
	call sampler%evaluate_sqme (c, x_in)
	if (sampler%is_valid ()) then
	call sampler%fetch (val, x, f)
	end if
	call sampler%record_call ()
	call sampler%evaluate_after_hook ()
	end subroutine process_instance_evaluate

	@ %def process_instance_evaluate
	@ The phase-space point is valid if the event has valid kinematics and
	has passed the cuts.
	<<Instances: process instance: TBP>>=
	procedure :: is_valid => process_instance_is_valid
	<<Instances: procedures>>=
	function process_instance_is_valid (sampler) result (valid)
	class(process_instance_t), intent(in) :: sampler
	logical :: valid
	valid = sampler%evaluation_status >= STAT_PASSED_CUTS
	end function process_instance_is_valid

	@ %def process_instance_is_valid
	@ Add a [[process_instance_hook]] object..
	<<Instances: process instance: TBP>>=
	procedure :: append_after_hook => process_instance_append_after_hook
	<<Instances: procedures>>=
	subroutine process_instance_append_after_hook (sampler, new_hook)
	class(process_instance_t), intent(inout), target :: sampler
	class(process_instance_hook_t), intent(inout), target :: new_hook
	class(process_instance_hook_t), pointer :: last
	if (associated (new_hook%next)) then
	call msg_bug ("process_instance_append_after_hook: reuse of SAME hook object is forbidden.")
	end if
	if (associated (sampler%hook)) then
	last => sampler%hook
	do while (associated (last%next))
	last => last%next
	end do
	last%next => new_hook
	else
	sampler%hook => new_hook
	end if
	end subroutine process_instance_append_after_hook

	@ %def process_instance_append_after_evaluate_hook
	@ Evaluate the after hook as first in, last out.
	<<Instances: process instance: TBP>>=
	procedure :: evaluate_after_hook => process_instance_evaluate_after_hook
	<<Instances: procedures>>=
	subroutine process_instance_evaluate_after_hook (sampler)
	class(process_instance_t), intent(in) :: sampler
	class(process_instance_hook_t), pointer :: current
	current => sampler%hook
	do while (associated(current))
	call current%evaluate (sampler)
	current => current%next
	end do
	end subroutine process_instance_evaluate_after_hook

	@ %def process_instance_evaluate_after_hook
	@ The [[rebuild]] method should rebuild the kinematics section out of
	the [[x_in]] parameter set. The integrand value [[val]] should not be
	computed, but is provided as input.
	<<Instances: process instance: TBP>>=
	procedure :: rebuild => process_instance_rebuild
	<<Instances: procedures>>=
	subroutine process_instance_rebuild (sampler, c, x_in, val, x, f)
	class(process_instance_t), intent(inout) :: sampler
	integer, intent(in) :: c
	real(default), dimension(:), intent(in) :: x_in
	real(default), intent(in) :: val
	real(default), dimension(:,:), intent(out) :: x
	real(default), dimension(:), intent(out) :: f
	call msg_bug ("process_instance_rebuild not implemented yet")
	x = 0
	f = 0
	end subroutine process_instance_rebuild

	@ %def process_instance_rebuild
	@ This is another method required by the [[sampler_t]] base type:
	fetch the data that are relevant for the MCI record.
	<<Instances: process instance: TBP>>=
	procedure :: fetch => process_instance_fetch
	<<Instances: procedures>>=
	subroutine process_instance_fetch (sampler, val, x, f)
	class(process_instance_t), intent(in) :: sampler
	real(default), intent(out) :: val
	real(default), dimension(:,:), intent(out) :: x
	real(default), dimension(:), intent(out) :: f
	integer, dimension(:), allocatable :: i_terms
	integer :: i, i_term_base, cc
	integer :: n_channel

	val = 0
	associate (process => sampler%process)
	FIND_COMPONENT: do i = 1, process%get_n_components ()
	if (sampler%process%component_is_selected (i)) then
	allocate (i_terms (size (process%get_component_i_terms (i))))
	i_terms = process%get_component_i_terms (i)
	i_term_base = i_terms(1)
	associate (k => sampler%kin(i_term_base))
	n_channel = k%n_channel
	do cc = 1, n_channel
	call k%get_mcpar (cc, x(:,cc))
	end do
	f = k%f
	val = sampler%sqme * k%phs_factor
	end associate
	if (allocated (i_terms)) deallocate (i_terms)
	exit FIND_COMPONENT
	end if
	end do FIND_COMPONENT
	end associate
	end subroutine process_instance_fetch

	@ %def process_instance_fetch
	@ Initialize and finalize event generation for the specified MCI
	entry.
	<<Instances: process instance: TBP>>=
	procedure :: init_simulation => process_instance_init_simulation
	procedure :: final_simulation => process_instance_final_simulation
	<<Instances: procedures>>=
	subroutine process_instance_init_simulation (instance, i_mci, &
	safety_factor, keep_failed_events)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	real(default), intent(in), optional :: safety_factor
	logical, intent(in), optional :: keep_failed_events
	call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events)
	end subroutine process_instance_init_simulation

	subroutine process_instance_final_simulation (instance, i_mci)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_mci
	call instance%mci_work(i_mci)%final_simulation ()
	end subroutine process_instance_final_simulation

	@ %def process_instance_init_simulation
	@ %def process_instance_final_simulation
	@
	\subsubsection{Accessing the process instance}
	Once the seed kinematics is complete, we can retrieve the MC input parameters
	for all channels, not just the seed channel.

	Note: We choose the first active component. This makes sense only if the seed
	kinematics is identical for all active components.
	<<Instances: process instance: TBP>>=
	procedure :: get_mcpar => process_instance_get_mcpar
	<<Instances: procedures>>=
	subroutine process_instance_get_mcpar (instance, channel, x)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: channel
	real(default), dimension(:), intent(out) :: x
	integer :: i
	if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
	do i = 1, size (instance%term)
	if (instance%term(i)%active) then
	call instance%kin(i)%get_mcpar (channel, x)
	return
	end if
	end do
	call msg_bug ("Process instance: get_mcpar: no active channels")
	else
	call msg_bug ("Process instance: get_mcpar: no seed kinematics")
	end if
	end subroutine process_instance_get_mcpar

	@ %def process_instance_get_mcpar
	@ Return true if the [[sqme]] value is known. This also implies that the
	event is kinematically valid and has passed all cuts.
	<<Instances: process instance: TBP>>=
	procedure :: has_evaluated_trace => process_instance_has_evaluated_trace
	<<Instances: procedures>>=
	function process_instance_has_evaluated_trace (instance) result (flag)
	class(process_instance_t), intent(in) :: instance
	logical :: flag
	flag = instance%evaluation_status >= STAT_EVALUATED_TRACE
	end function process_instance_has_evaluated_trace

	@ %def process_instance_has_evaluated_trace
	@ Return true if the event is complete. In particular, the event must
	be kinematically valid, passed all cuts, and the event data have been
	computed.
	<<Instances: process instance: TBP>>=
	procedure :: is_complete_event => process_instance_is_complete_event
	<<Instances: procedures>>=
	function process_instance_is_complete_event (instance) result (flag)
	class(process_instance_t), intent(in) :: instance
	logical :: flag
	flag = instance%evaluation_status >= STAT_EVENT_COMPLETE
	end function process_instance_is_complete_event

	@ %def process_instance_is_complete_event
	@ Select the term for the process instance that will provide the basic
	event record (used in [[evt_trivial_make_particle_set]]). It might be
	necessary to write out additional events corresponding to other terms
	(done in [[evt_nlo]]).
	<<Instances: process instance: TBP>>=
	procedure :: select_i_term => process_instance_select_i_term
	<<Instances: procedures>>=
	function process_instance_select_i_term (instance) result (i_term)
	integer :: i_term
	class(process_instance_t), intent(in) :: instance
	integer :: i_mci
	i_mci = instance%i_mci
	i_term = instance%process%select_i_term (i_mci)
	end function process_instance_select_i_term

	@ %def process_instance_select_i_term
	@ Return pointer to the master beam interaction.
	<<Instances: process instance: TBP>>=
	procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr
	<<Instances: procedures>>=
	function process_instance_get_beam_int_ptr (instance) result (ptr)
	class(process_instance_t), intent(in), target :: instance
	type(interaction_t), pointer :: ptr
	ptr => instance%sf_chain%get_beam_int_ptr ()
	end function process_instance_get_beam_int_ptr

	@ %def process_instance_get_beam_int_ptr
	@ Return pointers to the matrix and flows interactions, given a term index.
	<<Instances: process instance: TBP>>=
	procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr
	procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr
	procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr
	<<Instances: procedures>>=
	function process_instance_get_trace_int_ptr (instance, i_term) result (ptr)
	class(process_instance_t), intent(in), target :: instance
	integer, intent(in) :: i_term
	type(interaction_t), pointer :: ptr
	ptr => instance%term(i_term)%connected%get_trace_int_ptr ()
	end function process_instance_get_trace_int_ptr

	function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr)
	class(process_instance_t), intent(in), target :: instance
	integer, intent(in) :: i_term
	type(interaction_t), pointer :: ptr
	ptr => instance%term(i_term)%connected%get_matrix_int_ptr ()
	end function process_instance_get_matrix_int_ptr

	function process_instance_get_flows_int_ptr (instance, i_term) result (ptr)
	class(process_instance_t), intent(in), target :: instance
	integer, intent(in) :: i_term
	type(interaction_t), pointer :: ptr
	ptr => instance%term(i_term)%connected%get_flows_int_ptr ()
	end function process_instance_get_flows_int_ptr

	@ %def process_instance_get_trace_int_ptr
	@ %def process_instance_get_matrix_int_ptr
	@ %def process_instance_get_flows_int_ptr
	@ Return the complete account of flavor combinations in the underlying
	interaction object, including beams, radiation, and hard interaction.
	<<Instances: process instance: TBP>>=
	procedure :: get_state_flv => process_instance_get_state_flv
	<<Instances: procedures>>=
	function process_instance_get_state_flv (instance, i_term) result (state_flv)
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	type(state_flv_content_t) :: state_flv
	state_flv = instance%term(i_term)%connected%get_state_flv ()
	end function process_instance_get_state_flv

	@ %def process_instance_get_state_flv
	@ Return pointers to the parton states of a selected term.
	<<Instances: process instance: TBP>>=
	procedure :: get_isolated_state_ptr => &
	process_instance_get_isolated_state_ptr
	procedure :: get_connected_state_ptr => &
	process_instance_get_connected_state_ptr
	<<Instances: procedures>>=
	function process_instance_get_isolated_state_ptr (instance, i_term) &
	result (ptr)
	class(process_instance_t), intent(in), target :: instance
	integer, intent(in) :: i_term
	type(isolated_state_t), pointer :: ptr
	ptr => instance%term(i_term)%isolated
	end function process_instance_get_isolated_state_ptr

	function process_instance_get_connected_state_ptr (instance, i_term) &
	result (ptr)
	class(process_instance_t), intent(in), target :: instance
	integer, intent(in) :: i_term
	type(connected_state_t), pointer :: ptr
	ptr => instance%term(i_term)%connected
	end function process_instance_get_connected_state_ptr

	@ %def process_instance_get_isolated_state_ptr
	@ %def process_instance_get_connected_state_ptr
	@ Return the indices of the beam particles and incoming partons within the
	currently active state matrix, respectively.
	<<Instances: process instance: TBP>>=
	procedure :: get_beam_index => process_instance_get_beam_index
	procedure :: get_in_index => process_instance_get_in_index
	<<Instances: procedures>>=
	subroutine process_instance_get_beam_index (instance, i_term, i_beam)
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	integer, dimension(:), intent(out) :: i_beam
	call instance%term(i_term)%connected%get_beam_index (i_beam)
	end subroutine process_instance_get_beam_index

	subroutine process_instance_get_in_index (instance, i_term, i_in)
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	integer, dimension(:), intent(out) :: i_in
	call instance%term(i_term)%connected%get_in_index (i_in)
	end subroutine process_instance_get_in_index

	@ %def process_instance_get_beam_index
	@ %def process_instance_get_in_index
	@ Return squared matrix element and event weight, and event weight
	excess where applicable. [[n_dropped]] is a number that can be
	nonzero when a weighted event has been generated, dropping events with
	zero weight (failed cuts) on the fly.
	<<Instances: process instance: TBP>>=
	procedure :: get_sqme => process_instance_get_sqme
	procedure :: get_weight => process_instance_get_weight
	procedure :: get_excess => process_instance_get_excess
	procedure :: get_n_dropped => process_instance_get_n_dropped
	<<Instances: procedures>>=
	function process_instance_get_sqme (instance, i_term) result (sqme)
	real(default) :: sqme
	class(process_instance_t), intent(in) :: instance
	integer, intent(in), optional :: i_term
	if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
	if (present (i_term)) then
	sqme = instance%term(i_term)%connected%trace%get_matrix_element (1)
	else
	sqme = instance%sqme
	end if
	else
	sqme = 0
	end if
	end function process_instance_get_sqme

	function process_instance_get_weight (instance) result (weight)
	real(default) :: weight
	class(process_instance_t), intent(in) :: instance
	if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
	weight = instance%weight
	else
	weight = 0
	end if
	end function process_instance_get_weight

	function process_instance_get_excess (instance) result (excess)
	real(default) :: excess
	class(process_instance_t), intent(in) :: instance
	if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
	excess = instance%excess
	else
	excess = 0
	end if
	end function process_instance_get_excess

	function process_instance_get_n_dropped (instance) result (n_dropped)
	integer :: n_dropped
	class(process_instance_t), intent(in) :: instance
	if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
	n_dropped = instance%n_dropped
	else
	n_dropped = 0
	end if
	end function process_instance_get_n_dropped

	@ %def process_instance_get_sqme
	@ %def process_instance_get_weight
	@ %def process_instance_get_excess
	@ %def process_instance_get_n_dropped
	@ Return the currently selected MCI channel.
	<<Instances: process instance: TBP>>=
	procedure :: get_channel => process_instance_get_channel
	<<Instances: procedures>>=
	function process_instance_get_channel (instance) result (channel)
	integer :: channel
	class(process_instance_t), intent(in) :: instance
	channel = instance%selected_channel
	end function process_instance_get_channel

	@ %def process_instance_get_channel
	@
	<<Instances: process instance: TBP>>=
	procedure :: set_fac_scale => process_instance_set_fac_scale
	<<Instances: procedures>>=
	subroutine process_instance_set_fac_scale (instance, fac_scale)
	class(process_instance_t), intent(inout) :: instance
	real(default), intent(in) :: fac_scale
	integer :: i_term
	i_term = 1
	call instance%term(i_term)%set_fac_scale (fac_scale)
	end subroutine process_instance_set_fac_scale

	@ %def process_instance_set_fac_scale
	@ Return factorization scale and strong coupling. We have to select a
	term instance.
	<<Instances: process instance: TBP>>=
	procedure :: get_fac_scale => process_instance_get_fac_scale
	procedure :: get_alpha_s => process_instance_get_alpha_s
	<<Instances: procedures>>=
	function process_instance_get_fac_scale (instance, i_term) result (fac_scale)
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	real(default) :: fac_scale
	fac_scale = instance%term(i_term)%get_fac_scale ()
	end function process_instance_get_fac_scale

	function process_instance_get_alpha_s (instance, i_term) result (alpha_s)
	real(default) :: alpha_s
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	class(prc_core_t), pointer :: core => null ()
	core => instance%process%get_core_term (i_term)
	alpha_s = instance%term(i_term)%get_alpha_s (core)
	core => null ()
	end function process_instance_get_alpha_s

	@ %def process_instance_get_fac_scale
	@ %def process_instance_get_alpha_s
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_qcd => process_instance_get_qcd
	<<Instances: procedures>>=
	function process_instance_get_qcd (process_instance) result (qcd)
	type(qcd_t) :: qcd
	class(process_instance_t), intent(in) :: process_instance
	qcd = process_instance%process%get_qcd ()
	end function process_instance_get_qcd

	@ %def process_instance_get_qcd
	@ Counter.
	<<Instances: process instance: TBP>>=
	procedure :: reset_counter => process_instance_reset_counter
	procedure :: record_call => process_instance_record_call
	procedure :: get_counter => process_instance_get_counter
	<<Instances: procedures>>=
	subroutine process_instance_reset_counter (process_instance)
	class(process_instance_t), intent(inout) :: process_instance
	call process_instance%mci_work(process_instance%i_mci)%reset_counter ()
	end subroutine process_instance_reset_counter

	subroutine process_instance_record_call (process_instance)
	class(process_instance_t), intent(inout) :: process_instance
	call process_instance%mci_work(process_instance%i_mci)%record_call &
	(process_instance%evaluation_status)
	end subroutine process_instance_record_call

	pure function process_instance_get_counter (process_instance) result (counter)
	class(process_instance_t), intent(in) :: process_instance
	type(process_counter_t) :: counter
	counter = process_instance%mci_work(process_instance%i_mci)%get_counter ()
	end function process_instance_get_counter

	@ %def process_instance_reset_counter
	@ %def process_instance_record_call
	@ %def process_instance_get_counter
	@ Sum up the total number of calls for all MCI records.
	<<Instances: process instance: TBP>>=
	procedure :: get_actual_calls_total => process_instance_get_actual_calls_total
	<<Instances: procedures>>=
	pure function process_instance_get_actual_calls_total (process_instance) &
	result (n)
	class(process_instance_t), intent(in) :: process_instance
	integer :: n
	integer :: i
	type(process_counter_t) :: counter
	n = 0
	do i = 1, size (process_instance%mci_work)
	counter = process_instance%mci_work(i)%get_counter ()
	n = n + counter%total
	end do
	end function process_instance_get_actual_calls_total

	@ %def process_instance_get_actual_calls_total
	@
	<<Instances: process instance: TBP>>=
	procedure :: reset_matrix_elements => process_instance_reset_matrix_elements
	<<Instances: procedures>>=
	subroutine process_instance_reset_matrix_elements (instance)
	class(process_instance_t), intent(inout) :: instance
	integer :: i_term
	do i_term = 1, size (instance%term)
	call instance%term(i_term)%connected%trace%set_matrix_element (cmplx (0, 0, default))
	call instance%term(i_term)%connected%matrix%set_matrix_element (cmplx (0, 0, default))
	end do
	end subroutine process_instance_reset_matrix_elements

	@ %def process_instance_reset_matrix_elements
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_test_phase_space_point &
	=> process_instance_get_test_phase_space_point
	<<Instances: procedures>>=
	subroutine process_instance_get_test_phase_space_point (instance, &
	i_component, i_core, p)
	type(vector4_t), dimension(:), allocatable, intent(out) :: p
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_component, i_core
	real(default), dimension(:), allocatable :: x
	logical :: success
	integer :: i_term
	instance%i_mci = i_component
	i_term = instance%process%get_i_term (i_core)
	associate (term => instance%term(i_term), kin => instance%kin(i_term))
	allocate (x (instance%mci_work(i_component)%config%n_par))
	x = 0.5_default
	call instance%set_mcpar (x, .true.)
	call instance%select_channel (1)
	call term%compute_seed_kinematics &
	(kin, instance%mci_work(i_component), 1, success)
	call kin%evaluate_radiation_kinematics &
	(instance%mci_work(instance%i_mci)%get_x_process ())
	call term%compute_hard_kinematics (kin, success = success)
	allocate (p (size (term%p_hard)))
	p = term%int_hard%get_momenta ()
	end associate
	end subroutine process_instance_get_test_phase_space_point

	@ %def process_instance_get_test_phase_space_point
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_p_hard => process_instance_get_p_hard
	<<Instances: procedures>>=
	pure function process_instance_get_p_hard (process_instance, i_term) &
	result (p_hard)
	type(vector4_t), dimension(:), allocatable :: p_hard
	class(process_instance_t), intent(in) :: process_instance
	integer, intent(in) :: i_term
	allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ())))
	p_hard = process_instance%term(i_term)%get_p_hard ()
	end function process_instance_get_p_hard

	@ %def process_instance_get_p_hard
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_first_active_i_term => process_instance_get_first_active_i_term
	<<Instances: procedures>>=
	function process_instance_get_first_active_i_term (instance) result (i_term)
	integer :: i_term
	class(process_instance_t), intent(in) :: instance
	integer :: i
	i_term = 0
	do i = 1, size (instance%term)
	if (instance%term(i)%active) then
	i_term = i
	exit
	end if
	end do
	end function process_instance_get_first_active_i_term

	@ %def process_instance_get_first_active_i_term
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_real_of_mci => process_instance_get_real_of_mci
	<<Instances: procedures>>=
	function process_instance_get_real_of_mci (instance) result (i_real)
	integer :: i_real
	class(process_instance_t), intent(in) :: instance
	select type (pcm_work => instance%pcm_work)
	type is (pcm_nlo_workspace_t)
	i_real = pcm_work%i_mci_to_real_component (instance%i_mci)
	end select
	end function process_instance_get_real_of_mci

	@ %def process_instance_get_real_of_mci
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_connected_states => process_instance_get_connected_states
	<<Instances: procedures>>=
	function process_instance_get_connected_states (instance, i_component) result (connected)
	type(connected_state_t), dimension(:), allocatable :: connected
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_component
	connected = instance%process%get_connected_states (i_component, &
	instance%term(:)%connected)
	end function process_instance_get_connected_states

	@ %def process_instance_get_connected_states
	@ Get the hadronic center-of-mass energy
	<<Instances: process instance: TBP>>=
	procedure :: get_sqrts => process_instance_get_sqrts
	<<Instances: procedures>>=
	function process_instance_get_sqrts (instance) result (sqrts)
	class(process_instance_t), intent(in) :: instance
	real(default) :: sqrts
	sqrts = instance%process%get_sqrts ()
	end function process_instance_get_sqrts

	@ %def process_instance_get_sqrts
	@ Get the polarizations
	<<Instances: process instance: TBP>>=
	procedure :: get_polarization => process_instance_get_polarization
	<<Instances: procedures>>=
	function process_instance_get_polarization (instance) result (pol)
	class(process_instance_t), intent(in) :: instance
	real(default), dimension(:), allocatable :: pol
	pol = instance%process%get_polarization ()
	end function process_instance_get_polarization

	@ %def process_instance_get_polarization
	@ Get the beam spectrum
	<<Instances: process instance: TBP>>=
	procedure :: get_beam_file => process_instance_get_beam_file
	<<Instances: procedures>>=
	function process_instance_get_beam_file (instance) result (file)
	class(process_instance_t), intent(in) :: instance
	type(string_t) :: file
	file = instance%process%get_beam_file ()
	end function process_instance_get_beam_file

	@ %def process_instance_get_beam_file
	@ Get the process name
	<<Instances: process instance: TBP>>=
	procedure :: get_process_name => process_instance_get_process_name
	<<Instances: procedures>>=
	function process_instance_get_process_name (instance) result (name)
	class(process_instance_t), intent(in) :: instance
	type(string_t) :: name
	name = instance%process%get_id ()
	end function process_instance_get_process_name

	@ %def process_instance_get_process_name
	@
	\subsubsection{Particle sets}
	Here we provide two procedures that convert the process instance
	from/to a particle set. The conversion applies to the trace evaluator
	which has no quantum-number information, thus it involves only the
	momenta and the parent-child relations. We keep virtual particles.

	If [[n_incoming]] is provided, the status code of the first
	[[n_incoming]] particles will be reset to incoming. Otherwise, they
	would be classified as virtual.

	Nevertheless, it is possible to reconstruct the complete structure
	from a particle set. The reconstruction implies a re-evaluation of
	the structure function and matrix-element codes.

	The [[i_term]] index is needed for both input and output, to select
	among different active trace evaluators.

	In both cases, the [[instance]] object must be properly initialized.

	NB: The [[recover_beams]] option should be used only when the particle
	set originates from an external event file, and the user has asked for
	it. It should be switched off when reading from raw event file.
	<<Instances: process instance: TBP>>=
	procedure :: get_trace => process_instance_get_trace
	procedure :: set_trace => process_instance_set_trace
	<<Instances: procedures>>=
	subroutine process_instance_get_trace (instance, pset, i_term, n_incoming)
	class(process_instance_t), intent(in), target :: instance
	type(particle_set_t), intent(out) :: pset
	integer, intent(in) :: i_term
	integer, intent(in), optional :: n_incoming
	type(interaction_t), pointer :: int
	logical :: ok
	int => instance%get_trace_int_ptr (i_term)
	call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
	[0._default, 0._default], .false., .true., n_incoming)
	end subroutine process_instance_get_trace

	subroutine process_instance_set_trace &
	(instance, pset, i_term, recover_beams, check_match, success)
	class(process_instance_t), intent(inout), target :: instance
	type(particle_set_t), intent(in) :: pset
	integer, intent(in) :: i_term
	logical, intent(in), optional :: recover_beams, check_match
	logical, intent(out), optional :: success
	type(interaction_t), pointer :: int
	integer :: n_in
	int => instance%get_trace_int_ptr (i_term)
	n_in = instance%process%get_n_in ()
	call pset%fill_interaction (int, n_in, &
	recover_beams = recover_beams, &
	check_match = check_match, &
	state_flv = instance%get_state_flv (i_term), &
	success = success)
	end subroutine process_instance_set_trace

	@ %def process_instance_get_trace
	@ %def process_instance_set_trace
	@ This procedure allows us to override any QCD setting of the WHIZARD process
	and directly set the coupling value that comes together with a particle set.
	<<Instances: process instance: TBP>>=
	procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced
	<<Instances: procedures>>=
	subroutine process_instance_set_alpha_qcd_forced (instance, i_term, alpha_qcd)
	class(process_instance_t), intent(inout) :: instance
	integer, intent(in) :: i_term
	real(default), intent(in) :: alpha_qcd
	call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd)
	end subroutine process_instance_set_alpha_qcd_forced

	@ %def process_instance_set_alpha_qcd_forced
	@
	<<Instances: process instance: TBP>>=
	procedure :: has_nlo_component => process_instance_has_nlo_component
	<<Instances: procedures>>=
	function process_instance_has_nlo_component (instance) result (nlo)
	class(process_instance_t), intent(in) :: instance
	logical :: nlo
	nlo = instance%process%is_nlo_calculation ()
	end function process_instance_has_nlo_component

	@ %def process_instance_has_nlo_component
	@
	<<Instances: process instance: TBP>>=
	procedure :: keep_failed_events => process_instance_keep_failed_events
	<<Instances: procedures>>=
	function process_instance_keep_failed_events (instance) result (keep)
	logical :: keep
	class(process_instance_t), intent(in) :: instance
	keep = instance%mci_work(instance%i_mci)%keep_failed_events
	end function process_instance_keep_failed_events

	@ %def process_instance_keep_failed_events
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_term_indices => process_instance_get_term_indices
	<<Instances: procedures>>=
	function process_instance_get_term_indices (instance, nlo_type) result (i_term)
	integer, dimension(:), allocatable :: i_term
	class(process_instance_t), intent(in) :: instance
	integer :: nlo_type
	allocate (i_term (count (instance%term%nlo_type == nlo_type)))
	i_term = pack (instance%term%get_i_term_global (), instance%term%nlo_type == nlo_type)
	end function process_instance_get_term_indices

	@ %def process_instance_get_term_indices
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_boost_to_lab => process_instance_get_boost_to_lab
	<<Instances: procedures>>=
	function process_instance_get_boost_to_lab (instance, i_term) result (lt)
	type(lorentz_transformation_t) :: lt
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	lt = instance%kin(i_term)%get_boost_to_lab ()
	end function process_instance_get_boost_to_lab

	@ %def process_instance_get_boost_to_lab
	@
	<<Instances: process instance: TBP>>=
	procedure :: get_boost_to_cms => process_instance_get_boost_to_cms
	<<Instances: procedures>>=
	function process_instance_get_boost_to_cms (instance, i_term) result (lt)
	type(lorentz_transformation_t) :: lt
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	lt = instance%kin(i_term)%get_boost_to_cms ()
	end function process_instance_get_boost_to_cms

	@ %def process_instance_get_boost_to_cms
	@
	<<Instances: process instance: TBP>>=
	procedure :: lab_is_cm => process_instance_lab_is_cm
	<<Instances: procedures>>=
	function process_instance_lab_is_cm (instance, i_term) result (lab_is_cm)
	logical :: lab_is_cm
	class(process_instance_t), intent(in) :: instance
	integer, intent(in) :: i_term
	lab_is_cm = instance%kin(i_term)%phs%lab_is_cm ()
	end function process_instance_lab_is_cm

	@ %def process_instance_lab_is_cm
	@
	The [[pacify]] subroutine has the purpose of setting numbers to zero
	which are (by comparing with a [[tolerance]] parameter) considered
	equivalent with zero. We do this in some unit tests. Here, we a
	apply this to the phase space subobject of the process instance.
	<<Instances: public>>=
	public :: pacify
	<<Instances: interfaces>>=
	interface pacify
	module procedure pacify_process_instance
	end interface pacify

	<<Instances: procedures>>=
	subroutine pacify_process_instance (instance)
	type(process_instance_t), intent(inout) :: instance
	integer :: i
	do i = 1, size (instance%kin)
	call pacify (instance%kin(i)%phs)
	end do
	end subroutine pacify_process_instance

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

	module processes_ut
	use unit_tests
	use processes_uti

	<<Standard module head>>

	<<Processes: public test>>

	<<Processes: public test auxiliary>>

	contains

	<<Processes: test driver>>

	end module processes_ut
	@ %def processes_ut
	@
	<<[[processes_uti.f90]]>>=
	<<File header>>

	module processes_uti

	<<Use kinds>>
	<<Use strings>>
	use format_utils, only: write_separator
	use constants, only: TWOPI4
	use physics_defs, only: CONV
	use os_interface
	use sm_qcd
	use lorentz
	use pdg_arrays
	use model_data
	use models
	use var_base, only: vars_t
	use variables, only: var_list_t
	use model_testbed, only: prepare_model
	use particle_specifiers, only: new_prt_spec
	use flavors
	use interactions, only: reset_interaction_counter
	use particles
	use rng_base
	use mci_base
	use mci_none, only: mci_none_t
	use mci_midpoint
	use sf_mappings
	use sf_base
	use phs_base
	use phs_single
	use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
	use phs_wood, only: phs_wood_config_t
	use resonances, only: resonance_history_set_t
	use process_constants
	use prc_core_def, only: prc_core_def_t
	use prc_core
	use prc_test, only: prc_test_create_library
	use prc_template_me, only: template_me_def_t
	use process_libraries
	use prc_test_core

	use process_counter
	use process_config, only: process_term_t
	use process, only: process_t
	use instances, only: process_instance_t, process_instance_hook_t

	use rng_base_ut, only: rng_test_factory_t
	use sf_base_ut, only: sf_test_data_t
	use mci_base_ut, only: mci_test_t
	use phs_base_ut, only: phs_test_config_t

	<<Standard module head>>

	<<Processes: public test auxiliary>>

	<<Processes: test declarations>>

	<<Processes: test types>>

	contains

	<<Processes: tests>>

	<<Processes: test auxiliary>>

	end module processes_uti

	@ %def processes_uti
	@ API: driver for the unit tests below.
	<<Processes: public test>>=
	public :: processes_test
	<<Processes: test driver>>=
	subroutine processes_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Processes: execute tests>>
	end subroutine processes_test

	@ %def processes_test
	\subsubsection{Write an empty process object}
	The most trivial test is to write an uninitialized process object.
	<<Processes: execute tests>>=
	call test (processes_1, "processes_1", &
	"write an empty process object", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_1
	<<Processes: tests>>=
	subroutine processes_1 (u)
	integer, intent(in) :: u
	type(process_t) :: process

	write (u, "(A)") "* Test output: processes_1"
	write (u, "(A)") "* Purpose: display an empty process object"
	write (u, "(A)")

	call process%write (.false., u)

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

	end subroutine processes_1

	@ %def processes_1
	@
	\subsubsection{Initialize a process object}
	Initialize a process and display it.
	<<Processes: execute tests>>=
	call test (processes_2, "processes_2", &
	"initialize a simple process object", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_2
	<<Processes: tests>>=
	subroutine processes_2 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable :: process
	class(mci_t), allocatable :: mci_template
	class(phs_config_t), allocatable :: phs_config_template

	write (u, "(A)") "* Test output: processes_2"
	write (u, "(A)") "* Purpose: initialize a simple process object"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	libname = "processes2"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	write (u, "(A)") "* Initialize a process object"
	write (u, "(A)")

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)
	call process%set_run_id (var_str ("run_2"))
	call process%setup_test_cores ()

	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	call process%setup_mci (dispatch_mci_empty)

	call process%write (.false., u)

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

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_2

	@ %def processes_2
	@ Trivial for testing: do not allocate the MCI record.
	<<Processes: test auxiliary>>=
	subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	end subroutine dispatch_mci_empty

	@ %def dispatch_mci_empty
	@
	\subsubsection{Compute a trivial matrix element}
	Initialize a process, retrieve some information and compute a matrix
	element.

	We use the same trivial process as for the previous test. All
	momentum and state dependence is trivial, so we just test basic
	functionality.
	<<Processes: execute tests>>=
	call test (processes_3, "processes_3", &
	"retrieve a trivial matrix element", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_3
	<<Processes: tests>>=
	subroutine processes_3 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable :: process
	class(phs_config_t), allocatable :: phs_config_template
	type(process_constants_t) :: data
	type(vector4_t), dimension(:), allocatable :: p

	write (u, "(A)") "* Test output: processes_3"
	write (u, "(A)") "* Purpose: create a process &
	&and compute a matrix element"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	libname = "processes3"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)
	call process%setup_test_cores ()

	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)
	call process%setup_mci (dispatch_mci_test3)

	write (u, "(A)") "* Return the number of process components"
	write (u, "(A)")

	write (u, "(A,I0)") "n_components = ", process%get_n_components ()

	write (u, "(A)")
	write (u, "(A)") "* Return the number of flavor states"
	write (u, "(A)")

	data = process%get_constants (1)

	write (u, "(A,I0)") "n_flv(1) = ", data%n_flv

	write (u, "(A)")
	write (u, "(A)") "* Return the first flavor state"
	write (u, "(A)")

	write (u, "(A,4(1x,I0))") "flv_state(1) =", data%flv_state (:,1)

	write (u, "(A)")
	write (u, "(A)") "* Set up kinematics &
	&[arbitrary, the matrix element is constant]"

	allocate (p (4))

	write (u, "(A)")
	write (u, "(A)") "* Retrieve the matrix element"
	write (u, "(A)")


	write (u, "(A,F5.3,' + ',F5.3,' I')") "me (1, p, 1, 1, 1) = ", &
	process%compute_amplitude (1, 1, 1, p, 1, 1, 1)


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

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_3

	@ %def processes_3
	@ MCI record with some contents.
	<<Processes: test auxiliary>>=
	subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	allocate (mci_test_t :: mci)
	select type (mci)
	type is (mci_test_t)
	call mci%set_dimensions (2, 2)
	call mci%set_divisions (100)
	end select
	end subroutine dispatch_mci_test3

	@ %def dispatch_mci_test3
	@
	\subsubsection{Generate a process instance}
	Initialize a process and process instance, choose a sampling point and
	fill the process instance.

	We use the same trivial process as for the previous test. All
	momentum and state dependence is trivial, so we just test basic
	functionality.
	<<Processes: execute tests>>=
	call test (processes_4, "processes_4", &
	"create and fill a process instance (partonic event)", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_4
	<<Processes: tests>>=
	subroutine processes_4 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance
	type(particle_set_t) :: pset

	write (u, "(A)") "* Test output: processes_4"
	write (u, "(A)") "* Purpose: create a process &
	&and fill a process instance"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a test process"
	write (u, "(A)")

	libname = "processes4"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call reset_interaction_counter ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_empty)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inject a set of random numbers"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%set_mcpar ([0._default, 0._default])
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Set up hard kinematics"
	write (u, "(A)")

	call process_instance%select_channel (1)
	call process_instance%compute_seed_kinematics ()
	call process_instance%compute_hard_kinematics ()
	call process_instance%compute_eff_kinematics ()
	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels ()

	write (u, "(A)") "* Evaluate matrix element and square"
	write (u, "(A)")

	call process_instance%evaluate_trace ()
	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)

	call process_instance%activate ()
	process_instance%evaluation_status = STAT_EFF_KINEMATICS
	call process_instance%recover_hard_kinematics (i_term = 1)
	call process_instance%recover_seed_kinematics (i_term = 1)
	call process_instance%select_channel (1)
	call process_instance%recover_mcpar (i_term = 1)

	call process_instance%compute_seed_kinematics (skip_term = 1)
	call process_instance%compute_hard_kinematics (skip_term = 1)
	call process_instance%compute_eff_kinematics (skip_term = 1)

	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels (skip_term = 1)
	call process_instance%evaluate_trace ()
	call process_instance%write (u)

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

	call pset%final ()
	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_4

	@ %def processes_4
	@
	\subsubsection{Structure function configuration}
	Configure structure functions (multi-channel) in a process object.
	<<Processes: execute tests>>=
	call test (processes_7, "processes_7", &
	"process configuration with structure functions", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_7
	<<Processes: tests>>=
	subroutine processes_7 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_channel_t), dimension(2) :: sf_channel

	write (u, "(A)") "* Test output: processes_7"
	write (u, "(A)") "* Purpose: initialize a process with &
	&structure functions"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes7"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Set beam, structure functions, and mappings"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()

	pdg_in = 25
	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (process%get_model_ptr (), pdg_in)
	end select

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data)
	call sf_config(2)%init ([2], data)
	call process%init_sf_chain (sf_config)
	deallocate (sf_config)

	call process%test_allocate_sf_channels (3)

	call sf_channel(1)%init (2)
	call sf_channel(1)%activate_mapping ([1,2])
	call process%set_sf_channel (2, sf_channel(1))

	call sf_channel(2)%init (2)
	call sf_channel(2)%set_s_mapping ([1,2])
	call process%set_sf_channel (3, sf_channel(2))

	call process%setup_mci (dispatch_mci_empty)

	call process%write (.false., u)

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

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_7

	@ %def processes_7
	@
	\subsubsection{Evaluating a process with structure function}
	Configure structure functions (single-channel) in a process object,
	create an instance, compute kinematics and evaluate.

	Note the order of operations when setting up structure functions and
	phase space. The beams are first, they determine the [[sqrts]] value.
	We can also set up the chain of structure functions. We then
	configure the phase space. From this, we can obtain information about
	special configurations (resonances, etc.), which we need for
	allocating the possible structure-function channels (parameterizations
	and mappings). Finally, we match phase-space channels onto
	structure-function channels.

	In the current example, this matching is trivial; we only have one
	structure-function channel.
	<<Processes: execute tests>>=
	call test (processes_8, "processes_8", &
	"process evaluation with structure functions", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_8
	<<Processes: tests>>=
	subroutine processes_8 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_channel_t) :: sf_channel
	type(particle_set_t) :: pset

	write (u, "(A)") "* Test output: processes_8"
	write (u, "(A)") "* Purpose: evaluate a process with &
	&structure functions"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes8"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call reset_interaction_counter ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Set beam, structure functions, and mappings"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)

	pdg_in = 25
	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (process%get_model_ptr (), pdg_in)
	end select

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data)
	call sf_config(2)%init ([2], data)
	call process%init_sf_chain (sf_config)
	deallocate (sf_config)

	call process%configure_phs ()

	call process%test_allocate_sf_channels (1)

	call sf_channel%init (2)
	call sf_channel%activate_mapping ([1,2])
	call process%set_sf_channel (1, sf_channel)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_mci (dispatch_mci_empty)
	call process%setup_terms ()

	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)") "* Set up kinematics and evaluate"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%evaluate_sqme (1, &
	[0.8_default, 0.8_default, 0.1_default, 0.2_default])
	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover process instance"
	write (u, "(A)")

	call reset_interaction_counter (2)

	allocate (process_instance)
	call process_instance%init (process)

	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)
	call process_instance%recover &
	(channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
	call process_instance%write (u)

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

	call pset%final ()

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_8

	@ %def processes_8
	@
	\subsubsection{Multi-channel phase space and structure function}
	This is an extension of the previous example. This time, we have two
	distinct structure-function channels which are matched to the two
	distinct phase-space channels.
	<<Processes: execute tests>>=
	call test (processes_9, "processes_9", &
	"multichannel kinematics and structure functions", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_9
	<<Processes: tests>>=
	subroutine processes_9 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_channel_t) :: sf_channel
	real(default), dimension(4) :: x_saved
	type(particle_set_t) :: pset

	write (u, "(A)") "* Test output: processes_9"
	write (u, "(A)") "* Purpose: evaluate a process with &
	&structure functions"
	write (u, "(A)") "* in a multi-channel configuration"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes9"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call reset_interaction_counter ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Set beam, structure functions, and mappings"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)

	pdg_in = 25
	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (process%get_model_ptr (), pdg_in)
	end select

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data)
	call sf_config(2)%init ([2], data)
	call process%init_sf_chain (sf_config)
	deallocate (sf_config)

	call process%configure_phs ()

	call process%test_allocate_sf_channels (2)

	call sf_channel%init (2)
	call process%set_sf_channel (1, sf_channel)

	call sf_channel%init (2)
	call sf_channel%activate_mapping ([1,2])
	call process%set_sf_channel (2, sf_channel)

	call process%test_set_component_sf_channel ([1, 2])

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_mci (dispatch_mci_empty)
	call process%setup_terms ()

	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)") "* Set up kinematics in channel 1 and evaluate"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%evaluate_sqme (1, &
	[0.8_default, 0.8_default, 0.1_default, 0.2_default])
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extract MC input parameters"
	write (u, "(A)")

	write (u, "(A)") "Channel 1:"
	call process_instance%get_mcpar (1, x_saved)
	write (u, "(2x,9(1x,F7.5))") x_saved

	write (u, "(A)") "Channel 2:"
	call process_instance%get_mcpar (2, x_saved)
	write (u, "(2x,9(1x,F7.5))") x_saved

	write (u, "(A)")
	write (u, "(A)") "* Set up kinematics in channel 2 and evaluate"
	write (u, "(A)")

	call process_instance%evaluate_sqme (2, x_saved)
	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Recover process instance for channel 2"
	write (u, "(A)")

	call reset_interaction_counter (2)

	allocate (process_instance)
	call process_instance%init (process)

	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)
	call process_instance%recover &
	(channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.)
	call process_instance%write (u)

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

	call pset%final ()

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_9

	@ %def processes_9
	@
	\subsubsection{Event generation}
	Activate the MC integrator for the process object and use it to
	generate a single event. Note that the test integrator does not
	require integration in preparation for generating events.
	<<Processes: execute tests>>=
	call test (processes_10, "processes_10", &
	"event generation", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_10
	<<Processes: tests>>=
	subroutine processes_10 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(mci_t), pointer :: mci
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance

	write (u, "(A)") "* Test output: processes_10"
	write (u, "(A)") "* Purpose: generate events for a process without &
	&structure functions"
	write (u, "(A)") "* in a multi-channel configuration"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes10"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call reset_interaction_counter ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()

	call process%setup_mci (dispatch_mci_test10)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)") "* Generate weighted event"
	write (u, "(A)")

	call process%test_get_mci_ptr (mci)
	select type (mci)
	type is (mci_test_t)
	! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
	call mci%rng%init (3)
	! Include the constant PHS factor in the stored maximum of the integrand
	call mci%set_max_factor (conv * twopi4 &
	/ (2 * sqrt (lambda (sqrts 2, 125._default2, 125._default**2))))
	end select

	call process_instance%generate_weighted_event (1)
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate unweighted event"
	write (u, "(A)")

	call process_instance%generate_unweighted_event (1)
	call process%test_get_mci_ptr (mci)
	select type (mci)
	type is (mci_test_t)
	write (u, "(A,I0)") " Success in try ", mci%tries
	write (u, "(A)")
	end select

	call process_instance%write (u)

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

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_10

	@ %def processes_10
	@ MCI record with some contents.
	<<Processes: test auxiliary>>=
	subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	allocate (mci_test_t :: mci)
	select type (mci)
	type is (mci_test_t); call mci%set_divisions (100)
	end select
	end subroutine dispatch_mci_test10

	@ %def dispatch_mci_test10
	@
	\subsubsection{Integration}
	Activate the MC integrator for the process object and use it to
	integrate over phase space.
	<<Processes: execute tests>>=
	call test (processes_11, "processes_11", &
	"integration", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_11
	<<Processes: tests>>=
	subroutine processes_11 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(mci_t), allocatable :: mci_template
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance

	write (u, "(A)") "* Test output: processes_11"
	write (u, "(A)") "* Purpose: integrate a process without &
	&structure functions"
	write (u, "(A)") "* in a multi-channel configuration"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes11"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call reset_interaction_counter ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()

	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()

	call process%setup_mci (dispatch_mci_test10)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)") "* Integrate with default test parameters"
	write (u, "(A)")

	call process_instance%integrate (1, n_it=1, n_calls=10000)
	call process%final_integration (1)

	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A,ES13.7)") " Integral divided by phs factor = ", &
	process%get_integral (1) &
	/ process_instance%kin(1)%phs_factor

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

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_11

	@ %def processes_11
	@
	\subsubsection{Complete events}
	For the purpose of simplifying further tests, we implement a
	convenience routine that initializes a process and prepares a single
	event. This is a wrapup of the test [[processes_10]].

	The procedure is re-exported by the [[processes_ut]] module.
	<<Processes: public test auxiliary>>=
	public :: prepare_test_process
	<<Processes: test auxiliary>>=
	subroutine prepare_test_process &
	(process, process_instance, model, var_list, run_id)
	type(process_t), intent(out), target :: process
	type(process_instance_t), intent(out), target :: process_instance
	class(model_data_t), intent(in), target :: model
	type(var_list_t), intent(inout), optional :: var_list
	type(string_t), intent(in), optional :: run_id
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), allocatable, target :: process_model
	class(mci_t), pointer :: mci
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	libname = "processes_test"
	procname = libname
	call os_data%init ()
	call prc_test_create_library (libname, lib)
	call reset_interaction_counter ()
	allocate (process_model)
	call process_model%init (model%get_name (), &
	model%get_n_real (), &
	model%get_n_complex (), &
	model%get_n_field (), &
	model%get_n_vtx ())
	call process_model%copy_from (model)
	call process%init (procname, lib, os_data, process_model, var_list)
	if (present (run_id)) call process%set_run_id (run_id)
	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)
	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_test10)
	call process%setup_terms ()
	call process_instance%init (process)
	call process%test_get_mci_ptr (mci)
	select type (mci)
	type is (mci_test_t)
	! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
	call mci%rng%init (3)
	! Include the constant PHS factor in the stored maximum of the integrand
	call mci%set_max_factor (conv * twopi4 &
	/ (2 * sqrt (lambda (sqrts 2, 125._default2, 125._default**2))))
	end select
	call process%reset_library_ptr () ! avoid dangling pointer
	call process_model%final ()
	end subroutine prepare_test_process

	@ %def prepare_test_process
	@ Here we do the cleanup of the process and process instance emitted
	by the previous routine.
	<<Processes: public test auxiliary>>=
	public :: cleanup_test_process
	<<Processes: test auxiliary>>=
	subroutine cleanup_test_process (process, process_instance)
	type(process_t), intent(inout) :: process
	type(process_instance_t), intent(inout) :: process_instance
	call process_instance%final ()
	call process%final ()
	end subroutine cleanup_test_process

	@ %def cleanup_test_process
	@
	This is the actual test. Prepare the test process and event, fill
	all evaluators, and display the results. Use a particle set as
	temporary storage, read kinematics and recalculate the event.
	<<Processes: execute tests>>=
	call test (processes_12, "processes_12", &
	"event post-processing", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_12
	<<Processes: tests>>=
	subroutine processes_12 (u)
	integer, intent(in) :: u
	type(process_t), allocatable, target :: process
	type(process_instance_t), allocatable, target :: process_instance
	type(particle_set_t) :: pset
	type(model_data_t), target :: model

	write (u, "(A)") "* Test output: processes_12"
	write (u, "(A)") "* Purpose: generate a complete partonic event"
	write (u, "(A)")

	call model%init_test ()

	write (u, "(A)") "* Build and initialize process and process instance &
	&and generate event"
	write (u, "(A)")

	allocate (process)
	allocate (process_instance)
	call prepare_test_process (process, process_instance, model, &
	run_id = var_str ("run_12"))
	call process_instance%setup_event_data (i_core = 1)

	call process%prepare_simulation (1)
	call process_instance%init_simulation (1)
	call process_instance%generate_weighted_event (1)
	call process_instance%evaluate_event_data ()

	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)

	call process_instance%final_simulation (1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Recover kinematics and recalculate"
	write (u, "(A)")

	call reset_interaction_counter (2)

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%setup_event_data ()

	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)
	call process_instance%recover &
	(channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)

	call process_instance%recover_event ()
	call process_instance%evaluate_event_data ()

	call process_instance%write (u)


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

	call cleanup_test_process (process, process_instance)
	deallocate (process_instance)
	deallocate (process)

	call model%final ()

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

	end subroutine processes_12

	@ %def processes_12
	@
	\subsubsection{Colored interaction}
	This test specifically checks the transformation of process data
	(flavor, helicity, and color) into an interaction in a process term.

	We use the [[test_t]] process core (which has no nontrivial
	particles), but call only the [[is_allowed]] method, which always
	returns true.
	<<Processes: execute tests>>=
	call test (processes_13, "processes_13", &
	"colored interaction", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_13
	<<Processes: tests>>=
	subroutine processes_13 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(process_term_t) :: term
	class(prc_core_t), allocatable :: core

	write (u, "(A)") "* Test output: processes_13"
	write (u, "(A)") "* Purpose: initialized a colored interaction"
	write (u, "(A)")

	write (u, "(A)") "* Set up a process constants block"
	write (u, "(A)")

	call os_data%init ()
	call model%init_sm_test ()

	allocate (test_t :: core)

	associate (data => term%data)
	data%n_in = 2
	data%n_out = 3
	data%n_flv = 2
	data%n_hel = 2
	data%n_col = 2
	data%n_cin = 2

	allocate (data%flv_state (5, 2))
	data%flv_state (:,1) = [ 1, 21, 1, 21, 21]
	data%flv_state (:,2) = [ 2, 21, 2, 21, 21]

	allocate (data%hel_state (5, 2))
	data%hel_state (:,1) = [1, 1, 1, 1, 0]
	data%hel_state (:,2) = [1,-1, 1,-1, 0]

	allocate (data%col_state (2, 5, 2))
	data%col_state (:,:,1) = &
	reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5])
	data%col_state (:,:,2) = &
	reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5])

	allocate (data%ghost_flag (5, 2))
	data%ghost_flag(1:4,:) = .false.
	data%ghost_flag(5,:) = .true.

	end associate

	write (u, "(A)") "* Set up the interaction"
	write (u, "(A)")

	call reset_interaction_counter ()
	call term%setup_interaction (core, model)
	call term%int%basic_write (u)

	call model%final ()

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

	@ %def processes_13
	@
	\subsubsection{MD5 sums}
	Configure a process with structure functions (multi-channel) and
	compute MD5 sums
	<<Processes: execute tests>>=
	call test (processes_14, "processes_14", &
	"process configuration and MD5 sum", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_14
	<<Processes: tests>>=
	subroutine processes_14 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_channel_t), dimension(3) :: sf_channel

	write (u, "(A)") "* Test output: processes_14"
	write (u, "(A)") "* Purpose: initialize a process with &
	&structure functions"
	write (u, "(A)") "* and compute MD5 sum"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes7"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)
	call lib%compute_md5sum ()

	call model%init_test ()

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Set beam, structure functions, and mappings"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()

	pdg_in = 25
	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (process%get_model_ptr (), pdg_in)
	end select

	call process%test_allocate_sf_channels (3)

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data)
	call sf_config(2)%init ([2], data)
	call process%init_sf_chain (sf_config)
	deallocate (sf_config)

	call sf_channel(1)%init (2)
	call process%set_sf_channel (1, sf_channel(1))

	call sf_channel(2)%init (2)
	call sf_channel(2)%activate_mapping ([1,2])
	call process%set_sf_channel (2, sf_channel(2))

	call sf_channel(3)%init (2)
	call sf_channel(3)%set_s_mapping ([1,2])
	call process%set_sf_channel (3, sf_channel(3))

	call process%setup_mci (dispatch_mci_empty)

	call process%compute_md5sum ()

	call process%write (.false., u)

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

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_14

	@ %def processes_14
	@
	\subsubsection{Decay Process Evaluation}
	Initialize an evaluate a decay process.
	<<Processes: execute tests>>=
	call test (processes_15, "processes_15", &
	"decay process", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_15
	<<Processes: tests>>=
	subroutine processes_15 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	type(process_instance_t), allocatable, target :: process_instance
	type(particle_set_t) :: pset

	write (u, "(A)") "* Test output: processes_15"
	write (u, "(A)") "* Purpose: initialize a decay process object"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	libname = "processes15"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib, scattering = .false., &
	decay = .true.)

	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")))

	write (u, "(A)") "* Initialize a process object"
	write (u, "(A)")

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_single_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	call process%setup_beams_decay (i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_empty)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	call reset_interaction_counter (3)

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Inject a set of random numbers"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%set_mcpar ([0._default, 0._default])
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Set up hard kinematics"
	write (u, "(A)")

	call process_instance%select_channel (1)
	call process_instance%compute_seed_kinematics ()
	call process_instance%compute_hard_kinematics ()

	write (u, "(A)") "* Evaluate matrix element and square"
	write (u, "(A)")

	call process_instance%compute_eff_kinematics ()
	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels ()
	call process_instance%evaluate_trace ()
	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover process instance"
	write (u, "(A)")

	call reset_interaction_counter (3)

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)
	call process_instance%recover (1, 1, .true., .true.)
	call process_instance%write (u)

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

	call pset%final ()
	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_15

	@ %def processes_15
	@
	\subsubsection{Integration: decay}
	Activate the MC integrator for the decay object and use it to
	integrate over phase space.
	<<Processes: execute tests>>=
	call test (processes_16, "processes_16", &
	"decay integration", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_16
	<<Processes: tests>>=
	subroutine processes_16 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	type(process_instance_t), allocatable, target :: process_instance

	write (u, "(A)") "* Test output: processes_16"
	write (u, "(A)") "* Purpose: integrate a process without &
	&structure functions"
	write (u, "(A)") "* in a multi-channel configuration"
	write (u, "(A)")

	write (u, "(A)") "* Build and initialize a process object"
	write (u, "(A)")

	libname = "processes16"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib, scattering = .false., &
	decay = .true.)

	call reset_interaction_counter ()

	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")))

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_single_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	call process%setup_beams_decay (i_core = 1)
	call process%configure_phs ()

	call process%setup_mci (dispatch_mci_test_midpoint)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)") "* Integrate with default test parameters"
	write (u, "(A)")

	call process_instance%integrate (1, n_it=1, n_calls=10000)
	call process%final_integration (1)

	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A,ES13.7)") " Integral divided by phs factor = ", &
	process%get_integral (1) &
	/ process_instance%kin(1)%phs_factor

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

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_16

	@ %def processes_16
	@ MCI record prepared for midpoint integrator.
	<<Processes: test auxiliary>>=
	subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	allocate (mci_midpoint_t :: mci)
	end subroutine dispatch_mci_test_midpoint

	@ %def dispatch_mci_test_midpoint
	@
	\subsubsection{Decay Process Evaluation}
	Initialize an evaluate a decay process for a moving particle.
	<<Processes: execute tests>>=
	call test (processes_17, "processes_17", &
	"decay of moving particle", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_17
	<<Processes: tests>>=
	subroutine processes_17 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	type(process_instance_t), allocatable, target :: process_instance
	type(particle_set_t) :: pset
	type(flavor_t) :: flv_beam
	real(default) :: m, p, E

	write (u, "(A)") "* Test output: processes_17"
	write (u, "(A)") "* Purpose: initialize a decay process object"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	libname = "processes17"
	procname = libname

	call os_data%init ()

	call prc_test_create_library (libname, lib, scattering = .false., &
	decay = .true.)

	write (u, "(A)") "* Initialize a process object"
	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")))

	allocate (process)
	call process%init (procname, lib, os_data, model)

	call process%setup_test_cores ()
	allocate (phs_single_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	call process%setup_beams_decay (rest_frame = .false., i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_empty)

	write (u, "(A)") "* Complete process initialization"
	write (u, "(A)")

	call process%setup_terms ()
	call process%write (.false., u)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	call reset_interaction_counter (3)

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Set parent momentum and random numbers"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%set_mcpar ([0._default, 0._default])

	call flv_beam%init (25, process%get_model_ptr ())
	m = flv_beam%get_mass ()
	p = 3 * m / 4
	E = sqrt (m2 + p2)
	call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)])

	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Set up hard kinematics"
	write (u, "(A)")

	call process_instance%select_channel (1)
	call process_instance%compute_seed_kinematics ()
	call process_instance%compute_hard_kinematics ()

	write (u, "(A)") "* Evaluate matrix element and square"
	write (u, "(A)")

	call process_instance%compute_eff_kinematics ()
	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels ()
	call process_instance%evaluate_trace ()
	call process_instance%write (u)

	call process_instance%get_trace (pset, 1)
	call process_instance%final ()
	deallocate (process_instance)

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover process instance"
	write (u, "(A)")

	call reset_interaction_counter (3)

	allocate (process_instance)
	call process_instance%init (process)

	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1, check_match = .false.)
	call process_instance%recover (1, 1, .true., .true.)
	call process_instance%write (u)

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

	call pset%final ()
	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call model%final ()

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

	end subroutine processes_17

	@ %def processes_17
	@
	\subsubsection{Resonances in Phase Space}
	This test demonstrates the extraction of the resonance-history set from the
	generated phase space. We need a nontrivial process, but no matrix element.
	This is provided by the [[prc_template]] method, using the [[SM]] model. We
	also need the [[phs_wood]] method, otherwise we would not have resonances in
	the phase space configuration.
	<<Processes: execute tests>>=
	call test (processes_18, "processes_18", &
	"extract resonance history set", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_18
	<<Processes: tests>>=
	subroutine processes_18 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(string_t) :: model_name
	type(os_data_t) :: os_data
	class(model_data_t), pointer :: model
	class(vars_t), pointer :: vars
	type(process_t), pointer :: process
	type(resonance_history_set_t) :: res_set
	integer :: i

	write (u, "(A)") "* Test output: processes_18"
	write (u, "(A)") "* Purpose: extra resonance histories"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	libname = "processes_18_lib"
	procname = "processes_18_p"

	call os_data%init ()

	call syntax_phs_forest_init ()

	model_name = "SM"
	model => null ()
	call prepare_model (model, model_name, vars)

	write (u, "(A)") "* Initialize a process library with one process"
	write (u, "(A)")

	select type (model)
	class is (model_t)
	call prepare_resonance_test_library (lib, libname, procname, model, os_data, u)
	end select

	write (u, "(A)")
	write (u, "(A)") "* Initialize a process object with phase space"

	allocate (process)
	select type (model)
	class is (model_t)
	call prepare_resonance_test_process (process, lib, procname, model, os_data)
	end select

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

	call process%extract_resonance_history_set (res_set)
	call res_set%write (u)

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

	call process%final ()
	deallocate (process)

	call model%final ()
	deallocate (model)

	call syntax_phs_forest_final ()

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

	end subroutine processes_18

	@ %def processes_18
	@ Auxiliary subroutine that constructs the process library for the above test.
	<<Processes: test auxiliary>>=
	subroutine prepare_resonance_test_library &
	(lib, libname, procname, model, os_data, u)
	type(process_library_t), target, intent(out) :: lib
	type(string_t), intent(in) :: libname
	type(string_t), intent(in) :: procname
	type(model_t), intent(in), target :: model
	type(os_data_t), intent(in) :: os_data
	integer, intent(in) :: u
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	class(prc_core_def_t), allocatable :: def
	type(process_def_entry_t), pointer :: entry

	call lib%init (libname)

	allocate (prt_in (2), prt_out (3))
	prt_in = [var_str ("e+"), var_str ("e-")]
	prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]

	allocate (template_me_def_t :: def)
	select type (def)
	type is (template_me_def_t)
	call def%init (model, prt_in, prt_out, unity = .false.)
	end select
	allocate (entry)
	call entry%init (procname, &
	model_name = model%get_name (), &
	n_in = 2, n_components = 1)
	call entry%import_component (1, n_out = size (prt_out), &
	prt_in = new_prt_spec (prt_in), &
	prt_out = new_prt_spec (prt_out), &
	method = var_str ("template"), &
	variant = def)
	call entry%write (u)

	call lib%append (entry)

	call lib%configure (os_data)
	call lib%write_makefile (os_data, force = .true., verbose = .false.)
	call lib%clean (os_data, distclean = .false.)
	call lib%write_driver (force = .true.)
	call lib%load (os_data)

	end subroutine prepare_resonance_test_library

	@ %def prepare_resonance_test_library
	@ We want a test process which has been initialized up to the point where we
	can evaluate the matrix element. This is in fact rather complicated. We copy
	the steps from [[integration_setup_process]] in the [[integrate]] module,
	which is not available at this point.
	<<Processes: test auxiliary>>=
	subroutine prepare_resonance_test_process &
	(process, lib, procname, model, os_data)
	class(process_t), intent(out), target :: process
	type(process_library_t), intent(in), target :: lib
	type(string_t), intent(in) :: procname
	type(model_t), intent(in), target :: model
	type(os_data_t), intent(in) :: os_data
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts

	call process%init (procname, lib, os_data, model)

	allocate (phs_wood_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	call process%setup_test_cores (type_string = var_str ("template"))

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_none)

	call process%setup_terms ()

	end subroutine prepare_resonance_test_process

	@ %def prepare_resonance_test_process
	@ MCI record prepared for the none (dummy) integrator.
	<<Processes: test auxiliary>>=
	subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	allocate (mci_none_t :: mci)
	end subroutine dispatch_mci_none

	@ %def dispatch_mci_none
	@
	\subsubsection{Add after evaluate hook(s)}
	Initialize a process and process instance, add a trivial process hook,
	choose a sampling point and fill the process instance.

	We use the same trivial process as for the previous test. All
	momentum and state dependence is trivial, so we just test basic
	functionality.
	<<Processes: test types>>=
	type, extends(process_instance_hook_t) :: process_instance_hook_test_t
	integer :: unit
	character(len=15) :: name
	contains
	procedure :: init => process_instance_hook_test_init
	procedure :: final => process_instance_hook_test_final
	procedure :: evaluate => process_instance_hook_test_evaluate
	end type process_instance_hook_test_t

	@
	<<Processes: test auxiliary>>=
	subroutine process_instance_hook_test_init (hook, var_list, instance)
	class(process_instance_hook_test_t), intent(inout), target :: hook
	type(var_list_t), intent(in) :: var_list
	class(process_instance_t), intent(in), target :: instance
	end subroutine process_instance_hook_test_init

	subroutine process_instance_hook_test_final (hook)
	class(process_instance_hook_test_t), intent(inout) :: hook
	end subroutine process_instance_hook_test_final

	subroutine process_instance_hook_test_evaluate (hook, instance)
	class(process_instance_hook_test_t), intent(inout) :: hook
	class(process_instance_t), intent(in), target :: instance
	write (hook%unit, "(A)") "Execute hook:"
	write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")"
	end subroutine process_instance_hook_test_evaluate

	@
	<<Processes: execute tests>>=
	call test (processes_19, "processes_19", &
	"add trivial hooks to a process instance ", &
	u, results)
	<<Processes: test declarations>>=
	public :: processes_19
	<<Processes: tests>>=
	subroutine processes_19 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	class(model_data_t), pointer :: model
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t) :: process_instance
	class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2
	type(particle_set_t) :: pset

	write (u, "(A)") "* Test output: processes_19"
	write (u, "(A)") "* Purpose: allocate process instance &
	&and add an after evaluate hook"
	write (u, "(A)")

	write (u, "(A)")
	write (u, "(A)") "* Allocate a process instance"
	write (u, "(A)")

	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Allocate hook and add to process instance"
	write (u, "(A)")

	allocate (process_instance_hook_test_t :: process_instance_hook)
	call process_instance%append_after_hook (process_instance_hook)

	allocate (process_instance_hook_test_t :: process_instance_hook2)
	call process_instance%append_after_hook (process_instance_hook2)

	select type (process_instance_hook)
	type is (process_instance_hook_test_t)
	process_instance_hook%unit = u
	process_instance_hook%name = "Hook 1"
	end select
	select type (process_instance_hook2)
	type is (process_instance_hook_test_t)
	process_instance_hook2%unit = u
	process_instance_hook2%name = "Hook 2"
	end select

	write (u, "(A)") "* Evaluate matrix element and square"
	write (u, "(A)")

	call process_instance%evaluate_after_hook ()

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

	call process_instance_hook%final ()
	deallocate (process_instance_hook)

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

	end subroutine processes_19

	@ %def processes_19
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process Stacks}

	For storing and handling multiple processes, we define process stacks.
	These are ordinary stacks where new process entries are pushed onto
	the top. We allow for multiple entries with identical process ID, but
	distinct run ID.

	The implementation is essentially identical to the [[prclib_stacks]] module
	above. Unfortunately, Fortran supports no generic programming, so we do not
	make use of this fact.

	When searching for a specific process ID, we will get (a pointer to)
	the topmost process entry with that ID on the stack, which was entered
	last. Usually, this is the best version of the process (in terms of
	integral, etc.) Thus the stack terminology makes sense.
	<<[[process_stacks.f90]]>>=
	<<File header>>

	module process_stacks

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_utils, only: write_separator
	use diagnostics
	use os_interface
	use sm_qcd
	use model_data
	use rng_base
	use variables
	use observables
	use process_libraries
	use process

	<<Standard module head>>

	<<Process stacks: public>>

	<<Process stacks: types>>

	contains

	<<Process stacks: procedures>>

	end module process_stacks
	@ %def process_stacks
	@
	\subsection{The process entry type}
	A process entry is a process object, augmented by a pointer to the
	next entry. We do not need specific methods, all relevant methods are
	inherited.

	On higher level, processes should be prepared as process entry objects.
	<<Process stacks: public>>=
	public :: process_entry_t
	<<Process stacks: types>>=
	type, extends (process_t) :: process_entry_t
	type(process_entry_t), pointer :: next => null ()
	end type process_entry_t

	@ %def process_entry_t
	@
	\subsection{The process stack type}
	For easy conversion and lookup it is useful to store the filling
	number in the object. The content is stored as a linked list.

	The [[var_list]] component stores process-specific results, so they
	can be retrieved as (pseudo) variables.

	The process stack can be linked to another one. This allows us to
	work with stacks of local scope.
	<<Process stacks: public>>=
	public :: process_stack_t
	<<Process stacks: types>>=
	type :: process_stack_t
	integer :: n = 0
	type(process_entry_t), pointer :: first => null ()
	type(var_list_t), pointer :: var_list => null ()
	type(process_stack_t), pointer :: next => null ()
	contains
	<<Process stacks: process stack: TBP>>
	end type process_stack_t

	@ %def process_stack_t
	@ Finalize partly: deallocate the process stack and variable list
	entries, but keep the variable list as an empty object. This way, the
	variable list links are kept.
	<<Process stacks: process stack: TBP>>=
	procedure :: clear => process_stack_clear
	<<Process stacks: procedures>>=
	subroutine process_stack_clear (stack)
	class(process_stack_t), intent(inout) :: stack
	type(process_entry_t), pointer :: process
	if (associated (stack%var_list)) then
	call stack%var_list%final ()
	end if
	do while (associated (stack%first))
	process => stack%first
	stack%first => process%next
	call process%final ()
	deallocate (process)
	end do
	stack%n = 0
	end subroutine process_stack_clear

	@ %def process_stack_clear
	@ Finalizer. Clear and deallocate the variable list.
	<<Process stacks: process stack: TBP>>=
	procedure :: final => process_stack_final
	<<Process stacks: procedures>>=
	subroutine process_stack_final (object)
	class(process_stack_t), intent(inout) :: object
	call object%clear ()
	if (associated (object%var_list)) then
	deallocate (object%var_list)
	end if
	end subroutine process_stack_final

	@ %def process_stack_final
	@ Output. The processes on the stack will be ordered LIFO, i.e.,
	backwards.
	<<Process stacks: process stack: TBP>>=
	procedure :: write => process_stack_write
	<<Process stacks: procedures>>=
	recursive subroutine process_stack_write (object, unit, pacify)
	class(process_stack_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: pacify
	type(process_entry_t), pointer :: process
	integer :: u
	u = given_output_unit (unit)
	call write_separator (u, 2)
	select case (object%n)
	case (0)
	write (u, "(1x,A)") "Process stack: [empty]"
	call write_separator (u, 2)
	case default
	write (u, "(1x,A)") "Process stack:"
	process => object%first
	do while (associated (process))
	call process%write (.false., u, pacify = pacify)
	process => process%next
	end do
	end select
	if (associated (object%next)) then
	write (u, "(1x,A)") "[Processes from context environment:]"
	call object%next%write (u, pacify)
	end if
	end subroutine process_stack_write

	@ %def process_stack_write
	@ The variable list is printed by a separate routine, since
	it should be linked to the global variable list, anyway.
	<<Process stacks: process stack: TBP>>=
	procedure :: write_var_list => process_stack_write_var_list
	<<Process stacks: procedures>>=
	subroutine process_stack_write_var_list (object, unit)
	class(process_stack_t), intent(in) :: object
	integer, intent(in), optional :: unit
	if (associated (object%var_list)) then
	call var_list_write (object%var_list, unit)
	end if
	end subroutine process_stack_write_var_list

	@ %def process_stack_write_var_list
	@ Short output.

	Since this is a stack, the default output ordering for each stack will be
	last-in, first-out. To enable first-in, first-out, which is more likely to be
	requested, there is an optional [[fifo]] argument.
	<<Process stacks: process stack: TBP>>=
	procedure :: show => process_stack_show
	<<Process stacks: procedures>>=
	recursive subroutine process_stack_show (object, unit, fifo)
	class(process_stack_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: fifo
	type(process_entry_t), pointer :: process
	logical :: reverse
	integer :: u, i, j
	u = given_output_unit (unit)
	reverse = .false.; if (present (fifo)) reverse = fifo
	select case (object%n)
	case (0)
	case default
	if (.not. reverse) then
	process => object%first
	do while (associated (process))
	call process%show (u, verbose=.false.)
	process => process%next
	end do
	else
	do i = 1, object%n
	process => object%first
	do j = 1, object%n - i
	process => process%next
	end do
	call process%show (u, verbose=.false.)
	end do
	end if
	end select
	if (associated (object%next)) call object%next%show ()
	end subroutine process_stack_show

	@ %def process_stack_show
	@
	\subsection{Link}
	Link the current process stack to a global one.
	<<Process stacks: process stack: TBP>>=
	procedure :: link => process_stack_link
	<<Process stacks: procedures>>=
	subroutine process_stack_link (local_stack, global_stack)
	class(process_stack_t), intent(inout) :: local_stack
	type(process_stack_t), intent(in), target :: global_stack
	local_stack%next => global_stack
	end subroutine process_stack_link

	@ %def process_stack_link
	@ Initialize the process variable list and link the main variable list
	to it.
	<<Process stacks: process stack: TBP>>=
	procedure :: init_var_list => process_stack_init_var_list
	<<Process stacks: procedures>>=
	subroutine process_stack_init_var_list (stack, var_list)
	class(process_stack_t), intent(inout) :: stack
	type(var_list_t), intent(inout), optional :: var_list
	allocate (stack%var_list)
	if (present (var_list)) call var_list%link (stack%var_list)
	end subroutine process_stack_init_var_list

	@ %def process_stack_init_var_list
	@ Link the process variable list to a global
	variable list.
	<<Process stacks: process stack: TBP>>=
	procedure :: link_var_list => process_stack_link_var_list
	<<Process stacks: procedures>>=
	subroutine process_stack_link_var_list (stack, var_list)
	class(process_stack_t), intent(inout) :: stack
	type(var_list_t), intent(in), target :: var_list
	call stack%var_list%link (var_list)
	end subroutine process_stack_link_var_list

	@ %def process_stack_link_var_list
	@
	\subsection{Push}
	We take a process pointer and push it onto the stack. The previous
	pointer is nullified. Subsequently, the process is `owned' by the
	stack and will be finalized when the stack is deleted.
	<<Process stacks: process stack: TBP>>=
	procedure :: push => process_stack_push
	<<Process stacks: procedures>>=
	subroutine process_stack_push (stack, process)
	class(process_stack_t), intent(inout) :: stack
	type(process_entry_t), intent(inout), pointer :: process
	process%next => stack%first
	stack%first => process
	process => null ()
	stack%n = stack%n + 1
	end subroutine process_stack_push

	@ %def process_stack_push
	@ Inverse: Remove the last process pointer in the list and return it.
	<<Process stacks: process stack: TBP>>=
	procedure :: pop_last => process_stack_pop_last
	<<Process stacks: procedures>>=
	subroutine process_stack_pop_last (stack, process)
	class(process_stack_t), intent(inout) :: stack
	type(process_entry_t), intent(inout), pointer :: process
	type(process_entry_t), pointer :: previous
	integer :: i
	select case (stack%n)
	case (:0)
	process => null ()
	case (1)
	process => stack%first
	stack%first => null ()
	stack%n = 0
	case (2:)
	process => stack%first
	do i = 2, stack%n
	previous => process
	process => process%next
	end do
	previous%next => null ()
	stack%n = stack%n - 1
	end select
	end subroutine process_stack_pop_last

	@ %def process_stack_pop_last
	@ Initialize process variables for a given process ID, without setting
	values.
	<<Process stacks: process stack: TBP>>=
	procedure :: init_result_vars => process_stack_init_result_vars
	<<Process stacks: procedures>>=
	subroutine process_stack_init_result_vars (stack, id)
	class(process_stack_t), intent(inout) :: stack
	type(string_t), intent(in) :: id
	call var_list_init_num_id (stack%var_list, id)
	call var_list_init_process_results (stack%var_list, id)
	end subroutine process_stack_init_result_vars

	@ %def process_stack_init_result_vars
	@ Fill process variables with values. This is executed after the
	integration pass.

	Note: We set only integral and error. With multiple MCI records
	possible, the results for [[n_calls]], [[chi2]] etc. are not
	necessarily unique. (We might set the efficiency, though.)
	<<Process stacks: process stack: TBP>>=
	procedure :: fill_result_vars => process_stack_fill_result_vars
	<<Process stacks: procedures>>=
	subroutine process_stack_fill_result_vars (stack, id)
	class(process_stack_t), intent(inout) :: stack
	type(string_t), intent(in) :: id
	type(process_t), pointer :: process
	process => stack%get_process_ptr (id)
	if (associated (process)) then
	call var_list_init_num_id (stack%var_list, id, process%get_num_id ())
	if (process%has_integral ()) then
	call var_list_init_process_results (stack%var_list, id, &
	integral = process%get_integral (), &
	error = process%get_error ())
	end if
	else
	call msg_bug ("process_stack_fill_result_vars: unknown process ID")
	end if
	end subroutine process_stack_fill_result_vars

	@ %def process_stack_fill_result_vars
	@ If one of the result variables has a local image in [[var_list_local]],
	update the value there as well.
	<<Process stacks: process stack: TBP>>=
	procedure :: update_result_vars => process_stack_update_result_vars
	<<Process stacks: procedures>>=
	subroutine process_stack_update_result_vars (stack, id, var_list_local)
	class(process_stack_t), intent(inout) :: stack
	type(string_t), intent(in) :: id
	type(var_list_t), intent(inout) :: var_list_local
	call update ("integral(" // id // ")")
	call update ("error(" // id // ")")
	contains
	subroutine update (var_name)
	type(string_t), intent(in) :: var_name
	real(default) :: value
	if (var_list_local%contains (var_name, follow_link = .false.)) then
	value = stack%var_list%get_rval (var_name)
	call var_list_local%set_real (var_name, value, is_known = .true.)
	end if
	end subroutine update
	end subroutine process_stack_update_result_vars

	@ %def process_stack_update_result_vars
	@
	\subsection{Data Access}
	Tell if a process exists.
	<<Process stacks: process stack: TBP>>=
	procedure :: exists => process_stack_exists
	<<Process stacks: procedures>>=
	function process_stack_exists (stack, id) result (flag)
	class(process_stack_t), intent(in) :: stack
	type(string_t), intent(in) :: id
	logical :: flag
	type(process_t), pointer :: process
	process => stack%get_process_ptr (id)
	flag = associated (process)
	end function process_stack_exists

	@ %def process_stack_exists
	@ Return a pointer to a process with specific ID. Look also at a
	linked stack, if necessary.
	<<Process stacks: process stack: TBP>>=
	procedure :: get_process_ptr => process_stack_get_process_ptr
	<<Process stacks: procedures>>=
	recursive function process_stack_get_process_ptr (stack, id) result (ptr)
	class(process_stack_t), intent(in) :: stack
	type(string_t), intent(in) :: id
	type(process_t), pointer :: ptr
	type(process_entry_t), pointer :: entry
	ptr => null ()
	entry => stack%first
	do while (associated (entry))
	if (entry%get_id () == id) then
	ptr => entry%process_t
	return
	end if
	entry => entry%next
	end do
	if (associated (stack%next)) ptr => stack%next%get_process_ptr (id)
	end function process_stack_get_process_ptr

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

	module process_stacks_ut
	use unit_tests
	use process_stacks_uti

	<<Standard module head>>

	<<Process stacks: public test>>

	contains

	<<Process stacks: test driver>>

	end module process_stacks_ut
	@ %def process_stacks_ut
	@
	<<[[process_stacks_uti.f90]]>>=
	<<File header>>

	module process_stacks_uti

	<<Use strings>>
	use os_interface
	use sm_qcd
	use models
	use model_data
	use variables, only: var_list_t
	use process_libraries
	use rng_base
	use prc_test, only: prc_test_create_library
	use process, only: process_t
	use instances, only: process_instance_t
	use processes_ut, only: prepare_test_process

	use process_stacks

	use rng_base_ut, only: rng_test_factory_t

	<<Standard module head>>

	<<Process stacks: test declarations>>

	contains

	<<Process stacks: tests>>

	end module process_stacks_uti

	@ %def process_stacks_uti
	@ API: driver for the unit tests below.
	<<Process stacks: public test>>=
	public :: process_stacks_test
	<<Process stacks: test driver>>=
	subroutine process_stacks_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Process stacks: execute tests>>
	end subroutine process_stacks_test

	@ %def process_stacks_test
	@
	\subsubsection{Write an empty process stack}
	The most trivial test is to write an uninitialized process stack.
	<<Process stacks: execute tests>>=
	call test (process_stacks_1, "process_stacks_1", &
	"write an empty process stack", &
	u, results)
	<<Process stacks: test declarations>>=
	public :: process_stacks_1
	<<Process stacks: tests>>=
	subroutine process_stacks_1 (u)
	integer, intent(in) :: u
	type(process_stack_t) :: stack

	write (u, "(A)") "* Test output: process_stacks_1"
	write (u, "(A)") "* Purpose: display an empty process stack"
	write (u, "(A)")

	call stack%write (u)

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

	end subroutine process_stacks_1

	@ %def process_stacks_1
	@
	\subsubsection{Fill a process stack}
	Fill a process stack with two (identical) processes.
	<<Process stacks: execute tests>>=
	call test (process_stacks_2, "process_stacks_2", &
	"fill a process stack", &
	u, results)
	<<Process stacks: test declarations>>=
	public :: process_stacks_2
	<<Process stacks: tests>>=
	subroutine process_stacks_2 (u)
	integer, intent(in) :: u
	type(process_stack_t) :: stack
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(var_list_t) :: var_list
	type(process_entry_t), pointer :: process => null ()

	write (u, "(A)") "* Test output: process_stacks_2"
	write (u, "(A)") "* Purpose: fill a process stack"
	write (u, "(A)")

	write (u, "(A)") "* Build, initialize and store two test processes"
	write (u, "(A)")

	libname = "process_stacks2"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call model%init_test ()
	call var_list%append_string (var_str ("$run_id"))
	call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
	call var_list%append_int (var_str ("seed"), 0)

	allocate (process)

	call var_list%set_string &
	(var_str ("$run_id"), var_str ("run1"), is_known=.true.)
	call process%init (procname, lib, os_data, model, var_list)
	call stack%push (process)

	allocate (process)

	call var_list%set_string &
	(var_str ("$run_id"), var_str ("run2"), is_known=.true.)
	call process%init (procname, lib, os_data, model, var_list)
	call stack%push (process)

	call stack%write (u)

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

	call stack%final ()
	call model%final ()

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

	end subroutine process_stacks_2

	@ %def process_stacks_2
	@
	\subsubsection{Fill a process stack}
	Fill a process stack with two (identical) processes.
	<<Process stacks: execute tests>>=
	call test (process_stacks_3, "process_stacks_3", &
	"process variables", &
	u, results)
	<<Process stacks: test declarations>>=
	public :: process_stacks_3
	<<Process stacks: tests>>=
	subroutine process_stacks_3 (u)
	integer, intent(in) :: u
	type(process_stack_t) :: stack
	type(model_t), target :: model
	type(string_t) :: procname
	type(process_entry_t), pointer :: process => null ()
	type(process_instance_t), target :: process_instance

	write (u, "(A)") "* Test output: process_stacks_3"
	write (u, "(A)") "* Purpose: setup process variables"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process variables"
	write (u, "(A)")

	procname = "processes_test"
	call model%init_test ()

	write (u, "(A)") "* Initialize process variables"
	write (u, "(A)")

	call stack%init_var_list ()
	call stack%init_result_vars (procname)
	call stack%write_var_list (u)

	write (u, "(A)")
	write (u, "(A)") "* Build and integrate a test process"
	write (u, "(A)")

	allocate (process)
	call prepare_test_process (process%process_t, process_instance, model)
	call process_instance%integrate (1, 1, 1000)
	call process_instance%final ()
	call process%final_integration (1)
	call stack%push (process)

	write (u, "(A)") "* Fill process variables"
	write (u, "(A)")

	call stack%fill_result_vars (procname)
	call stack%write_var_list (u)

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

	call stack%final ()
	call model%final ()

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

	end subroutine process_stacks_3

	@ %def process_stacks_3
	@
	\subsubsection{Linked a process stack}
	Fill two process stack, linked to each other.
	<<Process stacks: execute tests>>=
	call test (process_stacks_4, "process_stacks_4", &
	"linked stacks", &
	u, results)
	<<Process stacks: test declarations>>=
	public :: process_stacks_4
	<<Process stacks: tests>>=
	subroutine process_stacks_4 (u)
	integer, intent(in) :: u
	type(process_library_t), target :: lib
	type(process_stack_t), target :: stack1, stack2
	type(model_t), target :: model
	type(string_t) :: libname
	type(string_t) :: procname1, procname2
	type(os_data_t) :: os_data
	type(process_entry_t), pointer :: process => null ()

	write (u, "(A)") "* Test output: process_stacks_4"
	write (u, "(A)") "* Purpose: link process stacks"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process variables"
	write (u, "(A)")

	libname = "process_stacks_4_lib"
	procname1 = "process_stacks_4a"
	procname2 = "process_stacks_4b"

	call os_data%init ()

	write (u, "(A)") "* Initialize first process"
	write (u, "(A)")

	call prc_test_create_library (procname1, lib)

	call model%init_test ()

	allocate (process)
	call process%init (procname1, lib, os_data, model)
	call stack1%push (process)

	write (u, "(A)") "* Initialize second process"
	write (u, "(A)")

	call stack2%link (stack1)

	call prc_test_create_library (procname2, lib)

	allocate (process)

	call process%init (procname2, lib, os_data, model)
	call stack2%push (process)

	write (u, "(A)") "* Show linked stacks"
	write (u, "(A)")

	call stack2%write (u)

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

	call stack2%final ()
	call stack1%final ()
	call model%final ()

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

	end subroutine process_stacks_4

	@ %def process_stacks_4
	@
	Index: trunk/src/particles/particles.nw
	===================================================================
	--- trunk/src/particles/particles.nw (revision 8777)
	+++ trunk/src/particles/particles.nw (revision 8778)
	@@ -1,8525 +1,8525 @@
	%% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: particle objects
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Particles}
	\includemodulegraph{particles}

	This chapter collects modules that implement particle objects, for use in
	event records.

	While within interactions, all correlations are
	manifest, a particle array is derived by selecting a particular
	quantum number set. This involves tracing over all other particles,
	as far as polarization is concerned. Thus, a particle has definite
	flavor, color, and a single-particle density matrix for polarization.
	\begin{description}
	\item[su\_algebra]
	We make use of $su(N)$ generators as the basis for representing
	polarization matrices. This module defines the basis and provides
	the necessary transformation routines.
	\item[bloch\_vectors]
	This defines polarization objects in Bloch representation. The
	object describes the spin density matrix of a particle,
	currently restricted to spin $0\ldots 2$.
	\item[polarizations]
	This extends the basic polarization object such that it supports
	properties of physical particles and appropriate constructors.
	\item[particles]
	Particle objects and particle lists, as the base of event records.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{$su(N)$ Algebra}
	We need a specific choice of basis for a well-defined component
	representation. The matrix elements of $T^a$ are
	ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
	lowest weight, for both row and column.

	We list first the generators of the $su(2)$ subalgebras which leave
	$\|m\|$ invariant ($\|m\|\neq 0$):
	\begin{equation}
	T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
	\end{equation}
	acting on the respective subspace $\|m\|=\ell,\ell-1,\ldots$ for
	$b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$
	($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.

	The following generators successively extend this to $su(4)$, $su(6)$,
	\ldots until $su(N)$ by adding first the missing off-diagonal and then
	diagonal generators. The phase conventions are analogous.

	(It should be possible to code these conventions for generic spin, but
	in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
	$N\leq 5$.)
	<<[[su_algebra.f90]]>>=
	<<File header>>

	module su_algebra

	<<Use kinds>>
	use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR

	<<Standard module head>>

	<<su algebra: public>>

	contains

	<<su algebra: procedures>>

	end module su_algebra
	@ %def su_algebra
	@
	\subsection{$su(N)$ fundamental representation}
	The dimension of the basis for a given spin type. consecutively, starting at
	[[SCALAR=1]].
	<<su algebra: public>>=
	public :: algebra_dimension
	<<su algebra: procedures>>=
	function algebra_dimension (s) result (n)
	integer :: n
	integer, intent(in) :: s
	n = fundamental_dimension (s) ** 2 - 1
	end function algebra_dimension

	@ %def algebra_dimension
	@ The dimension of the fundamental (defining) representation that we
	use. This implementation assumes that the spin type is numerically
	equal to the fundamental dimension.
	<<su algebra: public>>=
	public :: fundamental_dimension
	<<su algebra: procedures>>=
	function fundamental_dimension (s) result (d)
	integer :: d
	integer, intent(in) :: s
	d = s
	end function fundamental_dimension

	@ %def fundamental_dimension
	@
	\subsection{Mapping between helicity and matrix index}
	Return the helicity that corresponds to a particular entry in the
	polarization matrix representation. Helicities are counted downwards,
	in integers, and zero helicity is included (omitted) for odd (even)
	spin, respectively.
	<<su algebra: public>>=
	public :: helicity_value
	<<su algebra: procedures>>=
	function helicity_value (s, i) result (h)
	integer :: h
	integer, intent(in) :: s, i
	integer, dimension(1), parameter :: hh1 = [0]
	integer, dimension(2), parameter :: hh2 = [1, -1]
	integer, dimension(3), parameter :: hh3 = [1, 0, -1]
	integer, dimension(4), parameter :: hh4 = [2, 1, -1, -2]
	integer, dimension(5), parameter :: hh5 = [2, 1, 0, -1, -2]
	h = 0
	select case (s)
	case (SCALAR)
	select case (i)
	case (1:1); h = hh1(i)
	end select
	case (SPINOR)
	select case (i)
	case (1:2); h = hh2(i)
	end select
	case (VECTOR)
	select case (i)
	case (1:3); h = hh3(i)
	end select
	case (VECTORSPINOR)
	select case (i)
	case (1:4); h = hh4(i)
	end select
	case (TENSOR)
	select case (i)
	case (1:5); h = hh5(i)
	end select
	end select
	end function helicity_value

	@ %def helicity_value
	@ Inverse: return the index that corresponds to a certain
	helicity value in the chosen representation.
	<<su algebra: public>>=
	public :: helicity_index
	<<su algebra: procedures>>=
	function helicity_index (s, h) result (i)
	integer, intent(in) :: s, h
	integer :: i
	integer, dimension(0:0), parameter :: hi1 = [1]
	integer, dimension(-1:1), parameter :: hi2 = [2, 0, 1]
	integer, dimension(-1:1), parameter :: hi3 = [3, 2, 1]
	integer, dimension(-2:2), parameter :: hi4 = [4, 3, 0, 2, 1]
	integer, dimension(-2:2), parameter :: hi5 = [5, 4, 3, 2, 1]
	select case (s)
	case (SCALAR)
	i = hi1(h)
	case (SPINOR)
	i = hi2(h)
	case (VECTOR)
	i = hi3(h)
	case (VECTORSPINOR)
	i = hi4(h)
	case (TENSOR)
	i = hi5(h)
	end select
	end function helicity_index

	@ %def helicity_index
	@
	\subsection{Generator Basis: Cartan Generators}
	For each supported spin type, we return specific properties of the
	set of generators via inquiry functions. This is equivalent to using
	explicit representations of the generators.

	For easy access, the properties are hard-coded and selected via case
	expressions.

	Return true if the generator \#[[i]] is in the Cartan subalgebra,
	i.e., a diagonal matrix for spin type [[s]].
	<<su algebra: public>>=
	public :: is_cartan_generator
	<<su algebra: procedures>>=
	elemental function is_cartan_generator (s, i) result (cartan)
	logical :: cartan
	integer, intent(in) :: s, i
	select case (s)
	case (SCALAR)
	case (SPINOR)
	select case (i)
	case (3); cartan = .true.
	case default
	cartan = .false.
	end select
	case (VECTOR)
	select case (i)
	case (3,8); cartan = .true.
	case default
	cartan = .false.
	end select
	case (VECTORSPINOR)
	select case (i)
	case (3,6,15); cartan = .true.
	case default
	cartan = .false.
	end select
	case (TENSOR)
	select case (i)
	case (3,6,15,24); cartan = .true.
	case default
	cartan = .false.
	end select
	case default
	cartan = .false.
	end select
	end function is_cartan_generator

	@ %def is_cartan_generator
	@ Return the index of Cartan generator \#[[k]] in the chosen
	representation. This has to conform to [[cartan]] above.
	<<su algebra: public>>=
	public :: cartan_index
	<<su algebra: procedures>>=
	elemental function cartan_index (s, k) result (ci)
	integer :: ci
	integer, intent(in) :: s, k
	integer, dimension(1), parameter :: ci2 = [3]
	integer, dimension(2), parameter :: ci3 = [3,8]
	integer, dimension(3), parameter :: ci4 = [3,6,15]
	integer, dimension(4), parameter :: ci5 = [3,6,15,24]
	select case (s)
	case (SPINOR)
	ci = ci2(k)
	case (VECTOR)
	ci = ci3(k)
	case (VECTORSPINOR)
	ci = ci4(k)
	case (TENSOR)
	ci = ci5(k)
	case default
	ci = 0
	end select
	end function cartan_index

	@ %def cartan_index
	@ The element \#[[k]] of the result vector [[a]] is equal to the
	$(h,h)$ diagonal entry of the generator matrix $T^k$. That is,
	evaluating this for all allowed values of [[h]], we recover the set of
	Cartan generator matrices.
	<<su algebra: public>>=
	public :: cartan_element
	<<su algebra: procedures>>=
	function cartan_element (s, h) result (a)
	real(default), dimension(:), allocatable :: a
	integer, intent(in) :: s, h
	real(default), parameter :: sqrt2 = sqrt (2._default)
	real(default), parameter :: sqrt3 = sqrt (3._default)
	real(default), parameter :: sqrt10 = sqrt (10._default)
	allocate (a (algebra_dimension (s)), source = 0._default)
	select case (s)
	case (SCALAR)
	case (SPINOR)
	select case (h)
	case (1)
	a(3) = 1._default / 2
	case (-1)
	a(3) = -1._default / 2
	end select
	case (VECTOR)
	select case (h)
	case (1)
	a(3) = 1._default / 2
	a(8) = 1._default / (2 * sqrt3)
	case (-1)
	a(3) = -1._default / 2
	a(8) = 1._default / (2 * sqrt3)
	case (0)
	a(8) = -1._default / sqrt3
	end select
	case (VECTORSPINOR)
	select case (h)
	case (2)
	a(3) = 1._default / 2
	a(15) = 1._default / (2 * sqrt2)
	case (-2)
	a(3) = -1._default / 2
	a(15) = 1._default / (2 * sqrt2)
	case (1)
	a(6) = 1._default / 2
	a(15) = -1._default / (2 * sqrt2)
	case (-1)
	a(6) = -1._default / 2
	a(15) = -1._default / (2 * sqrt2)
	end select
	case (TENSOR)
	select case (h)
	case (2)
	a(3) = 1._default / 2
	a(15) = 1._default / (2 * sqrt2)
	a(24) = 1._default / (2 * sqrt10)
	case (-2)
	a(3) = -1._default / 2
	a(15) = 1._default / (2 * sqrt2)
	a(24) = 1._default / (2 * sqrt10)
	case (1)
	a(6) = 1._default / 2
	a(15) = -1._default / (2 * sqrt2)
	a(24) = 1._default / (2 * sqrt10)
	case (-1)
	a(6) = -1._default / 2
	a(15) = -1._default / (2 * sqrt2)
	a(24) = 1._default / (2 * sqrt10)
	case (0)
	a(24) = -4._default / (2 * sqrt10)
	end select
	end select
	end function cartan_element

	@ %def cartan_element
	@ Given an array of diagonal matrix elements [[rd]] of a generator,
	compute the array [[a]] of basis coefficients. The array must be
	ordered as defined by [[helicity_value]], i.e., highest weight first.
	The calculation is organized such that the trace of the generator,
	i.e., the sum of [[rd]] values, drops out. The result array [[a]] has
	coefficients for all basis generators, but only Cartan generators can
	get a nonzero coefficient.
	<<su algebra: public>>=
	public :: cartan_coeff
	<<su algebra: procedures>>=
	function cartan_coeff (s, rd) result (a)
	real(default), dimension(:), allocatable :: a
	integer, intent(in) :: s
	real(default), dimension(:), intent(in) :: rd
	real(default), parameter :: sqrt2 = sqrt (2._default)
	real(default), parameter :: sqrt3 = sqrt (3._default)
	real(default), parameter :: sqrt10 = sqrt (10._default)
	integer :: n
	n = algebra_dimension (s)
	allocate (a (n), source = 0._default)
	select case (s)
	case (SPINOR)
	a(3) = rd(1) - rd(2)
	case (VECTOR)
	a(3) = rd(1) - rd(3)
	a(8) = (rd(1) - 2 * rd(2) + rd(3)) / sqrt3
	case (VECTORSPINOR)
	a(3) = rd(1) - rd(4)
	a(6) = rd(2) - rd(3)
	a(15) = (rd(1) - rd(2) - rd(3) + rd(4)) / sqrt2
	case (TENSOR)
	a(3) = rd(1) - rd(5)
	a(6) = rd(2) - rd(4)
	a(15) = (rd(1) - rd(2) - rd(4) + rd(5)) / sqrt2
	a(24) = (rd(1) + rd(2) - 4 * rd(3) + rd(4) + rd(5)) / sqrt10
	end select
	end function cartan_coeff

	@ %def cartan_coeff
	@
	\subsection{Roots (Off-Diagonal Generators)}
	Return the appropriate generator index for a given off-diagonal helicity
	combination. We require $h_1>h_2$. We return the index of the
	appropriate real-valued generator if [[r]] is true, else the
	complex-valued one.

	This is separate from the [[cartan_coeff]] function above. The reason
	is that the off-diagonal generators have only a single nonzero matrix
	element, so there is a one-to-one correspondence of helicity and index.
	<<su algebra: public>>=
	public :: root_index
	<<su algebra: procedures>>=
	function root_index (s, h1, h2, r) result (ai)
	integer :: ai
	integer, intent(in) :: s, h1, h2
	logical :: r
	ai = 0
	select case (s)
	case (SCALAR)
	case (SPINOR)
	select case (h1)
	case (1)
	select case (h2)
	case (-1); ai = 1
	end select
	end select
	case (VECTOR)
	select case (h1)
	case (1)
	select case (h2)
	case (-1); ai = 1
	case (0); ai = 4
	end select
	case (0)
	select case (h2)
	case (-1); ai = 6
	end select
	end select
	case (VECTORSPINOR)
	select case (h1)
	case (2)
	select case (h2)
	case (-2); ai = 1
	case (1); ai = 7
	case (-1); ai = 11
	end select
	case (1)
	select case (h2)
	case (-1); ai = 4
	case (-2); ai = 13
	end select
	case (-1)
	select case (h2)
	case (-2); ai = 9
	end select
	end select
	case (TENSOR)
	select case (h1)
	case (2)
	select case (h2)
	case (-2); ai = 1
	case (1); ai = 7
	case (-1); ai = 11
	case (0); ai = 16
	end select
	case (1)
	select case (h2)
	case (-1); ai = 4
	case (-2); ai = 13
	case (0); ai = 20
	end select
	case (-1)
	select case (h2)
	case (-2); ai = 9
	end select
	case (0)
	select case (h2)
	case (-2); ai = 18
	case (-1); ai = 22
	end select
	end select
	end select
	if (ai /= 0 .and. .not. r) ai = ai + 1
	end function root_index

	@ %def root_index
	@ Inverse: return the helicity values ($h_2>h_1$) for an off-diagonal
	generator. The flag [[r]] tells whether this is a real or diagonal
	generator. The others are Cartan generators.
	<<su algebra: public>>=
	public :: root_helicity
	<<su algebra: procedures>>=
	subroutine root_helicity (s, i, h1, h2, r)
	integer, intent(in) :: s, i
	integer, intent(out) :: h1, h2
	logical, intent(out) :: r
	h1 = 0
	h2 = 0
	r = .false.
	select case (s)
	case (SCALAR)
	case (SPINOR)
	select case (i)
	case ( 1, 2); h1 = 1; h2 = -1; r = i == 1
	end select
	case (VECTOR)
	select case (i)
	case ( 1, 2); h1 = 1; h2 = -1; r = i == 1
	case ( 4, 5); h1 = 1; h2 = 0; r = i == 4
	case ( 6, 7); h1 = 0; h2 = -1; r = i == 6
	end select
	case (VECTORSPINOR)
	select case (i)
	case ( 1, 2); h1 = 2; h2 = -2; r = i == 1
	case ( 4, 5); h1 = 1; h2 = -1; r = i == 4
	case ( 7, 8); h1 = 2; h2 = 1; r = i == 7
	case ( 9,10); h1 = -1; h2 = -2; r = i == 9
	case (11,12); h1 = 2; h2 = -1; r = i ==11
	case (13,14); h1 = 1; h2 = -2; r = i ==13
	end select
	case (TENSOR)
	select case (i)
	case ( 1, 2); h1 = 2; h2 = -2; r = i == 1
	case ( 4, 5); h1 = 1; h2 = -1; r = i == 4
	case ( 7, 8); h1 = 2; h2 = 1; r = i == 7
	case ( 9,10); h1 = -1; h2 = -2; r = i == 9
	case (11,12); h1 = 2; h2 = -1; r = i ==11
	case (13,14); h1 = 1; h2 = -2; r = i ==13
	case (16,17); h1 = 2; h2 = 0; r = i ==16
	case (18,19); h1 = 0; h2 = -2; r = i ==18
	case (20,21); h1 = 1; h2 = 0; r = i ==20
	case (22,23); h1 = 0; h2 = -1; r = i ==22
	end select
	end select
	end subroutine root_helicity

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

	module su_algebra_ut
	use unit_tests
	use su_algebra_uti

	<<Standard module head>>

	<<su algebra: public test>>

	contains

	<<su algebra: test driver>>

	end module su_algebra_ut
	@ %def su_algebra_ut
	@
	<<[[su_algebra_uti.f90]]>>=
	<<File header>>

	module su_algebra_uti

	<<Use kinds>>
	use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use su_algebra

	<<Standard module head>>

	<<su algebra: test declarations>>

	contains

	<<su algebra: tests>>

	end module su_algebra_uti
	@ %def su_algebra_ut
	@ API: driver for the unit tests below.
	<<su algebra: public test>>=
	public :: su_algebra_test
	<<su algebra: test driver>>=
	subroutine su_algebra_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<su algebra: execute tests>>
	end subroutine su_algebra_test

	@ %def su_algebra_test
	@
	\subsubsection{Generator Ordering}
	Show the position of Cartan generators in the sequence of basis generators.
	<<su algebra: execute tests>>=
	call test (su_algebra_1, "su_algebra_1", &
	"generator ordering", &
	u, results)
	<<su algebra: test declarations>>=
	public :: su_algebra_1
	<<su algebra: tests>>=
	subroutine su_algebra_1 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: su_algebra_1"
	write (u, "(A)") "* Purpose: test su(N) algebra implementation"
	write (u, "(A)")

	write (u, "(A)") "* su(N) generators: &
	&list and mark Cartan subalgebra"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call cartan_check (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call cartan_check (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call cartan_check (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call cartan_check (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call cartan_check (TENSOR)

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

	contains

	subroutine cartan_check (s)
	integer, intent(in) :: s
	integer :: i
	write (u, *)
	do i = 1, algebra_dimension (s)
	write (u, "(1x,L1)", advance="no") is_cartan_generator (s, i)
	end do
	write (u, *)

	end subroutine cartan_check

	end subroutine su_algebra_1

	@ %def su_algebra_1
	@
	\subsubsection{Cartan Generator Basis}
	Show the explicit matrix representation for all Cartan generators and
	check their traces and Killing products.

	Also test helicity index mappings.
	<<su algebra: execute tests>>=
	call test (su_algebra_2, "su_algebra_2", &
	"Cartan generator representation", &
	u, results)
	<<su algebra: test declarations>>=
	public :: su_algebra_2
	<<su algebra: tests>>=
	subroutine su_algebra_2 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: su_algebra_2"
	write (u, "(A)") "* Purpose: test su(N) algebra implementation"
	write (u, "(A)")

	write (u, "(A)") "* diagonal su(N) generators: &
	&show explicit representation"
	write (u, "(A)") "* and check trace and Killing form"

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call cartan_show (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call cartan_show (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call cartan_show (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call cartan_show (TENSOR)

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

	contains

	subroutine cartan_show (s)
	integer, intent(in) :: s
	real(default), dimension(:,:), allocatable :: rd
	integer, dimension(:), allocatable :: ci
	integer :: n, d, h, i, j, k, l

	n = algebra_dimension (s)
	d = fundamental_dimension (s)

	write (u, *)
	write (u, "(A2,5X)", advance="no") "h:"
	do i = 1, d
	j = helicity_index (s, helicity_value (s, i))
	write (u, "(1x,I2,5X)", advance="no") helicity_value (s, j)
	end do
	write (u, "(8X)", advance="no")
	write (u, "(1X,A)") "tr"

	allocate (rd (n,d), source = 0._default)
	do i = 1, d
	h = helicity_value (s, i)
	rd(:,i) = cartan_element (s, h)
	end do

	allocate (ci (d-1), source = 0)
	do k = 1, d-1
	ci(k) = cartan_index (s, k)
	end do

	write (u, *)
	do k = 1, d-1
	write (u, "('T',I2,':',1X)", advance="no") ci(k)
	do i = 1, d
	write (u, 1, advance="no") rd(ci(k),i)
	end do
	write (u, "(8X)", advance="no")
	write (u, 1) sum (rd(ci(k),:))
	end do

	write (u, *)
	write (u, "(6X)", advance="no")
	do k = 1, d-1
	write (u, "(2X,'T',I2,3X)", advance="no") ci(k)
	end do
	write (u, *)

	do k = 1, d-1
	write (u, "('T',I2,2X)", advance="no") ci(k)
	do l = 1, d-1
	write (u, 1, advance="no") dot_product (rd(ci(k),:), rd(ci(l),:))
	end do
	write (u, *)
	end do

	1 format (1x,F7.4)

	end subroutine cartan_show

	end subroutine su_algebra_2

	@ %def su_algebra_2
	@
	\subsubsection{Bloch Representation: Cartan Generators}
	Transform from Bloch vectors to matrix and back, considering Cartan
	generators only.
	<<su algebra: execute tests>>=
	call test (su_algebra_3, "su_algebra_3", &
	"Cartan generator mapping", &
	u, results)
	<<su algebra: test declarations>>=
	public :: su_algebra_3
	<<su algebra: tests>>=
	subroutine su_algebra_3 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: su_algebra_3"
	write (u, "(A)") "* Purpose: test su(N) algebra implementation"
	write (u, "(A)")

	write (u, "(A)") "* diagonal su(N) generators: &
	&transform to matrix and back"

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call cartan_expand (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call cartan_expand (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call cartan_expand (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call cartan_expand (TENSOR)

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

	contains

	subroutine cartan_expand (s)
	integer, intent(in) :: s
	real(default), dimension(:,:), allocatable :: rd
	integer, dimension(:), allocatable :: ci
	real(default), dimension(:), allocatable :: a
	logical, dimension(:), allocatable :: mask
	integer :: n, d, h, i, k, l

	n = algebra_dimension (s)
	d = fundamental_dimension (s)

	allocate (rd (n,d), source = 0._default)
	do i = 1, d
	h = helicity_value (s, i)
	rd(:,i) = cartan_element (s, h)
	end do

	allocate (ci (d-1), source = 0)
	do k = 1, d-1
	ci(k) = cartan_index (s, k)
	end do

	allocate (a (n))

	write (u, *)
	do k = 1, d-1
	a(:) = cartan_coeff (s, rd(ci(k),:))
	write (u, "('T',I2,':',1X)", advance="no") ci(k)
	do i = 1, n
	if (is_cartan_generator (s, i)) then
	write (u, 1, advance="no") a(i)
	else if (a(i) /= 0) then
	! this should not happen (nonzero non-Cartan entry)
	write (u, "(1X,':',I2,':',3X)", advance="no") i
	end if
	end do
	write (u, *)
	end do

	1 format (1X,F7.4)

	end subroutine cartan_expand

	end subroutine su_algebra_3

	@ %def su_algebra_3
	@
	\subsubsection{Bloch Representation: Roots}
	List the mapping between helicity transitions and (real) off-diagonal
	generators.
	<<su algebra: execute tests>>=
	call test (su_algebra_4, "su_algebra_4", &
	"Root-helicity mapping", &
	u, results)
	<<su algebra: test declarations>>=
	public :: su_algebra_4
	<<su algebra: tests>>=
	subroutine su_algebra_4 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: su_algebra_4"
	write (u, "(A)") "* Purpose: test su(N) algebra implementation"
	write (u, "(A)")

	write (u, "(A)") "* off-diagonal su(N) generators: &
	&mapping from/to helicity pair"

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call root_expand (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call root_expand (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call root_expand (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call root_expand (TENSOR)

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

	contains

	subroutine root_expand (s)
	integer, intent(in) :: s
	integer :: n, d, i, j, h1, h2
	logical :: r

	n = algebra_dimension (s)

	write (u, *)
	do i = 1, n
	if (is_cartan_generator (s, i)) cycle
	call root_helicity (s, i, h1, h2, r)
	j = root_index (s, h1, h2, r)
	write (u, "('T',I2,':')", advance="no") j
	write (u, "(2(1x,I2))", advance="no") h1, h2
	if (r) then
	write (u, *)
	else
	write (u, "('*')")
	end if
	end do

	end subroutine root_expand

	end subroutine su_algebra_4

	@ %def su_algebra_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Bloch Representation}
	Particle polarization is determined by a particular quantum state
	which has just helicity information. Physically, this is the spin
	density matrix $\rho$, where we do not restrict ourselves to pure
	states.

	We adopt the phase convention for a spin-1/2 particle that
	\begin{equation}
	\rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
	\end{equation}
	with the polarization axis $\vec\alpha$. For a particle with
	arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
	definition to generalized Bloch form
	\begin{equation}
	\rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
	\end{equation}
	where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
	generators. These $N\times N$ matrices are hermitean, traceless, and
	orthogonal via
	\begin{equation}
	\mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
	\end{equation}
	In the spin-1/2 case, this reduces to the above (standard Bloch)
	representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1
	case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
	\begin{equation}
	\rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
	\end{equation}
	The normalization is chosen that $\|alpha\|\leq 1$ for allowed density
	matrix, where $\|\alpha\|=1$ is a necessary, but not sufficient,
	condition for a pure state.

	We need a specific choice of basis for a well-defined component
	representation. The matrix elements of $T^a$ are
	ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
	lowest weight, for both row and column.

	We list first the generators of the $su(2)$ subalgebras which leave
	$\|m\|$ invariant ($\|m\|\neq 0$):
	\begin{equation}
	T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
	\end{equation}
	acting on the respective subspace $\|m\|=\ell,\ell-1,\ldots$ for
	$b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$
	($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.

	The following generators successively extend this to $su(4)$, $su(6)$,
	\ldots until $su(N)$ by adding first the missing off-diagonal and then
	diagonal generators. The phase conventions are analogous.

	(It should be possible to code these conventions for generic spin, but
	in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
	$N\leq 5$.)

	Particle polarization is determined by a particular quantum state
	which has just helicity information. Physically, this is the spin
	density matrix $\rho$, where we do not restrict ourselves to pure
	states.

	We adopt the phase convention for a spin-1/2 particle that
	\begin{equation}
	\rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
	\end{equation}
	with the polarization axis $\vec\alpha$. For a particle with
	arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
	definition to generalized Bloch form
	\begin{equation}
	\rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
	\end{equation}
	where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
	generators. These $N\times N$ matrices are hermitean, traceless, and
	orthogonal via
	\begin{equation}
	\mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
	\end{equation}
	In the spin-1/2 case, this reduces to the above (standard Bloch)
	representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1
	case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
	\begin{equation}
	\rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
	\end{equation}
	The normalization is chosen that $\|alpha\|\leq 1$ for allowed density
	matrix, where $\|\alpha\|=1$ is a necessary, but not sufficient,
	condition for a pure state.
	<<[[bloch_vectors.f90]]>>=
	<<File header>>

	module bloch_vectors

	<<Use kinds>>
	use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use su_algebra

	<<Standard module head>>

	<<Bloch vectors: public>>

	<<Bloch vectors: types>>

	contains

	<<Bloch vectors: procedures>>

	end module bloch_vectors
	@ %def bloch_vectors
	@
	\subsection{Preliminaries}
	The normalization factor $\sqrt{2N(N-1)}/N$ that enters the Bloch
	representation.
	<<Bloch vectors: procedures>>=
	function bloch_factor (s) result (f)
	real(default) :: f
	integer, intent(in) :: s
	select case (s)
	case (SCALAR)
	f = 0
	case (SPINOR)
	f = 1
	case (VECTOR)
	f = 2 * sqrt (3._default) / 3
	case (VECTORSPINOR)
	f = 2 * sqrt (6._default) / 4
	case (TENSOR)
	f = 2 * sqrt (10._default) / 5
	case default
	f = 0
	end select
	end function bloch_factor

	@ %def bloch_factor
	@
	\subsection{The basic polarization type}
	The basic polarization object holds just the entries of the Bloch
	vector as an allocatable array.

	Bloch is active whenever the coefficient array is allocated.
	For convenience, we store the spin type ($2s$) and the multiplicity
	($N$) together with the coefficient array ($\alpha$). We have to allow for
	the massless case where $s$ is arbitrary $>0$ but $N=2$, and
	furthermore the chiral massless case where $N=1$. In the latter case,
	the array remains deallocated but the chirality is set to $\pm 1$.

	In the Bloch vector implementation, we do not distinguish between
	particle and antiparticle. If the distinction applies, it must be
	made by the caller when transforming between density matrix and Bloch vector.
	<<Bloch vectors: public>>=
	public :: bloch_vector_t
	<<Bloch vectors: types>>=
	type :: bloch_vector_t
	private
	integer :: spin_type = UNKNOWN
	real(default), dimension(:), allocatable :: a
	contains
	<<Bloch vectors: bloch vector: TBP>>
	end type bloch_vector_t

	@ %def bloch_vector_t
	@
	\subsection{Direct Access}
	This basic initializer just sets the spin type, leaving the Bloch vector
	unallocated. The object therefore does not support nonzero polarization.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: init_unpolarized => bloch_vector_init_unpolarized
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init_unpolarized (pol, spin_type)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	pol%spin_type = spin_type
	end subroutine bloch_vector_init_unpolarized

	@ %def bloch_vector_init_unpolarized
	@ The standard initializer allocates the Bloch vector and initializes
	with zeros, so we can define a polarization later. We make sure that
	this works only for the supported spin type. Initializing with
	[[UNKNOWN]] spin type resets the Bloch vector to undefined, i.e.,
	unpolarized state.
	<<Bloch vectors: bloch vector: TBP>>=
	generic :: init => bloch_vector_init
	procedure, private :: bloch_vector_init
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init (pol, spin_type)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	pol%spin_type = spin_type
	select case (spin_type)
	case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
	allocate (pol%a (algebra_dimension (spin_type)), source = 0._default)
	end select
	end subroutine bloch_vector_init

	@ %def bloch_vector_init
	@
	Fill the Bloch vector from an array, no change of normalization. No
	initialization and no check, we assume that the shapes do match.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: from_array => bloch_vector_from_array
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_from_array (pol, a)
	class(bloch_vector_t), intent(inout) :: pol
	real(default), dimension(:), allocatable, intent(in) :: a
	pol%a(:) = a
	end subroutine bloch_vector_from_array

	@ %def bloch_vector_from_array
	@
	Transform to an array of reals, i.e., extract the Bloch vector as-is.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: to_array => bloch_vector_to_array
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_to_array (pol, a)
	class(bloch_vector_t), intent(in) :: pol
	real(default), dimension(:), allocatable, intent(out) :: a
	if (pol%is_defined ()) allocate (a (size (pol%a)), source = pol%a)
	end subroutine bloch_vector_to_array

	@ %def bloch_vector_to_array
	@
	\subsection{Raw I/O}
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: write_raw => bloch_vector_write_raw
	procedure :: read_raw => bloch_vector_read_raw
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_write_raw (pol, u)
	class(bloch_vector_t), intent(in) :: pol
	integer, intent(in) :: u
	write (u) pol%spin_type
	write (u) allocated (pol%a)
	if (allocated (pol%a)) then
	write (u) pol%a
	end if
	end subroutine bloch_vector_write_raw

	subroutine bloch_vector_read_raw (pol, u, iostat)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: u
	integer, intent(out) :: iostat
	integer :: s
	logical :: polarized
	read (u, iostat=iostat) s
	read (u, iostat=iostat) polarized
	if (iostat /= 0) return
	if (polarized) then
	call pol%init (s)
	read (u, iostat=iostat) pol%a
	else
	call pol%init_unpolarized (s)
	end if
	end subroutine bloch_vector_read_raw

	@ %def bloch_vector_write_raw
	@ %def bloch_vector_read_raw
	@
	\subsection{Properties}
	Re-export algebra functions that depend on the spin type. These
	functions do not depend on the Bloch vector being allocated.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: get_n_states
	procedure :: get_length
	procedure :: hel_index => bv_helicity_index
	procedure :: hel_value => bv_helicity_value
	procedure :: bloch_factor => bv_factor
	<<Bloch vectors: procedures>>=
	function get_n_states (pol) result (n)
	class(bloch_vector_t), intent(in) :: pol
	integer :: n
	n = fundamental_dimension (pol%spin_type)
	end function get_n_states

	function get_length (pol) result (n)
	class(bloch_vector_t), intent(in) :: pol
	integer :: n
	n = algebra_dimension (pol%spin_type)
	end function get_length

	function bv_helicity_index (pol, h) result (i)
	class(bloch_vector_t), intent(in) :: pol
	integer, intent(in) :: h
	integer :: i
	i = helicity_index (pol%spin_type, h)
	end function bv_helicity_index

	function bv_helicity_value (pol, i) result (h)
	class(bloch_vector_t), intent(in) :: pol
	integer, intent(in) :: i
	integer :: h
	h = helicity_value (pol%spin_type, i)
	end function bv_helicity_value

	function bv_factor (pol) result (f)
	class(bloch_vector_t), intent(in) :: pol
	real(default) :: f
	f = bloch_factor (pol%spin_type)
	end function bv_factor

	@ %def get_n_states
	@ %def helicity_index
	@ %def helicity_value
	@ If the Bloch vector object is defined, the spin type is anything else but
	[[UNKNOWN]]. This allows us the provide the representation-specific
	functions above.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: is_defined => bloch_vector_is_defined
	<<Bloch vectors: procedures>>=
	function bloch_vector_is_defined (pol) result (flag)
	class(bloch_vector_t), intent(in) :: pol
	logical :: flag
	flag = pol%spin_type /= UNKNOWN
	end function bloch_vector_is_defined

	@ %def bloch_vector_is_defined
	@ If the Bloch vector object is (technically) polarized, it is
	defined, and the vector coefficient array has been allocated.
	However, the vector value may be zero.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: is_polarized => bloch_vector_is_polarized
	<<Bloch vectors: procedures>>=
	function bloch_vector_is_polarized (pol) result (flag)
	class(bloch_vector_t), intent(in) :: pol
	logical :: flag
	flag = allocated (pol%a)
	end function bloch_vector_is_polarized

	@ %def bloch_vector_is_polarized
	@ Return true if the polarization is diagonal, i.e., all entries in
	the density matrix are on the diagonal. This is equivalent to
	requiring that only Cartan generator coefficients are nonzero in the
	Bloch vector.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: is_diagonal => bloch_vector_is_diagonal
	<<Bloch vectors: procedures>>=
	function bloch_vector_is_diagonal (pol) result (diagonal)
	class(bloch_vector_t), intent(in) :: pol
	logical :: diagonal
	integer :: s, i
	s = pol%spin_type
	diagonal = .true.
	if (pol%is_polarized ()) then
	do i = 1, size (pol%a)
	if (is_cartan_generator (s, i)) cycle
	if (pol%a(i) /= 0) then
	diagonal = .false.
	return
	end if
	end do
	end if
	end function bloch_vector_is_diagonal

	@ %def bloch_vector_is_diagonal
	@
	Return the Euclidean norm of the Bloch vector. This is equal to the
	Killing form value of the corresponding algebra generator. We assume
	that the polarization object has been initialized.

	For a pure state, the norm is unity. All other allowed states have a
	norm less than unity. (For $s\geq 1$, this is a necessary but not
	sufficient condition.)
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: get_norm => bloch_vector_get_norm
	<<Bloch vectors: procedures>>=
	function bloch_vector_get_norm (pol) result (norm)
	class(bloch_vector_t), intent(in) :: pol
	real(default) :: norm
	select case (pol%spin_type)
	case (SPINOR,VECTOR,VECTORSPINOR,TENSOR)
	norm = sqrt (dot_product (pol%a, pol%a))
	case default
	norm = 1
	end select
	end function bloch_vector_get_norm

	@ %def bloch_vector_get_norm
	@
	\subsection{Diagonal density matrix}
	This initializer takes a diagonal density matrix, represented by a
	real-valued array. We assume that the trace is unity, and that the
	array has the correct shape for the given [[spin_type]].

	The [[bloch_factor]] renormalization is necessary such that a pure
	state maps to a Bloch vector with unit norm.
	<<Bloch vectors: bloch vector: TBP>>=
	generic :: init => bloch_vector_init_diagonal
	procedure, private :: bloch_vector_init_diagonal
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init_diagonal (pol, spin_type, rd)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	real(default), dimension(:), intent(in) :: rd
	call pol%init (spin_type)
	call pol%set (rd)
	end subroutine bloch_vector_init_diagonal

	@ %def bloch_vector_init_diagonal
	@ Set a Bloch vector, given a diagonal density matrix as a real array.
	The Bloch vector must be initialized with correct characteristics.
	<<Bloch vectors: bloch vector: TBP>>=
	generic :: set => bloch_vector_set_diagonal
	procedure, private :: bloch_vector_set_diagonal
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_set_diagonal (pol, rd)
	class(bloch_vector_t), intent(inout) :: pol
	real(default), dimension(:), intent(in) :: rd
	integer :: s
	s = pol%spin_type
	select case (s)
	case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
	pol%a(:) = cartan_coeff (s, rd) / bloch_factor (s)
	end select
	end subroutine bloch_vector_set_diagonal

	@ %def bloch_vector_set_diagonal
	@
	@
	\subsection{Massless density matrix}
	This is a specific variant which initializes an equipartition for
	the maximum helicity, corresponding to an unpolarized massless particle.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: init_max_weight => bloch_vector_init_max_weight
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init_max_weight (pol, spin_type)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	call pol%init (spin_type)
	select case (spin_type)
	case (VECTOR)
	call pol%set ([0.5_default, 0._default, 0.5_default])
	case (VECTORSPINOR)
	call pol%set ([0.5_default, 0._default, 0._default, 0.5_default])
	case (TENSOR)
	call pol%set ([0.5_default, 0._default, 0._default, 0._default, 0.5_default])
	end select
	end subroutine bloch_vector_init_max_weight

	@ %def bloch_vector_init_max_weight
	@ Initialize the maximum-weight submatrix with a three-component Bloch
	vector. This is not as trivial as it seems because we need the above
	initialization for the generalized Bloch in order to remove the lower
	weights from the density matrix.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: init_vector => bloch_vector_init_vector
	procedure :: to_vector => bloch_vector_to_vector
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init_vector (pol, s, a)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: s
	real(default), dimension(3), intent(in) :: a
	call pol%init_max_weight (s)
	select case (s)
	case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
	pol%a(1:3) = a / bloch_factor (s)
	end select
	end subroutine bloch_vector_init_vector

	subroutine bloch_vector_to_vector (pol, a)
	class(bloch_vector_t), intent(in) :: pol
	real(default), dimension(3), intent(out) :: a
	integer :: s
	s = pol%spin_type
	select case (s)
	case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
	a = pol%a(1:3) * bloch_factor (s)
	case default
	a = 0
	end select
	end subroutine bloch_vector_to_vector

	@ %def bloch_vector_init_vector
	@ %def bloch_vector_to_vector
	@
	\subsection{Arbitrary density matrix}
	Initialize the Bloch vector from a density matrix. We assume that the
	density is valid. In particular, the shape should match, the matrix
	should be hermitian, and the trace should be unity.

	We first fill the diagonal, then add the off-diagonal parts.
	<<Bloch vectors: bloch vector: TBP>>=
	generic :: init => bloch_vector_init_matrix
	procedure, private :: bloch_vector_init_matrix
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_init_matrix (pol, spin_type, r)
	class(bloch_vector_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	complex(default), dimension(:,:), intent(in) :: r
	select case (spin_type)
	case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
	call pol%init (spin_type)
	call pol%set (r)
	case default
	call pol%init (UNKNOWN)
	end select
	end subroutine bloch_vector_init_matrix

	@ %def bloch_vector_init_matrix
	@ Set a Bloch vector, given an arbitrary density matrix as a real
	array. The Bloch vector must be initialized with correct
	characteristics.
	<<Bloch vectors: bloch vector: TBP>>=
	generic :: set => bloch_vector_set_matrix
	procedure, private :: bloch_vector_set_matrix
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_set_matrix (pol, r)
	class(bloch_vector_t), intent(inout) :: pol
	complex(default), dimension(:,:), intent(in) :: r
	real(default), dimension(:), allocatable :: rd
	integer :: s, d, i, j, h1, h2, ir, ii
	s = pol%spin_type
	select case (s)
	case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
	d = fundamental_dimension (s)
	allocate (rd (d))
	do i = 1, d
	rd(i) = r(i,i)
	end do
	call pol%set (rd)
	do i = 1, d
	h1 = helicity_value (s, i)
	do j = i+1, d
	h2 = helicity_value (s, j)
	ir = root_index (s, h1, h2, .true.)
	ii = root_index (s, h1, h2, .false.)
	pol%a(ir) = real (r(j,i) + r(i,j)) / bloch_factor (s)
	pol%a(ii) = aimag (r(j,i) - r(i,j)) / bloch_factor (s)
	end do
	end do
	end select
	end subroutine bloch_vector_set_matrix

	@ %def bloch_vector_set_matrix
	@ Allocate and fill the density matrix [[r]] (with the index ordering as
	defined in [[su_algebra]]) that corresponds to a given Bloch vector.

	If the optional [[only_max_weight]] is set, the resulting matrix has
	entries only for $\pm h_\text{max}$, as appropriate for a massless
	particle (for spin $\geq 1$). Note that we always add the unit
	matrix, as this is part of the Bloch-vector definition.
	<<Bloch vectors: bloch vector: TBP>>=
	procedure :: to_matrix => bloch_vector_to_matrix
	<<Bloch vectors: procedures>>=
	subroutine bloch_vector_to_matrix (pol, r, only_max_weight)
	class(bloch_vector_t), intent(in) :: pol
	complex(default), dimension(:,:), intent(out), allocatable :: r
	logical, intent(in), optional :: only_max_weight
	integer :: d, s, h0, ng, ai, h, h1, h2, i, j
	logical :: is_real, only_max
	complex(default) :: val
	if (.not. pol%is_polarized ()) return
	s = pol%spin_type
	only_max = .false.
	select case (s)
	case (VECTOR, VECTORSPINOR, TENSOR)
	if (present (only_max_weight)) only_max = only_max_weight
	end select
	if (only_max) then
	ng = 2
	h0 = helicity_value (s, 1)
	else
	ng = algebra_dimension (s)
	h0 = 0
	end if
	d = fundamental_dimension (s)
	allocate (r (d, d), source = (0._default, 0._default))
	do i = 1, d
	h = helicity_value (s, i)
	if (abs (h) < h0) cycle
	r(i,i) = 1._default / d &
	+ dot_product (cartan_element (s, h), pol%a) * bloch_factor (s)
	end do
	do ai = 1, ng
	if (is_cartan_generator (s, ai)) cycle
	call root_helicity (s, ai, h1, h2, is_real)
	i = helicity_index (s, h1)
	j = helicity_index (s, h2)
	if (is_real) then
	val = cmplx (pol%a(ai) / 2 * bloch_factor (s), 0._default, &
	kind=default)
	r(i,j) = r(i,j) + val
	r(j,i) = r(j,i) + val
	else
	val = cmplx (0._default, pol%a(ai) / 2 * bloch_factor (s), &
	kind=default)
	r(i,j) = r(i,j) - val
	r(j,i) = r(j,i) + val
	end if
	end do
	end subroutine bloch_vector_to_matrix

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

	module bloch_vectors_ut
	use unit_tests
	use bloch_vectors_uti

	<<Standard module head>>

	<<Bloch vectors: public test>>

	contains

	<<Bloch vectors: test driver>>

	end module bloch_vectors_ut
	@ %def bloch_vectors_ut
	@
	<<[[bloch_vectors_uti.f90]]>>=
	<<File header>>

	module bloch_vectors_uti

	<<Use kinds>>
	use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use su_algebra, only: algebra_dimension, fundamental_dimension, helicity_value

	use bloch_vectors

	<<Standard module head>>

	<<Bloch vectors: test declarations>>

	contains

	<<Bloch vectors: tests>>

	end module bloch_vectors_uti
	@ %def bloch_vectors_ut
	@ API: driver for the unit tests below.
	<<Bloch vectors: public test>>=
	public :: bloch_vectors_test
	<<Bloch vectors: test driver>>=
	subroutine bloch_vectors_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Bloch vectors: execute tests>>
	end subroutine bloch_vectors_test

	@ %def bloch_vectors_test
	@
	\subsubsection{Initialization}
	Initialize the Bloch vector for any spin type. First as unpolarized
	(no array), then as polarized but with zero polarization.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_1, "bloch_vectors_1", &
	"initialization", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_1
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_1 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_1"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

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

	write (u, "(A)")
	write (u, "(A)") "* unknown"
	call bloch_init (UNKNOWN)

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_init (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_init (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_init (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_init (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_init (TENSOR)

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

	contains

	subroutine bloch_init (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	real(default), dimension(:), allocatable :: a
	integer :: i
	write (u, *)
	write (u, "(1X,L1,L1)", advance="no") &
	pol%is_defined (), pol%is_polarized ()
	call pol%init_unpolarized (s)
	write (u, "(1X,L1,L1)", advance="no") &
	pol%is_defined (), pol%is_polarized ()
	call pol%init (s)
	write (u, "(1X,L1,L1)", advance="no") &
	pol%is_defined (), pol%is_polarized ()
	write (u, *)
	call pol%to_array (a)
	if (allocated (a)) then
	write (u, "(*(F7.4))") a
	a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
	call pol%from_array (a)
	call pol%to_array (a)
	write (u, "(*(F7.4))") a
	else
	write (u, *)
	write (u, *)
	end if
	end subroutine bloch_init

	end subroutine bloch_vectors_1

	@ %def bloch_vectors_1
	@
	\subsubsection{Pure state (diagonal)}
	Initialize the Bloch vector with a pure state of definite helicity and
	check the normalization.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_2, "bloch_vectors_2", &
	"pure state (diagonal)", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_2
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_2 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_2"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Initialization (polarized, diagonal): &
	&display vector and norm"
	write (u, "(A)") "* transform back"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_diagonal (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_diagonal (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_diagonal (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_diagonal (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_diagonal (TENSOR)

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

	contains

	subroutine bloch_diagonal (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	real(default), dimension(:), allocatable :: a
	real(default), dimension(:), allocatable :: rd
	complex(default), dimension(:,:), allocatable :: r
	integer :: i, j, d
	real(default) :: rj
	real, parameter :: tolerance = 1.E-14_default
	d = fundamental_dimension (s)
	do i = 1, d
	allocate (rd (d), source = 0._default)
	rd(i) = 1
	call pol%init (s, rd)
	call pol%to_array (a)
	write (u, *)
	write (u, "(A,1X,I2)") "h:", helicity_value (s, i)
	write (u, 1, advance="no") a
	write (u, "(1X,L1)") pol%is_diagonal ()
	write (u, 1) pol%get_norm ()
	call pol%to_matrix (r)
	do j = 1, d
	rj = real (r(j,j))
	if (abs (rj) < tolerance) rj = 0
	write (u, 1, advance="no") rj
	end do
	write (u, "(1X,L1)") matrix_is_diagonal (r)
	deallocate (a, rd, r)
	end do
	1 format (99(1X,F7.4,:))
	end subroutine bloch_diagonal

	function matrix_is_diagonal (r) result (diagonal)
	complex(default), dimension(:,:), intent(in) :: r
	logical :: diagonal
	integer :: i, j
	diagonal = .true.
	do j = 1, size (r, 2)
	do i = 1, size (r, 1)
	if (i == j) cycle
	if (r(i,j) /= 0) then
	diagonal = .false.
	return
	end if
	end do
	end do
	end function matrix_is_diagonal

	end subroutine bloch_vectors_2

	@ %def bloch_vectors_2
	@
	\subsubsection{Pure state (arbitrary)}
	Initialize the Bloch vector with an arbitrarily chosen pure state,
	check the normalization, and transform back to the density matrix.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_3, "bloch_vectors_3", &
	"pure state (arbitrary)", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_3
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_3 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_3"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Initialization (pure polarized, arbitrary):"
	write (u, "(A)") "* input matrix, transform, display norm, transform back"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_arbitrary (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_arbitrary (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_arbitrary (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_arbitrary (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_arbitrary (TENSOR)

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

	contains

	subroutine bloch_arbitrary (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	complex(default), dimension(:,:), allocatable :: r
	integer :: d
	d = fundamental_dimension (s)
	write (u, *)
	call init_matrix (d, r)
	call write_matrix (d, r)
	call pol%init (s, r)
	write (u, *)
	write (u, 2) pol%get_norm (), pol%is_diagonal ()
	write (u, *)
	call pol%to_matrix (r)
	call write_matrix (d, r)
	2 format (1X,F7.4,1X,L1)
	end subroutine bloch_arbitrary

	subroutine init_matrix (d, r)
	integer, intent(in) :: d
	complex(default), dimension(:,:), allocatable, intent(out) :: r
	complex(default), dimension(:), allocatable :: a
	real(default) :: norm
	integer :: i, j
	allocate (a (d))
	norm = 0
	do i = 1, d
	a(i) = cmplx (2i-1, 2i, kind=default)
	norm = norm + conjg (a(i)) * a(i)
	end do
	a = a / sqrt (norm)
	allocate (r (d,d))
	do i = 1, d
	do j = 1, d
	r(i,j) = conjg (a(i)) * a(j)
	end do
	end do
	end subroutine init_matrix

	subroutine write_matrix (d, r)
	integer, intent(in) :: d
	complex(default), dimension(:,:), intent(in) :: r
	integer :: i, j
	do i = 1, d
	do j = 1, d
	write (u, 1, advance="no") r(i,j)
	end do
	write (u, *)
	end do
	1 format (99(1X,'(',F7.4,',',F7.4,')',:))
	end subroutine write_matrix

	end subroutine bloch_vectors_3

	@ %def bloch_vectors_3
	@
	\subsubsection{Raw I/O}
	Check correct input/output in raw format.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_4, "bloch_vectors_4", &
	"raw I/O", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_4
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_4 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_4"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Raw I/O"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_io (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_io (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_io (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_io (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_io (TENSOR)

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

	contains

	subroutine bloch_io (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	real(default), dimension(:), allocatable :: a
	integer :: n, i, utmp, iostat
	n = algebra_dimension (s)
	allocate (a (n))
	a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
	write (u, *)
	write (u, "(*(F7.4))") a
	call pol%init (s)
	call pol%from_array (a)
	open (newunit = utmp, status = "scratch", action = "readwrite", &
	form = "unformatted")
	call pol%write_raw (utmp)
	rewind (utmp)
	call pol%read_raw (utmp, iostat=iostat)
	close (utmp)
	call pol%to_array (a)
	write (u, "(*(F7.4))") a
	end subroutine bloch_io

	end subroutine bloch_vectors_4

	@ %def bloch_vectors_4
	@
	\subsubsection{Convenience Methods}
	Check some further TBP that are called by the [[polarizations]]
	module.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_5, "bloch_vectors_5", &
	"massless state (unpolarized)", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_5
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_5 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_5"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Massless states: equipartition"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_massless_unpol (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_massless_unpol (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_massless_unpol (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_massless_unpol (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_massless_unpol (TENSOR)

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

	contains

	subroutine bloch_massless_unpol (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	complex(default), dimension(:,:), allocatable :: r
	real(default), dimension(:), allocatable :: a
	integer :: d
	d = fundamental_dimension (s)
	call pol%init_max_weight (s)
	call pol%to_matrix (r, only_max_weight = .false.)
	write (u, *)
	where (abs (r) < 1.e-14_default) r = 0
	call write_matrix (d, r)
	call pol%to_matrix (r, only_max_weight = .true.)
	write (u, *)
	call write_matrix (d, r)
	end subroutine bloch_massless_unpol

	subroutine write_matrix (d, r)
	integer, intent(in) :: d
	complex(default), dimension(:,:), intent(in) :: r
	integer :: i, j
	do i = 1, d
	do j = 1, d
	write (u, 1, advance="no") r(i,j)
	end do
	write (u, *)
	end do
	1 format (99(1X,'(',F7.4,',',F7.4,')',:))
	end subroutine write_matrix

	end subroutine bloch_vectors_5

	@ %def bloch_vectors_5
	@
	\subsubsection{Massless state (arbitrary)}
	Initialize the Bloch vector with an arbitrarily chosen pure state
	which consists only of highest-weight components. Transform back to
	the density matrix.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_6, "bloch_vectors_6", &
	"massless state (arbitrary)", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_6
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_6 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_6"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Initialization (pure polarized massless, arbitrary):"
	write (u, "(A)") "* input matrix, transform, display norm, transform back"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_massless (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_massless (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_massless (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_massless (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_massless (TENSOR)

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

	contains

	subroutine bloch_massless (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	complex(default), dimension(:,:), allocatable :: r
	integer :: d
	d = fundamental_dimension (s)
	write (u, *)
	call init_matrix (d, r)
	call write_matrix (d, r)
	call pol%init (s, r)
	write (u, *)
	write (u, 2) pol%get_norm (), pol%is_diagonal ()
	write (u, *)
	call pol%to_matrix (r, only_max_weight = .true.)
	call write_matrix (d, r)
	2 format (1X,F7.4,1X,L1)
	end subroutine bloch_massless

	subroutine init_matrix (d, r)
	integer, intent(in) :: d
	complex(default), dimension(:,:), allocatable, intent(out) :: r
	complex(default), dimension(:), allocatable :: a
	real(default) :: norm
	integer :: i, j
	allocate (a (d), source = (0._default, 0._default))
	norm = 0
	do i = 1, d, max (d-1, 1)
	a(i) = cmplx (2i-1, 2i, kind=default)
	norm = norm + conjg (a(i)) * a(i)
	end do
	a = a / sqrt (norm)
	allocate (r (d,d), source = (0._default, 0._default))
	do i = 1, d, max (d-1, 1)
	do j = 1, d, max (d-1, 1)
	r(i,j) = conjg (a(i)) * a(j)
	end do
	end do
	end subroutine init_matrix

	subroutine write_matrix (d, r)
	integer, intent(in) :: d
	complex(default), dimension(:,:), intent(in) :: r
	integer :: i, j
	do i = 1, d
	do j = 1, d
	write (u, 1, advance="no") r(i,j)
	end do
	write (u, *)
	end do
	1 format (99(1X,'(',F7.4,',',F7.4,')',:))
	end subroutine write_matrix

	end subroutine bloch_vectors_6

	@ %def bloch_vectors_6
	@
	\subsubsection{Massless state (Bloch vector)}
	Initialize the (generalized) Bloch vector with an ordinary
	three-component Bloch vector that applies to the highest-weight part only.
	<<Bloch vectors: execute tests>>=
	call test (bloch_vectors_7, "bloch_vectors_7", &
	"massless state (vector)", &
	u, results)
	<<Bloch vectors: test declarations>>=
	public :: bloch_vectors_7
	<<Bloch vectors: tests>>=
	subroutine bloch_vectors_7 (u)
	integer, intent(in) :: u

	write (u, "(A)") "* Test output: bloch_vectors_7"
	write (u, "(A)") "* Purpose: test Bloch-vector &
	&polarization implementation"
	write (u, "(A)")

	write (u, "(A)") "* Initialization &
	&(pure polarized massless, arbitrary Bloch vector):"
	write (u, "(A)") "* input vector, transform, display norm, &
	&transform back"

	write (u, "(A)")
	write (u, "(A)") "* s = 0"
	call bloch_massless_vector (SCALAR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1/2"
	call bloch_massless_vector (SPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 1"
	call bloch_massless_vector (VECTOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 3/2"
	call bloch_massless_vector (VECTORSPINOR)

	write (u, "(A)")
	write (u, "(A)") "* s = 2"
	call bloch_massless_vector (TENSOR)

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

	contains

	subroutine bloch_massless_vector (s)
	integer, intent(in) :: s
	type(bloch_vector_t) :: pol
	real(default), dimension(3) :: a
	complex(default), dimension(:,:), allocatable :: r
	write (u, *)
	a = [1._default, 2._default, 4._default]
	a = a / sqrt (sum (a ** 2))
	write (u, 2) a
	call pol%init_vector (s, a)
	write (u, 2) pol%get_norm ()
	call pol%to_vector (a)
	write (u, 2) a
	call pol%to_matrix (r, only_max_weight = .false.)
	write (u, *)
	where (abs (r) < 1.e-14_default) r = 0
	call write_matrix (r)
	call pol%to_matrix (r, only_max_weight = .true.)
	write (u, *)
	call write_matrix (r)
	2 format (99(1X,F7.4,:))
	end subroutine bloch_massless_vector

	subroutine write_matrix (r)
	complex(default), dimension(:,:), intent(in) :: r
	integer :: i, j
	do i = 1, size (r, 1)
	do j = 1, size (r, 2)
	write (u, 1, advance="no") r(i,j)
	end do
	write (u, *)
	end do
	1 format (99(1X,'(',F7.4,',',F7.4,')',:))
	end subroutine write_matrix

	end subroutine bloch_vectors_7

	@ %def bloch_vectors_7
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Polarization}
	Using generalized Bloch vectors and the $su(N)$ algebra (see above)
	for the internal representation, we can define various modes of
	polarization. For
	spin-1/2, and analogously for massless spin-$s$ particles, we introduce
	\begin{enumerate}
	\item Trivial polarization: $\vec\alpha=0$. [This is unpolarized, but
	distinct from the particular undefined polarization matrix which has
	the same meaning.]
	\item Circular polarization: $\vec\alpha$ points in $\pm z$ direction.
	\item Transversal polarization: $\vec\alpha$ points orthogonal to the
	$z$ direction, with a phase $\phi$ that is $0$ for the $x$ axis, and
	$\pi/2=90^\circ$ for the $y$ axis. For antiparticles, the phase
	switches sign, corresponding to complex conjugation.
	\item Axis polarization, where we explicitly give $\vec\alpha$.
	\end{enumerate}
	For higher spin, we retain this definition, but apply it to the two
	components with maximum and minimum weight. In effect, we concentrate
	on the first three entries in the $\alpha^a$ array. For massless
	particles, this is sufficient. For massive particles, we then add the
	possibilities:
	\begin{enumerate}\setcounter{enumi}{4}
	\item Longitudinal polarization: Only the 0-component is set. This is
	possible only for bosons.
	\item Diagonal polarization: Explicitly specify all components in the
	helicity basis. The $su(N)$ representation consists of diagonal
	generators only, the Cartan subalgebra.
	\end{enumerate}
	Obviously, this does not exhaust the possible density matrices for
	higher spin, but it should cover practical applications.
	<<[[polarizations.f90]]>>=
	<<File header>>

	module polarizations

	<<Use kinds>>
	use io_units
	use format_defs, only: FMT_19
	use diagnostics
	use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
	use flavors
	use helicities
	use quantum_numbers
	use state_matrices
	use bloch_vectors

	<<Standard module head>>

	<<Polarizations: public>>

	<<Polarizations: types>>

	<<Polarizations: interfaces>>

	contains

	<<Polarizations: procedures>>

	end module polarizations
	@ %def polarizations
	@
	\subsection{The polarization type}
	Polarization is active whenever the coefficient array is allocated.
	For convenience, we store the spin type ($2s$) and the multiplicity
	($N$) together with the coefficient array ($\alpha$). We have to allow for
	the massless case where $s$ is arbitrary $>0$ but $N=2$, and
	furthermore the chiral massless case where $N=1$. In the latter case,
	the array remains deallocated but the chirality is set to $\pm 1$.

	There is a convention that an antiparticle transforms according to the
	complex conjugate representation. We apply this only when
	transforming from/to polarization defined by a three-vector. For
	antiparticles, the two-component flips sign in that case. When
	transforming from/to a state matrix or [[pmatrix]] representation, we
	do not apply this sign flip.
	<<Polarizations: public>>=
	public :: polarization_t
	<<Polarizations: types>>=
	type :: polarization_t
	private
	integer :: spin_type = SCALAR
	integer :: multiplicity = 1
	integer :: chirality = 0
	logical :: anti = .false.
	type(bloch_vector_t) :: bv
	contains
	<<Polarizations: polarization: TBP>>
	end type polarization_t

	@ %def polarization_t
	@
	\subsection{Basic initializer and finalizer}
	We need the particle flavor for determining the allowed helicity
	values. The Bloch vector is left undefined, so this initializer (in
	two versions) creates an unpolarized particle. Exception: a chiral
	particle is always polarized with definite helicity, it doesn't need a
	Bloch vector.

	This is private.
	<<Polarizations: polarization: TBP>>=
	generic, private :: init => polarization_init, polarization_init_flv
	procedure, private :: polarization_init
	procedure, private :: polarization_init_flv
	<<Polarizations: procedures>>=
	subroutine polarization_init (pol, spin_type, multiplicity, &
	anti, left_handed, right_handed)
	class(polarization_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	integer, intent(in) :: multiplicity
	logical, intent(in) :: anti
	logical, intent(in) :: left_handed
	logical, intent(in) :: right_handed
	pol%spin_type = spin_type
	pol%multiplicity = multiplicity
	pol%anti = anti
	select case (pol%multiplicity)
	case (1)
	if (left_handed) then
	pol%chirality = -1
	else if (right_handed) then
	pol%chirality = 1
	end if
	end select
	select case (pol%chirality)
	case (0)
	call pol%bv%init_unpolarized (spin_type)
	end select
	end subroutine polarization_init

	subroutine polarization_init_flv (pol, flv)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	call pol%init ( &
	spin_type = flv%get_spin_type (), &
	multiplicity = flv%get_multiplicity (), &
	anti = flv%is_antiparticle (), &
	left_handed = flv%is_left_handed (), &
	right_handed = flv%is_right_handed ())
	end subroutine polarization_init_flv

	@ %def polarization_init polarization_init_flv
	@ Generic polarization: as before, but create a polarized particle
	(Bloch vector defined) with initial polarization zero.
	<<Polarizations: polarization: TBP>>=
	generic :: init_generic => &
	polarization_init_generic, &
	polarization_init_generic_flv
	procedure, private :: polarization_init_generic
	procedure, private :: polarization_init_generic_flv
	<<Polarizations: procedures>>=
	subroutine polarization_init_generic (pol, spin_type, multiplicity, &
	anti, left_handed, right_handed)
	class(polarization_t), intent(out) :: pol
	integer, intent(in) :: spin_type
	integer, intent(in) :: multiplicity
	logical, intent(in) :: anti
	logical, intent(in) :: left_handed
	logical, intent(in) :: right_handed
	call pol%init (spin_type, multiplicity, &
	anti, left_handed, right_handed)
	select case (pol%chirality)
	case (0)
	if (pol%multiplicity == pol%bv%get_n_states ()) then
	call pol%bv%init (spin_type)
	else
	call pol%bv%init_max_weight (spin_type)
	end if
	end select
	end subroutine polarization_init_generic

	subroutine polarization_init_generic_flv (pol, flv)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	call pol%init_generic ( &
	spin_type = flv%get_spin_type (), &
	multiplicity = flv%get_multiplicity (), &
	anti = flv%is_antiparticle (), &
	left_handed = flv%is_left_handed (), &
	right_handed = flv%is_right_handed ())
	end subroutine polarization_init_generic_flv

	@ %def polarization_init_generic
	@ A finalizer is no longer necessary.

	\subsection{I/O}
	The default setting produces a tabular output of the polarization
	vector entries. Optionally, we can create a state matrix and write
	its contents, emulating the obsolete original implementation.

	If [[all_states]] is true (default), we generate all helity
	combinations regardless of the matrix-element value. Otherwise, skip
	helicities with zero entry, or absolute value less than [[tolerance]],
	if also given.
	<<Polarizations: polarization: TBP>>=
	procedure :: write => polarization_write
	<<Polarizations: procedures>>=
	subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance)
	class(polarization_t), intent(in) :: pol
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: state_matrix, all_states
	real(default), intent(in), optional :: tolerance
	logical :: state_m
	type(state_matrix_t) :: state
	real(default), dimension(:), allocatable :: a
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	state_m = .false.; if (present (state_matrix)) state_m = state_matrix
	if (pol%anti) then
	write (u, "(1x,A,I1,A,I1,A,L1,A)") &
	"Polarization: [spin_type = ", pol%spin_type, &
	", mult = ", pol%multiplicity, ", anti = ", pol%anti, "]"
	else
	write (u, "(1x,A,I1,A,I1,A)") &
	"Polarization: [spin_type = ", pol%spin_type, &
	", mult = ", pol%multiplicity, "]"
	end if
	if (state_m) then
	call pol%to_state (state, all_states, tolerance)
	call state%write (unit=unit)
	call state%final ()
	else if (pol%chirality == 1) then
	write (u, "(1x,A)") "chirality = +"
	else if (pol%chirality == -1) then
	write (u, "(1x,A)") "chirality = -"
	else if (pol%bv%is_polarized ()) then
	call pol%bv%to_array (a)
	do i = 1, size (a)
	write (u, "(1x,I2,':',1x,F10.7)") i, a(i)
	end do
	else
	write (u, "(1x,A)") "[unpolarized]"
	end if
	end subroutine polarization_write

	@ %def polarization_write
	@ Binary I/O.
	<<Polarizations: polarization: TBP>>=
	procedure :: write_raw => polarization_write_raw
	procedure :: read_raw => polarization_read_raw
	<<Polarizations: procedures>>=
	subroutine polarization_write_raw (pol, u)
	class(polarization_t), intent(in) :: pol
	integer, intent(in) :: u
	write (u) pol%spin_type
	write (u) pol%multiplicity
	write (u) pol%chirality
	write (u) pol%anti
	call pol%bv%write_raw (u)
	end subroutine polarization_write_raw

	subroutine polarization_read_raw (pol, u, iostat)
	class(polarization_t), intent(out) :: pol
	integer, intent(in) :: u
	integer, intent(out), optional :: iostat
	read (u, iostat=iostat) pol%spin_type
	read (u, iostat=iostat) pol%multiplicity
	read (u, iostat=iostat) pol%chirality
	read (u, iostat=iostat) pol%anti
	call pol%bv%read_raw (u, iostat)
	end subroutine polarization_read_raw

	@ %def polarization_read_raw
	@
	\subsection{Accessing contents}
	Return true if the particle is technically polarized. The particle
	is either chiral, or its Bloch vector has been defined. The
	function returns true even if the Bloch vector is zero or the particle
	is scalar.
	<<Polarizations: polarization: TBP>>=
	procedure :: is_polarized => polarization_is_polarized
	<<Polarizations: procedures>>=
	function polarization_is_polarized (pol) result (polarized)
	class(polarization_t), intent(in) :: pol
	logical :: polarized
	polarized = pol%chirality /= 0 .or. pol%bv%is_polarized ()
	end function polarization_is_polarized

	@ %def polarization_is_polarized
	@ Return true if the polarization is diagonal, i.e., all entries in
	the density matrix are diagonal. For an unpolarized particle, we also
	return [[.true.]] since the density matrix is proportional to the unit
	matrix.
	<<Polarizations: polarization: TBP>>=
	procedure :: is_diagonal => polarization_is_diagonal
	<<Polarizations: procedures>>=
	function polarization_is_diagonal (pol) result (diagonal)
	class(polarization_t), intent(in) :: pol
	logical :: diagonal
	select case (pol%chirality)
	case (0)
	diagonal = pol%bv%is_diagonal ()
	case default
	diagonal = .true.
	end select
	end function polarization_is_diagonal

	@ %def polarization_is_diagonal
	@
	\subsection{Mapping between polarization and state matrix}
	Create the polarization object that corresponds to a state matrix. The state
	matrix is not necessarily normalized. The result will be either unpolarized,
	or a generalized Bloch vector that we compute in terms of the appropriate spin
	generator basis. To this end, we first construct the complete density
	matrix, then set the Bloch vector with this input.

	For a naturally chiral particle (i.e., neutrino), we do not set the
	polarization vector, it is implied.

	Therefore, we cannot account for any sign flip and transform as-is.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_state_matrix => polarization_init_state_matrix
	<<Polarizations: procedures>>=
	subroutine polarization_init_state_matrix (pol, state)
	class(polarization_t), intent(out) :: pol
	type(state_matrix_t), intent(in), target :: state
	type(state_iterator_t) :: it
	type(flavor_t) :: flv
	type(helicity_t) :: hel
	integer :: d, h1, h2, i, j
	complex(default), dimension(:,:), allocatable :: r
	complex(default) :: me
	real(default) :: trace
	call it%init (state)
	flv = it%get_flavor (1)
	hel = it%get_helicity (1)
	if (hel%is_defined ()) then
	call pol%init_generic (flv)
	select case (pol%chirality)
	case (0)
	trace = 0
	d = pol%bv%get_n_states ()
	allocate (r (d, d), source = (0._default, 0._default))
	do while (it%is_valid ())
	hel = it%get_helicity (1)
	call hel%get_indices (h1, h2)
	i = pol%bv%hel_index (h1)
	j = pol%bv%hel_index (h2)
	me = it%get_matrix_element ()
	r(i,j) = me
	if (i == j) trace = trace + real (me)
	call it%advance ()
	end do
	if (trace /= 0) call pol%bv%set (r / trace)
	end select
	else
	call pol%init (flv)
	end if
	end subroutine polarization_init_state_matrix

	@ %def polarization_init_state_matrix
	@ Create the state matrix that corresponds to a given polarization. We make
	use of the polarization iterator as defined below, which should iterate
	according to the canonical helicity ordering.
	<<Polarizations: polarization: TBP>>=
	procedure :: to_state => polarization_to_state_matrix
	<<Polarizations: procedures>>=
	subroutine polarization_to_state_matrix (pol, state, all_states, tolerance)
	class(polarization_t), intent(in), target :: pol
	type(state_matrix_t), intent(out) :: state
	logical, intent(in), optional :: all_states
	real(default), intent(in), optional :: tolerance
	type(polarization_iterator_t) :: it
	type(quantum_numbers_t), dimension(1) :: qn
	complex(default) :: value
	call it%init (pol, all_states, tolerance)
	call state%init (store_values = .true.)
	do while (it%is_valid ())
	value = it%get_value ()
	qn(1) = it%get_quantum_numbers ()
	call state%add_state (qn, value = value)
	call it%advance ()
	end do
	call state%freeze ()
	end subroutine polarization_to_state_matrix

	@ %def polarization_to_state_matrix
	@
	\subsection{Specific initializers}
	Unpolarized particle, no nontrivial entries in the density matrix. This
	is the default initialization mode.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_unpolarized => polarization_init_unpolarized
	<<Polarizations: procedures>>=
	subroutine polarization_init_unpolarized (pol, flv)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	call pol%init (flv)
	end subroutine polarization_init_unpolarized

	@ %def polarization_init_unpolarized
	@ The following three modes are useful mainly for spin-1/2 particle
	and massless particles of any nonzero spin. Only the highest-weight
	components are filled.

	Circular polarization: The density matrix of the two highest-weight
	states is
	\begin{equation*}
	\rho(f) =
	\frac{1-\|f\|}{2}\mathbf{1} +
	\|f\| \times
	\begin{cases}
	\begin{pmatrix} 1 & 0 \\ 0 & 0 \end{pmatrix}, & f > 0; \\[6pt]
	\begin{pmatrix} 0 & 0 \\ 0 & 1 \end{pmatrix}, & f < 0,
	\end{cases}
	\end{equation*}
	In the generalized Bloch representation, this is an entry for the $T^3$
	generator only, regardless of the spin representation.

	A chiral particle is not affected.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_circular => polarization_init_circular
	<<Polarizations: procedures>>=
	subroutine polarization_init_circular (pol, flv, f)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), intent(in) :: f
	call pol%init (flv)
	select case (pol%chirality)
	case (0)
	call pol%bv%init_vector (pol%spin_type, &
	[0._default, 0._default, f])
	end select
	end subroutine polarization_init_circular

	@ %def polarization_init_circular
	@ Transversal polarization is analogous to circular, but we get a
	density matrix
	\begin{equation*}
	\rho(f,\phi) =
	\frac{1-\|f\|}{2}\mathbf{1}
	+ \frac{\|f\|}{2} \begin{pmatrix} 1 & e^{-i\phi} \\ e^{i\phi} & 1
	\end{pmatrix}.
	\end{equation*}
	for the highest-weight subspace. The lower weights are unaffected.
	The phase is $\phi=0$ for the $x$-axis, $\phi=90^\circ$ for the $y$
	axis as polarization vector.

	For an antiparticle, the phase switches sign, and for $f<0$, the
	off-diagonal elements switch sign.

	A chiral particle is not affected.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_transversal => polarization_init_transversal
	<<Polarizations: procedures>>=
	subroutine polarization_init_transversal (pol, flv, phi, f)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), intent(in) :: phi, f
	call pol%init (flv)
	select case (pol%chirality)
	case (0)
	if (pol%anti) then
	call pol%bv%init_vector (pol%spin_type, &
	[f * cos (phi), f * sin (phi), 0._default])
	else
	call pol%bv%init_vector (pol%spin_type, &
	[f * cos (phi),-f * sin (phi), 0._default])
	end if
	end select
	end subroutine polarization_init_transversal

	@ %def polarization_init_transversal
	@ For axis polarization, we again set only the entries with maximum weight,
	which for spin $1/2$ means
	\begin{equation*}
	\rho(f,\phi) =
	\frac{1}{2} \begin{pmatrix}
	1 + \alpha_3 & \alpha_1 - i\alpha_2 \\
	\alpha_1 + i\alpha_2 & 1 - \alpha_3
	\end{pmatrix}.
	\end{equation*}
	For an antiparticle, the imaginary part proportional to $\alpha_2$ switches
	sign (complex conjugate). A chiral particle is not affected.

	In the generalized Bloch representation, this translates into coefficients for
	$T^{1,2,3}$, all others stay zero.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_axis => polarization_init_axis
	<<Polarizations: procedures>>=
	subroutine polarization_init_axis (pol, flv, alpha)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), dimension(3), intent(in) :: alpha
	call pol%init (flv)
	select case (pol%chirality)
	case (0)
	if (pol%anti) then
	call pol%bv%init_vector (pol%spin_type, &
	[alpha(1), alpha(2), alpha(3)])
	else
	call pol%bv%init_vector (pol%spin_type, &
	[alpha(1),-alpha(2), alpha(3)])
	end if
	end select
	end subroutine polarization_init_axis

	@ %def polarization_init_axis
	@ This version specifies the polarization axis in terms of $r$
	(polarization degree) and $\theta,\phi$ (polar and azimuthal angles).

	If one of the angles is a nonzero multiple of $\pi$, roundoff errors
	typically will result in tiny contributions to unwanted components.
	Therefore, include a catch for small numbers.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_angles => polarization_init_angles
	<<Polarizations: procedures>>=
	subroutine polarization_init_angles (pol, flv, r, theta, phi)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), intent(in) :: r, theta, phi
	real(default), dimension(3) :: alpha
	real(default), parameter :: eps = 10 * epsilon (1._default)

	alpha(1) = r * sin (theta) * cos (phi)
	alpha(2) = r * sin (theta) * sin (phi)
	alpha(3) = r * cos (theta)
	where (abs (alpha) < eps) alpha = 0
	call pol%init_axis (flv, alpha)
	end subroutine polarization_init_angles

	@ %def polarization_init_angles
	@ Longitudinal polarization is defined only for massive bosons. Only
	the zero component is filled. Otherwise, unpolarized.

	In the generalized Bloch representation, the zero component corresponds to a
	linear combination of all diagonal (Cartan) generators.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_longitudinal => polarization_init_longitudinal
	<<Polarizations: procedures>>=
	subroutine polarization_init_longitudinal (pol, flv, f)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), intent(in) :: f
	real(default), dimension(:), allocatable :: rd
	integer :: s, d
	s = flv%get_spin_type ()
	select case (s)
	case (VECTOR, TENSOR)
	call pol%init_generic (flv)
	if (pol%bv%is_polarized ()) then
	d = pol%bv%get_n_states ()
	allocate (rd (d), source = 0._default)
	rd(pol%bv%hel_index (0)) = f
	call pol%bv%set (rd)
	end if
	case default
	call pol%init_unpolarized (flv)
	end select
	end subroutine polarization_init_longitudinal

	@ %def polarization_init_longitudinal
	@ This is diagonal polarization: we specify all components explicitly.
	[[rd]] is the array of diagonal elements of the density matrix. We
	assume that the length of [[rd]] is equal to the particle
	multiplicity.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_diagonal => polarization_init_diagonal
	<<Polarizations: procedures>>=
	subroutine polarization_init_diagonal (pol, flv, rd)
	class(polarization_t), intent(out) :: pol
	type(flavor_t), intent(in) :: flv
	real(default), dimension(:), intent(in) :: rd
	real(default) :: trace
	call pol%init_generic (flv)
	if (pol%bv%is_polarized ()) then
	trace = sum (rd)
	if (trace /= 0) call pol%bv%set (rd / trace)
	end if
	end subroutine polarization_init_diagonal

	@ %def polarization_init_diagonal
	@
	\subsection{Operations}
	Combine polarization states by computing the outer product of the
	state matrices.
	<<Polarizations: public>>=
	public :: combine_polarization_states
	<<Polarizations: procedures>>=
	subroutine combine_polarization_states (pol, state)
	type(polarization_t), dimension(:), intent(in), target :: pol
	type(state_matrix_t), intent(out) :: state
	type(state_matrix_t), dimension(size(pol)), target :: pol_state
	integer :: i
	do i = 1, size (pol)
	call pol(i)%to_state (pol_state(i))
	end do
	call outer_multiply (pol_state, state)
	do i = 1, size (pol)
	call pol_state(i)%final ()
	end do
	end subroutine combine_polarization_states

	@ %def combine_polarization_states
	@ Transform a polarization density matrix into a polarization vector. This is
	possible without information loss only for spin-1/2 and for massless
	particles. To get a unique answer in all cases, we consider only the
	components with highest weight. Obviously, this loses the longitudinal
	component of a massive vector, for instance. The norm of the returned axis is
	the polarization fraction for the highest-weight subspace. For a scalar
	particle, we return a zero vector. The same result applies if the
	highest-weight component vanishes.

	This is the inverse operation of [[polarization_init_axis]] above,
	where the polarization fraction is set to unity.

	For an antiparticle, the [[alpha(2)]] coefficient flips sign.
	<<Polarizations: polarization: TBP>>=
	procedure :: get_axis => polarization_get_axis
	<<Polarizations: procedures>>=
	function polarization_get_axis (pol) result (alpha)
	class(polarization_t), intent(in), target :: pol
	real(default), dimension(3) :: alpha
	select case (pol%chirality)
	case (0)
	call pol%bv%to_vector (alpha)
	if (.not. pol%anti) alpha(2) = - alpha(2)
	case (-1)
	alpha = [0._default, 0._default, -1._default]
	case (1)
	alpha = [0._default, 0._default, 1._default]
	end select
	end function polarization_get_axis

	@ %def polarization_get_axis
	@ This function returns polarization degree and polar and azimuthal
	angles ($\theta,\phi$) of the polarization axis. The same restrictions apply
	as above.

	Since we call the [[get_axis]] method, the phase flips sign for an
	antiparticle.
	<<Polarizations: polarization: TBP>>=
	procedure :: to_angles => polarization_to_angles
	<<Polarizations: procedures>>=
	subroutine polarization_to_angles (pol, r, theta, phi)
	class(polarization_t), intent(in) :: pol
	real(default), intent(out) :: r, theta, phi
	real(default), dimension(3) :: alpha
	real(default) :: norm, r12
	alpha = pol%get_axis ()
	norm = sum (alpha**2)
	r = sqrt (norm)
	if (norm > 0) then
	r12 = sqrt (alpha(1)2 + alpha(2)2)
	theta = atan2 (r12, alpha(3))
	if (any (alpha(1:2) /= 0)) then
	phi = atan2 (alpha(2), alpha(1))
	else
	phi = 0
	end if
	else
	theta = 0
	phi = 0
	end if
	end subroutine polarization_to_angles

	@ %def polarization_to_angles
	@
	\subsection{Polarization Iterator}
	The iterator acts like a state matrix iterator, i.e., it points to one
	helicity combination at a time and can return the corresponding helicity
	object and matrix-element value.

	Since the polarization is stored as a Bloch vector, we recover the
	whole density matrix explicitly upon initialization, store it inside
	the iterator object, and then just return its elements one at a time.

	For an unpolarized particle, the iterator returns a single state with
	undefined helicity. The value is the value of any diagonal density
	matrix element, $1/n$ where $n$ is the multiplicity.
	<<Polarizations: public>>=
	public :: polarization_iterator_t
	<<Polarizations: types>>=
	type :: polarization_iterator_t
	private
	type(polarization_t), pointer :: pol => null ()
	logical :: polarized = .false.
	integer :: h1 = 0
	integer :: h2 = 0
	integer :: i = 0
	integer :: j = 0
	complex(default), dimension(:,:), allocatable :: r
	complex(default) :: value = 1._default
	real(default) :: tolerance = -1._default
	logical :: valid = .false.
	contains
	<<Polarizations: polarization iterator: TBP>>
	end type polarization_iterator_t

	@ %def polarization_iterator_t
	@ Output for debugging purposes only, therefore no format for real/complex.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: write => polarization_iterator_write
	<<Polarizations: procedures>>=
	subroutine polarization_iterator_write (it, unit)
	class(polarization_iterator_t), intent(in) :: it
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1X,A)") "Polarization iterator:"
	write (u, "(3X,A,L1)") "assigned = ", associated (it%pol)
	write (u, "(3X,A,L1)") "valid = ", it%valid
	if (it%valid) then
	write (u, "(3X,A,2(1X,I2))") "i, j = ", it%i, it%j
	write (u, "(3X,A,2(1X,I2))") "h1, h2 = ", it%h1, it%h2
	write (u, "(3X,A)", advance="no") "value = "
	write (u, *) it%value
	if (allocated (it%r)) then
	do i = 1, size (it%r, 2)
	write (u, *) it%r(i,:)
	end do
	end if
	end if
	end subroutine polarization_iterator_write

	@ %def polarization_iterator_write
	@ Initialize, i.e., (virtually) point to the first helicity state
	supported by the polarization object. If the density matrix is
	nontrivial, we calculate it here.

	Following the older state-matrix
	conventions, the iterator sequence starts at the lowest helicity
	value. In the current internal representation, this corresponds to
	the highest index value.

	If the current matrix-element value is zero, advance the iterator.
	Advancing will stop at a nonzero value or if the iterator becomes
	invalid.

	If [[tolerance]] is given, any state matrix entry less or equal will
	be treated as zero, causing the iterator to skip an entry. By
	default, the value is negative, so no entry is skipped.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: init => polarization_iterator_init
	<<Polarizations: procedures>>=
	subroutine polarization_iterator_init (it, pol, all_states, tolerance)
	class(polarization_iterator_t), intent(out) :: it
	type(polarization_t), intent(in), target :: pol
	logical, intent(in), optional :: all_states
	real(default), intent(in), optional :: tolerance
	integer :: d
	logical :: only_max_weight
	it%pol => pol
	if (present (all_states)) then
	if (.not. all_states) then
	if (present (tolerance)) then
	it%tolerance = tolerance
	else
	it%tolerance = 0
	end if
	end if
	end if
	select case (pol%chirality)
	case (0)
	d = pol%bv%get_n_states ()
	only_max_weight = pol%multiplicity < d
	it%polarized = pol%bv%is_polarized ()
	if (it%polarized) then
	it%i = d
	it%j = it%i
	it%h1 = pol%bv%hel_value (it%i)
	it%h2 = it%h1
	call pol%bv%to_matrix (it%r, only_max_weight)
	it%value = it%r(it%i, it%j)
	else
	it%value = 1._default / d
	end if
	it%valid = .true.
	case (1,-1)
	it%polarized = .true.
	select case (pol%spin_type)
	case (SPINOR)
	it%h1 = pol%chirality
	case (VECTORSPINOR)
	it%h1 = 2 * pol%chirality
	end select
	it%h2 = it%h1
	it%valid = .true.
	end select
	if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance ()
	end subroutine polarization_iterator_init

	@ %def polarization_iterator_init
	@ Advance to the next valid helicity state. Repeat if the returned value is
	zero.

	For an unpolarized object, we iterate through the diagonal helicity
	states with a constant value.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: advance => polarization_iterator_advance
	<<Polarizations: procedures>>=
	recursive subroutine polarization_iterator_advance (it)
	class(polarization_iterator_t), intent(inout) :: it
	if (it%valid) then
	select case (it%pol%chirality)
	case (0)
	if (it%polarized) then
	if (it%j > 1) then
	it%j = it%j - 1
	it%h2 = it%pol%bv%hel_value (it%j)
	it%value = it%r(it%i, it%j)
	else if (it%i > 1) then
	it%j = it%pol%bv%get_n_states ()
	it%h2 = it%pol%bv%hel_value (it%j)
	it%i = it%i - 1
	it%h1 = it%pol%bv%hel_value (it%i)
	it%value = it%r(it%i, it%j)
	else
	it%valid = .false.
	end if
	else
	it%valid = .false.
	end if
	case default
	it%valid = .false.
	end select
	if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance ()
	end if
	end subroutine polarization_iterator_advance

	@ %def polarization_iterator_advance
	@ This is true as long as the iterator points to a valid helicity state.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: is_valid => polarization_iterator_is_valid
	<<Polarizations: procedures>>=
	function polarization_iterator_is_valid (it) result (is_valid)
	logical :: is_valid
	class(polarization_iterator_t), intent(in) :: it
	is_valid = it%valid
	end function polarization_iterator_is_valid

	@ %def polarization_iterator_is_valid
	@ Return the matrix element value for the helicity that we are currently
	pointing at.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: get_value => polarization_iterator_get_value
	<<Polarizations: procedures>>=
	function polarization_iterator_get_value (it) result (value)
	complex(default) :: value
	class(polarization_iterator_t), intent(in) :: it
	if (it%valid) then
	value = it%value
	else
	value = 0
	end if
	end function polarization_iterator_get_value

	@ %def polarization_iterator_get_value
	@ Return a quantum number object for the helicity that we are currently
	pointing at. This is a single quantum number object, not an array.

	Note that the [[init]] method of the helicity object has the order reversed.
	<<Polarizations: polarization iterator: TBP>>=
	procedure :: get_quantum_numbers => polarization_iterator_get_quantum_numbers
	<<Polarizations: procedures>>=
	function polarization_iterator_get_quantum_numbers (it) result (qn)
	class(polarization_iterator_t), intent(in) :: it
	type(helicity_t) :: hel
	type(quantum_numbers_t) :: qn
	if (it%polarized) then
	call hel%init (it%h2, it%h1)
	end if
	call qn%init (hel)
	end function polarization_iterator_get_quantum_numbers

	@ %def polarization_iterator_get_quantum_numbers
	@
	\subsection{Sparse Matrix}
	We introduce a simple implementation of a sparse matrix that can represent
	polarization (or similar concepts) for transfer to I/O within the
	program. It consists of an integer array that represents the index
	values, and a complex array that represents the nonvanishing entries. The
	number of nonvanishing entries must be known for initialization, but the
	entries are filled one at a time.

	Here is a base type without the special properties of a spin-density matrix.
	<<Polarizations: public>>=
	public :: smatrix_t
	<<Polarizations: types>>=
	type :: smatrix_t
	private
	integer :: dim = 0
	integer :: n_entry = 0
	integer, dimension(:,:), allocatable :: index
	complex(default), dimension(:), allocatable :: value
	contains
	<<Polarizations: smatrix: TBP>>
	end type smatrix_t

	@ %def smatrix_t
	@ Output.
	<<Polarizations: smatrix: TBP>>=
	procedure :: write => smatrix_write
	<<Polarizations: procedures>>=
	subroutine smatrix_write (object, unit, indent)
	class(smatrix_t), intent(in) :: object
	integer, intent(in), optional :: unit, indent
	integer :: u, i, ind
	u = given_output_unit (unit)
	ind = 0; if (present (indent)) ind = indent
	if (allocated (object%value)) then
	if (size (object%value) > 0) then
	do i = 1, object%n_entry
	write (u, "(1x,A,'@(')", advance="no") repeat (" ", ind)
	write (u, "(SP,9999(I2.1,':',1x))", advance="no") &
	object%index(:,i)
	write (u, "('('," // FMT_19 // ",','," // FMT_19 // &
	",'))')") object%value(i)
	end do
	else
	write (u, "(1x,A)", advance="no") repeat (" ", ind)
	write (u, "(A)") "[empty matrix]"
	end if
	else
	write (u, "(1x,A)", advance="no") repeat (" ", ind)
	write (u, "(A)") "[undefined matrix]"
	end if
	end subroutine smatrix_write

	@ %def smatrix_write
	@ Initialization: allocate arrays to the correct size. We specify both the
	dimension of the matrix (if different from two, this is rather a generic
	tensor) and the number of nonvanishing entries.
	<<Polarizations: smatrix: TBP>>=
	procedure :: init => smatrix_init
	<<Polarizations: procedures>>=
	subroutine smatrix_init (smatrix, dim, n_entry)
	class(smatrix_t), intent(out) :: smatrix
	integer, intent(in) :: dim
	integer, intent(in) :: n_entry
	smatrix%dim = dim
	smatrix%n_entry = n_entry
	allocate (smatrix%index (dim, n_entry))
	allocate (smatrix%value (n_entry))
	end subroutine smatrix_init

	@ %def smatrix_init
	@ Fill: one entry at a time.
	<<Polarizations: smatrix: TBP>>=
	procedure :: set_entry => smatrix_set_entry
	<<Polarizations: procedures>>=
	subroutine smatrix_set_entry (smatrix, i, index, value)
	class(smatrix_t), intent(inout) :: smatrix
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: index
	complex(default), intent(in) :: value
	smatrix%index(:,i) = index
	smatrix%value(i) = value
	end subroutine smatrix_set_entry

	@ %def smatrix_set_entry
	@
	<<Polarizations: smatrix: TBP>>=
	procedure :: exists => smatrix_exists
	<<Polarizations: procedures>>=
	elemental function smatrix_exists (smatrix) result (exist)
	logical :: exist
	class(smatrix_t), intent(in) :: smatrix
	exist = .not. all (smatrix%value == 0)
	end function smatrix_exists

	@ %def smatrix_exists
	@
	\subsection{Polarization Matrix}
	As an extension of the more generic [[smatrix]] type, we implement a proper
	spin-density matrix. After the matrix has been filled, we can fix spin type
	and multiplicity for a particle, check the matrix for consistency, and
	normalize it if necessary.

	This implementation does not have an antiparticle flag, just
	like the state matrix object. We therefore cannot account for sign
	flips when using this object.

	TODO: The [[pure]] flag is for informational purposes only, and it
	only represents a necessary condition if spin is greater than $1/2$.
	We may either check purity for all spins or drop this.
	<<Polarizations: public>>=
	public :: pmatrix_t
	<<Polarizations: types>>=
	type, extends (smatrix_t) :: pmatrix_t
	private
	integer :: spin_type = 0
	integer :: multiplicity = 0
	logical :: massive = .true.
	integer :: chirality = 0
	real(default) :: degree = 1
	logical :: pure = .false.
	contains
	<<Polarizations: pmatrix: TBP>>
	end type pmatrix_t

	@ %def pmatrix_t
	@ Output, including extra data. (The [[indent]] argument is ignored.)
	<<Polarizations: pmatrix: TBP>>=
	procedure :: write => pmatrix_write
	<<Polarizations: procedures>>=
	subroutine pmatrix_write (object, unit, indent)
	class(pmatrix_t), intent(in) :: object
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Polarization: spin density matrix"
	write (u, "(3x,A,I0)") "spin type = ", object%spin_type
	write (u, "(3x,A,I0)") "multiplicity = ", object%multiplicity
	write (u, "(3x,A,L1)") "massive = ", object%massive
	write (u, "(3x,A,I0)") "chirality = ", object%chirality
	write (u, "(3x,A,F10.7)") "pol.degree =", object%degree
	write (u, "(3x,A,L1)") "pure state = ", object%pure
	call object%smatrix_t%write (u, 1)
	end subroutine pmatrix_write

	@ %def pmatrix_write
	@ This assignment is trivial, but must be coded explicitly.
	<<Polarizations: pmatrix: TBP>>=
	generic :: assignment(=) => pmatrix_assign_from_smatrix
	procedure, private :: pmatrix_assign_from_smatrix
	<<Polarizations: procedures>>=
	subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix)
	class(pmatrix_t), intent(out) :: pmatrix
	type(smatrix_t), intent(in) :: smatrix
	pmatrix%smatrix_t = smatrix
	end subroutine pmatrix_assign_from_smatrix

	@ %def pmatrix_assign_from_smatrix
	@ Declare spin, multiplicity, and polarization degree. Check whether all
	entries fit, and whether this is a valid matrix.

	The required properties are:
	\begin{enumerate}
	\item all entries apply to the given spin and mass type
	\item the diagonal is real
	\item only the upper of corresponding off-diagonal elements is specified,
	i.e., the row index is less than the column index
	\item the trace is nonnegative and equal to the polarization degree (the
	remainder, proportional to the unit matrix, is understood to be present)
	\item the trace of the matrix square is positive and less or equal
	to the trace of the matrix itself, which is the polarization degree.
	\item If the trace of the matrix square and the trace of the matrix are unity,
	we may have a pure state. (For spin up to $1/2$, this is actually
	sufficient.)
	\end{enumerate}
	<<Polarizations: pmatrix: TBP>>=
	procedure :: normalize => pmatrix_normalize
	<<Polarizations: procedures>>=
	subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance)
	class(pmatrix_t), intent(inout) :: pmatrix
	type(flavor_t), intent(in) :: flv
	real(default), intent(in), optional :: degree
	real(default), intent(in), optional :: tolerance
	integer :: i, hmax
	logical :: fermion, ok
	real(default) :: trace, trace_sq
	real(default) :: tol
	tol = 0; if (present (tolerance)) tol = tolerance
	pmatrix%spin_type = flv%get_spin_type ()
	pmatrix%massive = flv%get_mass () /= 0
	if (.not. pmatrix%massive) then
	if (flv%is_left_handed ()) then
	pmatrix%chirality = -1
	else if (flv%is_right_handed ()) then
	pmatrix%chirality = +1
	end if
	end if
	if (pmatrix%spin_type == SCALAR) then
	pmatrix%multiplicity = 1
	else if (pmatrix%massive) then
	pmatrix%multiplicity = pmatrix%spin_type
	else if (pmatrix%chirality == 0) then
	pmatrix%multiplicity = 2
	else
	pmatrix%multiplicity = 1
	end if
	if (present (degree)) then
	if (degree < 0 .or. degree > 1) &
	call msg_error ("polarization degree must be between 0 and 1")
	pmatrix%degree = degree
	end if
	if (size (pmatrix%index, 1) /= 2) call error ("wrong array rank")
	fermion = mod (pmatrix%spin_type, 2) == 0
	hmax = pmatrix%spin_type / 2
	if (pmatrix%n_entry > 0) then
	if (fermion) then
	if (pmatrix%massive) then
	ok = all (pmatrix%index /= 0) &
	.and. all (abs (pmatrix%index) <= hmax)
	else if (pmatrix%chirality == -1) then
	ok = all (pmatrix%index == -hmax)
	else if (pmatrix%chirality == +1) then
	ok = all (pmatrix%index == +hmax)
	else
	ok = all (abs (pmatrix%index) == hmax)
	end if
	else
	if (pmatrix%massive) then
	ok = all (abs (pmatrix%index) <= hmax)
	else
	ok = all (abs (pmatrix%index) == hmax)
	end if
	end if
	if (.not. ok) call error ("illegal index value")
	else
	pmatrix%degree = 0
	pmatrix%pure = pmatrix%multiplicity == 1
	return
	end if
	trace = 0
	do i = 1, pmatrix%n_entry
	associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
	if (index(1) == index(2)) then
	if (abs (aimag (value)) > tol) call error ("diagonal must be real")
	value = real (value, kind=default)
	trace = trace + value

	else if (any (pmatrix%index(1,:) == index(2) &
	.and. pmatrix%index(2,:) == index(1))) then
	call error ("redundant off-diagonal entry")
	else if (index(2) < index (1)) then
	index = index([2,1])
	value = conjg (value)
	end if
	end associate
	end do
	if (abs (trace) <= tol) call error ("trace must not vanish")
	trace = real (trace, kind=default)
	pmatrix%value = pmatrix%value / trace * pmatrix%degree
	trace_sq = (1 - pmatrix%degree ** 2) / pmatrix%multiplicity
	do i = 1, pmatrix%n_entry
	associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
	if (index(1) == index(2)) then
	trace_sq = trace_sq + abs (value) ** 2
	else
	trace_sq = trace_sq + 2 * abs (value) ** 2
	end if
	end associate
	end do
	if (pmatrix%multiplicity == 1) then
	pmatrix%pure = .true.
	else if (abs (trace_sq - 1) <= tol) then
	pmatrix%pure = .true.
	else if (trace_sq - 1 > tol .or. trace_sq < -tol) then
	print *, "Trace of matrix square = ", trace_sq
	call error ("not permissible as density matrix")
	end if
	contains
	subroutine error (msg)
	character(*), intent(in) :: msg
	call pmatrix%write ()
	call msg_fatal ("Spin density matrix: " // msg)
	end subroutine error
	end subroutine pmatrix_normalize

	@ %def pmatrix_normalize
	@
	A polarized matrix is defined as one with a positive polarization degree, even
	if the actual matrix is trivial.
	<<Polarizations: pmatrix: TBP>>=
	procedure :: is_polarized => pmatrix_is_polarized
	<<Polarizations: procedures>>=
	elemental function pmatrix_is_polarized (pmatrix) result (flag)
	class(pmatrix_t), intent(in) :: pmatrix
	logical :: flag
	flag = pmatrix%degree > 0
	end function pmatrix_is_polarized

	@ %def pmatrix_is_polarized
	@
	Check if there are only diagonal entries.
	<<Polarizations: pmatrix: TBP>>=
	procedure :: is_diagonal => pmatrix_is_diagonal
	<<Polarizations: procedures>>=
	elemental function pmatrix_is_diagonal (pmatrix) result (flag)
	class(pmatrix_t), intent(in) :: pmatrix
	logical :: flag
	flag = all (pmatrix%index(1,:) == pmatrix%index(2,:))
	end function pmatrix_is_diagonal

	@ %def pmatrix_is_diagonal
	@
	Check if there are only diagonal entries.
	<<Polarizations: pmatrix: TBP>>=
	procedure :: get_simple_pol => pmatrix_get_simple_pol
	<<Polarizations: procedures>>=
	elemental function pmatrix_get_simple_pol (pmatrix) result (pol)
	class(pmatrix_t), intent(in) :: pmatrix
	real(default) :: pol
	if (pmatrix%is_polarized ()) then
	select case (size (pmatrix%value))
	case (0)
	pol = 0
	case (1)
	pol = pmatrix%index (1,1) * pmatrix%degree
	case (2)
	pol = 42
	end select
	else
	pol = 0
	end if
	end function pmatrix_get_simple_pol

	@ %def pmatrix_get_simple_pol
	@
	\subsection{Data Transformation}
	Create a [[polarization_t]] object from the contents of a normalized
	[[pmatrix_t]] object. We scan the entries as present in [[pmatrix]] and
	transform them into a density matrix, if necessary. The density
	matrix then initializes the Bloch vector. This is
	analogous to [[polarization_init_state_matrix]].

	There is a subtlety associated with massless particles. Since the
	[[pmatrix]] doesn't contain the full density matrix but just the
	nontrivial part, we have to initialize the polarization object with
	the massless equipartion, which contains nonzero entries for the
	Cartan generators. The [[set]] method therefore should not erase
	those initial contents. This is a constraint for the implementation
	of [[set]], as applied to the Bloch vector.

	As mentioned above, [[pmatrix_t]] does not support an
	antiparticle flag.
	<<Polarizations: polarization: TBP>>=
	procedure :: init_pmatrix => polarization_init_pmatrix
	<<Polarizations: procedures>>=
	subroutine polarization_init_pmatrix (pol, pmatrix)
	class(polarization_t), intent(out) :: pol
	type(pmatrix_t), intent(in) :: pmatrix
	integer :: d, i, j, k, h1, h2
	complex(default), dimension(:,:), allocatable :: r
	call pol%init_generic ( &
	spin_type = pmatrix%spin_type, &
	multiplicity = pmatrix%multiplicity, &
	anti = .false., & !!! SUFFICIENT?
	left_handed = pmatrix%chirality < 0, &
	right_handed = pmatrix%chirality > 0)
	if (pol%bv%is_polarized ()) then
	d = pol%bv%get_n_states ()
	allocate (r (d, d), source = (0._default, 0._default))
	if (d == pmatrix%multiplicity) then
	do i = 1, d
	r(i,i) = (1 - pmatrix%degree) / d
	end do
	else if (d > pmatrix%multiplicity) then
	r(1,1) = (1 - pmatrix%degree) / 2
	r(d,d) = r(1,1)
	end if
	do k = 1, size (pmatrix%value)
	h1 = pmatrix%index(1,k)
	h2 = pmatrix%index(2,k)
	i = pol%bv%hel_index (h1)
	j = pol%bv%hel_index (h2)
	r(i,j) = r(i,j) + pmatrix%value(k)
	r(j,i) = conjg (r(i,j))
	end do
	call pol%bv%set (r)
	end if
	end subroutine polarization_init_pmatrix

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

	module polarizations_ut
	use unit_tests
	use polarizations_uti

	<<Standard module head>>

	<<Polarizations: public test>>

	contains

	<<Polarizations: test driver>>

	end module polarizations_ut
	@ %def polarizations_ut
	@
	<<[[polarizations_uti.f90]]>>=
	<<File header>>

	module polarizations_uti

	<<Use kinds>>
	use flavors
	use model_data

	use polarizations

	<<Standard module head>>

	<<Polarizations: test declarations>>

	contains

	<<Polarizations: tests>>

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

	@ %def polarizations_test
	@
	\subsubsection{Polarization type}
	Checking the setup for polarization.
	<<Polarizations: execute tests>>=
	call test (polarization_1, "polarization_1", &
	"check polarization setup", &
	u, results)
	<<Polarizations: test declarations>>=
	public :: polarization_1
	<<Polarizations: tests>>=
	subroutine polarization_1 (u)
	use os_interface
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(polarization_t) :: pol
	type(flavor_t) :: flv
	real(default), dimension(3) :: alpha
	real(default) :: r, theta, phi
	real(default), parameter :: tolerance = 1.E-14_default

	write (u, "(A)") "* Test output: polarization_1"
	write (u, "(A)") "* Purpose: test polarization setup"
	write (u, "(A)")

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

	call model%init_sm_test ()

	write (u, "(A)") "* Unpolarized fermion"
	write (u, "(A)")

	call flv%init (1, model)
	call pol%init_unpolarized (flv)
	call pol%write (u, state_matrix = .true.)
	write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized fermion"
	write (u, "(A)")

	call pol%init_circular (flv, 0._default)
	call pol%write (u, state_matrix = .true., all_states = .false.)

	write (u, "(A)")
	write (u, "(A)") "* Transversally polarized fermion, phi=0"
	write (u, "(A)")

	call pol%init_transversal (flv, 0._default, 1._default)
	call pol%write (u, state_matrix = .true.)
	write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()

	write (u, "(A)")
	write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8"
	write (u, "(A)")

	call pol%init_transversal (flv, 0.9_default, 0.8_default)
	call pol%write (u, state_matrix = .true.)
	write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()

	write (u, "(A)")
	write (u, "(A)") "* All polarization directions of a fermion"
	write (u, "(A)")

	call pol%init_generic (flv)
	call pol%write (u, state_matrix = .true.)


	call flv%init (21, model)

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized gluon, frac=0.3"
	write (u, "(A)")

	call pol%init_circular (flv, 0.3_default)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)


	call flv%init (23, model)

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized massive vector, frac=-0.7"
	write (u, "(A)")

	call pol%init_circular (flv, -0.7_default)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized massive vector"
	write (u, "(A)")

	call pol%init_circular (flv, 1._default)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4"
	write (u, "(A)")

	call pol%init_longitudinal (flv, 0.4_default)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(A)") "* Longitudinally polarized massive vector"
	write (u, "(A)")

	call pol%init_longitudinal (flv, 1._default)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(A)") "* Diagonally polarized massive vector"
	write (u, "(A)")

	call pol%init_diagonal &
	(flv, [2._default, 1._default, 0._default])
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(A)") "* All polarization directions of a massive vector"
	write (u, "(A)")

	call pol%init_generic (flv)
	call pol%write (u, state_matrix = .true.)
	call flv%init (21, model)

	write (u, "(A)")
	write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)"
	write (u, "(A)")

	alpha = [0.2_default, 0.4_default, 0.6_default]
	call pol%init_axis (flv, alpha)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(1X,A)") "Recovered axis:"
	alpha = pol%get_axis ()
	write (u, "(3(1X,F10.7))") alpha

	write (u, "(A)")
	write (u, "(A)") "* Angle polarization (0.5, 0.6, -1)"
	r = 0.5_default
	theta = 0.6_default
	phi = -1._default
	call pol%init_angles (flv, r, theta, phi)
	write (u, "(A)")
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)

	write (u, "(A)")
	write (u, "(1X,A)") "Recovered parameters (r, theta, phi):"
	call pol%to_angles (r, theta, phi)
	write (u, "(3(1x,F10.7))") r, theta, phi

	call model%final ()

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

	end subroutine polarization_1

	@ %def polarization_1
	@
	\subsubsection{Sparse-Matrix type}
	Use a sparse density matrix universally as the input for setting up
	polarization.
	<<Polarizations: execute tests>>=
	call test (polarization_2, "polarization_2", &
	"matrix polarization setup", &
	u, results)
	<<Polarizations: test declarations>>=
	public :: polarization_2
	<<Polarizations: tests>>=
	subroutine polarization_2 (u)
	use os_interface
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(polarization_t) :: pol
	real(default), dimension(3) :: alpha
	type(pmatrix_t) :: pmatrix
	real(default), parameter :: tolerance = 1e-8_default

	write (u, "(A)") "* Test output: polarization_2"
	write (u, "(A)") "* Purpose: matrix polarization setup"
	write (u, "(A)")

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

	call model%init_sm_test ()

	write (u, "(A)") "* Unpolarized fermion"
	write (u, "(A)")

	call flv%init (1, model)
	call pmatrix%init (2, 0)
	call pmatrix%normalize (flv, 0._default, tolerance)
	call pmatrix%write (u)
	write (u, *)
	write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
	write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Transversally polarized fermion, phi=0"
	write (u, "(A)")

	call pmatrix%init (2, 3)
	call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
	call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
	call pmatrix%set_entry (3, [-1,+1], (1._default, 0._default))
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)
	write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
	write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8"
	write (u, "(A)")

	call pmatrix%init (2, 3)
	call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
	call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
	call pmatrix%set_entry (3, [-1,+1], exp ((0._default, -0.9_default)))
	call pmatrix%normalize (flv, 0.8_default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true.)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Left-handed massive fermion, frac=1"
	write (u, "(A)")

	call flv%init (11, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)
	write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
	write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Left-handed massive fermion, frac=0.8"
	write (u, "(A)")

	call flv%init (11, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
	call pmatrix%normalize (flv, 0.8_default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Left-handed massless fermion"
	write (u, "(A)")

	call flv%init (12, model)
	call pmatrix%init (2, 0)
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true.)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Right-handed massless fermion, frac=0.5"
	write (u, "(A)")

	call flv%init (-12, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
	call pmatrix%normalize (flv, 0.5_default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true.)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized gluon, frac=0.3"
	write (u, "(A)")

	call flv%init (21, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
	call pmatrix%normalize (flv, 0.3_default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized massive vector, frac=0.7"
	write (u, "(A)")

	call flv%init (23, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
	call pmatrix%normalize (flv, 0.7_default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Circularly polarized massive vector"
	write (u, "(A)")

	call flv%init (23, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4"
	write (u, "(A)")

	call flv%init (23, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
	call pmatrix%normalize (flv, 0.4_default, tolerance)
	call pmatrix%write (u)
	write (u, *)
	write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
	write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Longitudinally polarized massive vector"
	write (u, "(A)")

	call flv%init (23, model)
	call pmatrix%init (2, 1)
	call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)
	write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
	write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true., &
	all_states = .false., tolerance = tolerance)
	! call pol%final ()

	write (u, "(A)")
	write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)"
	write (u, "(A)")

	call flv%init (11, model)
	alpha = [0.2_default, 0.4_default, 0.6_default]
	alpha = alpha / sqrt (sum (alpha**2))
	call pmatrix%init (2, 3)
	call pmatrix%set_entry (1, [-1,-1], cmplx (1 - alpha(3), kind=default))
	call pmatrix%set_entry (2, [1,-1], &
	cmplx (alpha(1),-alpha(2), kind=default))
	call pmatrix%set_entry (3, [1,1], cmplx (1 + alpha(3), kind=default))
	call pmatrix%normalize (flv, 1._default, tolerance)
	call pmatrix%write (u)
	write (u, *)

	call pol%init_pmatrix (pmatrix)
	call pol%write (u, state_matrix = .true.)
	! call pol%final ()

	call model%final ()

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

	end subroutine polarization_2

	@ %def polarization_2
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Particles}
	This module defines the [[particle_t]] object type, and the methods
	and operations that deal with it.
	<<[[particles.f90]]>>=
	<<File header>>

	module particles

	<<Use kinds with double>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use format_utils, only: write_compressed_integer_array, write_separator
	use format_utils, only: pac_fmt
	use format_defs, only: FMT_16, FMT_19
	use numeric_utils
	use diagnostics
	use lorentz
	use phs_points, only: phs_point_t, assignment(=)
	use model_data
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices
	use interactions
	use subevents
	use polarizations
	use pdg_arrays, only: is_quark, is_gluon

	<<Standard module head>>

	<<Particles: public>>

	<<Particles: parameters>>

	<<Particles: types>>

	<<Particles: interfaces>>

	contains

	<<Particles: procedures>>

	end module particles
	@ %def particles
	@
	\subsection{The particle type}
	\subsubsection{Particle status codes}
	The overall status codes (incoming/outgoing etc.) are inherited from
	the module [[subevents]].

	Polarization status:
	<<Particles: parameters>>=
	integer, parameter, public :: PRT_UNPOLARIZED = 0
	integer, parameter, public :: PRT_DEFINITE_HELICITY = 1
	integer, parameter, public :: PRT_GENERIC_POLARIZATION = 2

	@ %def PRT_UNPOLARIZED PRT_DEFINITE_HELICITY PRT_GENERIC_POLARIZATION
	@
	\subsubsection{Definition}
	The quantum numbers are flavor (from which invariant particle
	properties can be derived), color, and polarization. The particle may
	be unpolarized. In this case, [[hel]] and [[pol]] are unspecified.
	If it has a definite helicity, the [[hel]] component is defined. If
	it has a generic polarization, the [[pol]] component is defined. For
	each particle we store the four-momentum and the invariant mass
	squared, i.e., the squared norm of the four-momentum. There is also
	an optional list of parent and child particles, for bookkeeping in
	physical events. The [[vertex]] is an optional component that consists of
	a Lorentz 4-vector, denoting the position and time of the vertex
	(displaced vertex/time). [[lifetime]] is an optional component that
	accounts for the finite lifetime $\tau$ of a decaying particle. In
	case there is no magnetic field etc., the true decay vertex of a
	particle in the detector would be $\vec{v}^\prime = \vec{v} + \tau
	\times \vec{p}/p^0$, where $p^0$ and $\vec{p}$ are the energy and
	3-momentum of the particle.

	<<Particles: public>>=
	public :: particle_t
	<<Particles: types>>=
	type :: particle_t
	!private
	integer :: status = PRT_UNDEFINED
	integer :: polarization = PRT_UNPOLARIZED
	type(flavor_t) :: flv
	type(color_t) :: col
	type(helicity_t) :: hel
	type(polarization_t) :: pol
	type(vector4_t) :: p = vector4_null
	real(default) :: p2 = 0
	type(vector4_t), allocatable :: vertex
	real(default), allocatable :: lifetime
	integer, dimension(:), allocatable :: parent
	integer, dimension(:), allocatable :: child
	contains
	<<Particles: particle: TBP>>
	end type particle_t

	@ %def particle_t
	@ Copy a particle. (Deep copy) This excludes the parent-child
	relations.
	<<Particles: particle: TBP>>=
	generic :: init => init_particle
	procedure :: init_particle => particle_init_particle
	<<Particles: procedures>>=
	subroutine particle_init_particle (prt_out, prt_in)
	class(particle_t), intent(out) :: prt_out
	type(particle_t), intent(in) :: prt_in
	prt_out%status = prt_in%status
	prt_out%polarization = prt_in%polarization
	prt_out%flv = prt_in%flv
	prt_out%col = prt_in%col
	prt_out%hel = prt_in%hel
	prt_out%pol = prt_in%pol
	prt_out%p = prt_in%p
	prt_out%p2 = prt_in%p2
	if (allocated (prt_in%vertex)) &
	allocate (prt_out%vertex, source=prt_in%vertex)
	if (allocated (prt_in%lifetime)) &
	allocate (prt_out%lifetime, source=prt_in%lifetime)
	end subroutine particle_init_particle

	@ %def particle_init_particle
	@ Initialize a particle using external information.
	<<Particles: particle: TBP>>=
	generic :: init => init_external
	procedure :: init_external => particle_init_external
	<<Particles: procedures>>=
	subroutine particle_init_external &
	(particle, status, pdg, model, col, anti_col, mom)
	class(particle_t), intent(out) :: particle
	integer, intent(in) :: status, pdg, col, anti_col
	class(model_data_t), pointer, intent(in) :: model
	type(vector4_t), intent(in) :: mom
	type(flavor_t) :: flavor
	type(color_t) :: color
	call flavor%init (pdg, model)
	call particle%set_flavor (flavor)
	call color%init_col_acl (col, anti_col)
	call particle%set_color (color)
	call particle%set_status (status)
	call particle%set_momentum (mom)
	end subroutine particle_init_external

	@ %def particle_init_external
	@ Initialize a particle using a single-particle state matrix which
	determines flavor, color, and polarization. The state matrix must
	have unique flavor and color. The factorization mode determines
	whether the particle is unpolarized, has definite helicity, or generic
	polarization. This mode is translated into the polarization status.
	<<Particles: particle: TBP>>=
	generic :: init => init_state
	procedure :: init_state => particle_init_state
	<<Particles: procedures>>=
	subroutine particle_init_state (prt, state, status, mode)
	class(particle_t), intent(out) :: prt
	type(state_matrix_t), intent(in), target :: state
	integer, intent(in) :: status, mode
	type(state_iterator_t) :: it
	prt%status = status
	call it%init (state)
	prt%flv = it%get_flavor (1)
	if (prt%flv%is_radiated ()) prt%status = PRT_BEAM_REMNANT
	prt%col = it%get_color (1)
	select case (mode)
	case (FM_SELECT_HELICITY)
	prt%hel = it%get_helicity (1)
	if (prt%hel%is_defined ()) then
	prt%polarization = PRT_DEFINITE_HELICITY
	end if
	case (FM_FACTOR_HELICITY)
	call prt%pol%init_state_matrix (state)
	prt%polarization = PRT_GENERIC_POLARIZATION
	end select
	end subroutine particle_init_state

	@ %def particle_init_state
	@ Finalizer.
	<<Particles: particle: TBP>>=
	procedure :: final => particle_final
	<<Particles: procedures>>=
	subroutine particle_final (prt)
	class(particle_t), intent(inout) :: prt
	if (allocated (prt%vertex)) deallocate (prt%vertex)
	if (allocated (prt%lifetime)) deallocate (prt%lifetime)
	end subroutine particle_final

	@ %def particle_final
	@
	\subsubsection{I/O}
	<<Particles: particle: TBP>>=
	procedure :: write => particle_write
	<<Particles: procedures>>=
	subroutine particle_write (prt, unit, testflag, compressed, polarization)
	class(particle_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag, compressed, polarization
	logical :: comp, pacified, pol
	integer :: u, h1, h2
	real(default) :: pp2
	character(len=7) :: fmt
	character(len=20) :: buffer
	comp = .false.; if (present (compressed)) comp = compressed
	pacified = .false.; if (present (testflag)) pacified = testflag
	pol = .true.; if (present (polarization)) pol = polarization
	call pac_fmt (fmt, FMT_19, FMT_16, testflag)
	u = given_output_unit (unit); if (u < 0) return
	pp2 = prt%p2
	if (pacified) call pacify (pp2, tolerance = 1E-10_default)
	select case (prt%status)
	case (PRT_UNDEFINED); write (u, "(1x, A)", advance="no") "[-]"
	case (PRT_BEAM); write (u, "(1x, A)", advance="no") "[b]"
	case (PRT_INCOMING); write (u, "(1x, A)", advance="no") "[i]"
	case (PRT_OUTGOING); write (u, "(1x, A)", advance="no") "[o]"
	case (PRT_VIRTUAL); write (u, "(1x, A)", advance="no") "[v]"
	case (PRT_RESONANT); write (u, "(1x, A)", advance="no") "[r]"
	case (PRT_BEAM_REMNANT); write (u, "(1x, A)", advance="no") "[x]"
	end select
	write (u, "(1x)", advance="no")
	if (comp) then
	write (u, "(A7,1X)", advance="no") char (prt%flv%get_name ())
	if (pol) then
	select case (prt%polarization)
	case (PRT_DEFINITE_HELICITY)
	! Integer helicity, assumed diagonal
	call prt%hel%get_indices (h1, h2)
	write (u, "(I2,1X)", advance="no") h1
	case (PRT_GENERIC_POLARIZATION)
	! No space for full density matrix here
	write (u, "(A2,1X)", advance="no") "*"
	case default
	! Blank entry if helicity is undefined
	write (u, "(A2,1X)", advance="no") " "
	end select
	end if
	write (u, "(2(I4,1X))", advance="no") &
	prt%col%get_col (), prt%col%get_acl ()
	call write_compressed_integer_array (buffer, prt%parent)
	write (u, "(A,1X)", advance="no") buffer
	call write_compressed_integer_array (buffer, prt%child)
	write (u, "(A,1X)", advance="no") buffer
	call prt%p%write(u, testflag = testflag, compressed = comp)
	write (u, "(F12.3)") pp2
	else
	call prt%flv%write (unit)
	if (prt%col%is_nonzero ()) then
	call color_write (prt%col, unit)
	end if
	if (pol) then
	select case (prt%polarization)
	case (PRT_DEFINITE_HELICITY)
	call prt%hel%write (unit)
	write (u, *)
	case (PRT_GENERIC_POLARIZATION)
	write (u, *)
	call prt%pol%write (unit, state_matrix = .true.)
	case default
	write (u, *)
	end select
	else
	write (u, *)
	end if
	call prt%p%write (unit, testflag = testflag)
	write (u, "(1x,A,1x," // fmt // ")") "T = ", pp2
	if (allocated (prt%parent)) then
	if (size (prt%parent) /= 0) then
	write (u, "(1x,A,40(1x,I0))") "Parents: ", prt%parent
	end if
	end if
	if (allocated (prt%child)) then
	if (size (prt%child) /= 0) then
	write (u, "(1x,A,40(1x,I0))") "Children:", prt%child
	end if
	end if
	if (allocated (prt%vertex)) then
	write (u, "(1x,A,1x," // fmt // ")") "Vtx t = ", prt%vertex%p(0)
	write (u, "(1x,A,1x," // fmt // ")") "Vtx x = ", prt%vertex%p(1)
	write (u, "(1x,A,1x," // fmt // ")") "Vtx y = ", prt%vertex%p(2)
	write (u, "(1x,A,1x," // fmt // ")") "Vtx z = ", prt%vertex%p(3)
	end if
	if (allocated (prt%lifetime)) then
	write (u, "(1x,A,1x," // fmt // ")") "Lifetime = ", &
	prt%lifetime
	end if
	end if
	end subroutine particle_write

	@ %def particle_write
	@ Binary I/O:
	<<Particles: particle: TBP>>=
	procedure :: write_raw => particle_write_raw
	procedure :: read_raw => particle_read_raw
	<<Particles: procedures>>=
	subroutine particle_write_raw (prt, u)
	class(particle_t), intent(in) :: prt
	integer, intent(in) :: u
	write (u) prt%status, prt%polarization
	call prt%flv%write_raw (u)
	call prt%col%write_raw (u)
	select case (prt%polarization)
	case (PRT_DEFINITE_HELICITY)
	call prt%hel%write_raw (u)
	case (PRT_GENERIC_POLARIZATION)
	call prt%pol%write_raw (u)
	end select
	call vector4_write_raw (prt%p, u)
	write (u) prt%p2
	write (u) allocated (prt%parent)
	if (allocated (prt%parent)) then
	write (u) size (prt%parent)
	write (u) prt%parent
	end if
	write (u) allocated (prt%child)
	if (allocated (prt%child)) then
	write (u) size (prt%child)
	write (u) prt%child
	end if
	write (u) allocated (prt%vertex)
	if (allocated (prt%vertex)) then
	call vector4_write_raw (prt%vertex, u)
	end if
	write (u) allocated (prt%lifetime)
	if (allocated (prt%lifetime)) then
	write (u) prt%lifetime
	end if
	end subroutine particle_write_raw

	subroutine particle_read_raw (prt, u, iostat)
	class(particle_t), intent(out) :: prt
	integer, intent(in) :: u
	integer, intent(out) :: iostat
	logical :: allocated_parent, allocated_child
	logical :: allocated_vertex, allocated_lifetime
	integer :: size_parent, size_child
	read (u, iostat=iostat) prt%status, prt%polarization
	call prt%flv%read_raw (u, iostat=iostat)
	call prt%col%read_raw (u, iostat=iostat)
	select case (prt%polarization)
	case (PRT_DEFINITE_HELICITY)
	call prt%hel%read_raw (u, iostat=iostat)
	case (PRT_GENERIC_POLARIZATION)
	call prt%pol%read_raw (u, iostat=iostat)
	end select
	call vector4_read_raw (prt%p, u, iostat=iostat)
	read (u, iostat=iostat) prt%p2
	read (u, iostat=iostat) allocated_parent
	if (allocated_parent) then
	read (u, iostat=iostat) size_parent
	allocate (prt%parent (size_parent))
	read (u, iostat=iostat) prt%parent
	end if
	read (u, iostat=iostat) allocated_child
	if (allocated_child) then
	read (u, iostat=iostat) size_child
	allocate (prt%child (size_child))
	read (u, iostat=iostat) prt%child
	end if
	read (u, iostat=iostat) allocated_vertex
	if (allocated_vertex) then
	allocate (prt%vertex)
	read (u, iostat=iostat) prt%vertex%p
	end if
	read (u, iostat=iostat) allocated_lifetime
	if (allocated_lifetime) then
	allocate (prt%lifetime)
	read (u, iostat=iostat) prt%lifetime
	end if
	end subroutine particle_read_raw

	@ %def particle_write_raw particle_read_raw
	@
	\subsubsection{Setting contents}
	Reset the status code. Where applicable, set $p^2$ assuming that the
	particle is on-shell.
	<<Particles: particle: TBP>>=
	procedure :: reset_status => particle_reset_status
	<<Particles: procedures>>=
	elemental subroutine particle_reset_status (prt, status)
	class(particle_t), intent(inout) :: prt
	integer, intent(in) :: status
	prt%status = status
	select case (status)
	case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
	prt%p2 = prt%flv%get_mass () ** 2
	end select
	end subroutine particle_reset_status

	@ %def particle_reset_status
	@ The color can be given explicitly.
	<<Particles: particle: TBP>>=
	procedure :: set_color => particle_set_color
	<<Particles: procedures>>=
	elemental subroutine particle_set_color (prt, col)
	class(particle_t), intent(inout) :: prt
	type(color_t), intent(in) :: col
	prt%col = col
	end subroutine particle_set_color

	@ %def particle_set_color
	@ The flavor can be given explicitly.
	<<Particles: particle: TBP>>=
	procedure :: set_flavor => particle_set_flavor
	<<Particles: procedures>>=
	subroutine particle_set_flavor (prt, flv)
	class(particle_t), intent(inout) :: prt
	type(flavor_t), intent(in) :: flv
	prt%flv = flv
	end subroutine particle_set_flavor

	@ %def particle_set_flavor
	@ As can the helicity.
	<<Particles: particle: TBP>>=
	procedure :: set_helicity => particle_set_helicity
	<<Particles: procedures>>=
	subroutine particle_set_helicity (prt, hel)
	class(particle_t), intent(inout) :: prt
	type(helicity_t), intent(in) :: hel
	prt%hel = hel
	end subroutine particle_set_helicity

	@ %def particle_set_helicity
	@ And the polarization.
	<<Particles: particle: TBP>>=
	procedure :: set_pol => particle_set_pol
	<<Particles: procedures>>=
	subroutine particle_set_pol (prt, pol)
	class(particle_t), intent(inout) :: prt
	type(polarization_t), intent(in) :: pol
	prt%pol = pol
	end subroutine particle_set_pol

	@ %def particle_set_pol
	@ Manually set the model for the particle flavor. This is required, e.g., if
	the particle has been read from file.
	<<Particles: particle: TBP>>=
	procedure :: set_model => particle_set_model
	<<Particles: procedures>>=
	subroutine particle_set_model (prt, model)
	class(particle_t), intent(inout) :: prt
	class(model_data_t), intent(in), target :: model
	call prt%flv%set_model (model)
	end subroutine particle_set_model

	@ %def particle_set_model
	@ The momentum is set independent of the quantum numbers.
	<<Particles: particle: TBP>>=
	procedure :: set_momentum => particle_set_momentum
	<<Particles: procedures>>=
	elemental subroutine particle_set_momentum (prt, p, p2, on_shell)
	class(particle_t), intent(inout) :: prt
	type(vector4_t), intent(in) :: p
	real(default), intent(in), optional :: p2
	logical, intent(in), optional :: on_shell
	prt%p = p
	if (present (on_shell)) then
	if (on_shell) then
	if (prt%flv%is_associated ()) then
	prt%p2 = prt%flv%get_mass () ** 2
	return
	end if
	end if
	end if
	if (present (p2)) then
	prt%p2 = p2
	else
	prt%p2 = p ** 2
	end if
	end subroutine particle_set_momentum

	@ %def particle_set_momentum
	@ Set resonance information. This should be done after momentum
	assignment, because we need to know wheter the particle is spacelike
	or timelike. The resonance flag is defined only for virtual
	particles.
	<<Particle: particle: TBP>>=
	procedure :: set_resonance_flag => particle_set_resonance_flag
	<<Particles: procedures>>=
	elemental subroutine particle_set_resonance_flag (prt, resonant)
	class(particle_t), intent(inout) :: prt
	logical, intent(in) :: resonant
	select case (prt%status)
	case (PRT_VIRTUAL)
	if (resonant) prt%status = PRT_RESONANT
	end select
	end subroutine particle_set_resonance_flag

	@ %def particle_set_resonance_flag
	@ Set children and parents information.
	<<Particles: particle: TBP>>=
	procedure :: set_children => particle_set_children
	procedure :: set_parents => particle_set_parents
	<<Particles: procedures>>=
	subroutine particle_set_children (prt, idx)
	class(particle_t), intent(inout) :: prt
	integer, dimension(:), intent(in) :: idx
	if (allocated (prt%child)) deallocate (prt%child)
	allocate (prt%child (count (idx /= 0)))
	prt%child = pack (idx, idx /= 0)
	end subroutine particle_set_children

	subroutine particle_set_parents (prt, idx)
	class(particle_t), intent(inout) :: prt
	integer, dimension(:), intent(in) :: idx
	if (allocated (prt%parent)) deallocate (prt%parent)
	allocate (prt%parent (count (idx /= 0)))
	prt%parent = pack (idx, idx /= 0)
	end subroutine particle_set_parents

	@ %def particle_set_children particle_set_parents
	@
	<<Particles: particle: TBP>>=
	procedure :: add_child => particle_add_child
	<<Particles: procedures>>=
	subroutine particle_add_child (prt, new_child)
	class(particle_t), intent(inout) :: prt
	integer, intent(in) :: new_child
	integer, dimension(:), allocatable :: idx
	integer :: n, i
	n = prt%get_n_children()
	if (n == 0) then
	call prt%set_children ([new_child])
	else
	do i = 1, n
	if (prt%child(i) == new_child) then
	return
	end if
	end do
	allocate (idx (1:n+1))
	idx(1:n) = prt%get_children ()
	idx(n+1) = new_child
	call prt%set_children (idx)
	end if
	end subroutine particle_add_child

	@ %def particle_add_child
	@
	<<Particles: particle: TBP>>=
	procedure :: add_children => particle_add_children
	<<Particles: procedures>>=
	subroutine particle_add_children (prt, new_child)
	class(particle_t), intent(inout) :: prt
	integer, dimension(:), intent(in) :: new_child
	integer, dimension(:), allocatable :: idx
	integer :: n
	n = prt%get_n_children()
	if (n == 0) then
	call prt%set_children (new_child)
	else
	allocate (idx (1:n+size(new_child)))
	idx(1:n) = prt%get_children ()
	idx(n+1:n+size(new_child)) = new_child
	call prt%set_children (idx)
	end if
	end subroutine particle_add_children

	@ %def particle_add_children
	@
	<<Particles: particle: TBP>>=
	procedure :: set_status => particle_set_status
	<<Particles: procedures>>=
	elemental subroutine particle_set_status (prt, status)
	class(particle_t), intent(inout) :: prt
	integer, intent(in) :: status
	prt%status = status
	end subroutine particle_set_status

	@ %def particle_set_status
	@
	<<Particles: particle: TBP>>=
	procedure :: set_polarization => particle_set_polarization
	<<Particles: procedures>>=
	subroutine particle_set_polarization (prt, polarization)
	class(particle_t), intent(inout) :: prt
	integer, intent(in) :: polarization
	prt%polarization = polarization
	end subroutine particle_set_polarization

	@ %def particle_set_polarization
	@
	<<Particles: particle: TBP>>=
	generic :: set_vertex => set_vertex_from_vector3, set_vertex_from_xyz, &
	set_vertex_from_vector4, set_vertex_from_xyzt
	procedure :: set_vertex_from_vector4 => particle_set_vertex_from_vector4
	procedure :: set_vertex_from_vector3 => particle_set_vertex_from_vector3
	procedure :: set_vertex_from_xyzt => particle_set_vertex_from_xyzt
	procedure :: set_vertex_from_xyz => particle_set_vertex_from_xyz
	<<Particles: procedures>>=
	subroutine particle_set_vertex_from_vector4 (prt, vertex)
	class(particle_t), intent(inout) :: prt
	type(vector4_t), intent(in) :: vertex
	if (allocated (prt%vertex)) deallocate (prt%vertex)
	allocate (prt%vertex, source=vertex)
	end subroutine particle_set_vertex_from_vector4

	subroutine particle_set_vertex_from_vector3 (prt, vertex)
	class(particle_t), intent(inout) :: prt
	type(vector3_t), intent(in) :: vertex
	type(vector4_t) :: vtx
	vtx = vector4_moving (0._default, vertex)
	if (allocated (prt%vertex)) deallocate (prt%vertex)
	allocate (prt%vertex, source=vtx)
	end subroutine particle_set_vertex_from_vector3

	subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t)
	class(particle_t), intent(inout) :: prt
	real(default), intent(in) :: vx, vy, vz, t
	type(vector4_t) :: vertex
	if (allocated (prt%vertex)) deallocate (prt%vertex)
	vertex = vector4_moving (t, vector3_moving ([vx, vy, vz]))
	allocate (prt%vertex, source=vertex)
	end subroutine particle_set_vertex_from_xyzt

	subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz)
	class(particle_t), intent(inout) :: prt
	real(default), intent(in) :: vx, vy, vz
	type(vector4_t) :: vertex
	if (allocated (prt%vertex)) deallocate (prt%vertex)
	vertex = vector4_moving (0._default, vector3_moving ([vx, vy, vz]))
	allocate (prt%vertex, source=vertex)
	end subroutine particle_set_vertex_from_xyz

	@ %def particle_set_vertex_from_vector3
	@ %def particle_set_vertex_from_vector4
	@ %def particle_set_vertex_from_xyz
	@ %def particle_set_vertex_from_xyzt
	@ Set the lifetime of a particle.
	<<Particles: particle: TBP>>=
	procedure :: set_lifetime => particle_set_lifetime
	<<Particles: procedures>>=
	elemental subroutine particle_set_lifetime (prt, lifetime)
	class(particle_t), intent(inout) :: prt
	real(default), intent(in) :: lifetime
	if (allocated (prt%lifetime)) deallocate (prt%lifetime)
	allocate (prt%lifetime, source=lifetime)
	end subroutine particle_set_lifetime

	@ %def particle_set_lifetime
	@
	\subsubsection{Accessing contents}
	The status code.
	<<Particles: particle: TBP>>=
	procedure :: get_status => particle_get_status
	<<Particles: procedures>>=
	elemental function particle_get_status (prt) result (status)
	integer :: status
	class(particle_t), intent(in) :: prt
	status = prt%status
	end function particle_get_status

	@ %def particle_get_status
	@ Return true if the status is either [[INCOMING]],
	[[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept, if
	[[keep_beams]] is set true.
	<<Particles: particle: TBP>>=
	procedure :: is_real => particle_is_real
	<<Particles: procedures>>=
	elemental function particle_is_real (prt, keep_beams) result (flag)
	logical :: flag, kb
	class(particle_t), intent(in) :: prt
	logical, intent(in), optional :: keep_beams
	kb = .false.
	if (present (keep_beams)) kb = keep_beams
	select case (prt%status)
	case (PRT_INCOMING, PRT_OUTGOING, PRT_RESONANT)
	flag = .true.
	case (PRT_BEAM)
	flag = kb
	case default
	flag = .false.
	end select
	end function particle_is_real

	@ %def particle_is_real
	@
	<<Particles: particle: TBP>>=
	procedure :: is_colored => particle_is_colored
	<<Particles: procedures>>=
	elemental function particle_is_colored (particle) result (flag)
	logical :: flag
	class(particle_t), intent(in) :: particle
	flag = particle%col%is_nonzero ()
	end function particle_is_colored

	@ %def particle_is_colored
	@ $[90,100]$ hopefully catches all of them and not too many.
	<<Particles: particle: TBP>>=
	procedure :: is_hadronic_beam_remnant => particle_is_hadronic_beam_remnant
	<<Particles: procedures>>=
	elemental function particle_is_hadronic_beam_remnant (particle) result (flag)
	class(particle_t), intent(in) :: particle
	logical :: flag
	integer :: pdg
	pdg = particle%flv%get_pdg ()
	flag = particle%status == PRT_BEAM_REMNANT .and. &
	abs(pdg) >= 90 .and. abs(pdg) <= 100
	end function particle_is_hadronic_beam_remnant

	@ %def particle_is_hadronic_beam_remnant
	@
	<<Particles: particle: TBP>>=
	procedure :: is_beam_remnant => particle_is_beam_remnant
	<<Particles: procedures>>=
	elemental function particle_is_beam_remnant (particle) result (flag)
	class(particle_t), intent(in) :: particle
	logical :: flag
	flag = particle%status == PRT_BEAM_REMNANT
	end function particle_is_beam_remnant

	@ %def particle_is_beam_remnant
	@ Polarization status.
	<<Particles: particle: TBP>>=
	procedure :: get_polarization_status => particle_get_polarization_status
	<<Particles: procedures>>=
	elemental function particle_get_polarization_status (prt) result (status)
	integer :: status
	class(particle_t), intent(in) :: prt
	status = prt%polarization
	end function particle_get_polarization_status

	@ %def particle_get_polarization_status
	@ Return the PDG code from the flavor component directly.
	<<Particles: particle: TBP>>=
	procedure :: get_pdg => particle_get_pdg
	<<Particles: procedures>>=
	elemental function particle_get_pdg (prt) result (pdg)
	integer :: pdg
	class(particle_t), intent(in) :: prt
	pdg = prt%flv%get_pdg ()
	end function particle_get_pdg

	@ %def particle_get_pdg
	@ Return the color and anticolor quantum numbers.
	<<Particles: particle: TBP>>=
	procedure :: get_color => particle_get_color
	<<Particles: procedures>>=
	pure function particle_get_color (prt) result (col)
	integer, dimension(2) :: col
	class(particle_t), intent(in) :: prt
	col(1) = prt%col%get_col ()
	col(2) = prt%col%get_acl ()
	end function particle_get_color

	@ %def particle_get_color
	@ Return a copy of the polarization density matrix.
	<<Particles: particle: TBP>>=
	procedure :: get_polarization => particle_get_polarization
	<<Particles: procedures>>=
	function particle_get_polarization (prt) result (pol)
	class(particle_t), intent(in) :: prt
	type(polarization_t) :: pol
	pol = prt%pol
	end function particle_get_polarization

	@ %def particle_get_polarization
	@ Return the flavor, color and helicity.
	<<Particles: particle: TBP>>=
	procedure :: get_flv => particle_get_flv
	procedure :: get_col => particle_get_col
	procedure :: get_hel => particle_get_hel
	<<Particles: procedures>>=
	function particle_get_flv (prt) result (flv)
	class(particle_t), intent(in) :: prt
	type(flavor_t) :: flv
	flv = prt%flv
	end function particle_get_flv

	function particle_get_col (prt) result (col)
	class(particle_t), intent(in) :: prt
	type(color_t) :: col
	col = prt%col
	end function particle_get_col

	function particle_get_hel (prt) result (hel)
	class(particle_t), intent(in) :: prt
	type(helicity_t) :: hel
	hel = prt%hel
	end function particle_get_hel

	@ %def particle_get_flv particle_get_col particle_get_hel
	@ Return the helicity (if defined and diagonal).
	<<Particles: particle: TBP>>=
	procedure :: get_helicity => particle_get_helicity
	<<Particles: procedures>>=
	elemental function particle_get_helicity (prt) result (hel)
	integer :: hel
	integer, dimension(2) :: hel_arr
	class(particle_t), intent(in) :: prt
	hel = 0
	if (prt%hel%is_defined () .and. prt%hel%is_diagonal ()) then
	hel_arr = prt%hel%to_pair ()
	hel = hel_arr (1)
	end if
	end function particle_get_helicity

	@ %def particle_get_helicity
	@ Return the number of children/parents
	<<Particles: particle: TBP>>=
	procedure :: get_n_parents => particle_get_n_parents
	procedure :: get_n_children => particle_get_n_children
	<<Particles: procedures>>=
	elemental function particle_get_n_parents (prt) result (n)
	integer :: n
	class(particle_t), intent(in) :: prt
	if (allocated (prt%parent)) then
	n = size (prt%parent)
	else
	n = 0
	end if
	end function particle_get_n_parents

	elemental function particle_get_n_children (prt) result (n)
	integer :: n
	class(particle_t), intent(in) :: prt
	if (allocated (prt%child)) then
	n = size (prt%child)
	else
	n = 0
	end if
	end function particle_get_n_children

	@ %def particle_get_n_parents particle_get_n_children
	@ Return the array of parents/children.
	<<Particles: particle: TBP>>=
	procedure :: get_parents => particle_get_parents
	procedure :: get_children => particle_get_children
	<<Particles: procedures>>=
	function particle_get_parents (prt) result (parent)
	class(particle_t), intent(in) :: prt
	integer, dimension(:), allocatable :: parent
	if (allocated (prt%parent)) then
	allocate (parent (size (prt%parent)))
	parent = prt%parent
	else
	allocate (parent (0))
	end if
	end function particle_get_parents

	function particle_get_children (prt) result (child)
	class(particle_t), intent(in) :: prt
	integer, dimension(:), allocatable :: child
	if (allocated (prt%child)) then
	allocate (child (size (prt%child)))
	child = prt%child
	else
	allocate (child (0))
	end if
	end function particle_get_children

	@ %def particle_get_children
	@
	<<Particles: particle: TBP>>=
	procedure :: has_children => particle_has_children
	<<Particles: procedures>>=
	elemental function particle_has_children (prt) result (has_children)
	logical :: has_children
	class(particle_t), intent(in) :: prt
	has_children = .false.
	if (allocated (prt%child)) then
	has_children = size (prt%child) > 0
	end if
	end function particle_has_children

	@ %def particle_has_children
	@
	<<Particles: particle: TBP>>=
	procedure :: has_parents => particle_has_parents
	<<Particles: procedures>>=
	elemental function particle_has_parents (prt) result (has_parents)
	logical :: has_parents
	class(particle_t), intent(in) :: prt
	has_parents = .false.
	if (allocated (prt%parent)) then
	has_parents = size (prt%parent) > 0
	end if
	end function particle_has_parents

	@ %def particle_has_parents
	@ Return momentum and momentum squared.
	<<Particles: particle: TBP>>=
	procedure :: get_momentum => particle_get_momentum
	procedure :: get_p2 => particle_get_p2
	<<Particles: procedures>>=
	elemental function particle_get_momentum (prt) result (p)
	type(vector4_t) :: p
	class(particle_t), intent(in) :: prt
	p = prt%p
	end function particle_get_momentum

	elemental function particle_get_p2 (prt) result (p2)
	real(default) :: p2
	class(particle_t), intent(in) :: prt
	p2 = prt%p2
	end function particle_get_p2

	@ %def particle_get_momentum particle_get_p2
	@ Return the particle vertex, if allocated.
	<<Particles: particle: TBP>>=
	procedure :: get_vertex => particle_get_vertex
	<<Particles: procedures>>=
	elemental function particle_get_vertex (prt) result (vtx)
	type(vector4_t) :: vtx
	class(particle_t), intent(in) :: prt
	if (allocated (prt%vertex)) then
	vtx = prt%vertex
	else
	vtx = vector4_null
	end if
	end function particle_get_vertex

	@ %def particle_get_vertex
	@ Return the lifetime of a particle.
	<<Particles: particle: TBP>>=
	procedure :: get_lifetime => particle_get_lifetime
	<<Particles: procedures>>=
	elemental function particle_get_lifetime (prt) result (lifetime)
	real(default) :: lifetime
	class(particle_t), intent(in) :: prt
	if (allocated (prt%lifetime)) then
	lifetime = prt%lifetime
	else
	lifetime = 0
	end if
	end function particle_get_lifetime

	@ %def particle_get_lifetime
	@
	<<Particles: particle: TBP>>=
	procedure :: momentum_to_pythia6 => particle_momentum_to_pythia6
	<<Particles: procedures>>=
	pure function particle_momentum_to_pythia6 (prt) result (p)
	real(double), dimension(1:5) :: p
	class(particle_t), intent(in) :: prt
	p = prt%p%to_pythia6 (sqrt (prt%p2))
	end function particle_momentum_to_pythia6

	@ %def particle_momentum_to_pythia6
	@
	\subsection{Particle sets}
	A particle set is what is usually called an event: an array of
	particles. The individual particle entries carry momentum, quantum
	numbers, polarization, and optionally connections. There is (also
	optionally) a correlated state-density matrix that maintains spin
	correlations that are lost in the individual particle entries.
	<<Particles: public>>=
	public :: particle_set_t
	<<Particles: types>>=
	type :: particle_set_t
	! private !!!
	integer :: n_beam = 0
	integer :: n_in = 0
	integer :: n_vir = 0
	integer :: n_out = 0
	integer :: n_tot = 0
	integer :: factorization_mode = FM_IGNORE_HELICITY
	type(particle_t), dimension(:), allocatable :: prt
	type(state_matrix_t) :: correlated_state
	contains
	<<Particles: particle set: TBP>>
	end type particle_set_t

	@ %def particle_set_t
	@ A particle set can be initialized from an interaction or from a
	HepMC event record.
	<<Particles: particle set: TBP>>=
	generic :: init => init_interaction
	procedure :: init_interaction => particle_set_init_interaction
	@ When a particle set is initialized from a given interaction, we have
	to determine the branch within the original state matrix that fixes
	the particle quantum numbers. This is done with the appropriate
	probabilities, based on a random number [[x]]. The [[mode]]
	determines whether the individual particles become unpolarized, or
	take a definite (diagonal) helicity, or acquire single-particle
	polarization matrices. The flag [[keep_correlations]] tells whether
	the spin-correlation matrix is to be calculated and stored in addition
	to the particles. The flag [[keep_virtual]] tells whether virtual
	particles should be dropped. Note that if virtual particles are
	dropped, the spin-correlation matrix makes no sense, and parent-child
	relations are not set.

	For a correct disentangling of color and flavor (in the presence of
	helicity), we consider two interactions. [[int]] has no color
	information, and is used to select a flavor state. Consequently, we
	trace over helicities here. [[int_flows]] contains color-flow and
	potentially helicity information, but is useful only after the flavor
	combination has been chosen. So this interaction is used to select
	helicity and color, but restricted to the selected flavor combination.

	[[int]] and [[int_flows]] may be identical if there is only a single
	(or no) color flow. If there is just a single flavor combination,
	[[x(1)]] can be set to zero.

	The current algorithm of evaluator convolution requires that the beam
	particles are assumed outgoing (in the beam interaction) and become
	virtual in all derived interactions. In the particle set they should
	be re-identified as incoming. The optional integer [[n_incoming]]
	can be used to perform this correction.

	The flag [[is_valid]] is false if factorization of the state is not
	possible, in particular if the squared matrix element is zero.
	<<Particles: procedures>>=
	subroutine particle_set_init_interaction &
	(particle_set, is_valid, int, int_flows, mode, x, &
	keep_correlations, keep_virtual, n_incoming, qn_select)
	class(particle_set_t), intent(out) :: particle_set
	logical, intent(out) :: is_valid
	type(interaction_t), intent(in), target :: int, int_flows
	integer, intent(in) :: mode
	real(default), dimension(2), intent(in) :: x
	logical, intent(in) :: keep_correlations, keep_virtual
	integer, intent(in), optional :: n_incoming
	type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select
	type(state_matrix_t), dimension(:), allocatable, target :: flavor_state
	type(state_matrix_t), dimension(:), allocatable, target :: single_state
	integer :: n_in, n_vir, n_out, n_tot
	type(quantum_numbers_t), dimension(:,:), allocatable :: qn
	logical :: ok
	integer :: i, j
	if (present (n_incoming)) then
	n_in = n_incoming
	n_vir = int%get_n_vir () - n_incoming
	else
	n_in = int%get_n_in ()
	n_vir = int%get_n_vir ()
	end if
	n_out = int%get_n_out ()
	n_tot = int%get_n_tot ()
	particle_set%n_in = n_in
	particle_set%n_out = n_out
	if (keep_virtual) then
	particle_set%n_vir = n_vir
	particle_set%n_tot = n_tot
	else
	particle_set%n_vir = 0
	particle_set%n_tot = n_in + n_out
	end if
	particle_set%factorization_mode = mode
	allocate (qn (n_tot, 1))
	if (.not. present (qn_select)) then
	call int%factorize &
	(FM_IGNORE_HELICITY, x(1), is_valid, flavor_state)
	do i = 1, n_tot
	qn(i,:) = flavor_state(i)%get_quantum_number (1)
	end do
	else
	do i = 1, n_tot
	qn(i,:) = qn_select(i)
	end do
	is_valid = .true.
	end if
	if (keep_correlations .and. keep_virtual) then
	call particle_set%correlated_state%final ()
	call int_flows%factorize (mode, x(2), ok, &
	single_state, particle_set%correlated_state, qn(:,1))
	else
	call int_flows%factorize (mode, x(2), ok, &
	single_state, qn_in=qn(:,1))
	end if
	is_valid = is_valid .and. ok
	allocate (particle_set%prt (particle_set%n_tot))
	j = 1
	do i = 1, n_tot
	if (i <= n_in) then
	call particle_set%prt(j)%init (single_state(i), PRT_INCOMING, mode)
	call particle_set%prt(j)%set_momentum (int%get_momentum (i))
	else if (i <= n_in + n_vir) then
	if (.not. keep_virtual) cycle
	call particle_set%prt(j)%init &
	(single_state(i), PRT_VIRTUAL, mode)
	call particle_set%prt(j)%set_momentum (int%get_momentum (i))
	else
	call particle_set%prt(j)%init (single_state(i), PRT_OUTGOING, mode)
	call particle_set%prt(j)%set_momentum &
	(int%get_momentum (i), on_shell = .true.)
	end if
	if (keep_virtual) then
	call particle_set%prt(j)%set_children &
	(interaction_get_children (int, i))
	call particle_set%prt(j)%set_parents &
	(interaction_get_parents (int, i))
	end if
	j = j + 1
	end do
	if (keep_virtual) then
	call particle_set_resonance_flag &
	(particle_set%prt, int%get_resonance_flags ())
	end if
	if (allocated (flavor_state)) then
	do i = 1, size(flavor_state)
	call flavor_state(i)%final ()
	end do
	end if
	do i = 1, size(single_state)
	call single_state(i)%final ()
	end do
	end subroutine particle_set_init_interaction

	@ %def particle_set_init_interaction
	@ Duplicate generic binding, to make sure that assignment works as it should.
	<<Particles: particle set: TBP>>=
	generic :: assignment(=) => init_particle_set
	generic :: init => init_particle_set
	procedure :: init_particle_set => particle_set_init_particle_set
	<<Particles: procedures>>=
	subroutine particle_set_init_particle_set (pset_out, pset_in)
	class(particle_set_t), intent(out) :: pset_out
	type(particle_set_t), intent(in) :: pset_in
	integer :: i
	pset_out%n_beam = pset_in%n_beam
	pset_out%n_in = pset_in%n_in
	pset_out%n_vir = pset_in%n_vir
	pset_out%n_out = pset_in%n_out
	pset_out%n_tot = pset_in%n_tot
	pset_out%factorization_mode = pset_in%factorization_mode
	if (allocated (pset_in%prt)) then
	allocate (pset_out%prt (size (pset_in%prt)))
	do i = 1, size (pset_in%prt)
	pset_out%prt(i) = pset_in%prt(i)
	end do
	end if
	pset_out%correlated_state = pset_in%correlated_state
	end subroutine particle_set_init_particle_set

	@ %def particle_set_init_particle_set
	@ Manually set the model for the stored particles.
	<<Particles: particle set: TBP>>=
	procedure :: set_model => particle_set_set_model
	<<Particles: procedures>>=
	subroutine particle_set_set_model (particle_set, model)
	class(particle_set_t), intent(inout) :: particle_set
	class(model_data_t), intent(in), target :: model
	integer :: i
	do i = 1, particle_set%n_tot
	call particle_set%prt(i)%set_model (model)
	end do
	call particle_set%correlated_state%set_model (model)
	end subroutine particle_set_set_model

	@ %def particle_set_set_model
	@ Pointer components are hidden inside the particle polarization, and
	in the correlated state matrix.
	<<Particles: particle set: TBP>>=
	procedure :: final => particle_set_final
	<<Particles: procedures>>=
	subroutine particle_set_final (particle_set)
	class(particle_set_t), intent(inout) :: particle_set
	integer :: i
	if (allocated (particle_set%prt)) then
	do i = 1, size(particle_set%prt)
	call particle_set%prt(i)%final ()
	end do
	deallocate (particle_set%prt)
	end if
	call particle_set%correlated_state%final ()
	end subroutine particle_set_final

	@ %def particle_set_final
	@
	\subsection{Manual build}
	Basic initialization. Just allocate with a given number of beam, incoming,
	virtual, and outgoing particles.
	<<Particles: particle set: TBP>>=
	procedure :: basic_init => particle_set_basic_init
	<<Particles: procedures>>=
	subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out)
	class(particle_set_t), intent(out) :: particle_set
	integer, intent(in) :: n_beam, n_in, n_vir, n_out
	particle_set%n_beam = n_beam
	particle_set%n_in = n_in
	particle_set%n_vir = n_vir
	particle_set%n_out = n_out
	particle_set%n_tot = n_beam + n_in + n_vir + n_out
	allocate (particle_set%prt (particle_set%n_tot))
	end subroutine particle_set_basic_init

	@ %def particle_set_basic_init
	@
	Build a particle set from scratch. This is used for testing
	purposes. The ordering of particles in the result is
	beam-incoming-remnant-virtual-outgoing.

	Parent-child relations:
	\begin{itemize}
	\item
	Beams are parents of incoming and beam remnants. The assignment is
	alternating (first beam, second beam).
	\item
	Incoming are parents of virtual and outgoing, collectively.
	\end{itemize}
	More specific settings, such as resonance histories, cannot be set
	this way.

	Beam-remnant particles are counted as virtual, but have a different
	status code.

	We assume that the [[pdg]] array has the correct size.
	<<Particles: particle set: TBP>>=
	procedure :: init_direct => particle_set_init_direct
	<<Particles: procedures>>=
	subroutine particle_set_init_direct (particle_set, &
	n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
	class(particle_set_t), intent(out) :: particle_set
	integer, intent(in) :: n_beam
	integer, intent(in) :: n_in
	integer, intent(in) :: n_rem
	integer, intent(in) :: n_vir
	integer, intent(in) :: n_out
	integer, dimension(:), intent(in) :: pdg
	class(model_data_t), intent(in), target :: model
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i, k, n
	call particle_set%basic_init (n_beam, n_in, n_rem+n_vir, n_out)
	n = 0
	call particle_set%prt(n+1:n+n_beam)%reset_status (PRT_BEAM)
	do i = n+1, n+n_beam
	call particle_set%prt(i)%set_children &
	([(k, k=i+n_beam, n+n_beam+n_in+n_rem, 2)])
	end do
	n = n + n_beam
	call particle_set%prt(n+1:n+n_in)%reset_status (PRT_INCOMING)
	do i = n+1, n+n_in
	if (n_beam > 0) then
	call particle_set%prt(i)%set_parents &
	([i-n_beam])
	end if
	call particle_set%prt(i)%set_children &
	([(k, k=n+n_in+n_rem+1, n+n_in+n_rem+n_vir+n_out)])
	end do
	n = n + n_in
	call particle_set%prt(n+1:n+n_rem)%reset_status (PRT_BEAM_REMNANT)
	do i = n+1, n+n_rem
	if (n_beam > 0) then
	call particle_set%prt(i)%set_parents &
	([i-n_in-n_beam])
	end if
	end do
	n = n + n_rem
	call particle_set%prt(n+1:n+n_vir)%reset_status (PRT_VIRTUAL)
	do i = n+1, n+n_vir
	call particle_set%prt(i)%set_parents &
	([(k, k=n-n_rem-n_in+1, n-n_rem)])
	end do
	n = n + n_vir
	call particle_set%prt(n+1:n+n_out)%reset_status (PRT_OUTGOING)
	do i = n+1, n+n_out
	call particle_set%prt(i)%set_parents &
	([(k, k=n-n_vir-n_rem-n_in+1, n-n_vir-n_rem)])
	end do
	allocate (flv (particle_set%n_tot))
	call flv%init (pdg, model)
	do k = n_beam+n_in+1, n_beam+n_in+n_rem
	call flv(k)%tag_radiated ()
	end do
	do i = 1, particle_set%n_tot
	call particle_set%prt(i)%set_flavor (flv(i))
	end do
	end subroutine particle_set_init_direct

	@ %def particle_set_init_direct
	@ Copy a particle set into a new, extended one. Use the mapping array to
	determine the new positions of particles. The new set contains [[n_new]]
	additional entries. Count the new, undefined particles as
	virtual.
	<<Particles: particle set: TBP>>=
	procedure :: transfer => particle_set_transfer
	<<Particles: procedures>>=
	subroutine particle_set_transfer (pset, source, n_new, map)
	class(particle_set_t), intent(out) :: pset
	class(particle_set_t), intent(in) :: source
	integer, intent(in) :: n_new
	integer, dimension(:), intent(in) :: map
	integer :: i
	call pset%basic_init &
	(source%n_beam, source%n_in, source%n_vir + n_new, source%n_out)
	pset%factorization_mode = source%factorization_mode
	do i = 1, source%n_tot
	call pset%prt(map(i))%reset_status (source%prt(i)%get_status ())
	call pset%prt(map(i))%set_flavor (source%prt(i)%get_flv ())
	call pset%prt(map(i))%set_color (source%prt(i)%get_col ())
	call pset%prt(map(i))%set_parents (map (source%prt(i)%get_parents ()))
	call pset%prt(map(i))%set_children (map (source%prt(i)%get_children ()))
	call pset%prt(map(i))%set_polarization &
	(source%prt(i)%get_polarization_status ())
	select case (source%prt(i)%get_polarization_status ())
	case (PRT_DEFINITE_HELICITY)
	call pset%prt(map(i))%set_helicity (source%prt(i)%get_hel ())
	case (PRT_GENERIC_POLARIZATION)
	call pset%prt(map(i))%set_pol (source%prt(i)%get_polarization ())
	end select
	end do
	end subroutine particle_set_transfer

	@ %def particle_set_transfer
	@ Insert a new particle as an intermediate into a previously empty position.

	Flavor and status are just set. Color is not set (but see below).
	The complicated part is reassigning parent-child relations. The
	inserted particle comes with an array [[child]] of its children which
	are supposed to be existing particles.

	We first scan all particles that come before the new insertion.
	Whenever a particle has children that coincide with the children of
	the new particle, those child entries are removed. (a) If the new
	particle has no parent entry yet, those child entries are replaced by
	the index of the new particle and simultaneously, the particle is
	registered as a parent of the new particle. (b) If the current particle
	already has a parent entry, those child entries are removed.

	When this is done, the new particle is registered as the (only) parent of its
	children.
	<<Particles: particle set: TBP>>=
	procedure :: insert => particle_set_insert
	<<Particles: procedures>>=
	subroutine particle_set_insert (pset, i, status, flv, child)
	class(particle_set_t), intent(inout) :: pset
	integer, intent(in) :: i
	integer, intent(in) :: status
	type(flavor_t), intent(in) :: flv
	integer, dimension(:), intent(in) :: child
	integer, dimension(:), allocatable :: p_child, parent
	integer :: j, k, c, n_parent
	logical :: no_match
	call pset%prt(i)%reset_status (status)
	call pset%prt(i)%set_flavor (flv)
	call pset%prt(i)%set_children (child)
	n_parent = pset%prt(i)%get_n_parents ()
	do j = 1, i - 1
	p_child = pset%prt(j)%get_children ()
	no_match = .true.
	do k = 1, size (p_child)
	if (any (p_child(k) == child)) then
	if (n_parent == 0 .and. no_match) then
	if (.not. allocated (parent)) then
	parent = [j]
	else
	parent = [parent, j]
	end if
	p_child(k) = i
	else
	p_child(k) = 0
	end if
	no_match = .false.
	end if
	end do
	if (.not. no_match) then
	p_child = pack (p_child, p_child /= 0)
	call pset%prt(j)%set_children (p_child)
	end if
	end do
	if (n_parent == 0) then
	call pset%prt(i)%set_parents (parent)
	end if
	do j = 1, size (child)
	c = child(j)
	call pset%prt(c)%set_parents ([i])
	end do
	end subroutine particle_set_insert

	@ %def particle_set_insert
	@ This should be done after completing all insertions: recover color
	assignments for the inserted particles, working backwards from
	children to parents. A single call to the routine recovers the color
	and anticolor line indices for a single particle.
	<<Particles: particle set: TBP>>=
	procedure :: recover_color => particle_set_recover_color
	<<Particles: procedures>>=
	subroutine particle_set_recover_color (pset, i)
	class(particle_set_t), intent(inout) :: pset
	integer, intent(in) :: i
	type(color_t) :: col
	integer, dimension(:), allocatable :: child
	integer :: j
	child = pset%prt(i)%get_children ()
	if (size (child) > 0) then
	col = pset%prt(child(1))%get_col ()
	do j = 2, size (child)
	col = col .fuse. pset%prt(child(j))%get_col ()
	end do
	call pset%prt(i)%set_color (col)
	end if
	end subroutine particle_set_recover_color

	@ %def particle_set_recover_color
	@
	\subsection{Extract/modify contents}
	<<Particles: particle set: TBP>>=
	generic :: get_color => get_color_all
	generic :: get_color => get_color_indices
	procedure :: get_color_all => particle_set_get_color_all
	procedure :: get_color_indices => particle_set_get_color_indices
	<<Particles: procedures>>=
	function particle_set_get_color_all (particle_set) result (col)
	class(particle_set_t), intent(in) :: particle_set
	type(color_t), dimension(:), allocatable :: col
	allocate (col (size (particle_set%prt)))
	col = particle_set%prt%col
	end function particle_set_get_color_all

	@ %def particle_set_get_color_all
	@
	<<Particles: procedures>>=
	function particle_set_get_color_indices (particle_set, indices) result (col)
	type(color_t), dimension(:), allocatable :: col
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in), dimension(:), allocatable :: indices
	integer :: i
	allocate (col (size (indices)))
	do i = 1, size (indices)
	col(i) = particle_set%prt(indices(i))%col
	end do
	end function particle_set_get_color_indices

	@ %def particle_set_get_color_indices
	@ Set a single or all color components. This is a wrapper around the
	corresponding [[particle_t]] method, with the same options. We assume
	that the particle array is allocated.
	<<Particles: particle set: TBP>>=
	generic :: set_color => set_color_single
	generic :: set_color => set_color_indices
	generic :: set_color => set_color_all
	procedure :: set_color_single => particle_set_set_color_single
	procedure :: set_color_indices => particle_set_set_color_indices
	procedure :: set_color_all => particle_set_set_color_all
	<<Particles: procedures>>=
	subroutine particle_set_set_color_single (particle_set, i, col)
	class(particle_set_t), intent(inout) :: particle_set
	integer, intent(in) :: i
	type(color_t), intent(in) :: col
	call particle_set%prt(i)%set_color (col)
	end subroutine particle_set_set_color_single

	subroutine particle_set_set_color_indices (particle_set, indices, col)
	class(particle_set_t), intent(inout) :: particle_set
	integer, dimension(:), intent(in) :: indices
	type(color_t), dimension(:), intent(in) :: col
	integer :: i
	do i = 1, size (indices)
	call particle_set%prt(indices(i))%set_color (col(i))
	end do
	end subroutine particle_set_set_color_indices

	subroutine particle_set_set_color_all (particle_set, col)
	class(particle_set_t), intent(inout) :: particle_set
	type(color_t), dimension(:), intent(in) :: col
	call particle_set%prt%set_color (col)
	end subroutine particle_set_set_color_all

	@ %def particle_set_set_color
	@ Assigning particles manually may result in color mismatches. This is
	checked here for all particles in the set. The color object is
	compared against the color type that belongs to the flavor object.
	The return value is an allocatable array which consists of the particles
	with invalid color assignments. If the array size is zero, all is fine.
	<<Particles: particle set: TBP>>=
	procedure :: find_prt_invalid_color => particle_set_find_prt_invalid_color
	<<Particles: procedures>>=
	subroutine particle_set_find_prt_invalid_color (particle_set, index, prt)
	class(particle_set_t), intent(in) :: particle_set
	integer, dimension(:), allocatable, intent(out) :: index
	type(particle_t), dimension(:), allocatable, intent(out), optional :: prt
	type(flavor_t) :: flv
	type(color_t) :: col
	logical, dimension(:), allocatable :: mask
	integer :: i, n, n_invalid
	n = size (particle_set%prt)
	allocate (mask (n))
	do i = 1, n
	associate (prt => particle_set%prt(i))
	flv = prt%get_flv ()
	col = prt%get_col ()
	mask(i) = flv%get_color_type () /= col%get_type ()
	end associate
	end do
	index = pack ([(i, i = 1, n)], mask)
	if (present (prt)) prt = pack (particle_set%prt, mask)
	end subroutine particle_set_find_prt_invalid_color

	@ %def particle_set_find_prt_invalid_color
	@
	<<Particles: particle set: TBP>>=
	generic :: get_momenta => get_momenta_all
	generic :: get_momenta => get_momenta_indices
	procedure :: get_momenta_all => particle_set_get_momenta_all
	procedure :: get_momenta_indices => particle_set_get_momenta_indices
	<<Particles: procedures>>=
	function particle_set_get_momenta_all (particle_set) result (p)
	class(particle_set_t), intent(in) :: particle_set
	type(vector4_t), dimension(:), allocatable :: p
	allocate (p (size (particle_set%prt)))
	p = particle_set%prt%p
	end function particle_set_get_momenta_all

	@ %def particle_set_get_momenta_all
	@
	<<Particles: procedures>>=
	function particle_set_get_momenta_indices (particle_set, indices) result (p)
	type(vector4_t), dimension(:), allocatable :: p
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in), dimension(:), allocatable :: indices
	integer :: i
	allocate (p (size (indices)))
	do i = 1, size (indices)
	p(i) = particle_set%prt(indices(i))%p
	end do
	end function particle_set_get_momenta_indices

	@ %def particle_set_get_momenta_indices
	@ Replace a single or all momenta. This is a wrapper around the
	corresponding [[particle_t]] method, with the same options. We assume
	that the particle array is allocated.
	<<Particles: particle set: TBP>>=
	generic :: set_momentum => set_momentum_single
	generic :: set_momentum => set_momentum_indices
	generic :: set_momentum => set_momentum_all
	procedure :: set_momentum_single => particle_set_set_momentum_single
	procedure :: set_momentum_indices => particle_set_set_momentum_indices
	procedure :: set_momentum_all => particle_set_set_momentum_all
	<<Particles: procedures>>=
	subroutine particle_set_set_momentum_single &
	(particle_set, i, p, p2, on_shell)
	class(particle_set_t), intent(inout) :: particle_set
	integer, intent(in) :: i
	type(vector4_t), intent(in) :: p
	real(default), intent(in), optional :: p2
	logical, intent(in), optional :: on_shell
	call particle_set%prt(i)%set_momentum (p, p2, on_shell)
	end subroutine particle_set_set_momentum_single

	subroutine particle_set_set_momentum_indices &
	(particle_set, indices, p, p2, on_shell)
	class(particle_set_t), intent(inout) :: particle_set
	integer, dimension(:), intent(in) :: indices
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), dimension(:), intent(in), optional :: p2
	logical, intent(in), optional :: on_shell
	integer :: i
	if (present (p2)) then
	do i = 1, size (indices)
	call particle_set%prt(indices(i))%set_momentum (p(i), p2(i), on_shell)
	end do
	else
	do i = 1, size (indices)
	call particle_set%prt(indices(i))%set_momentum &
	(p(i), on_shell=on_shell)
	end do
	end if
	end subroutine particle_set_set_momentum_indices

	subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell)
	class(particle_set_t), intent(inout) :: particle_set
	type(vector4_t), dimension(:), intent(in) :: p
	real(default), dimension(:), intent(in), optional :: p2
	logical, intent(in), optional :: on_shell
	call particle_set%prt%set_momentum (p, p2, on_shell)
	end subroutine particle_set_set_momentum_all

	@ %def particle_set_set_momentum
	@ Recover a momentum by recombining from children, assuming that this
	is possible. The reconstructed momentum is not projected on-shell.
	<<Particles: particle set: TBP>>=
	procedure :: recover_momentum => particle_set_recover_momentum
	<<Particles: procedures>>=
	subroutine particle_set_recover_momentum (particle_set, i)
	class(particle_set_t), intent(inout) :: particle_set
	integer, intent(in) :: i
	type(vector4_t), dimension(:), allocatable :: p
	integer, dimension(:), allocatable :: index
	index = particle_set%prt(i)%get_children ()
	p = particle_set%get_momenta (index)
	call particle_set%set_momentum (i, sum (p))
	end subroutine particle_set_recover_momentum

	@ %def particle_set_recover_momentum
	@
	<<Particles: particle set: TBP>>=
	procedure :: replace_incoming_momenta => particle_set_replace_incoming_momenta
	<<Particles: procedures>>=
	subroutine particle_set_replace_incoming_momenta (particle_set, p)
	class(particle_set_t), intent(inout) :: particle_set
	type(vector4_t), intent(in), dimension(:) :: p
	integer :: i, j
	i = 1
	do j = 1, particle_set%get_n_tot ()
	if (particle_set%prt(j)%get_status () == PRT_INCOMING) then
	particle_set%prt(j)%p = p(i)
	i = i + 1
	if (i > particle_set%n_in) exit
	end if
	end do
	end subroutine particle_set_replace_incoming_momenta

	@ %def particle_set_replace_incoming_momenta
	@
	<<Particles: particle set: TBP>>=
	procedure :: replace_outgoing_momenta => particle_set_replace_outgoing_momenta
	<<Particles: procedures>>=
	subroutine particle_set_replace_outgoing_momenta (particle_set, p)
	class(particle_set_t), intent(inout) :: particle_set
	type(vector4_t), intent(in), dimension(:) :: p
	integer :: i, j
	i = particle_set%n_in + 1
	do j = 1, particle_set%n_tot
	if (particle_set%prt(j)%get_status () == PRT_OUTGOING) then
	particle_set%prt(j)%p = p(i)
	i = i + 1
	end if
	end do
	end subroutine particle_set_replace_outgoing_momenta

	@ %def particle_set_replace_outgoing_momenta
	@
	<<Particles: particle set: TBP>>=
	procedure :: get_outgoing_momenta => particle_set_get_outgoing_momenta
	<<Particles: procedures>>=
	function particle_set_get_outgoing_momenta (particle_set) result (p)
	class(particle_set_t), intent(in) :: particle_set
	type(vector4_t), dimension(:), allocatable :: p
	integer :: i, k
	allocate (p (count (particle_set%prt%get_status () == PRT_OUTGOING)))
	k = 0
	do i = 1, size (particle_set%prt)
	if (particle_set%prt(i)%get_status () == PRT_OUTGOING) then
	k = k + 1
	p(k) = particle_set%prt(i)%get_momentum ()
	end if
	end do
	end function particle_set_get_outgoing_momenta

	@ %def particle_set_get_outgoing_momenta
	@
	<<Particles: particle set: TBP>>=
	procedure :: parent_add_child => particle_set_parent_add_child
	<<Particles: procedures>>=
	subroutine particle_set_parent_add_child (particle_set, parent, child)
	class(particle_set_t), intent(inout) :: particle_set
	integer, intent(in) :: parent, child
	call particle_set%prt(child)%set_parents ([parent])
	call particle_set%prt(parent)%add_child (child)
	end subroutine particle_set_parent_add_child

	@ %def particle_set_parent_add_child
	@ Given the [[particle_set]] before radiation, the new momenta
	[[p_radiated]], the [[emitter]] and the [[flv_radiated]] as well as the
	[[model]] and a random number [[r_color]] for chosing a color, we update
	the [[particle_set]].
	<<Particles: particle set: TBP>>=
	procedure :: build_radiation => particle_set_build_radiation
	<<Particles: procedures>>=
	subroutine particle_set_build_radiation (particle_set, p_radiated, &
	emitter, flv_radiated, model, r_color)
	class(particle_set_t), intent(inout) :: particle_set
	type(vector4_t), intent(in), dimension(:) :: p_radiated
	integer, intent(in) :: emitter
	integer, intent(in), dimension(:) :: flv_radiated
	class(model_data_t), intent(in), target :: model
	real(default), intent(in) :: r_color
	type(particle_set_t) :: new_particle_set
	type(particle_t) :: new_particle
	integer :: i
	integer :: pdg_index_emitter, pdg_index_radiation
	integer, dimension(:), allocatable :: parents, children
	type(flavor_t) :: new_flv
	logical, dimension(:), allocatable :: status_mask
	integer, dimension(:), allocatable :: &
	i_in1, i_beam1, i_remnant1, i_virt1, i_out1
	integer, dimension(:), allocatable :: &
	i_in2, i_beam2, i_remnant2, i_virt2, i_out2
	integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1
	integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2
	integer :: n, n_tot
	integer :: i_emitter

	n = particle_set%get_n_tot ()
	allocate (status_mask (n))
	do i = 1, n
	status_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING
	end do
	n_in1 = count (status_mask)
	allocate (i_in1 (n_in1))
	i_in1 = particle_set%get_indices (status_mask)
	do i = 1, n
	status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM
	end do
	n_beam1 = count (status_mask)
	allocate (i_beam1 (n_beam1))
	i_beam1 = particle_set%get_indices (status_mask)
	do i = 1, n
	status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM_REMNANT
	end do
	n_remnant1 = count (status_mask)
	allocate (i_remnant1 (n_remnant1))
	i_remnant1 = particle_set%get_indices (status_mask)
	do i = 1, n
	status_mask(i) = particle_set%prt(i)%get_status () == PRT_VIRTUAL
	end do
	n_virt1 = count (status_mask)
	allocate (i_virt1 (n_virt1))
	i_virt1 = particle_set%get_indices (status_mask)
	do i = 1, n
	status_mask(i) = particle_set%prt(i)%get_status () == PRT_OUTGOING
	end do
	n_out1 = count (status_mask)
	allocate (i_out1 (n_out1))
	i_out1 = particle_set%get_indices (status_mask)

	n_in2 = n_in1; n_beam2 = n_beam1; n_remnant2 = n_remnant1
	n_virt2 = n_virt1 + n_out1
	n_out2 = n_out1 + 1
	n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2

	allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2))
	i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1

	allocate (i_virt2 (n_virt2))
	i_virt2(1 : n_virt1) = i_virt1
	i_virt2(n_virt1 + 1 : n_virt2) = i_out1

	allocate (i_out2 (n_out2))
	i_out2(1 : n_out1) = i_out1(1 : n_out1) + n_out1
	i_out2(n_out2) = n_tot

	new_particle_set%n_beam = n_beam2
	new_particle_set%n_in = n_in2
	new_particle_set%n_vir = n_virt2
	new_particle_set%n_out = n_out2
	new_particle_set%n_tot = n_tot
	new_particle_set%correlated_state = particle_set%correlated_state
	allocate (new_particle_set%prt (n_tot))
	if (size (i_beam1) > 0) new_particle_set%prt(i_beam2) = particle_set%prt(i_beam1)
	if (size (i_remnant1) > 0) new_particle_set%prt(i_remnant2) = particle_set%prt(i_remnant1)
	do i = 1, n_virt1
	new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i))
	end do

	do i = n_virt1 + 1, n_virt2
	new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1))
	call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL)
	end do

	do i = 1, n_in2
	new_particle_set%prt(i_in2(i)) = particle_set%prt(i_in1(i))
	new_particle_set%prt(i_in2(i))%p = p_radiated (i)
	end do

	do i = 1, n_out2 - 1
	new_particle_set%prt(i_out2(i)) = particle_set%prt(i_out1(i))
	new_particle_set%prt(i_out2(i))%p = p_radiated(i + n_in2)
	call new_particle_set%prt(i_out2(i))%reset_status (PRT_OUTGOING)
	end do

	call new_particle%reset_status (PRT_OUTGOING)
	call new_particle%set_momentum (p_radiated (n_in2 + n_out2))

	!!! Helicity and polarization handling is missing at this point
	!!! Also, no helicities or polarizations yet
	pdg_index_emitter = flv_radiated (emitter)
	pdg_index_radiation = flv_radiated (n_in2 + n_out2)
	call new_flv%init (pdg_index_radiation, model)
	i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2

	call reassign_colors (new_particle, new_particle_set%prt(i_emitter), &
	pdg_index_radiation, pdg_index_emitter, r_color)

	call new_particle%set_flavor (new_flv)
	new_particle_set%prt(n_tot) = new_particle

	allocate (children (n_out2))
	children = i_out2
	do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2
	call new_particle_set%prt(i)%set_children (children)
	end do

	!!! Set proper parents for outgoing particles
	allocate (parents (n_out1))
	parents = i_out1
	do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot
	call new_particle_set%prt(i)%set_parents (parents)
	end do
	call particle_set%init (new_particle_set)
	contains

	<<build radiation: set color offset>>
	subroutine reassign_colors (prt_radiated, prt_emitter, i_rad, i_em, r_col)
	type(particle_t), intent(inout) :: prt_radiated, prt_emitter
	integer, intent(in) :: i_rad, i_em
	real(default), intent(in) :: r_col
	type(color_t) :: col_rad, col_em
	if (is_quark (i_em) .and. is_gluon (i_rad)) then
	call reassign_colors_qg (prt_emitter, col_rad, col_em)
	else if (is_gluon (i_em) .and. is_gluon (i_rad)) then
	call reassign_colors_gg (prt_emitter, r_col, col_rad, col_em)
	else if (is_gluon (i_em) .and. is_quark (i_rad)) then
	call reassign_colors_qq (prt_emitter, i_em, col_rad, col_em)
	else
	call msg_fatal ("Invalid splitting")
	end if
	call prt_emitter%set_color (col_em)
	call prt_radiated%set_color (col_rad)
	end subroutine reassign_colors

	subroutine reassign_colors_qg (prt_emitter, col_rad, col_em)
	type(particle_t), intent(in) :: prt_emitter
	type(color_t), intent(out) :: col_rad, col_em
	integer, dimension(2) :: color_rad, color_em
	integer :: i1, i2
	integer :: new_color_index
	logical :: is_anti_quark

	color_em = prt_emitter%get_color ()
	i1 = 1; i2 = 2
	is_anti_quark = color_em(2) /= 0
	if (is_anti_quark) then
	i1 = 2; i2 = 1
	end if
	new_color_index = color_em(i1)+1
	color_rad(i1) = color_em(i1)
	color_rad(i2) = new_color_index
	color_em(i1) = new_color_index
	call col_em%init_col_acl (color_em(1), color_em(2))
	call col_rad%init_col_acl (color_rad(1), color_rad(2))
	end subroutine reassign_colors_qg

	subroutine reassign_colors_gg (prt_emitter, random, col_rad, col_em)
	!!! NOT TESTED YET
	type(particle_t), intent(in) :: prt_emitter
	real(default), intent(in) :: random
	type(color_t), intent(out) :: col_rad, col_em
	integer, dimension(2) :: color_rad, color_em
	integer :: i1, i2
	integer :: new_color_index

	color_em = prt_emitter%get_color ()
	new_color_index = maxval (abs (color_em))
	i1 = 1; i2 = 2
	if (random < 0.5) then
	i1 = 2; i2 = 1
	end if
	color_rad(i1) = new_color_index
	color_rad(i2) = color_em(i2)
	color_em(i2) = new_color_index
	call col_em%init_col_acl (color_em(1), color_em(2))
	call col_rad%init_col_acl (color_rad(1), color_rad(2))
	end subroutine reassign_colors_gg

	subroutine reassign_colors_qq (prt_emitter, pdg_emitter, col_rad, col_em)
	!!! NOT TESTED YET
	type(particle_t), intent(in) :: prt_emitter
	integer, intent(in) :: pdg_emitter
	type(color_t), intent(out) :: col_rad, col_em
	integer, dimension(2) :: color_rad, color_em
	integer :: i1, i2
	logical :: is_anti_quark

	color_em = prt_emitter%get_color ()
	i1 = 1; i2 = 2
	is_anti_quark = pdg_emitter < 0
	if (is_anti_quark) then
	i1 = 2; i1 = 1
	end if
	color_em(i2) = 0
	color_rad(i1) = 0
	color_rad(i2) = color_em(i1)
	call col_em%init_col_acl (color_em(1), color_em(2))
	call col_rad%init_col_acl (color_rad(1), color_rad(2))
	end subroutine reassign_colors_qq
	end subroutine particle_set_build_radiation

	@ %def particle_set_build_radiation
	@ Increments the color indices of all particles by their maximal value to distinguish them
	from the record-keeping Born particles in the LHE-output if the virtual entries are kept.
	<<build radiation: set color offset>>=
	subroutine set_color_offset (particle_set)
	type(particle_set_t), intent(inout) :: particle_set
	integer, dimension(2) :: color
	integer :: i, i_color_max
	type(color_t) :: new_color

	i_color_max = 0
	do i = 1, size (particle_set%prt)
	associate (prt => particle_set%prt(i))
	if (prt%get_status () <= PRT_INCOMING) cycle
	color = prt%get_color ()
	i_color_max = maxval([i_color_max, color(1), color(2)])
	end associate
	end do


	do i = 1, size (particle_set%prt)
	associate (prt => particle_set%prt(i))
	if (prt%get_status () /= PRT_OUTGOING) cycle
	color = prt%get_color ()
	where (color /= 0) color = color + i_color_max
	call new_color%init_col_acl (color(1), color(2))
	call prt%set_color (new_color)
	end associate
	end do
	end subroutine set_color_offset

	@ %def set_color_offset
	@ Output (default format)
	<<Particles: particle set: TBP>>=
	procedure :: write => particle_set_write
	<<Particles: procedures>>=
	subroutine particle_set_write &
	(particle_set, unit, testflag, summary, compressed)
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag, summary, compressed
	logical :: summ, comp, pol
	type(vector4_t) :: sum_vec
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	summ = .false.; if (present (summary)) summ = summary
	comp = .false.; if (present (compressed)) comp = compressed
	pol = particle_set%factorization_mode /= FM_IGNORE_HELICITY
	write (u, "(1x,A)") "Particle set:"
	call write_separator (u)
	if (comp) then
	if (pol) then
	write (u, &
	"((A4,1X),(A6,1X),(A7,1X),(A3),2(A4,1X),2(A20,1X),5(A12,1X))") &
	"Nr", "Status", "Flavor", "Hel", "Col", "ACol", &
	"Parents", "Children", &
	"P(0)", "P(1)", "P(2)", "P(3)", "P^2"
	else
	write (u, &
	"((A4,1X),(A6,1X),(A7,1X),2(A4,1X),2(A20,1X),5(A12,1X))") &
	"Nr", "Status", "Flavor", "Col", "ACol", &
	"Parents", "Children", &
	"P(0)", "P(1)", "P(2)", "P(3)", "P^2"
	end if
	end if
	if (particle_set%n_tot /= 0) then
	do i = 1, particle_set%n_tot
	if (comp) then
	write (u, "(I4,1X,2X)", advance="no") i
	else
	write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
	end if
	call particle_set%prt(i)%write (u, testflag = testflag, &
	compressed = comp, polarization = pol)
	end do
	if (particle_set%correlated_state%is_defined ()) then
	call write_separator (u)
	write (u, *) "Correlated state density matrix:"
	call particle_set%correlated_state%write (u)
	end if
	if (summ) then
	call write_separator (u)
	write (u, "(A)", advance="no") &
	"Sum of incoming momenta: p(0:3) = "
	sum_vec = sum (particle_set%prt%p, &
	mask=particle_set%prt%get_status () == PRT_INCOMING)
	call pacify (sum_vec, tolerance = 1E-3_default)
	call sum_vec%write (u, compressed=.true.)
	write (u, *)
	write (u, "(A)", advance="no") &
	"Sum of beam remnant momenta: p(0:3) = "
	sum_vec = sum (particle_set%prt%p, &
	mask=particle_set%prt%get_status () == PRT_BEAM_REMNANT)
	call pacify (sum_vec, tolerance = 1E-3_default)
	call sum_vec%write (u, compressed=.true.)
	write (u, *)
	write (u, "(A)", advance="no") &
	"Sum of outgoing momenta: p(0:3) = "
	sum_vec = sum (particle_set%prt%p, &
	mask=particle_set%prt%get_status () == PRT_OUTGOING)
	call pacify (sum_vec, tolerance = 1E-3_default)
	call sum_vec%write (u, compressed=.true.)
	write (u, "(A)") ""
	end if
	else
	write (u, "(3x,A)") "[empty]"
	end if
	end subroutine particle_set_write

	@ %def particle_set_write
	@
	\subsection{I/O formats}
	Here, we define input/output of particle sets in various formats.
	This is the right place since particle sets contain most of the event
	information.

	All write/read routines take as first argument the object, as second
	argument the I/O unit which in this case is a mandatory argument.
	Then follow further event data.

	\subsubsection{Internal binary format}
	This format is supposed to contain the complete information, so
	the particle data set can be fully reconstructed. The exception is
	the model part of the particle flavors; this is unassigned for the
	flavor values read from file.
	<<Particles: particle set: TBP>>=
	procedure :: write_raw => particle_set_write_raw
	procedure :: read_raw => particle_set_read_raw
	<<Particles: procedures>>=
	subroutine particle_set_write_raw (particle_set, u)
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in) :: u
	integer :: i
	write (u) &
	particle_set%n_beam, particle_set%n_in, &
	particle_set%n_vir, particle_set%n_out
	write (u) particle_set%factorization_mode
	write (u) particle_set%n_tot
	do i = 1, particle_set%n_tot
	call particle_set%prt(i)%write_raw (u)
	end do
	call particle_set%correlated_state%write_raw (u)
	end subroutine particle_set_write_raw

	subroutine particle_set_read_raw (particle_set, u, iostat)
	class(particle_set_t), intent(out) :: particle_set
	integer, intent(in) :: u
	integer, intent(out) :: iostat
	integer :: i
	read (u, iostat=iostat) &
	particle_set%n_beam, particle_set%n_in, &
	particle_set%n_vir, particle_set%n_out
	read (u, iostat=iostat) particle_set%factorization_mode
	read (u, iostat=iostat) particle_set%n_tot
	allocate (particle_set%prt (particle_set%n_tot))
	do i = 1, size (particle_set%prt)
	call particle_set%prt(i)%read_raw (u, iostat=iostat)
	end do
	call particle_set%correlated_state%read_raw (u, iostat=iostat)
	end subroutine particle_set_read_raw

	@ %def particle_set_write_raw particle_set_read_raw
	@
	\subsubsection{Get contents}
	Find parents/children of a particular particle recursively; the
	search terminates if a parent/child has status [[BEAM]], [[INCOMING]],
	[[OUTGOING]] or [[RESONANT]].
	<<Particles: particle set: TBP>>=
	procedure :: get_real_parents => particle_set_get_real_parents
	procedure :: get_real_children => particle_set_get_real_children
	<<Particles: procedures>>=
	function particle_set_get_real_parents (pset, i, keep_beams) result (parent)
	integer, dimension(:), allocatable :: parent
	class(particle_set_t), intent(in) :: pset
	integer, intent(in) :: i
	logical, intent(in), optional :: keep_beams
	logical, dimension(:), allocatable :: is_real
	logical, dimension(:), allocatable :: is_parent, is_real_parent
	logical :: kb
	integer :: j, k
	kb = .false.
	if (present (keep_beams)) kb = keep_beams
	allocate (is_real (pset%n_tot))
	is_real = pset%prt%is_real (kb)
	allocate (is_parent (pset%n_tot), is_real_parent (pset%n_tot))
	is_real_parent = .false.
	is_parent = .false.
	is_parent(pset%prt(i)%get_parents()) = .true.
	do while (any (is_parent))
	where (is_real .and. is_parent)
	is_real_parent = .true.
	is_parent = .false.
	end where
	mark_next_parent: do j = size (is_parent), 1, -1
	if (is_parent(j)) then
	is_parent(pset%prt(j)%get_parents()) = .true.
	is_parent(j) = .false.
	exit mark_next_parent
	end if
	end do mark_next_parent
	end do
	allocate (parent (count (is_real_parent)))
	j = 0
	do k = 1, size (is_parent)
	if (is_real_parent(k)) then
	j = j + 1
	parent(j) = k
	end if
	end do
	end function particle_set_get_real_parents

	function particle_set_get_real_children (pset, i, keep_beams) result (child)
	integer, dimension(:), allocatable :: child
	class(particle_set_t), intent(in) :: pset
	integer, intent(in) :: i
	logical, dimension(:), allocatable :: is_real
	logical, dimension(:), allocatable :: is_child, is_real_child
	logical, intent(in), optional :: keep_beams
	integer :: j, k
	logical :: kb
	kb = .false.
	if (present (keep_beams)) kb = keep_beams
	allocate (is_real (pset%n_tot))
	is_real = pset%prt%is_real (kb)
	is_real = pset%prt%is_real (kb)
	allocate (is_child (pset%n_tot), is_real_child (pset%n_tot))
	is_real_child = .false.
	is_child = .false.
	is_child(pset%prt(i)%get_children()) = .true.
	do while (any (is_child))
	where (is_real .and. is_child)
	is_real_child = .true.
	is_child = .false.
	end where
	mark_next_child: do j = 1, size (is_child)
	if (is_child(j)) then
	is_child(pset%prt(j)%get_children()) = .true.
	is_child(j) = .false.
	exit mark_next_child
	end if
	end do mark_next_child
	end do
	allocate (child (count (is_real_child)))
	j = 0
	do k = 1, size (is_child)
	if (is_real_child(k)) then
	j = j + 1
	child(j) = k
	end if
	end do
	end function particle_set_get_real_children

	@ %def particle_set_get_real_parents
	@ %def particle_set_get_real_children
	@ Get the [[n_tot]], [[n_in]], and [[n_out]] values out of the
	particle set.
	<<Particles: particle set: TBP>>=
	procedure :: get_n_beam => particle_set_get_n_beam
	procedure :: get_n_in => particle_set_get_n_in
	procedure :: get_n_vir => particle_set_get_n_vir
	procedure :: get_n_out => particle_set_get_n_out
	procedure :: get_n_tot => particle_set_get_n_tot
	procedure :: get_n_remnants => particle_set_get_n_remnants
	<<Particles: procedures>>=
	function particle_set_get_n_beam (pset) result (n_beam)
	class(particle_set_t), intent(in) :: pset
	integer :: n_beam
	n_beam = pset%n_beam
	end function particle_set_get_n_beam

	function particle_set_get_n_in (pset) result (n_in)
	class(particle_set_t), intent(in) :: pset
	integer :: n_in
	n_in = pset%n_in
	end function particle_set_get_n_in

	function particle_set_get_n_vir (pset) result (n_vir)
	class(particle_set_t), intent(in) :: pset
	integer :: n_vir
	n_vir = pset%n_vir
	end function particle_set_get_n_vir

	function particle_set_get_n_out (pset) result (n_out)
	class(particle_set_t), intent(in) :: pset
	integer :: n_out
	n_out = pset%n_out
	end function particle_set_get_n_out

	function particle_set_get_n_tot (pset) result (n_tot)
	class(particle_set_t), intent(in) :: pset
	integer :: n_tot
	n_tot = pset%n_tot
	end function particle_set_get_n_tot

	function particle_set_get_n_remnants (pset) result (n_remn)
	class(particle_set_t), intent(in) :: pset
	integer :: n_remn
	if (allocated (pset%prt)) then
	n_remn = count (pset%prt%get_status () == PRT_BEAM_REMNANT)
	else
	n_remn = 0
	end if
	end function particle_set_get_n_remnants

	@ %def particle_set_get_n_beam
	@ %def particle_set_get_n_in
	@ %def particle_set_get_n_vir
	@ %def particle_set_get_n_out
	@ %def particle_set_get_n_tot
	@ %def particle_set_get_n_remnants
	@ Return a pointer to the particle corresponding to the number
	<<Particles: particle set: TBP>>=
	procedure :: get_particle => particle_set_get_particle
	<<Particles: procedures>>=
	function particle_set_get_particle (pset, index) result (particle)
	class(particle_set_t), intent(in) :: pset
	integer, intent(in) :: index
	type(particle_t) :: particle
	particle = pset%prt(index)
	end function particle_set_get_particle

	@ %def particle_set_get_particle
	@
	<<Particles: particle set: TBP>>=
	procedure :: get_indices => particle_set_get_indices
	<<Particles: procedures>>=
	pure function particle_set_get_indices (pset, mask) result (finals)
	integer, dimension(:), allocatable :: finals
	class(particle_set_t), intent(in) :: pset
	logical, dimension(:), intent(in) :: mask
	integer, dimension(size(mask)) :: indices
	integer :: i
	allocate (finals (count (mask)))
	indices = [(i, i=1, pset%n_tot)]
	finals = pack (indices, mask)
	end function particle_set_get_indices

	@ %def particle_set_get_indices
	@ Copy the subset of physical momenta to a [[phs_point]] container.
	<<Particles: particle set: TBP>>=
	procedure :: get_in_and_out_momenta => particle_set_get_in_and_out_momenta
	<<Particles: procedures>>=
	function particle_set_get_in_and_out_momenta (pset) result (phs_point)
	type(phs_point_t) :: phs_point
	class(particle_set_t), intent(in) :: pset
	logical, dimension(:), allocatable :: mask
	integer, dimension(:), allocatable :: indices
	type(vector4_t), dimension(:), allocatable :: p
	allocate (mask (pset%get_n_tot ()))
	allocate (p (size (pset%prt)))
	mask = pset%prt%status == PRT_INCOMING .or. &
	pset%prt%status == PRT_OUTGOING
	allocate (indices (count (mask)))
	indices = pset%get_indices (mask)
	phs_point = pset%get_momenta (indices)
	end function particle_set_get_in_and_out_momenta

	@ %def particle_set_get_in_and_out_momenta
	@
	\subsubsection{Tools}
	Build a new particles array without hadronic remnants but with
	[[n_extra]] additional spots. We also update the mother-daughter
	relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
	<<Particles: particle set: TBP>>=
	procedure :: without_hadronic_remnants => &
	particle_set_without_hadronic_remnants
	<<Particles: procedures>>=
	subroutine particle_set_without_hadronic_remnants &
	(particle_set, particles, n_particles, n_extra)
	class(particle_set_t), intent(inout) :: particle_set
	type(particle_t), dimension(:), allocatable, intent(out) :: particles
	integer, intent(out) :: n_particles
	integer, intent(in) :: n_extra
	logical, dimension(:), allocatable :: no_hadronic_remnants, &
	no_hadronic_children
	integer, dimension(:), allocatable :: children, new_children
	integer :: i, j, k, first_remnant
	first_remnant = particle_set%n_tot
	do i = 1, particle_set%n_tot
	if (particle_set%prt(i)%is_hadronic_beam_remnant ()) then
	first_remnant = i
	exit
	end if
	end do
	n_particles = count (.not. particle_set%prt%is_hadronic_beam_remnant ())
	allocate (no_hadronic_remnants (particle_set%n_tot))
	no_hadronic_remnants = .not. particle_set%prt%is_hadronic_beam_remnant ()
	allocate (particles (n_particles + n_extra))
	k = 1
	do i = 1, particle_set%n_tot
	if (no_hadronic_remnants(i)) then
	particles(k) = particle_set%prt(i)
	k = k + 1
	end if
	end do
	if (n_particles /= particle_set%n_tot) then
	do i = 1, n_particles
	select case (particles(i)%get_status ())
	case (PRT_BEAM)
	if (allocated (children)) deallocate (children)
	allocate (children (particles(i)%get_n_children ()))
	children = particles(i)%get_children ()
	if (allocated (no_hadronic_children)) &
	deallocate (no_hadronic_children)
	allocate (no_hadronic_children (particles(i)%get_n_children ()))
	no_hadronic_children = .not. &
	particle_set%prt(children)%is_hadronic_beam_remnant ()
	if (allocated (new_children)) deallocate (new_children)
	allocate (new_children (count (no_hadronic_children)))
	new_children = pack (children, no_hadronic_children)
	call particles(i)%set_children (new_children)
	case (PRT_INCOMING, PRT_RESONANT)
	<<update children after remnant>>
	case (PRT_OUTGOING, PRT_BEAM_REMNANT)
	case default
	end select
	end do
	end if
	end subroutine particle_set_without_hadronic_remnants

	@ %def particle_set_without_hadronic_remnants
	<<update children after remnant>>=
	if (allocated (children)) deallocate (children)
	allocate (children (particles(i)%get_n_children ()))
	children = particles(i)%get_children ()
	do j = 1, size (children)
	if (children(j) > first_remnant) then
	children(j) = children (j) - &
	(particle_set%n_tot - n_particles)
	end if
	end do
	call particles(i)%set_children (children)
	@
	Build a new particles array without remnants but with
	[[n_extra]] additional spots. We also update the mother-daughter
	relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
	<<Particles: particle set: TBP>>=
	procedure :: without_remnants => particle_set_without_remnants
	<<Particles: procedures>>=
	subroutine particle_set_without_remnants &
	(particle_set, particles, n_particles, n_extra)
	class(particle_set_t), intent(inout) :: particle_set
	type(particle_t), dimension(:), allocatable, intent(out) :: particles
	integer, intent(in) :: n_extra
	integer, intent(out) :: n_particles
	logical, dimension(:), allocatable :: no_remnants, no_children
	integer, dimension(:), allocatable :: children, new_children
	integer :: i,j, k, first_remnant
	first_remnant = particle_set%n_tot
	do i = 1, particle_set%n_tot
	if (particle_set%prt(i)%is_beam_remnant ()) then
	first_remnant = i
	exit
	end if
	end do
	allocate (no_remnants (particle_set%n_tot))
	no_remnants = .not. (particle_set%prt%is_beam_remnant ())
	n_particles = count (no_remnants)
	allocate (particles (n_particles + n_extra))
	k = 1
	do i = 1, particle_set%n_tot
	if (no_remnants(i)) then
	particles(k) = particle_set%prt(i)
	k = k + 1
	end if
	end do
	if (n_particles /= particle_set%n_tot) then
	do i = 1, n_particles
	select case (particles(i)%get_status ())
	case (PRT_BEAM)
	if (allocated (children)) deallocate (children)
	allocate (children (particles(i)%get_n_children ()))
	children = particles(i)%get_children ()
	if (allocated (no_children)) deallocate (no_children)
	allocate (no_children (particles(i)%get_n_children ()))
	no_children = .not. (particle_set%prt(children)%is_beam_remnant ())
	if (allocated (new_children)) deallocate (new_children)
	allocate (new_children (count (no_children)))
	new_children = pack (children, no_children)
	call particles(i)%set_children (new_children)
	case (PRT_INCOMING, PRT_RESONANT)
	<<update children after remnant>>
	case (PRT_OUTGOING, PRT_BEAM_REMNANT)
	case default
	end select
	end do
	end if
	end subroutine particle_set_without_remnants

	@ %def particle_set_without_remnants
	@
	<<Particles: particle set: TBP>>=
	procedure :: find_particle => particle_set_find_particle
	<<Particles: procedures>>=
	pure function particle_set_find_particle (particle_set, pdg, &
	momentum, abs_smallness, rel_smallness) result (idx)
	integer :: idx
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: momentum
	real(default), intent(in), optional :: abs_smallness, rel_smallness
	integer :: i
	logical, dimension(0:3) :: equals
	idx = 0
	do i = 1, size (particle_set%prt)
	if (particle_set%prt(i)%flv%get_pdg () == pdg) then
	equals = nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
	abs_smallness, rel_smallness)
	if (all (equals)) then
	idx = i
	return
	end if
	end if
	end do
	end function particle_set_find_particle

	@ %def particle_set_find_particle
	<<Particles: particle set: TBP>>=
	procedure :: reverse_find_particle => particle_set_reverse_find_particle
	<<Particles: procedures>>=
	pure function particle_set_reverse_find_particle &
	(particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx)
	integer :: idx
	class(particle_set_t), intent(in) :: particle_set
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: momentum
	real(default), intent(in), optional :: abs_smallness, rel_smallness
	integer :: i
	idx = 0
	do i = size (particle_set%prt), 1, -1
	if (particle_set%prt(i)%flv%get_pdg () == pdg) then
	if (all (nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
	abs_smallness, rel_smallness))) then
	idx = i
	return
	end if
	end if
	end do
	end function particle_set_reverse_find_particle

	@ %def particle_set_reverse_find_particle
	@ This connects broken links of the form
	$\text{something} \to i \to \text{none or} j$ and
	$\text{none} \to j \to \text{something or none}$ where the particles $i$ and $j$
	are \emph{identical}. It also works if $i \to j$, directly, and thus
	removes duplicates. We are removing $j$ and connect the possible
	daughters to $i$.
	<<Particles: particle set: TBP>>=
	procedure :: remove_duplicates => particle_set_remove_duplicates
	<<Particles: procedures>>=
	subroutine particle_set_remove_duplicates (particle_set, smallness)
	class(particle_set_t), intent(inout) :: particle_set
	real(default), intent(in) :: smallness
	integer :: n_removals
	integer, dimension(particle_set%n_tot) :: to_remove
	type(particle_t), dimension(:), allocatable :: particles
	type(vector4_t) :: p_i
	integer, dimension(:), allocatable :: map
	to_remove = 0
	call find_duplicates ()
	n_removals = count (to_remove > 0)
	if (n_removals > 0) then
	call strip_duplicates (particles)
	call particle_set%replace (particles)
	end if

	contains

	<<Particles: remove duplicates: procedures>>

	end subroutine particle_set_remove_duplicates

	@ %def particle_set_remove_duplicates
	@ This does not catch all cases. Missing are splittings of the type
	$i \to \text{something and} j$.
	<<Particles: remove duplicates: procedures>>=
	subroutine find_duplicates ()
	integer :: pdg_i, child_i, i, j
	OUTER: do i = 1, particle_set%n_tot
	if (particle_set%prt(i)%status == PRT_OUTGOING .or. &
	particle_set%prt(i)%status == PRT_VIRTUAL .or. &
	particle_set%prt(i)%status == PRT_RESONANT) then
	if (allocated (particle_set%prt(i)%child)) then
	if (size (particle_set%prt(i)%child) > 1) cycle OUTER
	if (size (particle_set%prt(i)%child) == 1) then
	child_i = particle_set%prt(i)%child(1)
	else
	child_i = 0
	end if
	else
	child_i = 0
	end if
	pdg_i = particle_set%prt(i)%flv%get_pdg ()
	p_i = particle_set%prt(i)%p
	do j = i + 1, particle_set%n_tot
	if (pdg_i == particle_set%prt(j)%flv%get_pdg ()) then
	if (all (nearly_equal (particle_set%prt(j)%p%p, p_i%p, &
	abs_smallness = smallness, &
	rel_smallness = 1E4_default * smallness))) then
	if (child_i == 0 .or. j == child_i) then
	to_remove(j) = i
	if (debug_on) call msg_debug2 (D_PARTICLES, &
	"Particles: Will remove duplicate of i", i)
	if (debug_on) call msg_debug2 (D_PARTICLES, &
	"Particles: j", j)
	end if
	cycle OUTER
	end if
	end if
	end do
	end if
	end do OUTER
	end subroutine find_duplicates

	@
	<<Particles: remove duplicates: procedures>>=
	recursive function get_alive_index (try) result (alive)
	integer :: alive
	integer :: try
	if (map(try) > 0) then
	alive = map(try)
	else
	alive = get_alive_index (to_remove(try))
	end if
	end function get_alive_index

	@
	<<Particles: remove duplicates: procedures>>=
	subroutine strip_duplicates (particles)
	type(particle_t), dimension(:), allocatable, intent(out) :: particles
	integer :: kept, removed, i, j
	integer, dimension(:), allocatable :: old_children
	logical, dimension(:), allocatable :: parent_set
	if (debug_on) call msg_debug (D_PARTICLES, "Particles: Removing duplicates")
	if (debug_on) call msg_debug (D_PARTICLES, "Particles: n_removals", n_removals)
	if (debug2_active (D_PARTICLES)) then
	call msg_debug2 (D_PARTICLES, "Particles: Given set before removing:")
	call particle_set%write (summary=.true., compressed=.true.)
	end if
	allocate (particles (particle_set%n_tot - n_removals))
	allocate (map (particle_set%n_tot))
	allocate (parent_set (particle_set%n_tot))
	parent_set = .false.
	map = 0
	j = 0
	do i = 1, particle_set%n_tot
	if (to_remove(i) == 0) then
	j = j + 1
	map(i) = j
	call particles(j)%init (particle_set%prt(i))
	end if
	end do
	do i = 1, particle_set%n_tot
	if (map(i) /= 0) then
	if (.not. parent_set(map(i))) then
	call particles(map(i))%set_parents &
	(map (particle_set%prt(i)%get_parents ()))
	end if
	call particles(map(i))%set_children &
	(map (particle_set%prt(i)%get_children ()))
	else
	removed = i
	kept = to_remove(i)
	if (particle_set%prt(removed)%has_children ()) then
	old_children = particle_set%prt(removed)%get_children ()
	do j = 1, size (old_children)
	if (map(old_children(j)) > 0) then
	call particles(map(old_children(j)))%set_parents &
	([get_alive_index (kept)])
	parent_set(map(old_children(j))) = .true.
	call particles(get_alive_index (kept))%add_child &
	(map(old_children(j)))
	end if
	end do
	particles(get_alive_index (kept))%status = PRT_RESONANT
	else
	particles(get_alive_index (kept))%status = PRT_OUTGOING
	end if
	end if
	end do
	end subroutine strip_duplicates

	@ Given a subevent, reset status codes. If the new status is beam,
	incoming, or outgoing, we also make sure that the stored $p^2$ value
	is equal to the on-shell mass squared.
	<<Particles: particle set: TBP>>=
	procedure :: reset_status => particle_set_reset_status
	<<Particles: procedures>>=
	subroutine particle_set_reset_status (particle_set, index, status)
	class(particle_set_t), intent(inout) :: particle_set
	integer, dimension(:), intent(in) :: index
	integer, intent(in) :: status
	integer :: i
	if (allocated (particle_set%prt)) then
	do i = 1, size (index)
	call particle_set%prt(index(i))%reset_status (status)
	end do
	end if
	particle_set%n_beam = &
	count (particle_set%prt%get_status () == PRT_BEAM)
	particle_set%n_in = &
	count (particle_set%prt%get_status () == PRT_INCOMING)
	particle_set%n_out = &
	count (particle_set%prt%get_status () == PRT_OUTGOING)
	particle_set%n_vir = particle_set%n_tot &
	- particle_set%n_beam - particle_set%n_in - particle_set%n_out
	end subroutine particle_set_reset_status

	@ %def particle_set_reset_status
	@ Reduce a particle set to the essential entries. The entries kept
	are those with status [[INCOMING]], [[OUTGOING]] or
	[[RESONANT]]. [[BEAM]] is kept if [[keep_beams]] is true. Other
	entries are skipped. The correlated state matrix, if any, is also
	ignored.
	<<Particles: particle set: TBP>>=
	procedure :: reduce => particle_set_reduce
	<<Particles: procedures>>=
	subroutine particle_set_reduce (pset_in, pset_out, keep_beams)
	class(particle_set_t), intent(in) :: pset_in
	type(particle_set_t), intent(out) :: pset_out
	logical, intent(in), optional :: keep_beams
	integer, dimension(:), allocatable :: status, map
	integer :: i, j
	logical :: kb
	kb = .false.; if (present (keep_beams)) kb = keep_beams
	allocate (status (pset_in%n_tot))
	pset_out%factorization_mode = pset_in%factorization_mode
	status = pset_in%prt%get_status ()
	if (kb) pset_out%n_beam = count (status == PRT_BEAM)
	pset_out%n_in = count (status == PRT_INCOMING)
	pset_out%n_vir = count (status == PRT_RESONANT)
	pset_out%n_out = count (status == PRT_OUTGOING)
	pset_out%n_tot = &
	pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
	allocate (pset_out%prt (pset_out%n_tot))
	allocate (map (pset_in%n_tot))
	map = 0
	j = 0
	if (kb) call copy_particles (PRT_BEAM)
	call copy_particles (PRT_INCOMING)
	call copy_particles (PRT_RESONANT)
	call copy_particles (PRT_OUTGOING)
	do i = 1, pset_in%n_tot
	if (map(i) == 0) cycle
	call pset_out%prt(map(i))%set_parents &
	(pset_in%get_real_parents (i, kb))
	call pset_out%prt(map(i))%set_parents &
	(map (pset_out%prt(map(i))%parent))
	call pset_out%prt(map(i))%set_children &
	(pset_in%get_real_children (i, kb))
	call pset_out%prt(map(i))%set_children &
	(map (pset_out%prt(map(i))%child))
	end do
	contains
	subroutine copy_particles (stat)
	integer, intent(in) :: stat
	integer :: i
	do i = 1, pset_in%n_tot
	if (status(i) == stat) then
	j = j + 1
	map(i) = j
	call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
	end if
	end do
	end subroutine copy_particles
	end subroutine particle_set_reduce

	@ %def particles_set_reduce
	@ Remove the beam particles and beam remnants from the particle set if the
	keep beams flag is false. If keep beams is not given, the beam particles
	and the beam remnants are removed.
	The correlated state matrix, if any, is also ignored.
	<<Particles: particle set: TBP>>=
	procedure :: filter_particles => particle_set_filter_particles
	<<Particles: procedures>>=
	subroutine particle_set_filter_particles &
	(pset_in, pset_out, keep_beams, real_parents, keep_virtuals)
	class(particle_set_t), intent(in) :: pset_in
	type(particle_set_t), intent(out) :: pset_out
	logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals
	integer, dimension(:), allocatable :: status, map
	logical, dimension(:), allocatable :: filter
	integer :: i, j
	logical :: kb, rp, kv
	kb = .false.; if (present (keep_beams)) kb = keep_beams
	rp = .false.; if (present (real_parents)) rp = real_parents
	kv = .true.; if (present (keep_virtuals)) kv = keep_virtuals
	if (debug_on) call msg_debug (D_PARTICLES, "filter_particles")
	if (debug2_active (D_PARTICLES)) then
	print *, 'keep_beams = ', kb
	print *, 'real_parents = ', rp
	print *, 'keep_virtuals = ', kv
	print *, '>>> pset_in : '
	call pset_in%write(compressed=.true.)
	end if
	call count_and_allocate()
	map = 0
	j = 0
	filter = .false.
	if (.not. kb) filter = status == PRT_BEAM .or. status == PRT_BEAM_REMNANT
	if (.not. kv) filter = filter .or. status == PRT_VIRTUAL
	call copy_particles ()
	do i = 1, pset_in%n_tot
	if (map(i) == 0) cycle
	if (rp) then
	call pset_out%prt(map(i))%set_parents &
	(map (pset_in%get_real_parents (i, kb)))
	call pset_out%prt(map(i))%set_children &
	(map (pset_in%get_real_children (i, kb)))
	else
	call pset_out%prt(map(i))%set_parents &
	(map (pset_in%prt(i)%get_parents ()))
	call pset_out%prt(map(i))%set_children &
	(map (pset_in%prt(i)%get_children ()))
	end if
	end do
	if (debug2_active (D_PARTICLES)) then
	print *, '>>> pset_out : '
	call pset_out%write(compressed=.true.)
	end if
	contains
	<<filter particles: procedures>>
	end subroutine particle_set_filter_particles

	@ %def particles_set_filter_particles
	<<filter particles: procedures>>=
	subroutine copy_particles ()
	integer :: i
	do i = 1, pset_in%n_tot
	if (.not. filter(i)) then
	j = j + 1
	map(i) = j
	call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
	end if
	end do
	end subroutine copy_particles

	<<filter particles: procedures>>=
	subroutine count_and_allocate
	allocate (status (pset_in%n_tot))
	status = particle_get_status (pset_in%prt)
	if (kb) pset_out%n_beam = count (status == PRT_BEAM)
	pset_out%n_in = count (status == PRT_INCOMING)
	if (kb .and. kv) then
	pset_out%n_vir = count (status == PRT_VIRTUAL) + &
	count (status == PRT_RESONANT) + &
	count (status == PRT_BEAM_REMNANT)
	else if (kb .and. .not. kv) then
	pset_out%n_vir = count (status == PRT_RESONANT) + &
	count (status == PRT_BEAM_REMNANT)
	else if (.not. kb .and. kv) then
	pset_out%n_vir = count (status == PRT_VIRTUAL) + &
	count (status == PRT_RESONANT)
	else
	pset_out%n_vir = count (status == PRT_RESONANT)
	end if
	pset_out%n_out = count (status == PRT_OUTGOING)
	pset_out%n_tot = &
	pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
	allocate (pset_out%prt (pset_out%n_tot))
	allocate (map (pset_in%n_tot))
	allocate (filter (pset_in%n_tot))
	end subroutine count_and_allocate

	@ Transform a particle set into HEPEVT-compatible form. In this form, for each
	particle, the parents and the children are contiguous in the particle array.
	Usually, this requires to clone some particles.

	We do not know in advance how many particles the canonical form will have.
	To be on the safe side, allocate four times the original size.
	<<Particles: particle set: TBP>>=
	procedure :: to_hepevt_form => particle_set_to_hepevt_form
	<<Particles: procedures>>=
	subroutine particle_set_to_hepevt_form (pset_in, pset_out)
	class(particle_set_t), intent(in) :: pset_in
	type(particle_set_t), intent(out) :: pset_out
	type :: particle_entry_t
	integer :: src = 0
	integer :: status = 0
	integer :: orig = 0
	integer :: copy = 0
	end type particle_entry_t
	type(particle_entry_t), dimension(:), allocatable :: prt
	integer, dimension(:), allocatable :: map1, map2
	integer, dimension(:), allocatable :: parent, child
	integer :: n_tot, n_parents, n_children, i, j, c, n

	n_tot = pset_in%n_tot
	allocate (prt (4 * n_tot))
	allocate (map1(4 * n_tot))
	allocate (map2(4 * n_tot))
	map1 = 0
	map2 = 0
	allocate (child (n_tot))
	allocate (parent (n_tot))
	n = 0
	do i = 1, n_tot
	if (pset_in%prt(i)%get_n_parents () == 0) then
	call append (i)
	end if
	end do
	do i = 1, n_tot
	n_children = pset_in%prt(i)%get_n_children ()
	if (n_children > 0) then
	child(1:n_children) = pset_in%prt(i)%get_children ()
	c = child(1)
	if (map1(c) == 0) then
	n_parents = pset_in%prt(c)%get_n_parents ()
	if (n_parents > 1) then
	parent(1:n_parents) = pset_in%prt(c)%get_parents ()
	if (i == parent(1) .and. &
	any( [(map1(i)+j-1, j=1,n_parents)] /= &
	map1(parent(1:n_parents)))) then
	do j = 1, n_parents
	call append (parent(j))
	end do
	end if
	else if (map1(i) == 0) then
	call append (i)
	end if
	do j = 1, n_children
	call append (child(j))
	end do
	end if
	else if (map1(i) == 0) then
	call append (i)
	end if
	end do
	do i = n, 1, -1
	if (prt(i)%status /= PRT_OUTGOING) then
	do j = 1, i-1
	if (prt(j)%status == PRT_OUTGOING) then
	call append(prt(j)%src)
	end if
	end do
	exit
	end if
	end do
	pset_out%n_beam = count (prt(1:n)%status == PRT_BEAM)
	pset_out%n_in = count (prt(1:n)%status == PRT_INCOMING)
	pset_out%n_vir = count (prt(1:n)%status == PRT_RESONANT)
	pset_out%n_out = count (prt(1:n)%status == PRT_OUTGOING)
	pset_out%n_tot = n
	allocate (pset_out%prt (n))
	do i = 1, n
	call particle_init_particle (pset_out%prt(i), pset_in%prt(prt(i)%src))
	call pset_out%prt(i)%reset_status (prt(i)%status)
	if (prt(i)%orig == 0) then
	call pset_out%prt(i)%set_parents &
	(map2 (pset_in%prt(prt(i)%src)%get_parents ()))
	else
	call pset_out%prt(i)%set_parents ([ prt(i)%orig ])
	end if
	if (prt(i)%copy == 0) then
	call pset_out%prt(i)%set_children &
	(map1 (pset_in%prt(prt(i)%src)%get_children ()))
	else
	call pset_out%prt(i)%set_children ([ prt(i)%copy ])
	end if
	end do
	contains
	subroutine append (i)
	integer, intent(in) :: i
	n = n + 1
	if (n > size (prt)) &
	call msg_bug ("Particle set transform to HEPEVT: insufficient space")
	prt(n)%src = i
	prt(n)%status = pset_in%prt(i)%get_status ()
	if (map1(i) == 0) then
	map1(i) = n
	else
	prt(map2(i))%status = PRT_VIRTUAL
	prt(map2(i))%copy = n
	prt(n)%orig = map2(i)
	end if
	map2(i) = n
	end subroutine append
	end subroutine particle_set_to_hepevt_form

	@ %def particle_set_to_hepevt_form
	@ This procedure aims at reconstructing the momenta of an interaction,
	given a particle set. The main task is to find the original hard process, by
	following the event history.

	In-state: take those particles which are flagged as [[PRT_INCOMING]]

	Out-state: try to be smart by checking the immediate children of the incoming
	particles. If the [[state_flv]] table is present, check any [[PRT_RESONANT]]
	particles that we get this way, whether they are potential out-particles by
	their PDG codes. If not, replace them by their children, recursively.
	(Resonances may have been inserted by the corresponding event transform.)

	[WK 21-02-16] Revised the algorithm for the case [[recover_beams]] = false,
	i.e., the particle set contains beams and radiation. This does not mean that
	the particle set contains the complete radiation history. To make up for
	missing information, we follow the history in the interaction one step
	backwards and do a bit of guesswork to match this to the possibly incomplete
	history in the particle set. [The current implementation allows only for one
	stage of radiation; this could be improved by iterating the procedure!]

	[WK 21-03-21] Amended the [[find_hard_process_in_pset]] algorithm as follows:
	Occasionally, PYTHIA adds a stepchild to the decay of a resonance that WHIZARD
	has inserted, a shower object that also has other particles in the event as
	parents. Such objects must not enter the hard-process record. Therefore,
	resonance child particle objects are ignored if they have more than one
	parent.
	<<Particles: particle set: TBP>>=
	procedure :: fill_interaction => particle_set_fill_interaction
	<<Particles: procedures>>=
	subroutine particle_set_fill_interaction &
	(pset, int, n_in, recover_beams, check_match, state_flv, success)
	class(particle_set_t), intent(in) :: pset
	type(interaction_t), intent(inout) :: int
	integer, intent(in) :: n_in
	logical, intent(in), optional :: recover_beams, check_match
	type(state_flv_content_t), intent(in), optional :: state_flv
	logical, intent(out), optional :: success
	integer, dimension(:), allocatable :: map, pdg
	integer, dimension(:), allocatable :: i_in, i_out, p_in, p_out
	logical, dimension(:), allocatable :: i_set
	integer :: n_out, i, p
	logical :: r_beams, check
	r_beams = .false.; if (present (recover_beams)) r_beams = recover_beams
	check = .true.; if (present (check_match)) check = check_match
	if (check) then
	call find_hard_process_in_int (i_in, i_out)
	call find_hard_process_in_pset (p_in, p_out, state_flv, success)
	if (present (success)) then
	if (size (i_in) /= n_in) success = .false.
	if (size (p_in) /= n_in) success = .false.
	if (size (p_out) /= n_out) success = .false.
	if (.not. success) return
	else
	if (size (i_in) /= n_in) call err_int_n_in
	if (size (p_in) /= n_in) call err_pset_n_in
	if (size (p_out) /= n_out) call err_pset_n_out
	end if
	call extract_hard_process_from_pset (pdg)
	call determine_map_for_hard_process (map, state_flv, success)
	if (present (success)) then
	if (.not. success) return
	end if
	call map_handle_duplicates (map)
	if (.not. r_beams) then
	call determine_map_for_beams (map)
	call map_handle_duplicates (map)
	call determine_map_for_radiation (map, i_in, p_in)
	call map_handle_duplicates (map)
	end if
	else
	allocate (map (int%get_n_tot ()))
	map = [(i, i = 1, size (map))]
	r_beams = .false.
	end if
	allocate (i_set (int%get_n_tot ()), source = .false.)
	do p = 1, size (map)
	if (map(p) /= 0) then
	if (.not. i_set(map(p))) then
	call int%set_momentum (pset%prt(p)%get_momentum (), map(p))
	i_set(map(p)) = .true.
	end if
	end if
	end do
	if (r_beams) then
	do i = 1, n_in
	call reconstruct_beam_and_radiation (i, i_set)
	end do
	else
	do i = int%get_n_tot (), 1, -1
	if (.not. i_set(i)) call reconstruct_missing (i, i_set)
	end do
	end if
	if (any (.not. i_set)) then
	if (present (success)) then
	success = .false.
	else
	call err_map
	end if
	end if
	contains
	subroutine find_hard_process_in_int (i_in, i_out)
	integer, dimension(:), allocatable, intent(out) :: i_in, i_out
	integer :: n_in_i
	integer :: i
	i = int%get_n_tot ()
	n_in_i = interaction_get_n_parents (int, i)
	if (n_in_i /= n_in) call err_int_n_in
	allocate (i_in (n_in))
	i_in = interaction_get_parents (int, i)
	i = i_in(1)
	n_out = interaction_get_n_children (int, i)
	allocate (i_out (n_out))
	i_out = interaction_get_children (int, i)
	end subroutine find_hard_process_in_int
	subroutine find_hard_process_in_pset (p_in, p_out, state_flv, success)
	integer, dimension(:), allocatable, intent(out) :: p_in, p_out
	type(state_flv_content_t), intent(in), optional :: state_flv
	logical, intent(out), optional :: success
	integer, dimension(:), allocatable :: p_status, p_idx, p_child
	integer :: n_out_p, n_child, n_shift
	integer :: i, k, c
	allocate (p_status (pset%n_tot), p_idx (pset%n_tot), p_child (pset%n_tot))
	p_status = pset%prt%get_status ()
	p_idx = [(i, i = 1, pset%n_tot)]
	allocate (p_in (n_in))
	p_in = pack (p_idx, p_status == PRT_INCOMING)
	if (size (p_in) == 0) call err_pset_hard
	i = p_in(1)
	allocate (p_out (n_out))
	n_out_p = particle_get_n_children (pset%prt(i))
	p_out(1:n_out_p) = particle_get_children (pset%prt(i))
	do k = 1, size (p_out)
	i = p_out(k)
	if (present (state_flv)) then
	do while (pset%prt(i)%get_status () == PRT_RESONANT)
	if (state_flv%contains (pset%prt(i)%get_pdg ())) exit
	n_child = particle_get_n_children (pset%prt(i))
	p_child(1:n_child) = particle_get_children (pset%prt(i))
	n_shift = -1
	do c = 1, n_child
	if (particle_get_n_parents (pset%prt(p_child(c))) == 1) then
	n_shift = n_shift + 1
	else
	p_child(c) = 0
	end if
	end do
	if (n_shift < 0) then
	if (present (success)) then
	success = .false.
	return
	else
	call err_mismatch
	end if
	end if
	p_out(k+1+n_shift:n_out_p+n_shift) = p_out(k+1:n_out_p)
	n_out_p = n_out_p + n_shift
	do c = 1, n_child
	if (p_child(c) /= 0) then
	p_out(k+c-1) = p_child(c)
	end if
	end do
	i = p_out(k)
	end do
	end if
	end do
	if (present (success)) success = .true.
	end subroutine find_hard_process_in_pset
	subroutine extract_hard_process_from_pset (pdg)
	integer, dimension(:), allocatable, intent(out) :: pdg
	integer, dimension(:), allocatable :: pdg_p
	logical, dimension(:), allocatable :: mask_p
	integer :: i
	allocate (pdg_p (pset%n_tot))
	pdg_p = pset%prt%get_pdg ()
	allocate (mask_p (pset%n_tot), source = .false.)
	mask_p (p_in) = .true.
	mask_p (p_out) = .true.
	allocate (pdg (n_in + n_out))
	pdg = pack (pdg_p, mask_p)
	end subroutine extract_hard_process_from_pset
	subroutine determine_map_for_hard_process (map, state_flv, success)
	integer, dimension(:), allocatable, intent(out) :: map
	type(state_flv_content_t), intent(in), optional :: state_flv
	logical, intent(out), optional :: success
	integer, dimension(:), allocatable :: pdg_i, map_i
	integer :: n_tot
	logical, dimension(:), allocatable :: mask_i, mask_p
	logical :: match
	n_tot = int%get_n_tot ()
	if (present (state_flv)) then
	allocate (mask_i (n_tot), source = .false.)
	mask_i (i_in) = .true.
	mask_i (i_out) = .true.
	allocate (pdg_i (n_tot), map_i (n_tot))
	pdg_i = unpack (pdg, mask_i, 0)
	call state_flv%match (pdg_i, match, map_i)
	if (present (success)) then
	success = match
	end if
	if (.not. match) then
	if (present (success)) then
	return
	else
	call err_mismatch
	end if
	end if
	allocate (mask_p (pset%n_tot), source = .false.)
	mask_p (p_in) = .true.
	mask_p (p_out) = .true.
	allocate (map (size (mask_p)), &
	source = unpack (pack (map_i, mask_i), mask_p, 0))
	else
	allocate (map (n_tot), source = 0)
	map(p_in) = i_in
	map(p_out) = i_out
	end if
	end subroutine determine_map_for_hard_process
	subroutine map_handle_duplicates (map)
	integer, dimension(:), intent(inout) :: map
	integer, dimension(1) :: p_parent, p_child
	integer :: p
	do p = 1, pset%n_tot
	if (map(p) == 0) then
	if (pset%prt(p)%get_n_parents () == 1) then
	p_parent = pset%prt(p)%get_parents ()
	if (map(p_parent(1)) /= 0) then
	if (pset%prt(p_parent(1))%get_n_children () == 1) then
	map(p) = map(p_parent(1))
	end if
	end if
	end if
	end if
	end do
	do p = pset%n_tot, 1, -1
	if (map(p) == 0) then
	if (pset%prt(p)%get_n_children () == 1) then
	p_child = pset%prt(p)%get_children ()
	if (map(p_child(1)) /= 0) then
	if (pset%prt(p_child(1))%get_n_parents () == 1) then
	map(p) = map(p_child(1))
	end if
	end if
	end if
	end if
	end do
	end subroutine map_handle_duplicates
	subroutine determine_map_for_beams (map)
	integer, dimension(:), intent(inout) :: map
	select case (n_in)
	case (1); map(1) = 1
	case (2); map(1:2) = [1,2]
	end select
	end subroutine determine_map_for_beams
	subroutine determine_map_for_radiation (map, i_in, p_in)
	integer, dimension(:), intent(inout) :: map
	integer, dimension(:), intent(in) :: i_in
	integer, dimension(:), intent(in) :: p_in
	integer, dimension(:), allocatable :: i_cur, p_cur
	integer, dimension(:), allocatable :: i_par, p_par, i_rad, p_rad
	integer :: i, p
	integer :: b, r
	i_cur = i_in
	p_cur = p_in
	do b = 1, n_in
	i = i_cur(b)
	p = p_cur(b)
	i_par = interaction_get_parents (int, i)
	p_par = pset%prt(p)%get_parents ()
	if (size (i_par) == 0 .or. size (p_par) == 0) cycle
	if (size (p_par) == 1) then
	if (pset%prt(p_par(1))%get_n_children () == 1) then
	p_par = pset%prt(p_par(1))%get_parents () ! copy of entry
	end if
	end if
	i_rad = interaction_get_children (int, i_par(1))
	p_rad = pset%prt(p_par(1))%get_children ()
	do r = 1, size (i_rad)
	if (any (map == i_rad(r))) i_rad(r) = 0
	end do
	i_rad = pack (i_rad, i_rad /= 0)
	do r = 1, size (p_rad)
	if (map(p_rad(r)) /= 0) p_rad(r) = 0
	end do
	p_rad = pack (p_rad, p_rad /= 0)
	do r = 1, min (size (i_rad), size (p_rad))
	map(p_rad(r)) = i_rad(r)
	end do
	end do
	do b = 1, min (size (p_par), size (i_par))
	if (map(p_par(b)) == 0 .and. all (map /= i_par(b))) then
	map(p_par(b)) = i_par(b)
	end if
	end do
	end subroutine determine_map_for_radiation
	subroutine reconstruct_beam_and_radiation (k, i_set)
	integer, intent(in) :: k
	logical, dimension(:), intent(inout) :: i_set
	integer :: k_src, k_pre, k_in, k_rad
	type(interaction_t), pointer :: int_src
	integer, dimension(2) :: i_child
	logical, dimension(2) :: is_final
	integer :: i
	call int%find_source (k, int_src, k_src)
	k_pre = 0
	k_in = k
	do while (.not. i_set (k_in))
	if (k_pre == 0) then
	call int%set_momentum (int_src%get_momentum (k_src), k_in)
	else
	call int%set_momentum (int%get_momentum (k_pre), k_in)
	end if
	i_set(k_in) = .true.
	if (n_in == 2) then
	k_pre = k_in
	i_child = interaction_get_children (int, k_pre)
	do i = 1, 2
	is_final(i) = interaction_get_n_children (int, i_child(i)) == 0
	end do
	if (all (.not. is_final)) then
	k_in = i_child(k); k_rad = 0
	else if (is_final(2)) then
	k_in = i_child(1); k_rad = i_child(2)
	else if (is_final(1)) then
	k_in = i_child(2); k_rad = i_child(1)
	else
	call err_beams
	end if
	if (k_rad /= 0) then
	if (i_set (k_in)) then
	call int%set_momentum &
	(int%get_momentum (k) - int%get_momentum (k_in), k_rad)
	i_set(k_rad) = .true.
	else
	call err_beams_norad
	end if
	end if
	end if
	end do
	end subroutine reconstruct_beam_and_radiation
	subroutine reconstruct_missing (i, i_set)
	integer, intent(in) :: i
	logical, dimension(:), intent(inout) :: i_set
	integer, dimension(:), allocatable :: i_child, i_parent, i_sibling
	integer :: s
	i_child = interaction_get_children (int, i)
	i_parent = interaction_get_parents (int, i)
	if (size (i_child) > 0 .and. all (i_set(i_child))) then
	call int%set_momentum (sum (int%get_momenta (i_child)), i)
	else if (size (i_parent) > 0 .and. all (i_set(i_parent))) then
	i_sibling = interaction_get_children (int, i_parent(1))
	call int%set_momentum (sum (int%get_momenta (i_parent)), i)
	do s = 1, size (i_sibling)
	if (i_sibling(s) == i) cycle
	if (i_set(i_sibling(s))) then
	call int%set_momentum (int%get_momentum (i) &
	- int%get_momentum (i_sibling(s)), i)
	else
	call err_beams_norad
	end if
	end do
	else
	call err_beams_norad
	end if
	i_set(i) = .true.
	end subroutine reconstruct_missing
	subroutine err_pset_hard
	call msg_fatal ("Reading particle set: no particles marked as incoming")
	end subroutine err_pset_hard
	subroutine err_int_n_in
	integer :: n
	if (allocated (i_in)) then
	n = size (i_in)
	else
	n = 0
	end if
	write (msg_buffer, "(A,I0,A,I0)") &
	"Filling hard process from particle set: expect ", n_in, &
	" incoming particle(s), found ", n
	call msg_bug
	end subroutine err_int_n_in
	subroutine err_pset_n_in
	write (msg_buffer, "(A,I0,A,I0)") &
	"Reading hard-process particle set: should contain ", n_in, &
	" incoming particle(s), found ", size (p_in)
	call msg_fatal
	end subroutine err_pset_n_in
	subroutine err_pset_n_out
	write (msg_buffer, "(A,I0,A,I0)") &
	"Reading hard-process particle set: should contain ", n_out, &
	" outgoing particle(s), found ", size (p_out)
	call msg_fatal
	end subroutine err_pset_n_out
	subroutine err_mismatch
	call pset%write ()
	call state_flv%write ()
	call msg_fatal ("Reading particle set: Flavor combination " &
	// "does not match requested process")
	end subroutine err_mismatch
	subroutine err_map
	call pset%write ()
	call int%basic_write ()
	call msg_fatal ("Reading hard-process particle set: " &
	// "Incomplete mapping from particle set to interaction")
	end subroutine err_map
	subroutine err_beams
	call pset%write ()
	call int%basic_write ()
	call msg_fatal ("Reading particle set: Beam structure " &
	// "does not match requested process")
	end subroutine err_beams
	subroutine err_beams_norad
	call pset%write ()
	call int%basic_write ()
	call msg_fatal ("Reading particle set: Beam structure " &
	// "cannot be reconstructed for this configuration")
	end subroutine err_beams_norad
	subroutine err_radiation
	call int%basic_write ()
	call msg_bug ("Reading particle set: Interaction " &
	// "contains inconsistent radiation pattern.")
	end subroutine err_radiation
	end subroutine particle_set_fill_interaction

	@ %def particle_set_fill_interaction
	@
	This procedure reconstructs an array of vertex indices from the
	parent-child information in the particle entries, according to the
	HepMC scheme. For each particle, we determine which vertex it comes
	from and which vertex it goes to. We return the two arrays and the
	maximum vertex index.

	For each particle in the list, we first check its parents. If for any
	parent the vertex where it goes to is already known, this vertex index
	is assigned as the current 'from' vertex. Otherwise, a new index is
	created, assigned as the current 'from' vertex, and as the 'to' vertex
	for all parents.

	Then, the analogous procedure is done for the children.

	Furthermore, we assign to each vertex the vertex position from the
	parent(s). We check that these vertex positions coincide, and if not
	return a null vector.
	<<Particles: particle set: TBP>>=
	procedure :: assign_vertices => particle_set_assign_vertices
	<<Particles: procedures>>=
	subroutine particle_set_assign_vertices &
	(particle_set, v_from, v_to, n_vertices)
	class(particle_set_t), intent(in) :: particle_set
	integer, dimension(:), intent(out) :: v_from, v_to
	integer, intent(out) :: n_vertices
	integer, dimension(:), allocatable :: parent, child
	integer :: n_parents, n_children, vf, vt
	integer :: i, j, v
	v_from = 0
	v_to = 0
	vf = 0
	vt = 0
	do i = 1, particle_set%n_tot
	n_parents = particle_set%prt(i)%get_n_parents ()
	if (n_parents /= 0) then
	allocate (parent (n_parents))
	parent = particle_set%prt(i)%get_parents ()
	SCAN_PARENTS: do j = 1, size (parent)
	v = v_to(parent(j))
	if (v /= 0) then
	v_from(i) = v; exit SCAN_PARENTS
	end if
	end do SCAN_PARENTS
	if (v_from(i) == 0) then
	vf = vf + 1; v_from(i) = vf
	v_to(parent) = vf
	end if
	deallocate (parent)
	end if
	n_children = particle_set%prt(i)%get_n_children ()
	if (n_children /= 0) then
	allocate (child (n_children))
	child = particle_set%prt(i)%get_children ()
	SCAN_CHILDREN: do j = 1, size (child)
	v = v_from(child(j))
	if (v /= 0) then
	v_to(i) = v; exit SCAN_CHILDREN
	end if
	end do SCAN_CHILDREN
	if (v_to(i) == 0) then
	vt = vt + 1; v_to(i) = vt
	v_from(child) = vt
	end if
	deallocate (child)
	end if
	end do
	n_vertices = max (vf, vt)
	end subroutine particle_set_assign_vertices

	@ %def particle_set_assign_vertices
	@
	\subsection{Expression interface}
	This converts a [[particle_set]] object as defined here to a more
	concise [[subevt]] object that can be used as the event root of an
	expression. In particular, the latter lacks virtual particles, spin
	correlations and parent-child relations.

	We keep beam particles, incoming partons, and outgoing partons.
	Furthermore, we keep radiated particles (a.k.a.\ beam remnants) if
	they have no children in the current particle set, and mark them as
	outgoing particles.

	If [[colorize]] is set and true, mark all particles in the subevent as
	colorized, and set color/anticolor flow indices where they are defined.
	Colorless particles do not get indices but are still marked as colorized, for
	consistency.
	<<Particles: particle set: TBP>>=
	procedure :: to_subevt => particle_set_to_subevt
	<<Particles: procedures>>=
	subroutine particle_set_to_subevt (particle_set, subevt, colorize)
	class(particle_set_t), intent(in) :: particle_set
	type(subevt_t), intent(out) :: subevt
	logical, intent(in), optional :: colorize
	integer :: n_tot, n_beam, n_in, n_out, n_rad
	integer :: i, k, n_active
	integer, dimension(2) :: hel
	logical :: keep
	n_tot = particle_set_get_n_tot (particle_set)
	n_beam = particle_set_get_n_beam (particle_set)
	n_in = particle_set_get_n_in (particle_set)
	n_out = particle_set_get_n_out (particle_set)
	n_rad = particle_set_get_n_remnants (particle_set)
	call subevt_init (subevt, n_beam + n_rad + n_in + n_out)
	k = 0
	do i = 1, n_tot
	associate (prt => particle_set%prt(i))
	keep = .false.
	select case (particle_get_status (prt))
	case (PRT_BEAM)
	k = k + 1
	- call subevt_set_beam (subevt, k, &
	+ call subevt%set_beam (k, &
	particle_get_pdg (prt), &
	particle_get_momentum (prt), &
	particle_get_p2 (prt))
	keep = .true.
	case (PRT_INCOMING)
	k = k + 1
	- call subevt_set_incoming (subevt, k, &
	+ call subevt%set_incoming (k, &
	particle_get_pdg (prt), &
	particle_get_momentum (prt), &
	particle_get_p2 (prt))
	keep = .true.
	case (PRT_OUTGOING)
	k = k + 1
	- call subevt_set_outgoing (subevt, k, &
	+ call subevt%set_outgoing (k, &
	particle_get_pdg (prt), &
	particle_get_momentum (prt), &
	particle_get_p2 (prt))
	keep = .true.
	case (PRT_BEAM_REMNANT)
	if (particle_get_n_children (prt) == 0) then
	k = k + 1
	- call subevt_set_outgoing (subevt, k, &
	+ call subevt%set_outgoing (k, &
	particle_get_pdg (prt), &
	particle_get_momentum (prt), &
	particle_get_p2 (prt))
	keep = .true.
	end if
	end select
	if (keep) then
	if (prt%polarization == PRT_DEFINITE_HELICITY) then
	if (prt%hel%is_diagonal ()) then
	hel = prt%hel%to_pair ()
	call subevt_polarize (subevt, k, hel(1))
	end if
	end if
	end if
	if (present (colorize)) then
	if (colorize) then
	call subevt_colorize &
	(subevt, i, prt%col%get_col (), prt%col%get_acl ())
	end if
	end if
	end associate
	n_active = k
	end do
	- call subevt_reset (subevt, n_active)
	+ call subevt%reset (n_active)
	end subroutine particle_set_to_subevt

	@ %def particle_set_to_subevt
	@
	This replaces the [[particle\_set\%prt array]] with a given array of particles
	<<Particles: particle set: TBP>>=
	procedure :: replace => particle_set_replace
	<<Particles: procedures>>=
	subroutine particle_set_replace (particle_set, newprt)
	class(particle_set_t), intent(inout) :: particle_set
	type(particle_t), intent(in), dimension(:), allocatable :: newprt
	if (allocated (particle_set%prt)) deallocate (particle_set%prt)
	allocate (particle_set%prt(size (newprt)))
	particle_set%prt = newprt
	particle_set%n_tot = size (newprt)
	particle_set%n_beam = count (particle_get_status (newprt) == PRT_BEAM)
	particle_set%n_in = count (particle_get_status (newprt) == PRT_INCOMING)
	particle_set%n_out = count (particle_get_status (newprt) == PRT_OUTGOING)
	particle_set%n_vir = particle_set%n_tot &
	- particle_set%n_beam - particle_set%n_in - particle_set%n_out
	end subroutine particle_set_replace

	@ %def particle_set_replace
	@ This routines orders the outgoing particles into clusters of
	colorless particles and such of particles ordered corresponding to the
	indices of the color lines. All outgoing particles in the ordered set
	appear as child of the corresponding outgoing particle in the
	unordered set, including colored beam remnants. We always start
	continue via the anti-color line, such that color flows within each
	Lund string system is always continued from the anticolor of one
	particle to the identical color index of another particle.
	<<Particles: particle set: TBP>>=
	procedure :: order_color_lines => particle_set_order_color_lines
	<<Particles: procedures>>=
	subroutine particle_set_order_color_lines (pset_out, pset_in)
	class(particle_set_t), intent(inout) :: pset_out
	type(particle_set_t), intent(in) :: pset_in
	integer :: i, n, n_col_rem
	n_col_rem = 0
	do i = 1, pset_in%n_tot
	if (pset_in%prt(i)%get_status () == PRT_BEAM_REMNANT .and. &
	any (pset_in%prt(i)%get_color () /= 0)) then
	n_col_rem = n_col_rem + 1
	end if
	end do
	pset_out%n_beam = pset_in%n_beam
	pset_out%n_in = pset_in%n_in
	pset_out%n_vir = pset_in%n_vir + pset_in%n_out + n_col_rem
	pset_out%n_out = pset_in%n_out
	pset_out%n_tot = pset_in%n_tot + pset_in%n_out + n_col_rem
	pset_out%correlated_state = pset_in%correlated_state
	pset_out%factorization_mode = pset_in%factorization_mode
	allocate (pset_out%prt (pset_out%n_tot))
	do i = 1, pset_in%n_tot
	call pset_out%prt(i)%init (pset_in%prt(i))
	call pset_out%prt(i)%set_children (pset_in%prt(i)%child)
	call pset_out%prt(i)%set_parents (pset_in%prt(i)%parent)
	end do
	n = pset_in%n_tot
	do i = 1, pset_in%n_tot
	if (pset_out%prt(i)%get_status () == PRT_OUTGOING .and. &
	all (pset_out%prt(i)%get_color () == 0) .and. &
	.not. pset_out%prt(i)%has_children ()) then
	n = n + 1
	call pset_out%prt(n)%init (pset_out%prt(i))
	call pset_out%prt(i)%reset_status (PRT_VIRTUAL)
	call pset_out%prt(i)%add_child (n)
	call pset_out%prt(i)%set_parents ([i])
	end if
	end do
	if (n_col_rem > 0) then
	do i = 1, n_col_rem
	end do
	end if
	end subroutine particle_set_order_color_lines

	@ %def particle_set_order_color_lines
	@
	Eliminate numerical noise
	<<Particles: public>>=
	public :: pacify
	<<Particles: interfaces>>=
	interface pacify
	module procedure pacify_particle
	module procedure pacify_particle_set
	end interface pacify

	<<Particles: procedures>>=
	subroutine pacify_particle (prt)
	class(particle_t), intent(inout) :: prt
	real(default) :: e
	e = epsilon (1._default) * energy (prt%p)
	call pacify (prt%p, 10 * e)
	call pacify (prt%p2, 1e4 * e)
	end subroutine pacify_particle

	subroutine pacify_particle_set (pset)
	class(particle_set_t), intent(inout) :: pset
	integer :: i
	do i = 1, pset%n_tot
	call pacify (pset%prt(i))
	end do
	end subroutine pacify_particle_set

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

	module particles_ut
	use unit_tests
	use particles_uti

	<<Standard module head>>

	<<Particles: public test>>

	contains

	<<Particles: test driver>>

	end module particles_ut
	@ %def particles_ut
	@
	<<[[particles_uti.f90]]>>=
	<<File header>>

	module particles_uti

	<<Use kinds>>
	use io_units
	use numeric_utils
	use constants, only: one, tiny_07
	use lorentz
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices
	use interactions
	use evaluators
	use model_data
	use subevents

	use particles

	<<Standard module head>>

	<<Particles: test declarations>>

	contains

	<<Particles: tests>>

	<<Particles: test auxiliary>>

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

	@ %def particles_test
	@
	Check the basic setup of the [[particle_set_t]] type:
	Set up a chain of production and decay and factorize the result into
	particles. The process is $d\bar d \to Z \to q\bar q$.
	<<Particles: execute tests>>=
	call test (particles_1, "particles_1", &
	"check particle_set routines", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_1
	<<Particles: tests>>=
	subroutine particles_1 (u)
	use os_interface
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(3) :: flv
	type(color_t), dimension(3) :: col
	type(helicity_t), dimension(3) :: hel
	type(quantum_numbers_t), dimension(3) :: qn
	type(vector4_t), dimension(3) :: p
	type(interaction_t), target :: int1, int2
	type(quantum_numbers_mask_t) :: qn_mask_conn
	type(evaluator_t), target :: eval
	type(interaction_t) :: int
	type(particle_set_t) :: particle_set1, particle_set2
	type(particle_set_t) :: particle_set3, particle_set4
	type(subevt_t) :: subevt
	logical :: ok
	integer :: unit, iostat

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: test particle_set routines"
	write (u, "(A)")

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

	call model%init_sm_test ()

	write (u, "(A)")
	write (u, "(A)") "* Initializing production process"

	call int1%basic_init (2, 0, 1, set_relations=.true.)
	call flv%init ([1, -1, 23], model)
	call col%init_col_acl ([0, 0, 0], [0, 0, 0])
	call hel(3)%init (1, 1)
	call qn%init (flv, col, hel)
	call int1%add_state (qn, value=(0.25_default, 0._default))
	call hel(3)%init (1,-1)
	call qn%init (flv, col, hel)
	call int1%add_state (qn, value=(0._default, 0.25_default))
	call hel(3)%init (-1, 1)
	call qn%init (flv, col, hel)
	call int1%add_state (qn, value=(0._default,-0.25_default))
	call hel(3)%init (-1,-1)
	call qn%init (flv, col, hel)
	call int1%add_state (qn, value=(0.25_default, 0._default))
	call hel(3)%init (0, 0)
	call qn%init (flv, col, hel)
	call int1%add_state (qn, value=(0.5_default, 0._default))
	call int1%freeze ()
	p(1) = vector4_moving (45._default, 45._default, 3)
	p(2) = vector4_moving (45._default,-45._default, 3)
	p(3) = p(1) + p(2)
	call int1%set_momenta (p)

	write (u, "(A)")
	write (u, "(A)") "* Setup decay process"

	call int2%basic_init (1, 0, 2, set_relations=.true.)
	call flv%init ([23, 1, -1], model)
	call col%init_col_acl ([0, 501, 0], [0, 0, 501])
	call hel%init ([1, 1, 1], [1, 1, 1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(1._default, 0._default))
	call hel%init ([1, 1, 1], [-1,-1,-1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(0._default, 0.1_default))
	call hel%init ([-1,-1,-1], [1, 1, 1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(0._default,-0.1_default))
	call hel%init ([-1,-1,-1], [-1,-1,-1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(1._default, 0._default))
	call hel%init ([0, 1,-1], [0, 1,-1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(4._default, 0._default))
	call hel%init ([0,-1, 1], [0, 1,-1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(2._default, 0._default))
	call hel%init ([0, 1,-1], [0,-1, 1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(2._default, 0._default))
	call hel%init ([0,-1, 1], [0,-1, 1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(4._default, 0._default))
	call flv%init ([23, 2, -2], model)
	call hel%init ([0, 1,-1], [0, 1,-1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(0.5_default, 0._default))
	call hel%init ([0,-1, 1], [0,-1, 1])
	call qn%init (flv, col, hel)
	call int2%add_state (qn, value=(0.5_default, 0._default))
	call int2%freeze ()
	p(2) = vector4_moving (45._default, 45._default, 2)
	p(3) = vector4_moving (45._default,-45._default, 2)
	call int2%set_momenta (p)
	call int2%set_source_link (1, int1, 3)
	call int1%basic_write (u)
	call int2%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Concatenate production and decay"

	call eval%init_product (int1, int2, qn_mask_conn, &
	connections_are_resonant=.true.)
	call eval%receive_momenta ()
	call eval%evaluate ()
	call eval%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Factorize as subevent (complete, polarized)"
	write (u, "(A)")

	int = eval%interaction_t
	call particle_set1%init &
	(ok, int, int, FM_FACTOR_HELICITY, &
	[0.2_default, 0.2_default], .false., .true.)
	call particle_set1%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)"
	write (u, "(A)")

	int = eval%interaction_t
	call particle_set2%init &
	(ok, int, int, FM_SELECT_HELICITY, &
	[0.9_default, 0.9_default], .false., .false.)
	call particle_set2%write (u)
	call particle_set2%final ()

	write (u, "(A)")
	write (u, "(A)") "* Factorize as subevent (complete, selected helicity)"
	write (u, "(A)")

	int = eval%interaction_t
	call particle_set2%init &
	(ok, int, int, FM_SELECT_HELICITY, &
	[0.7_default, 0.7_default], .false., .true.)
	call particle_set2%write (u)

	write (u, "(A)")
	write (u, "(A)") &
	"* Factorize (complete, polarized, correlated); write and read again"
	write (u, "(A)")

	int = eval%interaction_t
	call particle_set3%init &
	(ok, int, int, FM_FACTOR_HELICITY, &
	[0.7_default, 0.7_default], .true., .true.)
	call particle_set3%write (u)

	unit = free_unit ()
	open (unit, action="readwrite", form="unformatted", status="scratch")
	call particle_set3%write_raw (unit)
	rewind (unit)
	call particle_set4%read_raw (unit, iostat=iostat)
	call particle_set4%set_model (model)
	close (unit)

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

	call particle_set4%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Transform to a subevt object"
	write (u, "(A)")

	call particle_set4%to_subevt (subevt)
	- call subevt_write (subevt, u)
	+ call subevt%write (u)

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

	call particle_set1%final ()
	call particle_set2%final ()
	call particle_set3%final ()
	call particle_set4%final ()
	call eval%final ()
	call int1%final ()
	call int2%final ()

	call model%final ()

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

	end subroutine particles_1

	@ %def particles_1
	@
	Reconstruct a hard interaction from a particle set.
	<<Particles: execute tests>>=
	call test (particles_2, "particles_2", &
	"reconstruct hard interaction", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_2
	<<Particles: tests>>=
	subroutine particles_2 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct simple interaction"
	write (u, "(A)")

	write (u, "(A)") "* Set up a 2 -> 3 interaction"
	write (u, "(A)") " + incoming partons marked as virtual"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call reset_interaction_counter ()
	call int%basic_init (0, 2, 3)
	do i = 1, 2
	do j = 3, 5
	call int%relate (i, j)
	end do
	end do

	allocate (qn (5))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .false., .true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [11, 12, 3, 4, 5], &
	map = [1, 2, 3, 4, 5])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	pset%n_beam = 0
	pset%n_in = 2
	pset%n_vir = 0
	pset%n_out = 3
	pset%n_tot = 5
	allocate (pset%prt (pset%n_tot))
	do i = 1, 2
	call pset%prt(i)%reset_status (PRT_INCOMING)
	call pset%prt(i)%set_children ([3,4,5])
	end do
	do i = 3, 5
	call pset%prt(i)%reset_status (PRT_OUTGOING)
	call pset%prt(i)%set_parents ([1,2])
	end do
	call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(5)%set_momentum (vector4_at_rest (3._default))

	allocate (flv (5))
	call flv%init ([11,12,5,4,3])
	do i = 1, 5
	call pset%prt(i)%set_flavor (flv(i))
	end do

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 2, state_flv=state_flv)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_2

	@ %def particles_2
	@
	Reconstruct an interaction with beam structure, e.g., a hadronic
	interaction, from a particle set.
	<<Particles: execute tests>>=
	call test (particles_3, "particles_3", &
	"reconstruct interaction with beam structure", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_3
	<<Particles: tests>>=
	subroutine particles_3 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct simple interaction"
	write (u, "(A)")

	write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call reset_interaction_counter ()
	call int%basic_init (0, 6, 3)
	call int%relate (1, 3)
	call int%relate (1, 4)
	call int%relate (2, 5)
	call int%relate (2, 6)
	do i = 4, 6, 2
	do j = 7, 9
	call int%relate (i, j)
	end do
	end do

	allocate (qn (9))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .false., .false., .false., .false., .false., &
	.true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
	map = [1, 2, 3, 4, 5, 6, 7, 8, 9])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	call create_test_particle_set_1 (pset)

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 2, state_flv=state_flv)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_3

	@ %def particles_3
	@
	<<Particles: test auxiliary>>=
	subroutine create_test_particle_set_1 (pset)
	type(particle_set_t), intent(out) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	pset%n_beam = 2
	pset%n_in = 2
	pset%n_vir = 2
	pset%n_out = 3
	pset%n_tot = 9

	allocate (pset%prt (pset%n_tot))
	call pset%prt(1)%reset_status (PRT_BEAM)
	call pset%prt(2)%reset_status (PRT_BEAM)
	call pset%prt(3)%reset_status (PRT_INCOMING)
	call pset%prt(4)%reset_status (PRT_INCOMING)
	call pset%prt(5)%reset_status (PRT_BEAM_REMNANT)
	call pset%prt(6)%reset_status (PRT_BEAM_REMNANT)
	call pset%prt(7)%reset_status (PRT_OUTGOING)
	call pset%prt(8)%reset_status (PRT_OUTGOING)
	call pset%prt(9)%reset_status (PRT_OUTGOING)

	call pset%prt(1)%set_children ([3,5])
	call pset%prt(2)%set_children ([4,6])
	call pset%prt(3)%set_children ([7,8,9])
	call pset%prt(4)%set_children ([7,8,9])

	call pset%prt(3)%set_parents ([1])
	call pset%prt(4)%set_parents ([2])
	call pset%prt(5)%set_parents ([1])
	call pset%prt(6)%set_parents ([2])
	call pset%prt(7)%set_parents ([3,4])
	call pset%prt(8)%set_parents ([3,4])
	call pset%prt(9)%set_parents ([3,4])

	call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
	call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
	call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
	call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
	call pset%prt(9)%set_momentum (vector4_at_rest (9._default))

	allocate (flv (9))
	call flv%init ([2011, 2012, 11, 12, 91, 92, 3, 4, 5])
	do i = 1, 9
	call pset%prt(i)%set_flavor (flv(i))
	end do
	end subroutine create_test_particle_set_1

	@ %def create_test_particle_set_1

	@
	Reconstruct an interaction with beam structure, e.g., a hadronic
	interaction, from a particle set that is missing the beam information.
	<<Particles: execute tests>>=
	call test (particles_4, "particles_4", &
	"reconstruct interaction with missing beams", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_4
	<<Particles: tests>>=
	subroutine particles_4 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(interaction_t), target :: int_beams
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct beams"
	write (u, "(A)")

	call reset_interaction_counter ()

	write (u, "(A)") "* Set up an interaction that contains beams only"
	write (u, "(A)")

	call int_beams%basic_init (0, 0, 2)
	call int_beams%set_momentum (vector4_at_rest (1._default), 1)
	call int_beams%set_momentum (vector4_at_rest (2._default), 2)
	allocate (qn (2))
	call int_beams%add_state (qn)
	call int_beams%freeze ()

	call int_beams%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call int%basic_init (0, 6, 3)
	call int%relate (1, 3)
	call int%relate (1, 4)
	call int%relate (2, 5)
	call int%relate (2, 6)
	do i = 4, 6, 2
	do j = 7, 9
	call int%relate (i, j)
	end do
	end do
	do i = 1, 2
	call int%set_source_link (i, int_beams, i)
	end do

	deallocate (qn)
	allocate (qn (9))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .false., .false., .false., .false., .false., &
	.true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
	map = [1, 2, 3, 4, 5, 6, 7, 8, 9])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	pset%n_beam = 0
	pset%n_in = 2
	pset%n_vir = 0
	pset%n_out = 3
	pset%n_tot = 5

	allocate (pset%prt (pset%n_tot))
	call pset%prt(1)%reset_status (PRT_INCOMING)
	call pset%prt(2)%reset_status (PRT_INCOMING)
	call pset%prt(3)%reset_status (PRT_OUTGOING)
	call pset%prt(4)%reset_status (PRT_OUTGOING)
	call pset%prt(5)%reset_status (PRT_OUTGOING)

	call pset%prt(1)%set_children ([3,4,5])
	call pset%prt(2)%set_children ([3,4,5])

	call pset%prt(3)%set_parents ([1,2])
	call pset%prt(4)%set_parents ([1,2])
	call pset%prt(5)%set_parents ([1,2])

	call pset%prt(1)%set_momentum (vector4_at_rest (6._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (6._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(5)%set_momentum (vector4_at_rest (5._default))

	allocate (flv (5))
	call flv%init ([11, 12, 3, 4, 5])
	do i = 1, 5
	call pset%prt(i)%set_flavor (flv(i))
	end do

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 2, state_flv=state_flv, &
	recover_beams = .true.)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_4

	@ %def particles_4
	@
	Reconstruct an interaction with beam structure and cloned particles
	(radiated particles repeated in the event record, to maintain some
	canonical ordering).
	<<Particles: execute tests>>=
	call test (particles_5, "particles_5", &
	"reconstruct interaction with beams and duplicate entries", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_5
	<<Particles: tests>>=
	subroutine particles_5 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct event with duplicate entries"
	write (u, "(A)")

	write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call reset_interaction_counter ()
	call int%basic_init (0, 6, 3)
	call int%relate (1, 3)
	call int%relate (1, 4)
	call int%relate (2, 5)
	call int%relate (2, 6)
	do i = 4, 6, 2
	do j = 7, 9
	call int%relate (i, j)
	end do
	end do

	allocate (qn (9))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .false., .false., .false., .false., .false., &
	.true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
	map = [1, 2, 3, 4, 5, 6, 7, 8, 9])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	pset%n_beam = 2
	pset%n_in = 2
	pset%n_vir = 4
	pset%n_out = 5
	pset%n_tot = 13

	allocate (pset%prt (pset%n_tot))
	call pset%prt(1)%reset_status (PRT_BEAM)
	call pset%prt(2)%reset_status (PRT_BEAM)
	call pset%prt(3)%reset_status (PRT_VIRTUAL)
	call pset%prt(4)%reset_status (PRT_VIRTUAL)
	call pset%prt(5)%reset_status (PRT_VIRTUAL)
	call pset%prt(6)%reset_status (PRT_VIRTUAL)
	call pset%prt(7)%reset_status (PRT_INCOMING)
	call pset%prt(8)%reset_status (PRT_INCOMING)
	call pset%prt( 9)%reset_status (PRT_OUTGOING)
	call pset%prt(10)%reset_status (PRT_OUTGOING)
	call pset%prt(11)%reset_status (PRT_OUTGOING)
	call pset%prt(12)%reset_status (PRT_OUTGOING)
	call pset%prt(13)%reset_status (PRT_OUTGOING)

	call pset%prt(1)%set_children ([3,4])
	call pset%prt(2)%set_children ([5,6])
	call pset%prt(3)%set_children ([ 7])
	call pset%prt(4)%set_children ([ 9])
	call pset%prt(5)%set_children ([ 8])
	call pset%prt(6)%set_children ([10])
	call pset%prt(7)%set_children ([11,12,13])
	call pset%prt(8)%set_children ([11,12,13])

	call pset%prt(3)%set_parents ([1])
	call pset%prt(4)%set_parents ([1])
	call pset%prt(5)%set_parents ([2])
	call pset%prt(6)%set_parents ([2])
	call pset%prt( 7)%set_parents ([3])
	call pset%prt( 8)%set_parents ([5])
	call pset%prt( 9)%set_parents ([4])
	call pset%prt(10)%set_parents ([6])
	call pset%prt(11)%set_parents ([7,8])
	call pset%prt(12)%set_parents ([7,8])
	call pset%prt(13)%set_parents ([7,8])

	call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(5)%set_momentum (vector4_at_rest (6._default))
	call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
	call pset%prt(7)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(8)%set_momentum (vector4_at_rest (6._default))
	call pset%prt( 9)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(10)%set_momentum (vector4_at_rest (5._default))
	call pset%prt(11)%set_momentum (vector4_at_rest (7._default))
	call pset%prt(12)%set_momentum (vector4_at_rest (8._default))
	call pset%prt(13)%set_momentum (vector4_at_rest (9._default))

	allocate (flv (13))
	call flv%init ([2011, 2012, 11, 91, 12, 92, 11, 12, 91, 92, 3, 4, 5])
	do i = 1, 13
	call pset%prt(i)%set_flavor (flv(i))
	end do

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 2, state_flv=state_flv)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_5

	@ %def particles_5
	@
	Reconstruct an interaction with pair spectrum, e.g., beamstrahlung from a
	particle set.
	<<Particles: execute tests>>=
	call test (particles_6, "particles_6", &
	"reconstruct interaction with pair spectrum", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_6
	<<Particles: tests>>=
	subroutine particles_6 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct interaction with pair spectrum"
	write (u, "(A)")

	write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call reset_interaction_counter ()
	call int%basic_init (0, 6, 3)
	do i = 1, 2
	do j = 3, 6
	call int%relate (i, j)
	end do
	end do
	do i = 5, 6
	do j = 7, 9
	call int%relate (i, j)
	end do
	end do

	allocate (qn (9))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .false., .false., .false., .false., .false., &
	.true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [1011, 1012, 21, 22, 11, 12, 3, 4, 5], &
	map = [1, 2, 3, 4, 5, 6, 7, 8, 9])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	pset%n_beam = 2
	pset%n_in = 2
	pset%n_vir = 2
	pset%n_out = 3
	pset%n_tot = 9

	allocate (pset%prt (pset%n_tot))
	call pset%prt(1)%reset_status (PRT_BEAM)
	call pset%prt(2)%reset_status (PRT_BEAM)
	call pset%prt(3)%reset_status (PRT_INCOMING)
	call pset%prt(4)%reset_status (PRT_INCOMING)
	call pset%prt(5)%reset_status (PRT_OUTGOING)
	call pset%prt(6)%reset_status (PRT_OUTGOING)
	call pset%prt(7)%reset_status (PRT_OUTGOING)
	call pset%prt(8)%reset_status (PRT_OUTGOING)
	call pset%prt(9)%reset_status (PRT_OUTGOING)

	call pset%prt(1)%set_children ([3,4,5,6])
	call pset%prt(2)%set_children ([3,4,5,6])
	call pset%prt(3)%set_children ([7,8,9])
	call pset%prt(4)%set_children ([7,8,9])

	call pset%prt(3)%set_parents ([1,2])
	call pset%prt(4)%set_parents ([1,2])
	call pset%prt(5)%set_parents ([1,2])
	call pset%prt(6)%set_parents ([1,2])
	call pset%prt(7)%set_parents ([3,4])
	call pset%prt(8)%set_parents ([3,4])
	call pset%prt(9)%set_parents ([3,4])

	call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
	call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(6)%set_momentum (vector4_at_rest (4._default))
	call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
	call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
	call pset%prt(9)%set_momentum (vector4_at_rest (9._default))

	allocate (flv (9))
	call flv%init ([1011, 1012, 11, 12, 21, 22, 3, 4, 5])
	do i = 1, 9
	call pset%prt(i)%set_flavor (flv(i))
	end do

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 2, state_flv=state_flv)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_6

	@ %def particles_6
	@
	Reconstruct a hard decay interaction from a shuffled particle set.
	<<Particles: execute tests>>=
	call test (particles_7, "particles_7", &
	"reconstruct decay interaction with reordering", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_7
	<<Particles: tests>>=
	subroutine particles_7 (u)

	integer, intent(in) :: u
	type(interaction_t) :: int
	type(state_flv_content_t) :: state_flv
	type(particle_set_t) :: pset
	type(flavor_t), dimension(:), allocatable :: flv
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: i, j

	write (u, "(A)") "* Test output: Particles"
	write (u, "(A)") "* Purpose: reconstruct decay interaction with reordering"
	write (u, "(A)")

	write (u, "(A)") "* Set up a 1 -> 3 interaction"
	write (u, "(A)") " + no quantum numbers"
	write (u, "(A)")

	call reset_interaction_counter ()
	call int%basic_init (0, 1, 3)
	do j = 2, 4
	call int%relate (1, j)
	end do

	allocate (qn (4))
	call int%add_state (qn)
	call int%freeze ()

	call int%basic_write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually set up a flavor-content record"
	write (u, "(A)") "* assumed interaction: 6 12 5 -11"
	write (u, "(A)")

	call state_flv%init (1, &
	mask = [.false., .true., .true., .true.])
	call state_flv%set_entry (1, &
	pdg = [6, 5, -11, 12], &
	map = [1, 4, 2, 3])

	call state_flv%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Manually create a matching particle set"
	write (u, "(A)")

	pset%n_beam = 0
	pset%n_in = 1
	pset%n_vir = 0
	pset%n_out = 3
	pset%n_tot = 4
	allocate (pset%prt (pset%n_tot))
	do i = 1, 1
	call pset%prt(i)%reset_status (PRT_INCOMING)
	call pset%prt(i)%set_children ([2,3,4])
	end do
	do i = 2, 4
	call pset%prt(i)%reset_status (PRT_OUTGOING)
	call pset%prt(i)%set_parents ([1])
	end do
	call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
	call pset%prt(2)%set_momentum (vector4_at_rest (3._default))
	call pset%prt(3)%set_momentum (vector4_at_rest (2._default))
	call pset%prt(4)%set_momentum (vector4_at_rest (4._default))

	allocate (flv (4))
	call flv%init ([6,5,12,-11])
	do i = 1, 4
	call pset%prt(i)%set_flavor (flv(i))
	end do

	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill interaction from particle set"
	write (u, "(A)")

	call pset%fill_interaction (int, 1, state_flv=state_flv)
	call int%basic_write (u)

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

	call int%final ()
	call pset%final ()

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

	end subroutine particles_7

	@ %def particles_7
	@
	<<Particles: execute tests>>=
	call test (particles_8, "particles_8", &
	"Test functions on particle sets", u, results)
	<<Particles: test declarations>>=
	public :: particles_8
	<<Particles: tests>>=
	subroutine particles_8 (u)
	integer, intent(in) :: u
	type(particle_set_t) :: particle_set
	type(particle_t), dimension(:), allocatable :: particles
	integer, allocatable, dimension(:) :: children, parents
	integer :: n_particles, i
	write (u, "(A)") "* Test output: particles_8"
	write (u, "(A)") "* Purpose: Test functions on particle sets"
	write (u, "(A)")

	call create_test_particle_set_1 (particle_set)
	call particle_set%write (u)
	call assert_equal (u, particle_set%n_tot, 9)
	call assert_equal (u, particle_set%n_beam, 2)
	allocate (children (particle_set%prt(3)%get_n_children ()))
	children = particle_set%prt(3)%get_children()
	call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
	call assert_equal (u, size (particle_set%prt(1)%get_children ()), 2)
	call assert_equal (u, size (particle_set%prt(2)%get_children ()), 2)

	call particle_set%without_hadronic_remnants &
	(particles, n_particles, 3)
	call particle_set%replace (particles)
	write (u, "(A)")
	call particle_set%write (u)

	call assert_equal (u, n_particles, 7)
	call assert_equal (u, size(particles), 10)
	call assert_equal (u, particle_set%n_tot, 10)
	call assert_equal (u, particle_set%n_beam, 2)
	do i = 3, 4
	if (allocated (children)) deallocate (children)
	allocate (children (particle_set%prt(i)%get_n_children ()))
	children = particle_set%prt(i)%get_children()
	call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
	call assert_equal (u, particle_set%prt(children(2))%get_pdg (), 4)
	call assert_equal (u, particle_set%prt(children(3))%get_pdg (), 5)
	end do
	do i = 5, 7
	if (allocated (parents)) deallocate (parents)
	allocate (parents (particle_set%prt(i)%get_n_parents ()))
	parents = particle_set%prt(i)%get_parents()
	call assert_equal (u, particle_set%prt(parents(1))%get_pdg (), 11)
	call assert_equal (u, particle_set%prt(parents(2))%get_pdg (), 12)
	end do
	call assert_equal (u, size (particle_set%prt(1)%get_children ()), &
	1, "get children of 1")
	call assert_equal (u, size (particle_set%prt(2)%get_children ()), &
	1, "get children of 2")

	call assert_equal (u, particle_set%find_particle &
	(particle_set%prt(1)%get_pdg (), particle_set%prt(1)%p), &
	1, "find 1st particle")
	call assert_equal (u, particle_set%find_particle &
	(particle_set%prt(2)%get_pdg (), particle_set%prt(2)%p * &
	(one + tiny_07), rel_smallness=1.0E-6_default), &
	2, "find 2nd particle fuzzy")

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

	@ %def particles_8
	@
	Order color lines into Lund string systems, without colored beam
	remnants first.
	<<Particles: execute tests>>=
	call test (particles_9, "particles_9", &
	"order into Lund strings, uncolored beam remnants", &
	u, results)
	<<Particles: test declarations>>=
	public :: particles_9
	<<Particles: tests>>=
	subroutine particles_9 (u)
	integer, intent(in) :: u
	write (u, "(A)") "* Test output: particles_9"
	write (u, "(A)") "* Purpose: Order into Lund strings, "
	write (u, "(A)") "* uncolored beam remnants"
	write (u, "(A)")
	end subroutine particles_9

	@ %def particles_9
	Index: trunk/src/model_features/model_features.nw
	===================================================================
	--- trunk/src/model_features/model_features.nw (revision 8777)
	+++ trunk/src/model_features/model_features.nw (revision 8778)
	@@ -1,17520 +1,17516 @@
	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: model features
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Model Handling and Features}
	\includemodulegraph{model_features}

	These modules deal with process definitions and physics models.

	These modules use the [[model_data]] methods to automatically generate
	process definitions.
	\begin{description}
	\item[auto\_components]
	Generic process-definition generator. We can specify a basic
	process or initial particle(s) and some rules to extend this
	process, given a model definition with particle names and vertex
	structures.
	\item[radiation\_generator]
	Applies the generic generator to the specific problem of generating
	NLO corrections in a restricted setup.
	\end{description}

	Model construction:
	\begin{description}
	\item[eval\_trees]
	Implementation of the generic [[expr_t]] type for the concrete
	evaluation of expressions that access user variables.

	This module is actually part of the Sindarin language implementation, and
	should be moved elsewhere. Currently, the [[models]] module relies
	on it.
	\item[models]
	Extends the [[model_data_t]] structure by user-variable objects for
	easy access, and provides the means to read a model definition from file.
	\item[slha\_interface]
	Read/write a SUSY model in the standardized SLHA format. The format
	defines fields and parameters, but no vertices.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Automatic generation of process components}

	This module provides the functionality for automatically generating radiation
	corrections or decays, provided as lists of PDG codes.
	<<[[auto_components.f90]]>>=
	<<File header>>

	module auto_components

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use diagnostics
	use model_data
	use pdg_arrays
	use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON
	use numeric_utils, only: extend_integer_array

	<<Standard module head>>

	<<Auto components: public>>

	<<Auto components: parameters>>

	<<Auto components: types>>

	<<Auto components: interfaces>>

	contains

	<<Auto components: procedures>>

	end module auto_components
	@ %def auto_components
	@
	\subsection{Constraints: Abstract types}
	An abstract type that denotes a constraint on the automatically generated
	states. The concrete objects are applied as visitor objects at certain hooks
	during the splitting algorithm.
	<<Auto components: types>>=
	type, abstract :: split_constraint_t
	contains
	<<Auto components: split constraint: TBP>>
	end type split_constraint_t

	@ %def split_constraint_t
	@ By default, all checks return true.
	<<Auto components: split constraint: TBP>>=
	procedure :: check_before_split => split_constraint_check_before_split
	procedure :: check_before_insert => split_constraint_check_before_insert
	procedure :: check_before_record => split_constraint_check_before_record
	<<Auto components: procedures>>=
	subroutine split_constraint_check_before_split (c, table, pl, k, passed)
	class(split_constraint_t), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: k
	logical, intent(out) :: passed
	passed = .true.
	end subroutine split_constraint_check_before_split

	subroutine split_constraint_check_before_insert (c, table, pa, pl, passed)
	class(split_constraint_t), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	passed = .true.
	end subroutine split_constraint_check_before_insert

	subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed)
	class(split_constraint_t), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	passed = .true.
	end subroutine split_constraint_check_before_record

	@ %def check_before_split
	@ %def check_before_insert
	@ %def check_before_record
	@ A transparent wrapper, so we can collect constraints of different type.
	<<Auto components: types>>=
	type :: split_constraint_wrap_t
	class(split_constraint_t), allocatable :: c
	end type split_constraint_wrap_t

	@ %def split_constraint_wrap_t
	@ A collection of constraints.
	<<Auto components: public>>=
	public :: split_constraints_t
	<<Auto components: types>>=
	type :: split_constraints_t
	class(split_constraint_wrap_t), dimension(:), allocatable :: cc
	contains
	<<Auto components: split constraints: TBP>>
	end type split_constraints_t

	@ %def split_constraints_t
	@ Initialize the constraints set with a specific number of elements.
	<<Auto components: split constraints: TBP>>=
	procedure :: init => split_constraints_init
	<<Auto components: procedures>>=
	subroutine split_constraints_init (constraints, n)
	class(split_constraints_t), intent(out) :: constraints
	integer, intent(in) :: n
	allocate (constraints%cc (n))
	end subroutine split_constraints_init

	@ %def split_constraints_init
	@ Set a constraint.
	<<Auto components: split constraints: TBP>>=
	procedure :: set => split_constraints_set
	<<Auto components: procedures>>=
	subroutine split_constraints_set (constraints, i, c)
	class(split_constraints_t), intent(inout) :: constraints
	integer, intent(in) :: i
	class(split_constraint_t), intent(in) :: c
	allocate (constraints%cc(i)%c, source = c)
	end subroutine split_constraints_set

	@ %def split_constraints_set
	@ Apply checks.

	[[check_before_split]] is applied to the particle list that we want
	to split.

	[[check_before_insert]] is applied to the particle list [[pl]] that is to
	replace the particle [[pa]] that is split. This check may transform the
	particle list.

	[[check_before_record]] is applied to the complete new particle list that
	results from splitting before it is recorded.
	<<Auto components: split constraints: TBP>>=
	procedure :: check_before_split => split_constraints_check_before_split
	procedure :: check_before_insert => split_constraints_check_before_insert
	procedure :: check_before_record => split_constraints_check_before_record
	<<Auto components: procedures>>=
	subroutine split_constraints_check_before_split &
	(constraints, table, pl, k, passed)
	class(split_constraints_t), intent(in) :: constraints
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: k
	logical, intent(out) :: passed
	integer :: i
	passed = .true.
	do i = 1, size (constraints%cc)
	call constraints%cc(i)%c%check_before_split (table, pl, k, passed)
	if (.not. passed) return
	end do
	end subroutine split_constraints_check_before_split

	subroutine split_constraints_check_before_insert &
	(constraints, table, pa, pl, passed)
	class(split_constraints_t), intent(in) :: constraints
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	integer :: i
	passed = .true.
	do i = 1, size (constraints%cc)
	call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed)
	if (.not. passed) return
	end do
	end subroutine split_constraints_check_before_insert

	subroutine split_constraints_check_before_record &
	(constraints, table, pl, n_loop, passed)
	class(split_constraints_t), intent(in) :: constraints
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	integer :: i
	passed = .true.
	do i = 1, size (constraints%cc)
	call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed)
	if (.not. passed) return
	end do
	end subroutine split_constraints_check_before_record

	@ %def split_constraints_check_before_split
	@ %def split_constraints_check_before_insert
	@ %def split_constraints_check_before_record
	@
	\subsection{Specific constraints}
	\subsubsection{Number of particles}
	Specific constraint: The number of particles plus the number of loops, if
	any, must remain less than the given limit. Note that the number of loops is
	defined only when we are recording the entry.
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_n_tot
	private
	integer :: n_max = 0
	contains
	procedure :: check_before_split => constraint_n_tot_check_before_split
	procedure :: check_before_record => constraint_n_tot_check_before_record
	end type constraint_n_tot

	@ %def constraint_n_tot
	<<Auto components: public>>=
	public :: constrain_n_tot
	<<Auto components: procedures>>=
	function constrain_n_tot (n_max) result (c)
	integer, intent(in) :: n_max
	type(constraint_n_tot) :: c
	c%n_max = n_max
	end function constrain_n_tot

	subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed)
	class(constraint_n_tot), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: k
	logical, intent(out) :: passed
	passed = pl%get_size () < c%n_max
	end subroutine constraint_n_tot_check_before_split

	subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed)
	class(constraint_n_tot), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	passed = pl%get_size () + n_loop <= c%n_max
	end subroutine constraint_n_tot_check_before_record

	@ %def constrain_n_tot
	@ %def constraint_n_tot_check_before_insert
	@
	\subsubsection{Number of loops}
	Specific constraint: The number of loops is limited, independent of the
	total number of particles.
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_n_loop
	private
	integer :: n_loop_max = 0
	contains
	procedure :: check_before_record => constraint_n_loop_check_before_record
	end type constraint_n_loop

	@ %def constraint_n_loop
	<<Auto components: public>>=
	public :: constrain_n_loop
	<<Auto components: procedures>>=
	function constrain_n_loop (n_loop_max) result (c)
	integer, intent(in) :: n_loop_max
	type(constraint_n_loop) :: c
	c%n_loop_max = n_loop_max
	end function constrain_n_loop

	subroutine constraint_n_loop_check_before_record &
	(c, table, pl, n_loop, passed)
	class(constraint_n_loop), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	passed = n_loop <= c%n_loop_max
	end subroutine constraint_n_loop_check_before_record

	@ %def constrain_n_loop
	@ %def constraint_n_loop_check_before_insert
	@
	\subsubsection{Particles allowed in splitting}
	Specific constraint: The entries in the particle list ready for insertion
	are matched to a given list of particle patterns. If a match occurs, the
	entry is replaced by the corresponding pattern. If there is no match, the
	check fails. If a massless gauge boson splitting is detected, the splitting
	partners are checked against a list of excluded particles. If a match
	occurs, the check fails.
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_splittings
	private
	type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings
	contains
	procedure :: check_before_insert => constraint_splittings_check_before_insert
	end type constraint_splittings

	@ %def constraint_splittings
	<<Auto components: public>>=
	public :: constrain_splittings
	<<Auto components: procedures>>=
	function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c)
	type(pdg_list_t), intent(in) :: pl_match
	type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
	type(constraint_splittings) :: c
	c%pl_match = pl_match
	c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
	end function constrain_splittings

	subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed)
	class(constraint_splittings), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	logical :: has_massless_vector
	integer :: i
	has_massless_vector = .false.
	do i = 1, pa%get_length ()
	if (is_massless_vector(pa%get(i))) then
	has_massless_vector = .true.
	exit
	end if
	end do
	passed = .false.
	if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then
	do i = 1, c%pl_excluded_gauge_splittings%get_size ()
	if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return
	end do
	call pl%match_replace (c%pl_match, passed)
	passed = .true.
	else
	call pl%match_replace (c%pl_match, passed)
	end if
	end subroutine constraint_splittings_check_before_insert

	@ %def constrain_splittings
	@ %def constraint_splittings_check_before_insert
	@
	Specific constraint: The entries in the particle list ready for insertion
	are matched to a given list of particle patterns. If a match occurs, the
	entry is replaced by the corresponding pattern. If there is no match, the
	check fails.
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_insert
	private
	type(pdg_list_t) :: pl_match
	contains
	procedure :: check_before_insert => constraint_insert_check_before_insert
	end type constraint_insert

	@ %def constraint_insert
	<<Auto components: public>>=
	public :: constrain_insert
	<<Auto components: procedures>>=
	function constrain_insert (pl_match) result (c)
	type(pdg_list_t), intent(in) :: pl_match
	type(constraint_insert) :: c
	c%pl_match = pl_match
	end function constrain_insert

	subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed)
	class(constraint_insert), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	call pl%match_replace (c%pl_match, passed)
	end subroutine constraint_insert_check_before_insert

	@ %def constrain_insert
	@ %def constraint_insert_check_before_insert
	@
	\subsubsection{Particles required in final state}
	Specific constraint: The entries in the recorded state must be a superset of
	the entries in the given list (for instance, the lowest-order
	state).
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_require
	private
	type(pdg_list_t) :: pl
	contains
	procedure :: check_before_record => constraint_require_check_before_record
	end type constraint_require

	@ %def constraint_require
	@ We check the current state by matching all particle entries against the
	stored particle list, and crossing out the particles in the latter list when a
	match is found. The constraint passed if all entries have been crossed out.

	For an [[if_table]] in particular, we check the final state only.
	<<Auto components: public>>=
	public :: constrain_require
	<<Auto components: procedures>>=
	function constrain_require (pl) result (c)
	type(pdg_list_t), intent(in) :: pl
	type(constraint_require) :: c
	c%pl = pl
	end function constrain_require

	subroutine constraint_require_check_before_record &
	(c, table, pl, n_loop, passed)
	class(constraint_require), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	logical, dimension(:), allocatable :: mask
	integer :: i, k, n_in
	select type (table)
	type is (if_table_t)
	if (table%proc_type > 0) then
	select case (table%proc_type)
	case (PROC_DECAY)
	n_in = 1
	case (PROC_SCATTER)
	n_in = 2
	end select
	else
	call msg_fatal ("Neither a decay nor a scattering process")
	end if
	class default
	n_in = 0
	end select
	allocate (mask (c%pl%get_size ()), source = .true.)
	do i = n_in + 1, pl%get_size ()
	k = c%pl%find_match (pl%get (i), mask)
	if (k /= 0) mask(k) = .false.
	end do
	passed = .not. any (mask)
	end subroutine constraint_require_check_before_record

	@ %def constrain_require
	@ %def constraint_require_check_before_record
	@
	\subsubsection{Radiation}
	Specific constraint: We have radiation pattern if the original particle
	matches an entry in the list of particles that should replace it. The
	constraint prohibits this situation.
	<<Auto components: public>>=
	public :: constrain_radiation
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_radiation
	private
	contains
	procedure :: check_before_insert => &
	constraint_radiation_check_before_insert
	end type constraint_radiation

	@ %def constraint_radiation
	<<Auto components: procedures>>=
	function constrain_radiation () result (c)
	type(constraint_radiation) :: c
	end function constrain_radiation

	subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed)
	class(constraint_radiation), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	passed = .not. (pl .match. pa)
	end subroutine constraint_radiation_check_before_insert

	@ %def constrain_radiation
	@ %def constraint_radiation_check_before_insert
	@
	\subsubsection{Mass sum}
	Specific constraint: The sum of masses within the particle list must
	be smaller than a given limit. For in/out state combinations, we
	check initial and final state separately.

	If we specify [[margin]] in the initialization, the sum must be
	strictly less than the limit minus the given margin (which may be
	zero). If not, equality is allowed.
	<<Auto components: public>>=
	public :: constrain_mass_sum
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_mass_sum
	private
	real(default) :: mass_limit = 0
	logical :: strictly_less = .false.
	real(default) :: margin = 0
	contains
	procedure :: check_before_record => constraint_mass_sum_check_before_record
	end type constraint_mass_sum

	@ %def contraint_mass_sum
	<<Auto components: procedures>>=
	function constrain_mass_sum (mass_limit, margin) result (c)
	real(default), intent(in) :: mass_limit
	real(default), intent(in), optional :: margin
	type(constraint_mass_sum) :: c
	c%mass_limit = mass_limit
	if (present (margin)) then
	c%strictly_less = .true.
	c%margin = margin
	end if
	end function constrain_mass_sum

	subroutine constraint_mass_sum_check_before_record &
	(c, table, pl, n_loop, passed)
	class(constraint_mass_sum), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	real(default) :: limit
	if (c%strictly_less) then
	limit = c%mass_limit - c%margin
	select type (table)
	type is (if_table_t)
	passed = mass_sum (pl, 1, 2, table%model) < limit &
	.and. mass_sum (pl, 3, pl%get_size (), table%model) < limit
	class default
	passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit
	end select
	else
	limit = c%mass_limit
	select type (table)
	type is (if_table_t)
	passed = mass_sum (pl, 1, 2, table%model) <= limit &
	.and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit
	class default
	passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit
	end select
	end if
	end subroutine constraint_mass_sum_check_before_record

	@ %def constrain_mass_sum
	@ %def constraint_mass_sum_check_before_record
	@
	\subsubsection{Initial state particles}
	Specific constraint: The two incoming particles must both match the given
	particle list. This is checked for the generated particle list, just before
	it is recorded.
	<<Auto components: public>>=
	public :: constrain_in_state
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_in_state
	private
	type(pdg_list_t) :: pl
	contains
	procedure :: check_before_record => constraint_in_state_check_before_record
	end type constraint_in_state

	@ %def constraint_in_state
	<<Auto components: procedures>>=
	function constrain_in_state (pl) result (c)
	type(pdg_list_t), intent(in) :: pl
	type(constraint_in_state) :: c
	c%pl = pl
	end function constrain_in_state

	subroutine constraint_in_state_check_before_record &
	(c, table, pl, n_loop, passed)
	class(constraint_in_state), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	integer :: i
	select type (table)
	type is (if_table_t)
	passed = .false.
	do i = 1, 2
	if (.not. (c%pl .match. pl%get (i))) return
	end do
	end select
	passed = .true.
	end subroutine constraint_in_state_check_before_record

	@ %def constrain_in_state
	@ %def constraint_in_state_check_before_record
	@
	\subsubsection{Photon induced processes}
	If set, filter out photon induced processes.
	<<Auto components: public>>=
	public :: constrain_photon_induced_processes
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_photon_induced_processes
	private
	integer :: n_in
	contains
	procedure :: check_before_record => &
	constraint_photon_induced_processes_check_before_record
	end type constraint_photon_induced_processes

	@ %def constraint_photon_induced_processes
	<<Auto components: procedures>>=
	function constrain_photon_induced_processes (n_in) result (c)
	integer, intent(in) :: n_in
	type(constraint_photon_induced_processes) :: c
	c%n_in = n_in
	end function constrain_photon_induced_processes

	subroutine constraint_photon_induced_processes_check_before_record &
	(c, table, pl, n_loop, passed)
	class(constraint_photon_induced_processes), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop
	logical, intent(out) :: passed
	integer :: i
	select type (table)
	type is (if_table_t)
	passed = .false.
	do i = 1, c%n_in
	if (pl%a(i)%get () == 22) return
	end do
	end select
	passed = .true.
	end subroutine constraint_photon_induced_processes_check_before_record

	@ %def constrain_photon_induced_processes
	@ %def constraint_photon_induced_processes_check_before_record
	@
	\subsubsection{Coupling constraint}
	Filters vertices which do not match the desired NLO pattern.
	<<Auto components: types>>=
	type, extends (split_constraint_t) :: constraint_coupling_t
	private
	logical :: qed = .false.
	logical :: qcd = .true.
	logical :: ew = .false.
	integer :: n_nlo_correction_types
	contains
	<<Auto components: constraint coupling: TBP>>
	end type constraint_coupling_t

	@ %def constraint_coupling_t
	@
	<<Auto components: public>>=
	public :: constrain_couplings
	<<Auto components: procedures>>=
	function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c)
	type(constraint_coupling_t) :: c
	logical, intent(in) :: qcd, qed
	integer, intent(in) :: n_nlo_correction_types
	c%qcd = qcd; c%qed = qed
	c%n_nlo_correction_types = n_nlo_correction_types
	end function constrain_couplings

	@ %def constrain_couplings
	@
	<<Auto components: constraint coupling: TBP>>=
	procedure :: check_before_insert => constraint_coupling_check_before_insert
	<<Auto components: procedures>>=
	subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed)
	class(constraint_coupling_t), intent(in) :: c
	class(ps_table_t), intent(in) :: table
	type(pdg_array_t), intent(in) :: pa
	type(pdg_list_t), intent(inout) :: pl
	logical, intent(out) :: passed
	type(pdg_list_t) :: pl_vertex
	type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons
	integer :: i, j
	pdg_gluon = GLUON; pdg_photon = PHOTON
	pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON]
	if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon
	if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon
	if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z
	do j = 1, pa%get_length ()
	call pl_vertex%init (pl%get_size () + 1)
	call pl_vertex%set (1, pa%get(j))
	do i = 1, pl%get_size ()
	call pl_vertex%set (i + 1, pl%get(i))
	end do
	if (pl_vertex%get_size () > 3) then
	passed = .false.
	cycle
	end if
	if (is_massless_vector(pa%get(j))) then
	if (.not. table%model%check_vertex &
	(pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
	passed = .false.
	cycle
	end if
	else if (.not. table%model%check_vertex &
	(- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
	passed = .false.
	cycle
	end if
	if (.not. (pl_vertex .match. pdg_gauge_bosons)) then
	passed = .false.
	cycle
	end if
	passed = .true.
	exit
	end do
	end subroutine constraint_coupling_check_before_insert

	@ %def constraint_coupling_check_before_insert
	@
	\subsection{Tables of states}
	Automatically generate a list of possible process components for a given
	initial set (a single massive particle or a preset list of states).

	The set of process components are generated by recursive splitting, applying
	constraints on the fly that control and limit the process. The generated
	states are accumulated in a table that we can read out after completion.
	<<Auto components: types>>=
	type, extends (pdg_list_t) :: ps_entry_t
	integer :: n_loop = 0
	integer :: n_rad = 0
	type(ps_entry_t), pointer :: previous => null ()
	type(ps_entry_t), pointer :: next => null ()
	end type ps_entry_t

	@ %def ps_entry_t
	@
	<<Auto components: parameters>>=
	integer, parameter :: PROC_UNDEFINED = 0
	integer, parameter :: PROC_DECAY = 1
	integer, parameter :: PROC_SCATTER = 2

	@ %def auto_components parameters
	@ This is the wrapper type for the decay tree for the list of final
	states and the final array. First, an abstract base type:
	<<Auto components: public>>=
	public :: ps_table_t
	<<Auto components: types>>=
	type, abstract :: ps_table_t
	private
	class(model_data_t), pointer :: model => null ()
	logical :: loops = .false.
	type(ps_entry_t), pointer :: first => null ()
	type(ps_entry_t), pointer :: last => null ()
	integer :: proc_type
	contains
	<<Auto components: ps table: TBP>>
	end type ps_table_t

	@ %def ps_table_t
	@ The extensions: one for decay, one for generic final states. The decay-state
	table stores the initial particle. The final-state table is
	indifferent, and the initial/final state table treats the first two
	particles in its list as incoming antiparticles.
	<<Auto components: public>>=
	public :: ds_table_t
	public :: fs_table_t
	public :: if_table_t
	<<Auto components: types>>=
	type, extends (ps_table_t) :: ds_table_t
	private
	integer :: pdg_in = 0
	contains
	<<Auto components: ds table: TBP>>
	end type ds_table_t

	type, extends (ps_table_t) :: fs_table_t
	contains
	<<Auto components: fs table: TBP>>
	end type fs_table_t

	type, extends (fs_table_t) :: if_table_t
	contains
	<<Auto components: if table: TBP>>
	end type if_table_t

	@ %def ds_table_t fs_table_t if_table_t
	@ Finalizer: we must deallocate the embedded list.
	<<Auto components: ps table: TBP>>=
	procedure :: final => ps_table_final
	<<Auto components: procedures>>=
	subroutine ps_table_final (object)
	class(ps_table_t), intent(inout) :: object
	type(ps_entry_t), pointer :: current
	do while (associated (object%first))
	current => object%first
	object%first => current%next
	deallocate (current)
	end do
	nullify (object%last)
	end subroutine ps_table_final

	@ %def ps_table_final
	@ Write the table. A base writer for the body and specific writers
	for the headers.
	<<Auto components: ps table: TBP>>=
	procedure :: base_write => ps_table_base_write
	procedure (ps_table_write), deferred :: write
	<<Auto components: interfaces>>=
	interface
	subroutine ps_table_write (object, unit)
	import
	class(ps_table_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine ps_table_write
	end interface
	<<Auto components: ds table: TBP>>=
	procedure :: write => ds_table_write
	<<Auto components: fs table: TBP>>=
	procedure :: write => fs_table_write
	<<Auto components: if table: TBP>>=
	procedure :: write => if_table_write
	@ The first [[n_in]] particles will be replaced by antiparticles in
	the output, and we write an arrow if [[n_in]] is present.
	<<Auto components: procedures>>=
	subroutine ps_table_base_write (object, unit, n_in)
	class(ps_table_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: n_in
	integer, dimension(:), allocatable :: pdg
	type(ps_entry_t), pointer :: entry
	type(field_data_t), pointer :: prt
	integer :: u, i, j, n0
	u = given_output_unit (unit)
	entry => object%first
	do while (associated (entry))
	write (u, "(2x)", advance = "no")
	if (present (n_in)) then
	do i = 1, n_in
	write (u, "(1x)", advance = "no")
	pdg = entry%get (i)
	do j = 1, size (pdg)
	prt => object%model%get_field_ptr (pdg(j))
	if (j > 1) write (u, "(':')", advance = "no")
	write (u, "(A)", advance = "no") &
	char (prt%get_name (pdg(j) >= 0))
	end do
	end do
	write (u, "(1x,A)", advance = "no") "=>"
	n0 = n_in + 1
	else
	n0 = 1
	end if
	do i = n0, entry%get_size ()
	write (u, "(1x)", advance = "no")
	pdg = entry%get (i)
	do j = 1, size (pdg)
	prt => object%model%get_field_ptr (pdg(j))
	if (j > 1) write (u, "(':')", advance = "no")
	write (u, "(A)", advance = "no") &
	char (prt%get_name (pdg(j) < 0))
	end do
	end do
	if (object%loops) then
	write (u, "(2x,'[',I0,',',I0,']')") entry%n_loop, entry%n_rad
	else
	write (u, "(A)")
	end if
	entry => entry%next
	end do
	end subroutine ps_table_base_write

	subroutine ds_table_write (object, unit)
	class(ds_table_t), intent(in) :: object
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: prt
	integer :: u
	u = given_output_unit (unit)
	prt => object%model%get_field_ptr (object%pdg_in)
	write (u, "(1x,A,1x,A)") "Decays for particle:", &
	char (prt%get_name (object%pdg_in < 0))
	call object%base_write (u)
	end subroutine ds_table_write

	subroutine fs_table_write (object, unit)
	class(fs_table_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Table of final states:"
	call object%base_write (u)
	end subroutine fs_table_write

	subroutine if_table_write (object, unit)
	class(if_table_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Table of in/out states:"
	select case (object%proc_type)
	case (PROC_DECAY)
	call object%base_write (u, n_in = 1)
	case (PROC_SCATTER)
	call object%base_write (u, n_in = 2)
	end select
	end subroutine if_table_write

	@ %def ps_table_write ds_table_write fs_table_write
	@ Obtain a particle string for a given index in the pdg list
	<<Auto components: ps table: TBP>>=
	procedure :: get_particle_string => ps_table_get_particle_string
	<<Auto components: procedures>>=
	subroutine ps_table_get_particle_string (object, index, prt_in, prt_out)
	class(ps_table_t), intent(in) :: object
	integer, intent(in) :: index
	type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
	integer :: n_in
	type(field_data_t), pointer :: prt
	type(ps_entry_t), pointer :: entry
	integer, dimension(:), allocatable :: pdg
	integer :: n0
	integer :: i, j
	entry => object%first
	i = 1
	do while (i < index)
	if (associated (entry%next)) then
	entry => entry%next
	i = i + 1
	else
	call msg_fatal ("ps_table: entry with requested index does not exist!")
	end if
	end do

	if (object%proc_type > 0) then
	select case (object%proc_type)
	case (PROC_DECAY)
	n_in = 1
	case (PROC_SCATTER)
	n_in = 2
	end select
	else
	call msg_fatal ("Neither decay nor scattering process")
	end if

	n0 = n_in + 1
	allocate (prt_in (n_in), prt_out (entry%get_size () - n_in))
	do i = 1, n_in
	prt_in(i) = ""
	pdg = entry%get(i)
	do j = 1, size (pdg)
	prt => object%model%get_field_ptr (pdg(j))
	prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0)
	if (j /= size (pdg)) prt_in(i) = prt_in(i) // ":"
	end do
	end do
	do i = n0, entry%get_size ()
	prt_out(i-n_in) = ""
	pdg = entry%get(i)
	do j = 1, size (pdg)
	prt => object%model%get_field_ptr (pdg(j))
	prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0)
	if (j /= size (pdg)) prt_out(i-n_in) = prt_out(i-n_in) // ":"
	end do
	end do
	end subroutine ps_table_get_particle_string

	@ %def ps_table_get_particle_string
	@ Initialize with a predefined set of final states, or in/out state lists.
	<<Auto components: ps table: TBP>>=
	generic :: init => ps_table_init
	procedure, private :: ps_table_init
	<<Auto components: if table: TBP>>=
	generic :: init => if_table_init
	procedure, private :: if_table_init
	<<Auto components: procedures>>=
	subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular)
	class(ps_table_t), intent(out) :: table
	class(model_data_t), intent(in), target :: model
	type(pdg_list_t), dimension(:), intent(in) :: pl
	type(split_constraints_t), intent(in) :: constraints
	integer, intent(in), optional :: n_in
	logical, intent(in), optional :: do_not_check_regular
	logical :: passed
	integer :: i
	table%model => model

	if (present (n_in)) then
	select case (n_in)
	case (1)
	table%proc_type = PROC_DECAY
	case (2)
	table%proc_type = PROC_SCATTER
	case default
	table%proc_type = PROC_UNDEFINED
	end select
	else
	table%proc_type = PROC_UNDEFINED
	end if

	do i = 1, size (pl)
	call table%record (pl(i), 0, 0, constraints, &
	do_not_check_regular, passed)
	if (.not. passed) then
	call msg_fatal ("ps_table: Registering process components failed")
	end if
	end do
	end subroutine ps_table_init

	subroutine if_table_init (table, model, pl_in, pl_out, constraints)
	class(if_table_t), intent(out) :: table
	class(model_data_t), intent(in), target :: model
	type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out
	type(split_constraints_t), intent(in) :: constraints
	integer :: i, j, k, p, n_in, n_out
	type(pdg_array_t), dimension(:), allocatable :: pa_in
	type(pdg_list_t), dimension(:), allocatable :: pl
	allocate (pl (size (pl_in) * size (pl_out)))
	k = 0
	do i = 1, size (pl_in)
	n_in = pl_in(i)%get_size ()
	allocate (pa_in (n_in))
	do p = 1, n_in
	pa_in(p) = pl_in(i)%get (p)
	end do
	do j = 1, size (pl_out)
	n_out = pl_out(j)%get_size ()
	k = k + 1
	call pl(k)%init (n_in + n_out)
	do p = 1, n_in
	call pl(k)%set (p, invert_pdg_array (pa_in(p), model))
	end do
	do p = 1, n_out
	call pl(k)%set (n_in + p, pl_out(j)%get (p))
	end do
	end do
	deallocate (pa_in)
	end do
	n_in = size (pl_in(1)%a)
	call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.)
	end subroutine if_table_init

	@ %def ps_table_init if_table_init
	@ Enable loops for the table. This affects both splitting and output.
	<<Auto components: ps table: TBP>>=
	procedure :: enable_loops => ps_table_enable_loops
	<<Auto components: procedures>>=
	subroutine ps_table_enable_loops (table)
	class(ps_table_t), intent(inout) :: table
	table%loops = .true.
	end subroutine ps_table_enable_loops

	@ %def ps_table_enable_loops
	@
	\subsection{Top-level methods}
	Create a table for a single-particle decay. Construct all possible final
	states from a single particle with PDG code [[pdg_in]]. The construction is
	limited by the given [[constraints]].
	<<Auto components: ds table: TBP>>=
	procedure :: make => ds_table_make
	<<Auto components: procedures>>=
	subroutine ds_table_make (table, model, pdg_in, constraints)
	class(ds_table_t), intent(out) :: table
	class(model_data_t), intent(in), target :: model
	integer, intent(in) :: pdg_in
	type(split_constraints_t), intent(in) :: constraints
	type(pdg_list_t) :: pl_in
	type(pdg_list_t), dimension(0) :: pl
	call table%init (model, pl, constraints)
	table%pdg_in = pdg_in
	call pl_in%init (1)
	call pl_in%set (1, [pdg_in])
	call table%split (pl_in, 0, constraints)
	end subroutine ds_table_make

	@ %def ds_table_make
	@ Split all entries in a growing table, starting from a table that may already
	contain states. Add and record split states on the fly.
	<<Auto components: fs table: TBP>>=
	procedure :: radiate => fs_table_radiate
	<<Auto components: procedures>>=
	subroutine fs_table_radiate (table, constraints, do_not_check_regular)
	class(fs_table_t), intent(inout) :: table
	type(split_constraints_t) :: constraints
	logical, intent(in), optional :: do_not_check_regular
	type(ps_entry_t), pointer :: current
	current => table%first
	do while (associated (current))
	call table%split (current, 0, constraints, record = .true., &
	do_not_check_regular = do_not_check_regular)
	current => current%next
	end do
	end subroutine fs_table_radiate

	@ %def fs_table_radiate
	@
	\subsection{Splitting algorithm}
	Recursive splitting. First of all, we record the current [[pdg_list]] in
	the table, subject to [[constraints]], if requested. We also record copies of
	the list marked as loop corrections.

	When we record a particle list, we sort it first.

	If there is room for splitting, We take a PDG array list and the index of an
	element, and split this element in all possible ways. The split entry is
	inserted into the list, which we split further.

	The recursion terminates whenever the split array would have a length
	greater than $n_\text{max}$.
	<<Auto components: ps table: TBP>>=
	procedure :: split => ps_table_split
	<<Auto components: procedures>>=
	recursive subroutine ps_table_split (table, pl, n_rad, constraints, &
	record, do_not_check_regular)
	class(ps_table_t), intent(inout) :: table
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_rad
	type(split_constraints_t), intent(in) :: constraints
	logical, intent(in), optional :: record, do_not_check_regular
	integer :: n_loop, i
	logical :: passed, save_pdg_index
	type(vertex_iterator_t) :: vit
	integer, dimension(:), allocatable :: pdg1
	integer, dimension(:), allocatable :: pdg2
	if (present (record)) then
	if (record) then
	n_loop = 0
	INCR_LOOPS: do
	call table%record_sorted (pl, n_loop, n_rad, constraints, &
	do_not_check_regular, passed)
	if (.not. passed) exit INCR_LOOPS
	if (.not. table%loops) exit INCR_LOOPS
	n_loop = n_loop + 1
	end do INCR_LOOPS
	end if
	end if
	select type (table)
	type is (if_table_t)
	save_pdg_index = .true.
	class default
	save_pdg_index = .false.
	end select
	do i = 1, pl%get_size ()
	call constraints%check_before_split (table, pl, i, passed)
	if (passed) then
	pdg1 = pl%get (i)
	call vit%init (table%model, pdg1, save_pdg_index)
	SCAN_VERTICES: do
	call vit%get_next_match (pdg2)
	if (allocated (pdg2)) then
	call table%insert (pl, n_rad, i, pdg2, constraints, &
	do_not_check_regular = do_not_check_regular)
	else
	exit SCAN_VERTICES
	end if
	end do SCAN_VERTICES
	end if
	end do
	end subroutine ps_table_split

	@ %def ps_table_split
	@ The worker part: insert the list of particles found by vertex matching in
	place of entry [[i]] in the PDG list. Then split/record further.

	The [[n_in]] parameter tells the replacement routine to insert the new
	particles after entry [[n_in]]. Otherwise, they follow index [[i]].
	<<Auto components: ps table: TBP>>=
	procedure :: insert => ps_table_insert
	<<Auto components: procedures>>=
	recursive subroutine ps_table_insert &
	(table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
	class(ps_table_t), intent(inout) :: table
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_rad, i
	integer, dimension(:), intent(in) :: pdg
	type(split_constraints_t), intent(in) :: constraints
	integer, intent(in), optional :: n_in
	logical, intent(in), optional :: do_not_check_regular
	type(pdg_list_t) :: pl_insert
	logical :: passed
	integer :: k, s
	s = size (pdg)
	call pl_insert%init (s)
	do k = 1, s
	call pl_insert%set (k, pdg(k))
	end do
	call constraints%check_before_insert (table, pl%get (i), pl_insert, passed)
	if (passed) then
	if (.not. is_colored_isr ()) return
	call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, &
	constraints, record = .true., do_not_check_regular = .true.)
	end if
	contains
	logical function is_colored_isr () result (ok)
	type(pdg_list_t) :: pl_replaced
	ok = .true.
	if (present (n_in)) then
	if (i <= n_in) then
	ok = pl_insert%contains_colored_particles ()
	if (.not. ok) then
	pl_replaced = pl%replace (i, pl_insert, n_in)
	associate (size_replaced => pl_replaced%get_pdg_sizes (), &
	size => pl%get_pdg_sizes ())
	ok = all (size_replaced(:n_in) == size(:n_in))
	end associate
	end if
	end if
	end if
	end function is_colored_isr
	end subroutine ps_table_insert

	@ %def ps_table_insert
	@ Special case:
	If we are splitting an initial particle, there is slightly more to
	do. We loop over the particles from the vertex match and replace the
	initial particle by each of them in turn. The remaining particles
	must be appended after the second initial particle, so they will end
	up in the out state. This is done by providing the [[n_in]] argument
	to the base method as an optional argument.

	Note that we must call the base-method procedure explicitly, so the
	[[table]] argument keeps its dynamic type as [[if_table]] inside this
	procedure.
	<<Auto components: if table: TBP>>=
	procedure :: insert => if_table_insert
	<<Auto components: procedures>>=
	recursive subroutine if_table_insert &
	(table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
	class(if_table_t), intent(inout) :: table
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_rad, i
	integer, dimension(:), intent(in) :: pdg
	type(split_constraints_t), intent(in) :: constraints
	integer, intent(in), optional :: n_in
	logical, intent(in), optional :: do_not_check_regular
	integer, dimension(:), allocatable :: pdg_work
	integer :: p
	if (i > 2) then
	call ps_table_insert (table, pl, n_rad, i, pdg, constraints, &
	do_not_check_regular = do_not_check_regular)
	else
	allocate (pdg_work (size (pdg)))
	do p = 1, size (pdg)
	pdg_work(1) = pdg(p)
	pdg_work(2:p) = pdg(1:p-1)
	pdg_work(p+1:) = pdg(p+1:)
	select case (table%proc_type)
	case (PROC_DECAY)
	call ps_table_insert (table, &
	pl, n_rad, i, pdg_work, constraints, n_in = 1, &
	do_not_check_regular = do_not_check_regular)
	case (PROC_SCATTER)
	call ps_table_insert (table, &
	pl, n_rad, i, pdg_work, constraints, n_in = 2, &
	do_not_check_regular = do_not_check_regular)
	end select
	end do
	end if
	end subroutine if_table_insert

	@ %def if_table_insert
	@ Sort before recording. In the case of the [[if_table]], we do not
	sort the first [[n_in]] particle entries. Instead, we check whether they are
	allowed in the [[pl_beam]] PDG list, if that is provided.
	<<Auto components: ps table: TBP>>=
	procedure :: record_sorted => ps_table_record_sorted
	<<Auto components: if table: TBP>>=
	procedure :: record_sorted => if_table_record_sorted
	<<Auto components: procedures>>=
	subroutine ps_table_record_sorted &
	(table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
	class(ps_table_t), intent(inout) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop, n_rad
	type(split_constraints_t), intent(in) :: constraints
	logical, intent(in), optional :: do_not_check_regular
	logical, intent(out) :: passed
	call table%record (pl%sort_abs (), n_loop, n_rad, constraints, &
	do_not_check_regular, passed)
	end subroutine ps_table_record_sorted

	subroutine if_table_record_sorted &
	(table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
	class(if_table_t), intent(inout) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop, n_rad
	type(split_constraints_t), intent(in) :: constraints
	logical, intent(in), optional :: do_not_check_regular
	logical, intent(out) :: passed
	call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, &
	do_not_check_regular, passed)
	end subroutine if_table_record_sorted

	@ %def ps_table_record_sorted if_table_record_sorted
	@ Record an entry: insert into the list. Check the ordering and
	insert it at the correct place, unless it is already there.

	We record an array only if its mass sum is less than the total
	available energy. This restriction is removed by setting
	[[constrained]] to false.
	<<Auto components: ps table: TBP>>=
	procedure :: record => ps_table_record
	<<Auto components: procedures>>=
	subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, &
	do_not_check_regular, passed)
	class(ps_table_t), intent(inout) :: table
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n_loop, n_rad
	type(split_constraints_t), intent(in) :: constraints
	logical, intent(in), optional :: do_not_check_regular
	logical, intent(out) :: passed
	type(ps_entry_t), pointer :: current
	logical :: needs_check
	passed = .false.
	needs_check = .true.
	if (present (do_not_check_regular)) needs_check = .not. do_not_check_regular
	if (needs_check .and. .not. pl%is_regular ()) then
	call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!")
	return
	end if
	call constraints%check_before_record (table, pl, n_loop, passed)
	if (.not. passed) then
	return
	end if
	current => table%first
	do while (associated (current))
	if (pl == current) then
	if (n_loop == current%n_loop) return
	else if (pl < current) then
	call insert
	return
	end if
	current => current%next
	end do
	call insert
	contains
	subroutine insert ()
	type(ps_entry_t), pointer :: entry
	allocate (entry)
	entry%pdg_list_t = pl
	entry%n_loop = n_loop
	entry%n_rad = n_rad
	if (associated (current)) then
	if (associated (current%previous)) then
	current%previous%next => entry
	entry%previous => current%previous
	else
	table%first => entry
	end if
	entry%next => current
	current%previous => entry
	else
	if (associated (table%last)) then
	table%last%next => entry
	entry%previous => table%last
	else
	table%first => entry
	end if
	table%last => entry
	end if
	end subroutine insert
	end subroutine ps_table_record

	@ %def ps_table_record
	@
	\subsection{Tools}
	Compute the mass sum for a PDG list object, counting the entries with indices
	between (including) [[n1]] and [[n2]]. Rely on the requirement that
	if an entry is a PDG array, this array must be degenerate in mass.
	<<Auto components: procedures>>=
	function mass_sum (pl, n1, n2, model) result (m)
	type(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: n1, n2
	class(model_data_t), intent(in), target :: model
	integer, dimension(:), allocatable :: pdg
	real(default) :: m
	type(field_data_t), pointer :: prt
	integer :: i
	m = 0
	do i = n1, n2
	pdg = pl%get (i)
	prt => model%get_field_ptr (pdg(1))
	m = m + prt%get_mass ()
	end do
	end function mass_sum

	@ %def mass_sum
	@ Invert a PDG array, replacing particles by antiparticles. This
	depends on the model.
	<<Auto components: procedures>>=
	function invert_pdg_array (pa, model) result (pa_inv)
	type(pdg_array_t), intent(in) :: pa
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t) :: pa_inv
	type(field_data_t), pointer :: prt
	integer :: i, pdg
	pa_inv = pa
	do i = 1, pa_inv%get_length ()
	pdg = pa_inv%get (i)
	prt => model%get_field_ptr (pdg)
	if (prt%has_antiparticle ()) call pa_inv%set (i, -pdg)
	end do
	end function invert_pdg_array

	@ %def invert_pdg_array
	@
	\subsection{Access results}
	Return the number of generated decays.
	<<Auto components: ps table: TBP>>=
	procedure :: get_length => ps_table_get_length
	<<Auto components: procedures>>=
	function ps_table_get_length (ps_table) result (n)
	class(ps_table_t), intent(in) :: ps_table
	integer :: n
	type(ps_entry_t), pointer :: entry
	n = 0
	entry => ps_table%first
	do while (associated (entry))
	n = n + 1
	entry => entry%next
	end do
	end function ps_table_get_length

	@ %def ps_table_get_length
	@
	<<Auto components: ps table: TBP>>=
	procedure :: get_emitters => ps_table_get_emitters
	<<Auto components: procedures>>=
	subroutine ps_table_get_emitters (table, constraints, emitters)
	class(ps_table_t), intent(in) :: table
	type(split_constraints_t), intent(in) :: constraints
	integer, dimension(:), allocatable, intent(out) :: emitters
	class(pdg_list_t), pointer :: pl
	integer :: i
	logical :: passed
	type(vertex_iterator_t) :: vit
	integer, dimension(:), allocatable :: pdg1, pdg2
	integer :: n_emitters
	integer, dimension(:), allocatable :: emitters_tmp
	integer, parameter :: buf0 = 6
	n_emitters = 0
	pl => table%first
	allocate (emitters_tmp (buf0))
	do i = 1, pl%get_size ()
	call constraints%check_before_split (table, pl, i, passed)
	if (passed) then
	pdg1 = pl%get(i)
	call vit%init (table%model, pdg1, .false.)
	do
	call vit%get_next_match(pdg2)
	if (allocated (pdg2)) then
	if (n_emitters + 1 > size (emitters_tmp)) &
	call extend_integer_array (emitters_tmp, 10)
	emitters_tmp (n_emitters + 1) = pdg1(1)
	n_emitters = n_emitters + 1
	else
	exit
	end if
	end do
	end if
	end do
	allocate (emitters (n_emitters))
	emitters = emitters_tmp (1:n_emitters)
	deallocate (emitters_tmp)
	end subroutine ps_table_get_emitters

	@ %def ps_table_get_emitters
	@ Return an allocated array of decay products (PDG codes). If
	requested, return also the loop and radiation order count.
	<<Auto components: ps table: TBP>>=
	procedure :: get_pdg_out => ps_table_get_pdg_out
	<<Auto components: procedures>>=
	subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad)
	class(ps_table_t), intent(in) :: ps_table
	integer, intent(in) :: i
	type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out
	integer, intent(out), optional :: n_loop, n_rad
	type(ps_entry_t), pointer :: entry
	integer :: n, j
	n = 0
	entry => ps_table%first
	FIND_ENTRY: do while (associated (entry))
	n = n + 1
	if (n == i) then
	allocate (pa_out (entry%get_size ()))
	do j = 1, entry%get_size ()
	pa_out(j) = entry%get (j)
	if (present (n_loop)) n_loop = entry%n_loop
	if (present (n_rad)) n_rad = entry%n_rad
	end do
	exit FIND_ENTRY
	end if
	entry => entry%next
	end do FIND_ENTRY
	end subroutine ps_table_get_pdg_out

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

	module auto_components_ut
	use unit_tests
	use auto_components_uti

	<<Standard module head>>

	<<Auto components: public test>>

	contains

	<<Auto components: test driver>>

	end module auto_components_ut
	@ %def auto_components_ut
	@
	<<[[auto_components_uti.f90]]>>=
	<<File header>>

	module auto_components_uti

	<<Use kinds>>
	<<Use strings>>
	use pdg_arrays
	use model_data
	use model_testbed, only: prepare_model, cleanup_model

	use auto_components

	<<Standard module head>>

	<<Auto components: test declarations>>

	contains

	<<Auto components: tests>>

	end module auto_components_uti
	@ %def auto_components_ut
	@ API: driver for the unit tests below.
	<<Auto components: public test>>=
	public :: auto_components_test
	<<Auto components: test driver>>=
	subroutine auto_components_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Auto components: execute tests>>
	end subroutine auto_components_test

	@ %def auto_components_tests
	@
	\subsubsection{Generate Decay Table}
	Determine all kinematically allowed decay channels for a Higgs boson,
	using default parameter values.
	<<Auto components: execute tests>>=
	call test (auto_components_1, "auto_components_1", &
	"generate decay table", &
	u, results)
	<<Auto components: test declarations>>=
	public :: auto_components_1
	<<Auto components: tests>>=
	subroutine auto_components_1 (u)
	integer, intent(in) :: u
	class(model_data_t), pointer :: model
	type(field_data_t), pointer :: prt
	type(ds_table_t) :: ds_table
	type(split_constraints_t) :: constraints

	write (u, "(A)") "* Test output: auto_components_1"
	write (u, "(A)") "* Purpose: determine Higgs decay table"
	write (u, *)

	write (u, "(A)") "* Read Standard Model"

	model => null ()
	call prepare_model (model, var_str ("SM"))

	prt => model%get_field_ptr (25)

	write (u, *)
	write (u, "(A)") "* Higgs decays n = 2"
	write (u, *)

	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (2))
	call constraints%set (2, constrain_mass_sum (prt%get_mass ()))

	call ds_table%make (model, 25, constraints)
	call ds_table%write (u)
	call ds_table%final ()

	write (u, *)
	write (u, "(A)") "* Higgs decays n = 3 (w/o radiative)"
	write (u, *)

	call constraints%init (3)
	call constraints%set (1, constrain_n_tot (3))
	call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
	call constraints%set (3, constrain_radiation ())

	call ds_table%make (model, 25, constraints)
	call ds_table%write (u)
	call ds_table%final ()

	write (u, *)
	write (u, "(A)") "* Higgs decays n = 3 (w/ radiative)"
	write (u, *)

	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (3))
	call constraints%set (2, constrain_mass_sum (prt%get_mass ()))

	call ds_table%make (model, 25, constraints)
	call ds_table%write (u)
	call ds_table%final ()

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

	call cleanup_model (model)
	deallocate (model)

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

	end subroutine auto_components_1

	@ %def auto_components_1
	@
	\subsubsection{Generate radiation}
	Given a final state, add radiation (NLO and NNLO). We provide a list
	of particles that is allowed to occur in the generated final states.
	<<Auto components: execute tests>>=
	call test (auto_components_2, "auto_components_2", &
	"generate NLO corrections, final state", &
	u, results)
	<<Auto components: test declarations>>=
	public :: auto_components_2
	<<Auto components: tests>>=
	subroutine auto_components_2 (u)
	integer, intent(in) :: u
	class(model_data_t), pointer :: model
	type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh
	type(pdg_list_t) :: pl_match
	type(fs_table_t) :: fs_table
	type(split_constraints_t) :: constraints
	real(default) :: sqrts
	integer :: i

	write (u, "(A)") "* Test output: auto_components_2"
	write (u, "(A)") "* Purpose: generate radiation (NLO)"
	write (u, *)


	write (u, "(A)") "* Read Standard Model"

	model => null ()
	call prepare_model (model, var_str ("SM"))

	write (u, *)
	write (u, "(A)") "* LO final state"
	write (u, *)

	allocate (pl (2))
	call pl(1)%init (2)
	call pl(1)%set (1, 1)
	call pl(1)%set (2, -1)
	call pl(2)%init (2)
	call pl(2)%set (1, 21)
	call pl(2)%set (2, 21)
	do i = 1, 2
	call pl(i)%write (u); write (u, *)
	end do

	write (u, *)
	write (u, "(A)") "* Initialize FS table"
	write (u, *)

	call constraints%init (1)
	call constraints%set (1, constrain_n_tot (3))

	call fs_table%init (model, pl, constraints)
	call fs_table%write (u)

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, unconstrained"
	write (u, *)

	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, &
	&complete but mass-constrained"
	write (u, *)

	sqrts = 50

	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (3))
	call constraints%set (2, constrain_mass_sum (sqrts))

	call fs_table%init (model, pl, constraints)
	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, restricted"
	write (u, *)

	call pl_match%init ([1, -1, 21])

	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (3))
	call constraints%set (2, constrain_insert (pl_match))

	call fs_table%init (model, pl, constraints)
	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NNLO corrections, restricted, with one loop"
	write (u, *)

	call pl_match%init ([1, -1, 21])

	call constraints%init (3)
	call constraints%set (1, constrain_n_tot (4))
	call constraints%set (2, constrain_n_loop (1))
	call constraints%set (3, constrain_insert (pl_match))

	call fs_table%init (model, pl, constraints)
	call fs_table%enable_loops ()
	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NNLO corrections, restricted, with loops"
	write (u, *)

	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (4))
	call constraints%set (2, constrain_insert (pl_match))

	call fs_table%init (model, pl, constraints)
	call fs_table%enable_loops ()
	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NNLO corrections, restricted, to Z Z H, &
	&no loops"
	write (u, *)

	allocate (pl_zzh (1))
	call pl_zzh(1)%init (3)
	call pl_zzh(1)%set (1, 23)
	call pl_zzh(1)%set (2, 23)
	call pl_zzh(1)%set (3, 25)

	call constraints%init (3)
	call constraints%set (1, constrain_n_tot (5))
	call constraints%set (2, constrain_mass_sum (500._default))
	call constraints%set (3, constrain_require (pl_zzh(1)))

	call fs_table%init (model, pl_zzh, constraints)
	call fs_table%radiate (constraints)
	call fs_table%write (u)
	call fs_table%final ()

	call cleanup_model (model)
	deallocate (model)

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

	end subroutine auto_components_2

	@ %def auto_components_2
	@
	\subsubsection{Generate radiation from initial and final state}
	Given a process, add radiation (NLO and NNLO). We provide a list
	of particles that is allowed to occur in the generated final states.
	<<Auto components: execute tests>>=
	call test (auto_components_3, "auto_components_3", &
	"generate NLO corrections, in and out", &
	u, results)
	<<Auto components: test declarations>>=
	public :: auto_components_3
	<<Auto components: tests>>=
	subroutine auto_components_3 (u)
	integer, intent(in) :: u
	class(model_data_t), pointer :: model
	type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
	type(pdg_list_t) :: pl_match, pl_beam
	type(if_table_t) :: if_table
	type(split_constraints_t) :: constraints
	real(default) :: sqrts
	integer :: i

	write (u, "(A)") "* Test output: auto_components_3"
	write (u, "(A)") "* Purpose: generate radiation (NLO)"
	write (u, *)

	write (u, "(A)") "* Read Standard Model"

	model => null ()
	call prepare_model (model, var_str ("SM"))

	write (u, *)
	write (u, "(A)") "* LO initial state"
	write (u, *)

	allocate (pl_in (2))
	call pl_in(1)%init (2)
	call pl_in(1)%set (1, 1)
	call pl_in(1)%set (2, -1)
	call pl_in(2)%init (2)
	call pl_in(2)%set (1, -1)
	call pl_in(2)%set (2, 1)
	do i = 1, 2
	call pl_in(i)%write (u); write (u, *)
	end do

	write (u, *)
	write (u, "(A)") "* LO final state"
	write (u, *)

	allocate (pl_out (1))
	call pl_out(1)%init (1)
	call pl_out(1)%set (1, 23)
	call pl_out(1)%write (u); write (u, *)

	write (u, *)
	write (u, "(A)") "* Initialize FS table"
	write (u, *)

	call constraints%init (1)
	call constraints%set (1, constrain_n_tot (4))

	call if_table%init (model, pl_in, pl_out, constraints)
	call if_table%write (u)

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, unconstrained"
	write (u, *)

	call if_table%radiate (constraints)
	call if_table%write (u)
	call if_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, &
	&complete but mass-constrained"
	write (u, *)

	sqrts = 100
	call constraints%init (2)
	call constraints%set (1, constrain_n_tot (4))
	call constraints%set (2, constrain_mass_sum (sqrts))

	call if_table%init (model, pl_in, pl_out, constraints)
	call if_table%radiate (constraints)
	call if_table%write (u)
	call if_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, &
	&mass-constrained, restricted beams"
	write (u, *)

	call pl_beam%init (3)
	call pl_beam%set (1, 1)
	call pl_beam%set (2, -1)
	call pl_beam%set (3, 21)

	call constraints%init (3)
	call constraints%set (1, constrain_n_tot (4))
	call constraints%set (2, constrain_in_state (pl_beam))
	call constraints%set (3, constrain_mass_sum (sqrts))

	call if_table%init (model, pl_in, pl_out, constraints)
	call if_table%radiate (constraints)
	call if_table%write (u)
	call if_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NLO corrections, restricted"
	write (u, *)

	call pl_match%init ([1, -1, 21])

	call constraints%init (4)
	call constraints%set (1, constrain_n_tot (4))
	call constraints%set (2, constrain_in_state (pl_beam))
	call constraints%set (3, constrain_mass_sum (sqrts))
	call constraints%set (4, constrain_insert (pl_match))

	call if_table%init (model, pl_in, pl_out, constraints)
	call if_table%radiate (constraints)
	call if_table%write (u)
	call if_table%final ()

	write (u, *)
	write (u, "(A)") "* Generate NNLO corrections, restricted, Z preserved, &
	&with loops"
	write (u, *)

	call constraints%init (5)
	call constraints%set (1, constrain_n_tot (5))
	call constraints%set (2, constrain_in_state (pl_beam))
	call constraints%set (3, constrain_mass_sum (sqrts))
	call constraints%set (4, constrain_insert (pl_match))
	call constraints%set (5, constrain_require (pl_out(1)))

	call if_table%init (model, pl_in, pl_out, constraints)
	call if_table%enable_loops ()
	call if_table%radiate (constraints)
	call if_table%write (u)
	call if_table%final ()

	call cleanup_model (model)
	deallocate (model)

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

	end subroutine auto_components_3

	@ %def auto_components_3
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Creating the real flavor structure}
	<<[[radiation_generator.f90]]>>=
	<<File header>>

	module radiation_generator

	<<Use kinds>>
	<<Use strings>>
	use diagnostics
	use io_units
	+ use sorting, only: sort_abs
	use physics_defs, only: PHOTON, GLUON
	use pdg_arrays
	use flavors
	use model_data
	use auto_components
	use string_utils, only: split_string, string_contains_word

	implicit none
	private

	<<radiation generator: public>>

	<<radiation generator: types>>

	contains

	<<radiation generator: procedures>>

	end module radiation_generator
	@ %def radiation_generator
	@
	<<radiation generator: types>>=
	type :: pdg_sorter_t
	integer :: pdg
	logical :: checked = .false.
	integer :: associated_born = 0
	end type pdg_sorter_t

	@ %def pdg_sorter
	@
	<<radiation generator: types>>=
	type :: pdg_states_t
	type(pdg_array_t), dimension(:), allocatable :: pdg
	type(pdg_states_t), pointer :: next
	integer :: n_particles
	contains
	<<radiation generator: pdg states: TBP>>
	end type pdg_states_t

	@ %def pdg_states_t
	<<radiation generator: pdg states: TBP>>=
	procedure :: init => pdg_states_init
	<<radiation generator: procedures>>=
	subroutine pdg_states_init (states)
	class(pdg_states_t), intent(inout) :: states
	nullify (states%next)
	end subroutine pdg_states_init

	@ %def pdg_states_init
	@
	<<radiation generator: pdg states: TBP>>=
	procedure :: add => pdg_states_add
	<<radiation generator: procedures>>=
	subroutine pdg_states_add (states, pdg)
	class(pdg_states_t), intent(inout), target :: states
	type(pdg_array_t), dimension(:), intent(in) :: pdg
	type(pdg_states_t), pointer :: current_state
	select type (states)
	type is (pdg_states_t)
	current_state => states
	do
	if (associated (current_state%next)) then
	current_state => current_state%next
	else
	allocate (current_state%next)
	nullify(current_state%next%next)
	current_state%pdg = pdg
	exit
	end if
	end do
	end select
	end subroutine pdg_states_add

	@ %def pdg_states_add
	@
	<<radiation generator: pdg states: TBP>>=
	procedure :: get_n_states => pdg_states_get_n_states
	<<radiation generator: procedures>>=
	function pdg_states_get_n_states (states) result (n)
	class(pdg_states_t), intent(in), target :: states
	integer :: n
	type(pdg_states_t), pointer :: current_state
	n = 0
	select type(states)
	type is (pdg_states_t)
	current_state => states
	do
	if (associated (current_state%next)) then
	n = n+1
	current_state => current_state%next
	else
	exit
	end if
	end do
	end select
	end function pdg_states_get_n_states

	@ %def pdg_states_get_n_states
	@
	<<radiation generator: types>>=
	type :: prt_queue_t
	type(string_t), dimension(:), allocatable :: prt_string
	type(prt_queue_t), pointer :: next => null ()
	type(prt_queue_t), pointer :: previous => null ()
	type(prt_queue_t), pointer :: front => null ()
	type(prt_queue_t), pointer :: current_prt => null ()
	type(prt_queue_t), pointer :: back => null ()
	integer :: n_lists = 0
	contains
	<<radiation generator: prt queue: TBP>>
	end type prt_queue_t

	@ %def prt_queue_t
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: null => prt_queue_null
	<<radiation generator: procedures>>=
	subroutine prt_queue_null (queue)
	class(prt_queue_t), intent(out) :: queue
	queue%next => null ()
	queue%previous => null ()
	queue%front => null ()
	queue%current_prt => null ()
	queue%back => null ()
	queue%n_lists = 0
	if (allocated (queue%prt_string)) deallocate (queue%prt_string)
	end subroutine prt_queue_null

	@ %def prt_queue_null
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: append => prt_queue_append
	<<radiation generator: procedures>>=
	subroutine prt_queue_append (queue, prt_string)
	class(prt_queue_t), intent(inout) :: queue
	type(string_t), intent(in), dimension(:) :: prt_string
	type(prt_queue_t), pointer :: new_element => null ()
	type(prt_queue_t), pointer :: current_back => null ()
	allocate (new_element)
	allocate (new_element%prt_string(size (prt_string)))
	new_element%prt_string = prt_string
	if (associated (queue%back)) then
	current_back => queue%back
	current_back%next => new_element
	new_element%previous => current_back
	queue%back => new_element
	else
	!!! Initial entry
	queue%front => new_element
	queue%back => queue%front
	queue%current_prt => queue%front
	end if
	queue%n_lists = queue%n_lists + 1
	end subroutine prt_queue_append

	@ %def prt_queue_append
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: get => prt_queue_get
	<<radiation generator: procedures>>=
	subroutine prt_queue_get (queue, prt_string)
	class(prt_queue_t), intent(inout) :: queue
	type(string_t), dimension(:), allocatable, intent(out) :: prt_string
	if (associated (queue%current_prt)) then
	prt_string = queue%current_prt%prt_string
	if (associated (queue%current_prt%next)) &
	queue%current_prt => queue%current_prt%next
	else
	prt_string = " "
	end if
	end subroutine prt_queue_get

	@ %def prt_queue_get
	@ As above.
	<<radiation generator: prt queue: TBP>>=
	procedure :: get_last => prt_queue_get_last
	<<radiation generator: procedures>>=
	subroutine prt_queue_get_last (queue, prt_string)
	class(prt_queue_t), intent(in) :: queue
	type(string_t), dimension(:), allocatable, intent(out) :: prt_string
	if (associated (queue%back)) then
	allocate (prt_string(size (queue%back%prt_string)))
	prt_string = queue%back%prt_string
	else
	prt_string = " "
	end if
	end subroutine prt_queue_get_last

	@ %def prt_queue_get_last
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: reset => prt_queue_reset
	<<radiation generator: procedures>>=
	subroutine prt_queue_reset (queue)
	class(prt_queue_t), intent(inout) :: queue
	queue%current_prt => queue%front
	end subroutine prt_queue_reset

	@ %def prt_queue_reset
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings
	<<radiation generator: procedures>>=
	function prt_queue_check_for_same_prt_strings (queue) result (val)
	class(prt_queue_t), intent(inout) :: queue
	logical :: val
	type(string_t), dimension(:), allocatable :: prt_string
	integer, dimension(:,:), allocatable :: i_particle
	integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A
	integer :: i, j
	call queue%reset ()
	allocate (i_particle (queue%n_lists, 12))
	do i = 1, queue%n_lists
	call queue%get (prt_string)
	n_d = count_particle (prt_string, 1)
	n_dbar = count_particle (prt_string, -1)
	n_u = count_particle (prt_string, 2)
	n_ubar = count_particle (prt_string, -2)
	n_s = count_particle (prt_string, 3)
	n_sbar = count_particle (prt_string, -3)
	n_gl = count_particle (prt_string, 21)
	n_e = count_particle (prt_string, 11)
	n_ep = count_particle (prt_string, -11)
	n_mu = count_particle (prt_string, 13)
	n_mup = count_particle (prt_string, -13)
	n_A = count_particle (prt_string, 22)
	i_particle (i, 1) = n_d
	i_particle (i, 2) = n_dbar
	i_particle (i, 3) = n_u
	i_particle (i, 4) = n_ubar
	i_particle (i, 5) = n_s
	i_particle (i, 6) = n_sbar
	i_particle (i, 7) = n_gl
	i_particle (i, 8) = n_e
	i_particle (i, 9) = n_ep
	i_particle (i, 10) = n_mu
	i_particle (i, 11) = n_mup
	i_particle (i, 12) = n_A
	end do
	val = .false.
	do i = 1, queue%n_lists
	do j = 1, queue%n_lists
	if (i == j) cycle
	val = val .or. all (i_particle (i,:) == i_particle(j,:))
	end do
	end do
	contains
	function count_particle (prt_string, pdg) result (n)
	type(string_t), dimension(:), intent(in) :: prt_string
	integer, intent(in) :: pdg
	integer :: n
	integer :: i
	type(string_t) :: prt_ref
	n = 0
	select case (pdg)
	case (1)
	prt_ref = "d"
	case (-1)
	prt_ref = "dbar"
	case (2)
	prt_ref = "u"
	case (-2)
	prt_ref = "ubar"
	case (3)
	prt_ref = "s"
	case (-3)
	prt_ref = "sbar"
	case (21)
	prt_ref = "gl"
	case (11)
	prt_ref = "e-"
	case (-11)
	prt_ref = "e+"
	case (13)
	prt_ref = "mu-"
	case (-13)
	prt_ref = "mu+"
	case (22)
	prt_ref = "A"
	end select
	do i = 1, size (prt_string)
	if (prt_string(i) == prt_ref) n = n+1
	end do
	end function count_particle

	end function prt_queue_check_for_same_prt_strings

	@ %def prt_queue_check_for_same_prt_strings
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: contains => prt_queue_contains
	<<radiation generator: procedures>>=
	function prt_queue_contains (queue, prt_string) result (val)
	class(prt_queue_t), intent(in) :: queue
	type(string_t), intent(in), dimension(:) :: prt_string
	logical :: val
	type(prt_queue_t), pointer :: current => null()
	if (associated (queue%front)) then
	current => queue%front
	else
	call msg_fatal ("Trying to access empty particle queue")
	end if
	val = .false.
	do
	if (size (current%prt_string) == size (prt_string)) then
	if (all (current%prt_string == prt_string)) then
	val = .true.
	exit
	end if
	end if
	if (associated (current%next)) then
	current => current%next
	else
	exit
	end if
	end do
	end function prt_queue_contains

	@ %def prt_string_list_contains
	@
	<<radiation generator: prt queue: TBP>>=
	procedure :: write => prt_queue_write
	<<radiation generator: procedures>>=
	subroutine prt_queue_write (queue, unit)
	class(prt_queue_t), intent(in) :: queue
	integer, optional :: unit
	type(prt_queue_t), pointer :: current => null ()
	integer :: i, j, u
	u = given_output_unit (unit)
	if (associated (queue%front)) then
	current => queue%front
	else
	write (u, "(A)") "[Particle queue is empty]"
	return
	end if
	j = 1
	do
	write (u, "(I2,A,1X)", advance = 'no') j , ":"
	do i = 1, size (current%prt_string)
	write (u, "(A,1X)", advance = 'no') char (current%prt_string(i))
	end do
	write (u, "(A)")
	if (associated (current%next)) then
	current => current%next
	j = j+1
	else
	exit
	end if
	end do
	end subroutine prt_queue_write

	@ %def prt_queue_write
	@
	<<radiation generator: procedures>>=
	subroutine sort_prt (prt, model)
	type(string_t), dimension(:), intent(inout) :: prt
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(:), allocatable :: pdg
	type(flavor_t) :: flv
	integer :: i
	call create_pdg_array (prt, model, pdg)
	call sort_pdg (pdg)
	do i = 1, size (pdg)
	call flv%init (pdg(i)%get(), model)
	prt(i) = flv%get_name ()
	end do
	end subroutine sort_prt

	subroutine sort_pdg (pdg)
	type(pdg_array_t), dimension(:), intent(inout) :: pdg
	integer, dimension(:), allocatable :: i_pdg
	integer :: i
	allocate (i_pdg (size (pdg)))
	do i = 1, size (pdg)
	i_pdg(i) = pdg(i)%get ()
	end do
	i_pdg = sort_abs (i_pdg)
	do i = 1, size (pdg)
	call pdg(i)%set (1, i_pdg(i))
	end do
	end subroutine sort_pdg

	subroutine create_pdg_array (prt, model, pdg)
	type (string_t), dimension(:), intent(in) :: prt
	class (model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg
	type(flavor_t) :: flv
	integer :: i
	allocate (pdg (size (prt)))
	do i = 1, size (prt)
	call flv%init (prt(i), model)
	pdg(i) = flv%get_pdg ()
	end do
	end subroutine create_pdg_array

	@ %def sort_prt sort_pdg create_pdg_array
	@ This is used in unit tests:
	<<radiation generator: test auxiliary>>=
	subroutine write_pdg_array (pdg, u)
	use pdg_arrays
	type(pdg_array_t), dimension(:), intent(in) :: pdg
	integer, intent(in) :: u
	integer :: i
	do i = 1, size (pdg)
	call pdg(i)%write (u)
	end do
	write (u, "(A)")
	end subroutine write_pdg_array

	subroutine write_particle_string (prt, u)
	<<Use strings>>
	type(string_t), dimension(:), intent(in) :: prt
	integer, intent(in) :: u
	integer :: i
	do i = 1, size (prt)
	write (u, "(A,1X)", advance = "no") char (prt(i))
	end do
	write (u, "(A)")
	end subroutine write_particle_string

	@ %def write_pdg_array write_particle_string
	<<radiation generator: types>>=
	type :: reshuffle_list_t
	integer, dimension(:), allocatable :: ii
	type(reshuffle_list_t), pointer :: next => null ()
	contains
	<<radiation generator: reshuffle list: TBP>>
	end type reshuffle_list_t

	@ %def reshuffle_list_t
	@
	<<radiation generator: reshuffle list: TBP>>=
	procedure :: write => reshuffle_list_write
	<<radiation generator: procedures>>=
	subroutine reshuffle_list_write (rlist)
	class(reshuffle_list_t), intent(in) :: rlist
	type(reshuffle_list_t), pointer :: current => null ()
	integer :: i
	print *, 'Content of reshuffling list: '
	if (associated (rlist%next)) then
	current => rlist%next
	i = 1
	do
	print *, 'i: ', i, 'list: ', current%ii
	i = i + 1
	if (associated (current%next)) then
	current => current%next
	else
	exit
	end if
	end do
	else
	print *, '[EMPTY]'
	end if
	end subroutine reshuffle_list_write

	@ %def reshuffle_list_write
	@
	<<radiation generator: reshuffle list: TBP>>=
	procedure :: append => reshuffle_list_append
	<<radiation generator: procedures>>=
	subroutine reshuffle_list_append (rlist, ii)
	class(reshuffle_list_t), intent(inout) :: rlist
	integer, dimension(:), allocatable, intent(in) :: ii
	type(reshuffle_list_t), pointer :: current
	if (associated (rlist%next)) then
	current => rlist%next
	do
	if (associated (current%next)) then
	current => current%next
	else
	allocate (current%next)
	allocate (current%next%ii (size (ii)))
	current%next%ii = ii
	exit
	end if
	end do
	else
	allocate (rlist%next)
	allocate (rlist%next%ii (size (ii)))
	rlist%next%ii = ii
	end if
	end subroutine reshuffle_list_append

	@ %def reshuffle_list_append
	@
	<<radiation generator: reshuffle list: TBP>>=
	procedure :: is_empty => reshuffle_list_is_empty
	<<radiation generator: procedures>>=
	elemental function reshuffle_list_is_empty (rlist) result (is_empty)
	logical :: is_empty
	class(reshuffle_list_t), intent(in) :: rlist
	is_empty = .not. associated (rlist%next)
	end function reshuffle_list_is_empty

	@ %def reshuffle_list_is_empty
	@
	<<radiation generator: reshuffle list: TBP>>=
	procedure :: get => reshuffle_list_get
	<<radiation generator: procedures>>=
	function reshuffle_list_get (rlist, index) result (ii)
	integer, dimension(:), allocatable :: ii
	class(reshuffle_list_t), intent(inout) :: rlist
	integer, intent(in) :: index
	type(reshuffle_list_t), pointer :: current => null ()
	integer :: i
	current => rlist%next
	do i = 1, index - 1
	if (associated (current%next)) then
	current => current%next
	else
	call msg_fatal ("Index exceeds size of reshuffling list")
	end if
	end do
	allocate (ii (size (current%ii)))
	ii = current%ii
	end function reshuffle_list_get

	@ %def reshuffle_list_get
	@ We need to reset the [[reshuffle_list]] in order to deal with
	subsequent usages of the [[radiation_generator]]. Below is obviously
	the lazy and dirty solution. Otherwise, we would have to equip this
	auxiliary type with additional information about [[last]] and [[previous]]
	pointers. Considering that at most $n_{\rm{legs}}$ integers are saved
	in the lists, and that the subroutine is only called during the
	initialization phase (more precisely: at the moment only in the
	[[radiation_generator]] unit tests), I think this quick fix is justified.
	<<radiation generator: reshuffle list: TBP>>=
	procedure :: reset => reshuffle_list_reset
	<<radiation generator: procedures>>=
	subroutine reshuffle_list_reset (rlist)
	class(reshuffle_list_t), intent(inout) :: rlist
	rlist%next => null ()
	end subroutine reshuffle_list_reset

	@ %def reshuffle_list_reset
	@
	<<radiation generator: public>>=
	public :: radiation_generator_t
	<<radiation generator: types>>=
	type :: radiation_generator_t
	logical :: qcd_enabled = .false.
	logical :: qed_enabled = .false.
	logical :: is_gluon = .false.
	logical :: fs_gluon = .false.
	logical :: is_photon = .false.
	logical :: fs_photon = .false.
	logical :: only_final_state = .true.
	type(pdg_list_t) :: pl_in, pl_out
	type(pdg_list_t) :: pl_excluded_gauge_splittings
	type(split_constraints_t) :: constraints
	integer :: n_tot
	integer :: n_in, n_out
	integer :: n_loops
	integer :: n_light_quarks
	real(default) :: mass_sum
	type(prt_queue_t) :: prt_queue
	type(pdg_states_t) :: pdg_raw
	type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born
	type(if_table_t) :: if_table
	type(reshuffle_list_t) :: reshuffle_list
	contains
	<<radiation generator: radiation generator: TBP>>
	end type radiation_generator_t

	@
	@ %def radiation_generator_t
	<<radiation generator: radiation generator: TBP>>=
	generic :: init => init_pdg_list, init_pdg_array
	procedure :: init_pdg_list => radiation_generator_init_pdg_list
	procedure :: init_pdg_array => radiation_generator_init_pdg_array
	<<radiation generator: procedures>>=
	subroutine radiation_generator_init_pdg_list &
	(generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
	class(radiation_generator_t), intent(inout) :: generator
	type(pdg_list_t), intent(in) :: pl_in, pl_out
	type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
	logical, intent(in), optional :: qcd, qed
	if (present (qcd)) generator%qcd_enabled = qcd
	if (present (qed)) generator%qed_enabled = qed
	generator%pl_in = pl_in
	generator%pl_out = pl_out
	generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
	generator%is_gluon = pl_in%search_for_particle (GLUON)
	generator%fs_gluon = pl_out%search_for_particle (GLUON)
	generator%is_photon = pl_in%search_for_particle (PHOTON)
	generator%fs_photon = pl_out%search_for_particle (PHOTON)
	generator%mass_sum = 0._default
	call generator%pdg_raw%init ()
	end subroutine radiation_generator_init_pdg_list

	subroutine radiation_generator_init_pdg_array &
	(generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed)
	class(radiation_generator_t), intent(inout) :: generator
	type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out
	type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings
	logical, intent(in), optional :: qcd, qed
	type(pdg_list_t) :: pl_in, pl_out
	type(pdg_list_t) :: pl_excluded_gauge_splittings
	integer :: i
	call pl_in%init(size (pdg_in))
	call pl_out%init(size (pdg_out))
	do i = 1, size (pdg_in)
	call pl_in%set (i, pdg_in(i))
	end do
	do i = 1, size (pdg_out)
	call pl_out%set (i, pdg_out(i))
	end do
	call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings))
	do i = 1, size (pdg_excluded_gauge_splittings)
	call pl_excluded_gauge_splittings%set &
	(i, pdg_excluded_gauge_splittings(i))
	end do
	call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
	end subroutine radiation_generator_init_pdg_array

	@ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: set_initial_state_emissions => &
	radiation_generator_set_initial_state_emissions
	<<radiation generator: procedures>>=
	subroutine radiation_generator_set_initial_state_emissions (generator)
	class(radiation_generator_t), intent(inout) :: generator
	generator%only_final_state = .false.
	end subroutine radiation_generator_set_initial_state_emissions

	@ %def radiation_generator_set_initial_state_emissions
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: setup_if_table => radiation_generator_setup_if_table
	<<radiation generator: procedures>>=
	subroutine radiation_generator_setup_if_table (generator, model)
	class(radiation_generator_t), intent(inout) :: generator
	class(model_data_t), intent(in), target :: model
	type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out

	allocate (pl_in(1), pl_out(1))

	pl_in(1) = generator%pl_in
	pl_out(1) = generator%pl_out

	call generator%if_table%init &
	(model, pl_in, pl_out, generator%constraints)
	end subroutine radiation_generator_setup_if_table

	@ %def radiation_generator_setup_if_table
	@
	<<radiation generator: radiation generator: TBP>>=
	generic :: reset_particle_content => reset_particle_content_pdg_array, &
	reset_particle_content_pdg_list
	procedure :: reset_particle_content_pdg_list => &
	radiation_generator_reset_particle_content_pdg_list
	procedure :: reset_particle_content_pdg_array => &
	radiation_generator_reset_particle_content_pdg_array
	<<radiation generator: procedures>>=
	subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl)
	class(radiation_generator_t), intent(inout) :: generator
	type(pdg_list_t), intent(in) :: pl
	generator%pl_out = pl
	generator%fs_gluon = pl%search_for_particle (GLUON)
	generator%fs_photon = pl%search_for_particle (PHOTON)
	end subroutine radiation_generator_reset_particle_content_pdg_list

	subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg)
	class(radiation_generator_t), intent(inout) :: generator
	type(pdg_array_t), intent(in), dimension(:) :: pdg
	type(pdg_list_t) :: pl
	integer :: i
	call pl%init (size (pdg))
	do i = 1, size (pdg)
	call pl%set (i, pdg(i))
	end do
	call generator%reset_particle_content (pl)
	end subroutine radiation_generator_reset_particle_content_pdg_array

	@ %def radiation_generator_reset_particle_content
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list
	<<radiation generator: procedures>>=
	subroutine radiation_generator_reset_reshuffle_list (generator)
	class(radiation_generator_t), intent(inout) :: generator
	call generator%reshuffle_list%reset ()
	end subroutine radiation_generator_reset_reshuffle_list

	@ %def radiation_generator_reset_reshuffle_list
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: set_n => radiation_generator_set_n
	<<radiation generator: procedures>>=
	subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops)
	class(radiation_generator_t), intent(inout) :: generator
	integer, intent(in) :: n_in, n_out, n_loops
	generator%n_tot = n_in + n_out + 1
	generator%n_in = n_in
	generator%n_out = n_out
	generator%n_loops = n_loops
	end subroutine radiation_generator_set_n

	@ %def radiation_generator_set_n
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: set_constraints => radiation_generator_set_constraints
	<<radiation generator: procedures>>=
	subroutine radiation_generator_set_constraints &
	(generator, set_n_loop, set_mass_sum, &
	set_selected_particles, set_required_particles)
	class(radiation_generator_t), intent(inout), target :: generator
	logical, intent(in) :: set_n_loop
	logical, intent(in) :: set_mass_sum
	logical, intent(in) :: set_selected_particles
	logical, intent(in) :: set_required_particles
	logical :: set_no_photon_induced = .true.
	integer :: i, j, n, n_constraints
	type(pdg_list_t) :: pl_req, pl_insert
	type(pdg_list_t) :: pl_antiparticles
	type(pdg_array_t) :: pdg_gluon, pdg_photon
	type(pdg_array_t) :: pdg_add, pdg_tmp
	integer :: last_index
	integer :: n_new_particles, n_skip
	integer, dimension(:), allocatable :: i_skip
	integer :: n_nlo_correction_types

	n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled])
	if (generator%is_photon) set_no_photon_induced = .false.

	allocate (i_skip (generator%n_tot))
	i_skip = -1

	n_constraints = 2 + count([set_n_loop, set_mass_sum, &
	set_selected_particles, set_required_particles, set_no_photon_induced])
	associate (constraints => generator%constraints)
	n = 1
	call constraints%init (n_constraints)
	call constraints%set (n, constrain_n_tot (generator%n_tot))
	n = 2
	call constraints%set (n, constrain_couplings (generator%qcd_enabled, &
	generator%qed_enabled, n_nlo_correction_types))
	n = n + 1
	if (set_no_photon_induced) then
	call constraints%set (n, constrain_photon_induced_processes (generator%n_in))
	n = n + 1
	end if
	if (set_n_loop) then
	call constraints%set (n, constrain_n_loop(generator%n_loops))
	n = n + 1
	end if
	if (set_mass_sum) then
	call constraints%set (n, constrain_mass_sum(generator%mass_sum))
	n = n + 1
	end if
	if (set_required_particles) then
	if (generator%fs_gluon .or. generator%fs_photon) then
	do i = 1, generator%n_out
	pdg_tmp = generator%pl_out%get(i)
	if (pdg_tmp%search_for_particle (GLUON) &
	.or. pdg_tmp%search_for_particle (PHOTON)) then
	i_skip(i) = i
	end if
	end do

	n_skip = count (i_skip > 0)
	call pl_req%init (generator%n_out-n_skip)
	else
	call pl_req%init (generator%n_out)
	end if
	j = 1
	do i = 1, generator%n_out
	if (any (i == i_skip)) cycle
	call pl_req%set (j, generator%pl_out%get(i))
	j = j + 1
	end do
	call constraints%set (n, constrain_require (pl_req))
	n = n + 1
	end if
	if (set_selected_particles) then
	if (generator%only_final_state ) then
	call pl_insert%init (generator%n_out + n_nlo_correction_types)
	do i = 1, generator%n_out
	call pl_insert%set(i, generator%pl_out%get(i))
	end do
	last_index = generator%n_out + 1
	else
	call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles)
	call pl_insert%init (generator%n_tot + n_new_particles &
	+ n_nlo_correction_types)
	do i = 1, generator%n_in
	call pl_insert%set(i, generator%pl_in%get(i))
	end do
	do i = 1, generator%n_out
	j = i + generator%n_in
	call pl_insert%set(j, generator%pl_out%get(i))
	end do
	do i = 1, n_new_particles
	j = i + generator%n_in + generator%n_out
	call pl_insert%set(j, pl_antiparticles%get(i))
	end do
	last_index = generator%n_tot + n_new_particles + 1
	end if
	pdg_gluon = GLUON; pdg_photon = PHOTON
	if (generator%qcd_enabled) then
	pdg_add = pdg_gluon
	call pl_insert%set (last_index, pdg_add)
	last_index = last_index + 1
	end if
	if (generator%qed_enabled) then
	pdg_add = pdg_photon
	call pl_insert%set (last_index, pdg_add)
	end if
	call constraints%set (n, constrain_splittings (pl_insert, &
	generator%pl_excluded_gauge_splittings))
	end if
	end associate
	end subroutine radiation_generator_set_constraints

	@ %def radiation_generator_set_constraints
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: find_splittings => radiation_generator_find_splittings
	<<radiation generator: procedures>>=
	subroutine radiation_generator_find_splittings (generator)
	class(radiation_generator_t), intent(inout) :: generator
	integer :: i
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp
	integer, dimension(:), allocatable :: reshuffle_list

	call generator%pl_in%create_pdg_array (pdg_in)
	call generator%pl_out%create_pdg_array (pdg_out)

	associate (if_table => generator%if_table)
	call if_table%radiate (generator%constraints, do_not_check_regular = .true.)

	do i = 1, if_table%get_length ()
	call if_table%get_pdg_out (i, pdg_tmp)
	if (size (pdg_tmp) == generator%n_tot) then
	call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list)
	call generator%reshuffle_list%append (reshuffle_list)
	end if
	end do
	end associate

	contains

	subroutine pdg_reshuffle (pdg_born, pdg_real, list)
	type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real
	integer, intent(out), dimension(:), allocatable :: list
	type(pdg_sorter_t), dimension(:), allocatable :: sort_born
	type(pdg_sorter_t), dimension(:), allocatable :: sort_real
	integer :: i_min, n_in, n_born, n_real
	integer :: ib, ir

	n_in = generator%n_in
	n_born = size (pdg_born)
	n_real = size (pdg_real)
	allocate (list (n_real - n_in))
	allocate (sort_born (n_born))
	allocate (sort_real (n_real - n_in))
	sort_born%pdg = pdg_born%get ()
	sort_real%pdg = pdg_real(n_in + 1 : n_real)%get()
	do ib = 1, n_born
	if (any (sort_born(ib)%pdg == sort_real%pdg)) &
	call associate_born_indices (sort_born(ib), sort_real, ib, n_real)
	end do
	i_min = maxval (sort_real%associated_born) + 1
	do ir = 1, n_real - n_in
	if (sort_real(ir)%associated_born == 0) then
	sort_real(ir)%associated_born = i_min
	i_min = i_min + 1
	end if
	end do
	list = sort_real%associated_born
	end subroutine pdg_reshuffle

	subroutine associate_born_indices (sort_born, sort_real, ib, n_real)
	type(pdg_sorter_t), intent(in) :: sort_born
	type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real
	integer, intent(in) :: ib, n_real
	integer :: ir
	do ir = 1, n_real - generator%n_in
	if (sort_born%pdg == sort_real(ir)%pdg &
	.and..not. sort_real(ir)%checked) then
	sort_real(ir)%associated_born = ib
	sort_real(ir)%checked = .true.
	exit
	end if
	end do
	end subroutine associate_born_indices
	end subroutine radiation_generator_find_splittings

	@ %def radiation_generator_find_splittings
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: generate_real_particle_strings &
	=> radiation_generator_generate_real_particle_strings
	<<radiation generator: procedures>>=
	subroutine radiation_generator_generate_real_particle_strings &
	(generator, prt_tot_in, prt_tot_out)
	type :: prt_array_t
	type(string_t), dimension(:), allocatable :: prt
	end type
	class(radiation_generator_t), intent(inout) :: generator
	type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out
	type(prt_array_t), dimension(:), allocatable :: prt_in, prt_out
	type(prt_array_t), dimension(:), allocatable :: prt_out0, prt_in0
	type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in
	type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
	type(prt_array_t) :: prt_out0_tmp, prt_in0_tmp
	integer :: i, j
	integer, dimension(:), allocatable :: reshuffle_list_local
	type(reshuffle_list_t) :: reshuffle_list
	integer :: flv
	type(string_t), dimension(:), allocatable :: buf
	integer :: i_buf

	flv = 0
	allocate (prt_in0(0), prt_out0(0))
	associate (if_table => generator%if_table)
	do i = 1, if_table%get_length ()
	call if_table%get_pdg_out (i, pdg_tmp)
	if (size (pdg_tmp) == generator%n_tot) then
	call if_table%get_particle_string (i, &
	prt_in0_tmp%prt, prt_out0_tmp%prt)
	prt_in0 = [prt_in0, prt_in0_tmp]
	prt_out0 = [prt_out0, prt_out0_tmp]
	flv = flv + 1
	end if
	end do
	end associate

	allocate (prt_in(size (prt_in0)), prt_out(size (prt_out0)))
	do i = 1, flv
	allocate (prt_in(i)%prt (generator%n_in))
	allocate (prt_out(i)%prt (generator%n_tot - generator%n_in))
	end do
	allocate (prt_tot_in (generator%n_in))
	allocate (prt_tot_out (generator%n_tot - generator%n_in))
	allocate (buf (generator%n_tot))
	buf = ""

	do j = 1, flv
	do i = 1, generator%n_in
	prt_in(j)%prt(i) = prt_in0(j)%prt(i)
	call fill_buffer (buf(i), prt_in0(j)%prt(i))
	end do
	end do
	prt_tot_in = buf(1 : generator%n_in)

	do j = 1, flv
	allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j))))
	reshuffle_list_local = generator%reshuffle_list%get(j)
	do i = 1, size (reshuffle_list_local)
	prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i)
	i_buf = reshuffle_list_local(i) + generator%n_in
	call fill_buffer (buf(i_buf), &
	prt_out(j)%prt(reshuffle_list_local(i)))
	end do
	!!! Need to deallocate here because in the next iteration the reshuffling
	!!! list can have a different size
	deallocate (reshuffle_list_local)
	end do
	prt_tot_out = buf(generator%n_in + 1 : generator%n_tot)
	if (debug2_active (D_CORE)) then
	print *, 'Generated initial state: '
	do i = 1, size (prt_tot_in)
	print *, char (prt_tot_in(i))
	end do
	print *, 'Generated final state: '
	do i = 1, size (prt_tot_out)
	print *, char (prt_tot_out(i))
	end do
	end if


	contains

	subroutine fill_buffer (buffer, particle)
	type(string_t), intent(inout) :: buffer
	type(string_t), intent(in) :: particle
	logical :: particle_present
	if (len (buffer) > 0) then
	particle_present = check_for_substring (char(buffer), particle)
	if (.not. particle_present) buffer = buffer // ":" // particle
	else
	buffer = buffer // particle
	end if
	end subroutine fill_buffer

	function check_for_substring (buffer, substring) result (exist)
	character(len=*), intent(in) :: buffer
	type(string_t), intent(in) :: substring
	character(len=50) :: buffer_internal
	logical :: exist
	integer :: i_first, i_last
	exist = .false.
	i_first = 1; i_last = 1
	do
	if (buffer(i_last:i_last) == ":") then
	buffer_internal = buffer (i_first : i_last - 1)
	if (buffer_internal == char (substring)) then
	exist = .true.
	exit
	end if
	i_first = i_last + 1; i_last = i_first + 1
	if (i_last > len(buffer)) exit
	else if (i_last == len(buffer)) then
	buffer_internal = buffer (i_first : i_last)
	exist = buffer_internal == char (substring)
	exit
	else
	i_last = i_last + 1
	if (i_last > len(buffer)) exit
	end if
	end do
	end function check_for_substring
	end subroutine radiation_generator_generate_real_particle_strings

	@ %def radiation_generator_generate_real_particle_strings
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: contains_emissions => radiation_generator_contains_emissions
	<<radiation generator: procedures>>=
	function radiation_generator_contains_emissions (generator) result (has_em)
	logical :: has_em
	class(radiation_generator_t), intent(in) :: generator
	has_em = .not. generator%reshuffle_list%is_empty ()
	end function radiation_generator_contains_emissions

	@ %def radiation_generator_contains_emissions
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: generate => radiation_generator_generate
	<<radiation generator: procedures>>=
	subroutine radiation_generator_generate (generator, prt_in, prt_out)
	class(radiation_generator_t), intent(inout) :: generator
	type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
	call generator%find_splittings ()
	call generator%generate_real_particle_strings (prt_in, prt_out)
	end subroutine radiation_generator_generate

	@ %def radiation_generator_generate
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: generate_multiple => radiation_generator_generate_multiple
	<<radiation generator: procedures>>=
	subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model)
	class(radiation_generator_t), intent(inout) :: generator
	integer, intent(in) :: max_multiplicity
	class(model_data_t), intent(in), target :: model
	if (max_multiplicity <= generator%n_out) &
	call msg_fatal ("GKS states: Multiplicity is not large enough!")
	call generator%first_emission (model)
	call generator%reset_reshuffle_list ()
	if (max_multiplicity - generator%n_out > 1) &
	call generator%append_emissions (max_multiplicity, model)
	end subroutine radiation_generator_generate_multiple

	@ %def radiation_generator_generate_multiple
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: first_emission => radiation_generator_first_emission
	<<radiation generator: procedures>>=
	subroutine radiation_generator_first_emission (generator, model)
	class(radiation_generator_t), intent(inout) :: generator
	class(model_data_t), intent(in), target :: model
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	call generator%setup_if_table (model)
	call generator%generate (prt_in, prt_out)
	call generator%prt_queue%null ()
	call generator%prt_queue%append (prt_out)
	end subroutine radiation_generator_first_emission

	@ %def radiation_generator_first_emission
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: append_emissions => radiation_generator_append_emissions
	<<radiation generator: procedures>>=
	subroutine radiation_generator_append_emissions (generator, max_multiplicity, model)
	class(radiation_generator_t), intent(inout) :: generator
	integer, intent(in) :: max_multiplicity
	class(model_data_t), intent(in), target :: model
	type(string_t), dimension(:), allocatable :: prt_fetched
	type(string_t), dimension(:), allocatable :: prt_in
	type(string_t), dimension(:), allocatable :: prt_out
	type(pdg_array_t), dimension(:), allocatable :: pdg_new_out
	integer :: current_multiplicity, i, j, n_longest_length
	type :: prt_table_t
	type(string_t), dimension(:), allocatable :: prt
	end type prt_table_t
	type(prt_table_t), dimension(:), allocatable :: prt_table_out
	do
	call generator%prt_queue%get (prt_fetched)
	current_multiplicity = size (prt_fetched)
	if (current_multiplicity == max_multiplicity) exit
	call create_pdg_array (prt_fetched, model, &
	pdg_new_out)
	call generator%reset_particle_content (pdg_new_out)
	call generator%set_n (2, current_multiplicity, 0)
	call generator%set_constraints (.false., .false., .true., .true.)
	call generator%setup_if_table (model)
	call generator%generate (prt_in, prt_out)
	n_longest_length = get_length_of_longest_tuple (prt_out)
	call separate_particles (prt_out, prt_table_out)
	do i = 1, n_longest_length
	if (.not. any (prt_table_out(i)%prt == " ")) then
	call sort_prt (prt_table_out(i)%prt, model)
	if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then
	call generator%prt_queue%append (prt_table_out(i)%prt)
	end if
	end if
	end do
	call generator%reset_reshuffle_list ()
	end do

	contains
	subroutine separate_particles (prt, prt_table)
	type(string_t), intent(in), dimension(:) :: prt
	type(string_t), dimension(:), allocatable :: prt_tmp
	type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table
	integer :: i, j
	logical, dimension(:), allocatable :: tuples_occured
	allocate (prt_table (n_longest_length))
	do i = 1, n_longest_length
	allocate (prt_table(i)%prt (size (prt)))
	end do
	allocate (tuples_occured (size (prt)))
	do j = 1, size (prt)
	call split_string (prt(j), var_str (":"), prt_tmp)
	do i = 1, n_longest_length
	if (i <= size (prt_tmp)) then
	prt_table(i)%prt(j) = prt_tmp(i)
	else
	prt_table(i)%prt(j) = " "
	end if
	end do
	if (n_longest_length > 1) &
	tuples_occured(j) = prt_table(1)%prt(j) /= " " &
	.and. prt_table(2)%prt(j) /= " "
	end do
	if (any (tuples_occured)) then
	do j = 1, size (tuples_occured)
	if (.not. tuples_occured(j)) then
	do i = 2, n_longest_length
	prt_table(i)%prt(j) = prt_table(1)%prt(j)
	end do
	end if
	end do
	end if
	end subroutine separate_particles

	function get_length_of_longest_tuple (prt) result (longest_length)
	type(string_t), intent(in), dimension(:) :: prt
	integer :: longest_length, i
	type(prt_table_t), dimension(:), allocatable :: prt_table
	allocate (prt_table (size (prt)))
	longest_length = 0
	do i = 1, size (prt)
	call split_string (prt(i), var_str (":"), prt_table(i)%prt)
	if (size (prt_table(i)%prt) > longest_length) &
	longest_length = size (prt_table(i)%prt)
	end do
	end function get_length_of_longest_tuple
	end subroutine radiation_generator_append_emissions
	@ %def radiation_generator_append_emissions
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: reset_queue => radiation_generator_reset_queue
	<<radiation generator: procedures>>=
	subroutine radiation_generator_reset_queue (generator)
	class(radiation_generator_t), intent(inout) :: generator
	call generator%prt_queue%reset ()
	end subroutine radiation_generator_reset_queue

	@ %def radiation_generator_reset_queue
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: get_n_gks_states => radiation_generator_get_n_gks_states
	<<radiation generator: procedures>>=
	function radiation_generator_get_n_gks_states (generator) result (n)
	class(radiation_generator_t), intent(in) :: generator
	integer :: n
	n = generator%prt_queue%n_lists
	end function radiation_generator_get_n_gks_states

	@ %def radiation_generator_get_n_fks_states
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: get_next_state => radiation_generator_get_next_state
	<<radiation generator: procedures>>=
	function radiation_generator_get_next_state (generator) result (prt_string)
	class(radiation_generator_t), intent(inout) :: generator
	type(string_t), dimension(:), allocatable :: prt_string
	call generator%prt_queue%get (prt_string)
	end function radiation_generator_get_next_state

	@ %def radiation_generator_get_next_state
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: get_emitter_indices => radiation_generator_get_emitter_indices
	<<radiation generator: procedures>>=
	subroutine radiation_generator_get_emitter_indices (generator, indices)
	class(radiation_generator_t), intent(in) :: generator
	integer, dimension(:), allocatable, intent(out) :: indices
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	integer, dimension(:), allocatable :: flv_in, flv_out
	integer, dimension(:), allocatable :: emitters
	integer :: i, j
	integer :: n_in, n_out

	call generator%pl_in%create_pdg_array (pdg_in)
	call generator%pl_out%create_pdg_array (pdg_out)

	n_in = size (pdg_in); n_out = size (pdg_out)
	allocate (flv_in (n_in), flv_out (n_out))
	forall (i=1:n_in) flv_in(i) = pdg_in(i)%get()
	forall (i=1:n_out) flv_out(i) = pdg_out(i)%get()

	call generator%if_table%get_emitters (generator%constraints, emitters)
	allocate (indices (size (emitters)))

	j = 1
	do i = 1, n_in + n_out
	if (i <= n_in) then
	if (any (flv_in(i) == emitters)) then
	indices (j) = i
	j = j + 1
	end if
	else
	if (any (flv_out(i-n_in) == emitters)) then
	indices (j) = i
	j = j + 1
	end if
	end if
	end do
	end subroutine radiation_generator_get_emitter_indices

	@ %def radiation_generator_get_emitter_indices
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: get_raw_states => radiation_generator_get_raw_states
	<<radiation generator: procedures>>=
	function radiation_generator_get_raw_states (generator) result (raw_states)
	class(radiation_generator_t), intent(in), target :: generator
	integer, dimension(:,:), allocatable :: raw_states
	type(pdg_states_t), pointer :: state
	integer :: n_states, n_particles
	integer :: i_state
	integer :: j
	state => generator%pdg_raw
	n_states = generator%pdg_raw%get_n_states ()
	n_particles = size (generator%pdg_raw%pdg)
	allocate (raw_states (n_particles, n_states))
	do i_state = 1, n_states
	do j = 1, n_particles
	raw_states (j, i_state) = state%pdg(j)%get ()
	end do
	state => state%next
	end do
	end function radiation_generator_get_raw_states

	@ %def radiation_generator_get_raw_states
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: save_born_raw => radiation_generator_save_born_raw
	<<radiation generator: procedures>>=
	subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out)
	class(radiation_generator_t), intent(inout) :: generator
	type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out
	generator%pdg_in_born = pdg_in
	generator%pdg_out_born = pdg_out
	end subroutine radiation_generator_save_born_raw
	@ %def radiation_generator_save_born_raw
	@
	<<radiation generator: radiation generator: TBP>>=
	procedure :: get_born_raw => radiation_generator_get_born_raw
	<<radiation generator: procedures>>=
	function radiation_generator_get_born_raw (generator) result (flv_born)
	class(radiation_generator_t), intent(in) :: generator
	integer, dimension(:,:), allocatable :: flv_born
	integer :: i_part, n_particles
	n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born)
	allocate (flv_born (n_particles, 1))
	flv_born(1,1) = generator%pdg_in_born(1)%get ()
	flv_born(2,1) = generator%pdg_in_born(2)%get ()
	do i_part = 3, n_particles
	flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get ()
	end do
	end function radiation_generator_get_born_raw

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

	module radiation_generator_ut
	use unit_tests
	use radiation_generator_uti

	<<Standard module head>>

	<<radiation generator: public test>>

	contains

	<<radiation generator: test driver>>

	end module radiation_generator_ut
	@ %def radiation_generator_ut
	@
	<<[[radiation_generator_uti.f90]]>>=
	<<File header>>

	module radiation_generator_uti

	<<Use strings>>
	use format_utils, only: write_separator
	use os_interface
	use pdg_arrays
	use models
	use kinds, only: default

	use radiation_generator

	<<Standard module head>>

	<<radiation generator: test declarations>>

	contains

	<<radiation generator: tests>>

	<<radiation generator: test auxiliary>>

	end module radiation_generator_uti
	@ %def radiation_generator_ut
	@ API: driver for the unit tests below.
	<<radiation generator: public test>>=
	public :: radiation_generator_test
	<<radiation generator: test driver>>=
	subroutine radiation_generator_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	call test(radiation_generator_1, "radiation_generator_1", &
	"Test the generator of N+1-particle flavor structures in QCD", &
	u, results)
	call test(radiation_generator_2, "radiation_generator_2", &
	"Test multiple splittings in QCD", &
	u, results)
	call test(radiation_generator_3, "radiation_generator_3", &
	"Test the generator of N+1-particle flavor structures in QED", &
	u, results)
	call test(radiation_generator_4, "radiation_generator_4", &
	"Test multiple splittings in QED", &
	u, results)
	end subroutine radiation_generator_test

	@ %def radiation_generator_test
	@
	<<radiation generator: test declarations>>=
	public :: radiation_generator_1
	<<radiation generator: tests>>=
	subroutine radiation_generator_1 (u)
	integer, intent(in) :: u
	type(radiation_generator_t) :: generator
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()

	write (u, "(A)") "* Test output: radiation_generator_1"
	write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
	&from predefined N-particle flavor structures"
	write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling"
	write (u, "(A)")
	write (u, "(A)") "* Loading radiation model: SM.mdl"

	call syntax_model_file_init ()
	call os_data%init ()
	call model_list%read_model &
	(var_str ("SM"), var_str ("SM.mdl"), &
	os_data, model)
	write (u, "(A)") "* Success"

	allocate (pdg_in (2))
	pdg_in(1) = 11; pdg_in(2) = -11

	write (u, "(A)") "* Start checking processes"
	call write_separator (u)

	write (u, "(A)") "* Process 1: Top pair-production with additional gluon"
	allocate (pdg_out(3))
	pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 2: Top pair-production with additional jet"
	allocate (pdg_out(3))
	pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21]
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 3: Quark-antiquark production"
	allocate (pdg_out(2))
	pdg_out(1) = 2; pdg_out(2) = -2
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon"
	allocate (pdg_out(3))
	pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 5: Z + jets"
	allocate (pdg_out(3))
	pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 6: Top Decay"
	allocate (pdg_out(4))
	pdg_out(1) = 24; pdg_out(2) = -24
	pdg_out(3) = 5; pdg_out(4) = -5
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 7: Production of four quarks"
	allocate (pdg_out(4))
	pdg_out(1) = 2; pdg_out(2) = -2;
	pdg_out(3) = 2; pdg_out(4) = -2
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out); deallocate (pdg_in)

	write (u, "(A)") "* Process 8: Drell-Yan lepto-production"
	allocate (pdg_in (2)); allocate (pdg_out (2))
	pdg_in(1) = 2; pdg_in(2) = -2
	pdg_out(1) = 11; pdg_out(2) = -11
	call test_process (generator, pdg_in, pdg_out, u, .true.)
	deallocate (pdg_out); deallocate (pdg_in)

	write (u, "(A)") "* Process 9: WZ production at hadron-colliders"
	allocate (pdg_in (2)); allocate (pdg_out (2))
	pdg_in(1) = 1; pdg_in(2) = -2
	pdg_out(1) = -24; pdg_out(2) = 23
	call test_process (generator, pdg_in, pdg_out, u, .true.)
	deallocate (pdg_out); deallocate (pdg_in)

	contains
	subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
	type(radiation_generator_t), intent(inout) :: generator
	type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
	integer, intent(in) :: u
	logical, intent(in), optional :: include_initial_state
	type(string_t), dimension(:), allocatable :: prt_strings_in
	type(string_t), dimension(:), allocatable :: prt_strings_out
	type(pdg_array_t), dimension(10) :: pdg_excluded
	logical :: yorn
	yorn = .false.
	pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
	if (present (include_initial_state)) yorn = include_initial_state
	write (u, "(A)") "* Leading order: "
	write (u, "(A)", advance = 'no') '* Incoming: '
	call write_pdg_array (pdg_in, u)
	write (u, "(A)", advance = 'no') '* Outgoing: '
	call write_pdg_array (pdg_out, u)

	call generator%init (pdg_in, pdg_out, &
	pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
	call generator%set_n (2, size(pdg_out), 0)
	if (yorn) call generator%set_initial_state_emissions ()
	call generator%set_constraints (.false., .false., .true., .true.)
	call generator%setup_if_table (model)
	call generator%generate (prt_strings_in, prt_strings_out)
	write (u, "(A)") "* Additional radiation: "
	write (u, "(A)") "* Incoming: "
	call write_particle_string (prt_strings_in, u)
	write (u, "(A)") "* Outgoing: "
	call write_particle_string (prt_strings_out, u)
	call write_separator(u)
	call generator%reset_reshuffle_list ()
	end subroutine test_process

	end subroutine radiation_generator_1

	@ %def radiation_generator_1
	@
	<<radiation generator: test declarations>>=
	public :: radiation_generator_2
	<<radiation generator: tests>>=
	subroutine radiation_generator_2 (u)
	integer, intent(in) :: u
	type(radiation_generator_t) :: generator
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()
	integer, parameter :: max_multiplicity = 10
	type(string_t), dimension(:), allocatable :: prt_last

	write (u, "(A)") "* Test output: radiation_generator_2"
	write (u, "(A)") "* Purpose: Test the repeated application of &
	&a radiation generator splitting in QCD"
	write (u, "(A)") "* Only Final state emissions! "
	write (u, "(A)")
	write (u, "(A)") "* Loading radiation model: SM.mdl"

	call syntax_model_file_init ()
	call os_data%init ()
	call model_list%read_model &
	(var_str ("SM"), var_str ("SM.mdl"), &
	os_data, model)
	write (u, "(A)") "* Success"

	allocate (pdg_in (2))
	pdg_in(1) = 11; pdg_in(2) = -11
	allocate (pdg_out(2))
	pdg_out(1) = 2; pdg_out(2) = -2
	allocate (pdg_excluded (10))
	pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]

	write (u, "(A)") "* Leading order"
	write (u, "(A)", advance = 'no') "* Incoming: "
	call write_pdg_array (pdg_in, u)
	write (u, "(A)", advance = 'no') "* Outgoing: "
	call write_pdg_array (pdg_out, u)

	call generator%init (pdg_in, pdg_out, &
	pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
	call generator%set_n (2, 2, 0)
	call generator%set_constraints (.false., .false., .true., .true.)

	call write_separator (u)
	write (u, "(A)") "Generate higher-multiplicity states"
	write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
	call generator%generate_multiple (max_multiplicity, model)
	call generator%prt_queue%write (u)
	call write_separator (u)
	write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists

	write (u, "(A)") "Check that no particle state occurs twice or more"
	if (.not. generator%prt_queue%check_for_same_prt_strings()) then
	write (u, "(A)") "SUCCESS"
	else
	write (u, "(A)") "FAIL"
	end if
	call write_separator (u)
	write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
	call generator%prt_queue%get_last (prt_last)
	if (size (prt_last) == max_multiplicity) then
	write (u, "(A)") "SUCCESS"
	else
	write (u, "(A)") "FAIL"
	end if
	end subroutine radiation_generator_2

	@ %def radiation_generator_2
	@
	<<radiation generator: test declarations>>=
	public :: radiation_generator_3
	<<radiation generator: tests>>=
	subroutine radiation_generator_3 (u)
	integer, intent(in) :: u
	type(radiation_generator_t) :: generator
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()

	write (u, "(A)") "* Test output: radiation_generator_3"
	write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
	&from predefined N-particle flavor structures"
	write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling"
	write (u, "(A)")
	write (u, "(A)") "* Loading radiation model: SM.mdl"

	call syntax_model_file_init ()
	call os_data%init ()
	call model_list%read_model &
	(var_str ("SM"), var_str ("SM.mdl"), &
	os_data, model)
	write (u, "(A)") "* Success"

	allocate (pdg_in (2))
	pdg_in(1) = 11; pdg_in(2) = -11

	write (u, "(A)") "* Start checking processes"
	call write_separator (u)

	write (u, "(A)") "* Process 1: Tau pair-production with additional photon"
	allocate (pdg_out(3))
	pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon"
	allocate (pdg_out(3))
	pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22]
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 3: Electron-positron production"
	allocate (pdg_out(2))
	pdg_out(1) = 11; pdg_out(2) = -11
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon"
	allocate (pdg_out(3))
	pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 5: Z + jets "
	allocate (pdg_out(3))
	pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 6: W + jets"
	allocate (pdg_out(3))
	pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 7: Top Decay"
	allocate (pdg_out(4))
	pdg_out(1) = 24; pdg_out(2) = -24
	pdg_out(3) = 5; pdg_out(4) = -5
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 8: Production of four quarks"
	allocate (pdg_out(4))
	pdg_out(1) = 2; pdg_out(2) = -2;
	pdg_out(3) = 2; pdg_out(4) = -2
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out)

	write (u, "(A)") "* Process 9: Neutrino pair-production"
	allocate (pdg_out(2))
	pdg_out(1) = 12; pdg_out(2) = -12
	call test_process (generator, pdg_in, pdg_out, u, .true.)
	deallocate (pdg_out); deallocate (pdg_in)

	write (u, "(A)") "* Process 10: Drell-Yan lepto-production"
	allocate (pdg_in (2)); allocate (pdg_out (2))
	pdg_in(1) = 2; pdg_in(2) = -2
	pdg_out(1) = 11; pdg_out(2) = -11
	call test_process (generator, pdg_in, pdg_out, u, .true.)
	deallocate (pdg_out); deallocate (pdg_in)

	write (u, "(A)") "* Process 11: WZ production at hadron-colliders"
	allocate (pdg_in (2)); allocate (pdg_out (2))
	pdg_in(1) = 1; pdg_in(2) = -2
	pdg_out(1) = -24; pdg_out(2) = 23
	call test_process (generator, pdg_in, pdg_out, u, .true.)
	deallocate (pdg_out); deallocate (pdg_in)

	write (u, "(A)") "* Process 12: Positron-neutrino production"
	allocate (pdg_in (2)); allocate (pdg_out (2))
	pdg_in(1) = -1; pdg_in(2) = 2
	pdg_out(1) = -11; pdg_out(2) = 12
	call test_process (generator, pdg_in, pdg_out, u)
	deallocate (pdg_out); deallocate (pdg_in)

	contains
	subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
	type(radiation_generator_t), intent(inout) :: generator
	type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
	integer, intent(in) :: u
	logical, intent(in), optional :: include_initial_state
	type(string_t), dimension(:), allocatable :: prt_strings_in
	type(string_t), dimension(:), allocatable :: prt_strings_out
	type(pdg_array_t), dimension(10) :: pdg_excluded
	logical :: yorn
	yorn = .false.
	pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
	if (present (include_initial_state)) yorn = include_initial_state
	write (u, "(A)") "* Leading order: "
	write (u, "(A)", advance = 'no') '* Incoming: '
	call write_pdg_array (pdg_in, u)
	write (u, "(A)", advance = 'no') '* Outgoing: '
	call write_pdg_array (pdg_out, u)

	call generator%init (pdg_in, pdg_out, &
	pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
	call generator%set_n (2, size(pdg_out), 0)
	if (yorn) call generator%set_initial_state_emissions ()
	call generator%set_constraints (.false., .false., .true., .true.)
	call generator%setup_if_table (model)
	call generator%generate (prt_strings_in, prt_strings_out)
	write (u, "(A)") "* Additional radiation: "
	write (u, "(A)") "* Incoming: "
	call write_particle_string (prt_strings_in, u)
	write (u, "(A)") "* Outgoing: "
	call write_particle_string (prt_strings_out, u)
	call write_separator(u)
	call generator%reset_reshuffle_list ()
	end subroutine test_process

	end subroutine radiation_generator_3

	@ %def radiation_generator_3
	@
	<<radiation generator: test declarations>>=
	public :: radiation_generator_4
	<<radiation generator: tests>>=
	subroutine radiation_generator_4 (u)
	integer, intent(in) :: u
	type(radiation_generator_t) :: generator
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()
	integer, parameter :: max_multiplicity = 10
	type(string_t), dimension(:), allocatable :: prt_last

	write (u, "(A)") "* Test output: radiation_generator_4"
	write (u, "(A)") "* Purpose: Test the repeated application of &
	&a radiation generator splitting in QED"
	write (u, "(A)") "* Only Final state emissions! "
	write (u, "(A)")
	write (u, "(A)") "* Loading radiation model: SM.mdl"

	call syntax_model_file_init ()
	call os_data%init ()
	call model_list%read_model &
	(var_str ("SM"), var_str ("SM.mdl"), &
	os_data, model)
	write (u, "(A)") "* Success"

	allocate (pdg_in (2))
	pdg_in(1) = 2; pdg_in(2) = -2
	allocate (pdg_out(2))
	pdg_out(1) = 11; pdg_out(2) = -11
	allocate ( pdg_excluded (14))
	pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15]

	write (u, "(A)") "* Leading order"
	write (u, "(A)", advance = 'no') "* Incoming: "
	call write_pdg_array (pdg_in, u)
	write (u, "(A)", advance = 'no') "* Outgoing: "
	call write_pdg_array (pdg_out, u)

	call generator%init (pdg_in, pdg_out, &
	pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
	call generator%set_n (2, 2, 0)
	call generator%set_constraints (.false., .false., .true., .true.)

	call write_separator (u)
	write (u, "(A)") "Generate higher-multiplicity states"
	write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
	call generator%generate_multiple (max_multiplicity, model)
	call generator%prt_queue%write (u)
	call write_separator (u)
	write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists

	write (u, "(A)") "Check that no particle state occurs twice or more"
	if (.not. generator%prt_queue%check_for_same_prt_strings()) then
	write (u, "(A)") "SUCCESS"
	else
	write (u, "(A)") "FAIL"
	end if
	call write_separator (u)
	write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
	call generator%prt_queue%get_last (prt_last)
	if (size (prt_last) == max_multiplicity) then
	write (u, "(A)") "SUCCESS"
	else
	write (u, "(A)") "FAIL"
	end if
	end subroutine radiation_generator_4

	@ %def radiation_generator_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Sindarin Expression Implementation}

	This module defines expressions of all kinds, represented in
	a tree structure, for repeated evaluation. This provides an
	implementation of the [[expr_base]] abstract type.

	We have two flavors of expressions: one with particles and one without
	particles. The latter version is used for defining cut/selection
	criteria and for online analysis.
	<<[[eval_trees.f90]]>>=
	<<File header>>

	module eval_trees

	use, intrinsic :: iso_c_binding !NODEP!
	<<Use kinds>>
	<<Use strings>>
	use io_units
	use constants, only: DEGREE, IMAGO, PI
	use format_defs, only: FMT_19
	use numeric_utils, only: nearly_equal
	use diagnostics
	use lorentz
	use md5
	use formats
	use sorting
	use ifiles
	use lexers
	use syntax_rules
	use parser
	use analysis
	use jets
	use pdg_arrays
	use subevents
	use var_base
	use expr_base
	use variables
	use observables

	<<Standard module head>>

	<<Eval trees: public>>

	<<Eval trees: types>>

	<<Eval trees: interfaces>>

	<<Eval trees: variables>>

	contains

	<<Eval trees: procedures>>

	end module eval_trees
	@ %def eval_trees
	@
	\subsection{Tree nodes}
	The evaluation tree consists of branch nodes (unary and binary) and of
	leaf nodes, originating from a common root. The node object should be
	polymorphic. For the time being, polymorphism is emulated here. This
	means that we have to maintain all possibilities that the node may
	hold, including associated procedures as pointers.

	The following parameter values characterize the node. Unary and
	binary operators have sub-nodes. The other are leaf nodes. Possible
	leafs are literal constants or named-parameter references.
	<<Eval trees: types>>=
	integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2
	integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4
	integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6
	integer, parameter :: EN_RECORD_CMD = 7
	integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12
	integer, parameter :: EN_OBSEV_INT = 13
	integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22
	integer, parameter :: EN_OBSEV_REAL = 23
	integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102
	integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112
	integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122
	integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132
	integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142
	integer, parameter :: EN_REAL_FUN_CUM = 151
	integer, parameter :: EN_FORMAT_STR = 161

	@ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL
	@ %def EN_RECORD_CMD
	@ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL EN_OBSEV_INT EN_OBSEV_REAL
	@ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY
	@ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY
	@ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY
	@ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY
	@ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY
	@ %def EN_REAL_FUN_CUM
	@ %def EN_FORMAT_STR
	@ This is exported only for use within unit tests.
	<<Eval trees: public>>=
	public :: eval_node_t
	<<Eval trees: types>>=
	type :: eval_node_t
	private
	type(string_t) :: tag
	integer :: type = EN_UNKNOWN
	integer :: result_type = V_NONE
	type(var_list_t), pointer :: var_list => null ()
	type(string_t) :: var_name
	logical, pointer :: value_is_known => null ()
	logical, pointer :: lval => null ()
	integer, pointer :: ival => null ()
	real(default), pointer :: rval => null ()
	complex(default), pointer :: cval => null ()
	type(subevt_t), pointer :: pval => null ()
	type(pdg_array_t), pointer :: aval => null ()
	type(string_t), pointer :: sval => null ()
	type(eval_node_t), pointer :: arg0 => null ()
	type(eval_node_t), pointer :: arg1 => null ()
	type(eval_node_t), pointer :: arg2 => null ()
	type(eval_node_t), pointer :: arg3 => null ()
	type(eval_node_t), pointer :: arg4 => null ()
	procedure(obs_unary_int), nopass, pointer :: obs1_int => null ()
	procedure(obs_unary_real), nopass, pointer :: obs1_real => null ()
	procedure(obs_binary_int), nopass, pointer :: obs2_int => null ()
	procedure(obs_binary_real), nopass, pointer :: obs2_real => null ()
	procedure(obs_sev_int), nopass, pointer :: obsev_int => null ()
	procedure(obs_sev_real), nopass, pointer :: obsev_real => null ()
	integer, pointer :: prt_type => null ()
	integer, pointer :: index => null ()
	real(default), pointer :: tolerance => null ()
	integer, pointer :: jet_algorithm => null ()
	real(default), pointer :: jet_r => null ()
	real(default), pointer :: jet_p => null ()
	real(default), pointer :: jet_ycut => null ()
	real(default), pointer :: jet_dcut => null ()
	real(default), pointer :: photon_iso_eps => null ()
	real(default), pointer :: photon_iso_n => null ()
	real(default), pointer :: photon_iso_r0 => null ()
	real(default), pointer :: photon_rec_r0 => null ()
	type(prt_t), pointer :: prt1 => null ()
	type(prt_t), pointer :: prt2 => null ()
	procedure(unary_log), nopass, pointer :: op1_log => null ()
	procedure(unary_int), nopass, pointer :: op1_int => null ()
	procedure(unary_real), nopass, pointer :: op1_real => null ()
	procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null ()
	procedure(unary_pdg), nopass, pointer :: op1_pdg => null ()
	procedure(unary_sev), nopass, pointer :: op1_sev => null ()
	procedure(unary_str), nopass, pointer :: op1_str => null ()
	procedure(unary_cut), nopass, pointer :: op1_cut => null ()
	procedure(unary_evi), nopass, pointer :: op1_evi => null ()
	procedure(unary_evr), nopass, pointer :: op1_evr => null ()
	procedure(binary_log), nopass, pointer :: op2_log => null ()
	procedure(binary_int), nopass, pointer :: op2_int => null ()
	procedure(binary_real), nopass, pointer :: op2_real => null ()
	procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null ()
	procedure(binary_pdg), nopass, pointer :: op2_pdg => null ()
	procedure(binary_sev), nopass, pointer :: op2_sev => null ()
	procedure(binary_str), nopass, pointer :: op2_str => null ()
	procedure(binary_cut), nopass, pointer :: op2_cut => null ()
	procedure(binary_evi), nopass, pointer :: op2_evi => null ()
	procedure(binary_evr), nopass, pointer :: op2_evr => null ()
	procedure(cum_evi), nopass, pointer :: opcum_evi => null ()
	procedure(cum_evr), nopass, pointer :: opcum_evr => null ()
	contains
	<<Eval trees: eval node: TBP>>
	end type eval_node_t

	@ %def eval_node_t
	@ Finalize a node recursively. Allocated constants are deleted,
	pointers are ignored.
	<<Eval trees: eval node: TBP>>=
	procedure :: final_rec => eval_node_final_rec
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_final_rec (node)
	class(eval_node_t), intent(inout) :: node
	select case (node%type)
	case (EN_UNARY)
	call eval_node_final_rec (node%arg1)
	case (EN_BINARY)
	call eval_node_final_rec (node%arg1)
	call eval_node_final_rec (node%arg2)
	case (EN_CONDITIONAL)
	call eval_node_final_rec (node%arg0)
	call eval_node_final_rec (node%arg1)
	call eval_node_final_rec (node%arg2)
	case (EN_BLOCK)
	call eval_node_final_rec (node%arg0)
	call eval_node_final_rec (node%arg1)
	case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
	EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY)
	if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
	call eval_node_final_rec (node%arg1)
	deallocate (node%index)
	deallocate (node%prt1)
	case (EN_REAL_FUN_CUM)
	if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
	call eval_node_final_rec (node%arg1)
	deallocate (node%index)
	deallocate (node%prt1)
	case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
	EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
	if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
	call eval_node_final_rec (node%arg1)
	call eval_node_final_rec (node%arg2)
	deallocate (node%index)
	deallocate (node%prt1)
	deallocate (node%prt2)
	case (EN_FORMAT_STR)
	if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
	if (associated (node%arg1)) call eval_node_final_rec (node%arg1)
	deallocate (node%ival)
	case (EN_RECORD_CMD)
	if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
	if (associated (node%arg1)) call eval_node_final_rec (node%arg1)
	if (associated (node%arg2)) call eval_node_final_rec (node%arg2)
	if (associated (node%arg3)) call eval_node_final_rec (node%arg3)
	if (associated (node%arg4)) call eval_node_final_rec (node%arg4)
	end select
	select case (node%type)
	case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, &
	EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
	EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
	EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
	EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
	EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, &
	EN_REAL_FUN_CUM, &
	EN_FORMAT_STR, EN_RECORD_CMD)
	select case (node%result_type)
	case (V_LOG); deallocate (node%lval)
	case (V_INT); deallocate (node%ival)
	case (V_REAL); deallocate (node%rval)
	case (V_CMPLX); deallocate (node%cval)
	case (V_SEV); deallocate (node%pval)
	case (V_PDG); deallocate (node%aval)
	case (V_STR); deallocate (node%sval)
	end select
	deallocate (node%value_is_known)
	end select
	end subroutine eval_node_final_rec

	@ %def eval_node_final_rec
	@
	\subsubsection{Leaf nodes}
	Initialize a leaf node with a literal constant.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_log (node, lval)
	type(eval_node_t), intent(out) :: node
	logical, intent(in) :: lval
	node%type = EN_CONSTANT
	node%result_type = V_LOG
	allocate (node%lval, node%value_is_known)
	node%lval = lval
	node%value_is_known = .true.
	end subroutine eval_node_init_log

	subroutine eval_node_init_int (node, ival)
	type(eval_node_t), intent(out) :: node
	integer, intent(in) :: ival
	node%type = EN_CONSTANT
	node%result_type = V_INT
	allocate (node%ival, node%value_is_known)
	node%ival = ival
	node%value_is_known = .true.
	end subroutine eval_node_init_int

	subroutine eval_node_init_real (node, rval)
	type(eval_node_t), intent(out) :: node
	real(default), intent(in) :: rval
	node%type = EN_CONSTANT
	node%result_type = V_REAL
	allocate (node%rval, node%value_is_known)
	node%rval = rval
	node%value_is_known = .true.
	end subroutine eval_node_init_real

	subroutine eval_node_init_cmplx (node, cval)
	type(eval_node_t), intent(out) :: node
	complex(default), intent(in) :: cval
	node%type = EN_CONSTANT
	node%result_type = V_CMPLX
	allocate (node%cval, node%value_is_known)
	node%cval = cval
	node%value_is_known = .true.
	end subroutine eval_node_init_cmplx

	subroutine eval_node_init_subevt (node, pval)
	type(eval_node_t), intent(out) :: node
	type(subevt_t), intent(in) :: pval
	node%type = EN_CONSTANT
	node%result_type = V_SEV
	allocate (node%pval, node%value_is_known)
	node%pval = pval
	node%value_is_known = .true.
	end subroutine eval_node_init_subevt

	subroutine eval_node_init_pdg_array (node, aval)
	type(eval_node_t), intent(out) :: node
	type(pdg_array_t), intent(in) :: aval
	node%type = EN_CONSTANT
	node%result_type = V_PDG
	allocate (node%aval, node%value_is_known)
	node%aval = aval
	node%value_is_known = .true.
	end subroutine eval_node_init_pdg_array

	subroutine eval_node_init_string (node, sval)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: sval
	node%type = EN_CONSTANT
	node%result_type = V_STR
	allocate (node%sval, node%value_is_known)
	node%sval = sval
	node%value_is_known = .true.
	end subroutine eval_node_init_string

	@ %def eval_node_init_log eval_node_init_int eval_node_init_real
	@ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt
	@ %def eval_node_init_pdg_array eval_node_init_string
	@ Initialize a leaf node with a pointer to a named parameter
	<<Eval trees: procedures>>=
	subroutine eval_node_init_log_ptr (node, name, lval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	logical, intent(in), target :: lval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_LOG
	node%lval => lval
	node%value_is_known => is_known
	end subroutine eval_node_init_log_ptr

	subroutine eval_node_init_int_ptr (node, name, ival, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	integer, intent(in), target :: ival
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_INT
	node%ival => ival
	node%value_is_known => is_known
	end subroutine eval_node_init_int_ptr

	subroutine eval_node_init_real_ptr (node, name, rval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	real(default), intent(in), target :: rval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_REAL
	node%rval => rval
	node%value_is_known => is_known
	end subroutine eval_node_init_real_ptr

	subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	complex(default), intent(in), target :: cval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_CMPLX
	node%cval => cval
	node%value_is_known => is_known
	end subroutine eval_node_init_cmplx_ptr

	subroutine eval_node_init_subevt_ptr (node, name, pval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), target :: pval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_SEV
	node%pval => pval
	node%value_is_known => is_known
	end subroutine eval_node_init_subevt_ptr

	subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), target :: aval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_PDG
	node%aval => aval
	node%value_is_known => is_known
	end subroutine eval_node_init_pdg_array_ptr

	subroutine eval_node_init_string_ptr (node, name, sval, is_known)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	type(string_t), intent(in), target :: sval
	logical, intent(in), target :: is_known
	node%type = EN_VARIABLE
	node%tag = name
	node%result_type = V_STR
	node%sval => sval
	node%value_is_known => is_known
	end subroutine eval_node_init_string_ptr

	@ %def eval_node_init_log_ptr eval_node_init_int_ptr
	@ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr
	@ %def eval_node_init_subevt_ptr eval_node_init_string_ptr
	@ The procedure-pointer cases:
	<<Eval trees: procedures>>=
	subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_unary_int), intent(in), pointer :: obs1_iptr
	type(prt_t), intent(in), target :: p1
	node%type = EN_OBS1_INT
	node%tag = name
	node%result_type = V_INT
	node%obs1_int => obs1_iptr
	node%prt1 => p1
	allocate (node%ival, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obs1_int_ptr

	subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_binary_int), intent(in), pointer :: obs2_iptr
	type(prt_t), intent(in), target :: p1, p2
	node%type = EN_OBS2_INT
	node%tag = name
	node%result_type = V_INT
	node%obs2_int => obs2_iptr
	node%prt1 => p1
	node%prt2 => p2
	allocate (node%ival, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obs2_int_ptr

	subroutine eval_node_init_obsev_int_ptr (node, name, obsev_iptr, pval)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_sev_int), intent(in), pointer :: obsev_iptr
	type(subevt_t), intent(in), target :: pval
	node%type = EN_OBSEV_INT
	node%tag = name
	node%result_type = V_INT
	node%obsev_int => obsev_iptr
	node%pval => pval
	allocate (node%rval, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obsev_int_ptr

	subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_unary_real), intent(in), pointer :: obs1_rptr
	type(prt_t), intent(in), target :: p1
	node%type = EN_OBS1_REAL
	node%tag = name
	node%result_type = V_REAL
	node%obs1_real => obs1_rptr
	node%prt1 => p1
	allocate (node%rval, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obs1_real_ptr

	subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_binary_real), intent(in), pointer :: obs2_rptr
	type(prt_t), intent(in), target :: p1, p2
	node%type = EN_OBS2_REAL
	node%tag = name
	node%result_type = V_REAL
	node%obs2_real => obs2_rptr
	node%prt1 => p1
	node%prt2 => p2
	allocate (node%rval, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obs2_real_ptr

	subroutine eval_node_init_obsev_real_ptr (node, name, obsev_rptr, pval)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: name
	procedure(obs_sev_real), intent(in), pointer :: obsev_rptr
	type(subevt_t), intent(in), target :: pval
	node%type = EN_OBSEV_REAL
	node%tag = name
	node%result_type = V_REAL
	node%obsev_real => obsev_rptr
	node%pval => pval
	allocate (node%rval, node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_init_obsev_real_ptr

	@ %def eval_node_init_obs1_int_ptr
	@ %def eval_node_init_obs2_int_ptr
	@ %def eval_node_init_obs1_real_ptr
	@ %def eval_node_init_obs2_real_ptr
	@ %def eval_node_init_obsev_int_ptr
	@ %def eval_node_init_obsev_real_ptr
	@
	\subsubsection{Branch nodes}
	Initialize a branch node, sub-nodes are given.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2)
	type(eval_node_t), intent(out) :: node
	type(string_t), intent(in) :: tag
	integer, intent(in) :: result_type
	type(eval_node_t), intent(in), target :: arg1
	type(eval_node_t), intent(in), target, optional :: arg2
	if (present (arg2)) then
	node%type = EN_BINARY
	else
	node%type = EN_UNARY
	end if
	node%tag = tag
	node%result_type = result_type
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	if (present (arg2)) node%arg2 => arg2
	end subroutine eval_node_init_branch

	@ %def eval_node_init_branch
	@ Allocate the node value according to the result type.
	<<Eval trees: procedures>>=
	subroutine eval_node_allocate_value (node)
	type(eval_node_t), intent(inout) :: node
	select case (node%result_type)
	case (V_LOG); allocate (node%lval)
	case (V_INT); allocate (node%ival)
	case (V_REAL); allocate (node%rval)
	case (V_CMPLX); allocate (node%cval)
	case (V_PDG); allocate (node%aval)
	case (V_SEV); allocate (node%pval)
	call subevt_init (node%pval)
	case (V_STR); allocate (node%sval)
	end select
	allocate (node%value_is_known)
	node%value_is_known = .false.
	end subroutine eval_node_allocate_value

	@ %def eval_node_allocate_value
	@ Initialize a block node which contains, in addition to the
	expression to be evaluated, a variable definition. The result type is
	not yet assigned, because we can compile the enclosed expression only
	after the var list is set up.

	Note that the node always allocates a new variable list and appends it to the
	current one. Thus, if the variable redefines an existing one, it only shadows
	it but does not reset it. Any side-effects are therefore absent and need not
	be undone outside the block.

	If the flag [[new]] is set, a variable is (re)declared. This must not be done
	for intrinsic variables. Vice versa, if the variable is not existent, the
	[[new]] flag is required.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_block (node, name, type, var_def, var_list)
	type(eval_node_t), intent(out), target :: node
	type(string_t), intent(in) :: name
	integer, intent(in) :: type
	type(eval_node_t), intent(in), target :: var_def
	type(var_list_t), intent(in), target :: var_list
	node%type = EN_BLOCK
	node%tag = "var_def"
	node%var_name = name
	node%arg1 => var_def
	allocate (node%var_list)
	call node%var_list%link (var_list)
	if (var_def%type == EN_CONSTANT) then
	select case (type)
	case (V_LOG)
	call var_list_append_log (node%var_list, name, var_def%lval)
	case (V_INT)
	call var_list_append_int (node%var_list, name, var_def%ival)
	case (V_REAL)
	call var_list_append_real (node%var_list, name, var_def%rval)
	case (V_CMPLX)
	call var_list_append_cmplx (node%var_list, name, var_def%cval)
	case (V_PDG)
	call var_list_append_pdg_array &
	(node%var_list, name, var_def%aval)
	case (V_SEV)
	call var_list_append_subevt &
	(node%var_list, name, var_def%pval)
	case (V_STR)
	call var_list_append_string (node%var_list, name, var_def%sval)
	end select
	else
	select case (type)
	case (V_LOG); call var_list_append_log_ptr &
	(node%var_list, name, var_def%lval, var_def%value_is_known)
	case (V_INT); call var_list_append_int_ptr &
	(node%var_list, name, var_def%ival, var_def%value_is_known)
	case (V_REAL); call var_list_append_real_ptr &
	(node%var_list, name, var_def%rval, var_def%value_is_known)
	case (V_CMPLX); call var_list_append_cmplx_ptr &
	(node%var_list, name, var_def%cval, var_def%value_is_known)
	case (V_PDG); call var_list_append_pdg_array_ptr &
	(node%var_list, name, var_def%aval, var_def%value_is_known)
	case (V_SEV); call var_list_append_subevt_ptr &
	(node%var_list, name, var_def%pval, var_def%value_is_known)
	case (V_STR); call var_list_append_string_ptr &
	(node%var_list, name, var_def%sval, var_def%value_is_known)
	end select
	end if
	end subroutine eval_node_init_block

	@ %def eval_node_init_block
	@ Complete block initialization by assigning the expression to
	evaluate to [[arg0]].
	<<Eval trees: procedures>>=
	subroutine eval_node_set_expr (node, arg, result_type)
	type(eval_node_t), intent(inout) :: node
	type(eval_node_t), intent(in), target :: arg
	integer, intent(in), optional :: result_type
	if (present (result_type)) then
	node%result_type = result_type
	else
	node%result_type = arg%result_type
	end if
	call eval_node_allocate_value (node)
	node%arg0 => arg
	end subroutine eval_node_set_expr

	@ %def eval_node_set_block_expr
	@ Initialize a conditional. There are three branches: the condition
	(evaluates to logical) and the two alternatives (evaluate both to the
	same arbitrary type).
	<<Eval trees: procedures>>=
	subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2)
	type(eval_node_t), intent(out) :: node
	integer, intent(in) :: result_type
	type(eval_node_t), intent(in), target :: cond, arg1, arg2
	node%type = EN_CONDITIONAL
	node%tag = "cond"
	node%result_type = result_type
	call eval_node_allocate_value (node)
	node%arg0 => cond
	node%arg1 => arg1
	node%arg2 => arg2
	end subroutine eval_node_init_conditional

	@ %def eval_node_init_conditional
	@ Initialize a recording command (which evaluates to a logical
	constant). The first branch is the ID of the analysis object to be
	filled, the optional branches 1 to 4 are the values to be recorded.

	If the event-weight pointer is null, we record values with unit weight.
	Otherwise, we use the value pointed to as event weight.

	There can be up to four arguments which represent $x$, $y$, $\Delta y$,
	$\Delta x$. Therefore, this is the only node type that may fill four
	sub-nodes.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_record_cmd &
	(node, event_weight, id, arg1, arg2, arg3, arg4)
	type(eval_node_t), intent(out) :: node
	real(default), pointer :: event_weight
	type(eval_node_t), intent(in), target :: id
	type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4
	call eval_node_init_log (node, .true.)
	node%type = EN_RECORD_CMD
	node%rval => event_weight
	node%tag = "record_cmd"
	node%arg0 => id
	if (present (arg1)) then
	node%arg1 => arg1
	if (present (arg2)) then
	node%arg2 => arg2
	if (present (arg3)) then
	node%arg3 => arg3
	if (present (arg4)) then
	node%arg4 => arg4
	end if
	end if
	end if
	end if
	end subroutine eval_node_init_record_cmd

	@ %def eval_node_init_record_cmd
	@ Initialize a node for operations on subevents. The particle
	lists (one or two) are inserted as [[arg1]] and [[arg2]]. We
	allocated particle pointers as temporaries for iterating over particle
	lists. The procedure pointer which holds the function to evaluate for
	the subevents (e.g., combine, select) is also initialized.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	procedure(unary_sev) :: proc
	node%type = EN_PRT_FUN_UNARY
	node%tag = name
	node%result_type = V_SEV
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	node%op1_sev => proc
	end subroutine eval_node_init_prt_fun_unary

	subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1, arg2
	type(string_t), intent(in) :: name
	procedure(binary_sev) :: proc
	node%type = EN_PRT_FUN_BINARY
	node%tag = name
	node%result_type = V_SEV
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	node%arg2 => arg2
	allocate (node%index, source = 0)
	allocate (node%prt1)
	allocate (node%prt2)
	node%op2_sev => proc
	end subroutine eval_node_init_prt_fun_binary

	@ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary
	@ Similar, but for particle-list functions that evaluate to a real
	value.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_eval_fun_unary (node, arg1, name)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	node%type = EN_EVAL_FUN_UNARY
	node%tag = name
	node%result_type = V_REAL
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	end subroutine eval_node_init_eval_fun_unary

	subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1, arg2
	type(string_t), intent(in) :: name
	node%type = EN_EVAL_FUN_BINARY
	node%tag = name
	node%result_type = V_REAL
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	node%arg2 => arg2
	allocate (node%index, source = 0)
	allocate (node%prt1)
	allocate (node%prt2)
	end subroutine eval_node_init_eval_fun_binary

	@ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary
	@ These are for particle-list functions that evaluate to a logical
	value.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_log_fun_unary (node, arg1, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	procedure(unary_cut) :: proc
	node%type = EN_LOG_FUN_UNARY
	node%tag = name
	node%result_type = V_LOG
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	node%op1_cut => proc
	end subroutine eval_node_init_log_fun_unary

	subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1, arg2
	type(string_t), intent(in) :: name
	procedure(binary_cut) :: proc
	node%type = EN_LOG_FUN_BINARY
	node%tag = name
	node%result_type = V_LOG
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	node%arg2 => arg2
	allocate (node%index, source = 0)
	allocate (node%prt1)
	allocate (node%prt2)
	node%op2_cut => proc
	end subroutine eval_node_init_log_fun_binary

	@ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary
	@ These are for particle-list functions that evaluate to an integer
	value.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_int_fun_unary (node, arg1, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	procedure(unary_evi) :: proc
	node%type = EN_INT_FUN_UNARY
	node%tag = name
	node%result_type = V_INT
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	node%op1_evi => proc
	end subroutine eval_node_init_int_fun_unary

	subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1, arg2
	type(string_t), intent(in) :: name
	procedure(binary_evi) :: proc
	node%type = EN_INT_FUN_BINARY
	node%tag = name
	node%result_type = V_INT
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	node%arg2 => arg2
	allocate (node%index, source = 0)
	allocate (node%prt1)
	allocate (node%prt2)
	node%op2_evi => proc
	end subroutine eval_node_init_int_fun_binary

	@ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary
	@ These are for particle-list functions that evaluate to a real
	value.
	<<Eval trees: procedures>>=
	subroutine eval_node_init_real_fun_unary (node, arg1, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	procedure(unary_evr) :: proc
	node%type = EN_REAL_FUN_UNARY
	node%tag = name
	node%result_type = V_REAL
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	node%op1_evr => proc
	end subroutine eval_node_init_real_fun_unary

	subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1, arg2
	type(string_t), intent(in) :: name
	procedure(binary_evr) :: proc
	node%type = EN_REAL_FUN_BINARY
	node%tag = name
	node%result_type = V_REAL
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	node%arg2 => arg2
	allocate (node%index, source = 0)
	allocate (node%prt1)
	allocate (node%prt2)
	node%op2_evr => proc
	end subroutine eval_node_init_real_fun_binary

	subroutine eval_node_init_real_fun_cum (node, arg1, name, proc)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), intent(in), target :: arg1
	type(string_t), intent(in) :: name
	procedure(cum_evr) :: proc
	node%type = EN_REAL_FUN_CUM
	node%tag = name
	node%result_type = V_REAL
	call eval_node_allocate_value (node)
	node%arg1 => arg1
	allocate (node%index, source = 0)
	allocate (node%prt1)
	node%opcum_evr => proc
	end subroutine eval_node_init_real_fun_cum

	@ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary
	@ %def eval_node_init_real_fun_cum
	@ Initialize a node for a string formatting function (sprintf).
	<<Eval trees: procedures>>=
	subroutine eval_node_init_format_string (node, fmt, arg, name, n_args)
	type(eval_node_t), intent(out) :: node
	type(eval_node_t), pointer :: fmt, arg
	type(string_t), intent(in) :: name
	integer, intent(in) :: n_args
	node%type = EN_FORMAT_STR
	node%tag = name
	node%result_type = V_STR
	call eval_node_allocate_value (node)
	node%arg0 => fmt
	node%arg1 => arg
	allocate (node%ival)
	node%ival = n_args
	end subroutine eval_node_init_format_string

	@ %def eval_node_init_format_string
	@ If particle functions depend upon a condition (or an expression is
	evaluated), the observables that can be evaluated for the given
	particles have to be thrown on the local variable stack. This is done
	here. Each observable is initialized with the particle pointers which
	have been allocated for the node.

	The integer variable that is referred to by the [[Index]]
	pseudo-observable is always known when it is referred to.
	<<Eval trees: procedures>>=
	subroutine eval_node_set_observables (node, var_list)
	type(eval_node_t), intent(inout) :: node
	type(var_list_t), intent(in), target :: var_list
	logical, save, target :: known = .true.
	allocate (node%var_list)
	call node%var_list%link (var_list)
	allocate (node%index, source = 0)
	call var_list_append_int_ptr &
	(node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.)
	if (.not. associated (node%prt2)) then
	call var_list_set_observables_unary &
	(node%var_list, node%prt1)
	if (associated (node%pval)) then
	call var_list_set_observables_sev &
	(node%var_list, node%pval)
	end if
	else
	call var_list_set_observables_binary &
	(node%var_list, node%prt1, node%prt2)
	end if
	end subroutine eval_node_set_observables

	@ %def eval_node_set_observables
	@
	\subsubsection{Output}
	<<Eval trees: eval node: TBP>>=
	procedure :: write => eval_node_write
	<<Eval trees: procedures>>=
	subroutine eval_node_write (node, unit, indent)
	class(eval_node_t), intent(in) :: node
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: indent
	integer :: u, ind
	u = given_output_unit (unit); if (u < 0) return
	ind = 0; if (present (indent)) ind = indent
	write (u, "(A)", advance="no") repeat ("\| ", ind) // "o "
	select case (node%type)
	case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, &
	EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
	EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
	EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
	EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
	EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, &
	EN_REAL_FUN_CUM)
	write (u, "(A)", advance="no") "[" // char (node%tag) // "] ="
	case (EN_CONSTANT)
	write (u, "(A)", advance="no") "[const] ="
	case (EN_VARIABLE)
	write (u, "(A)", advance="no") char (node%tag) // " =>"
	case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL)
	write (u, "(A)", advance="no") char (node%tag) // " ="
	case (EN_BLOCK)
	write (u, "(A)", advance="no") "[" // char (node%tag) // "]" // &
	char (node%var_name) // " [expr] = "
	case default
	write (u, "(A)", advance="no") "[???] ="
	end select
	select case (node%result_type)
	case (V_LOG)
	if (node%value_is_known) then
	if (node%lval) then
	write (u, "(1x,A)") "true"
	else
	write (u, "(1x,A)") "false"
	end if
	else
	write (u, "(1x,A)") "[unknown logical]"
	end if
	case (V_INT)
	if (node%value_is_known) then
	write (u, "(1x,I0)") node%ival
	else
	write (u, "(1x,A)") "[unknown integer]"
	end if
	case (V_REAL)
	if (node%value_is_known) then
	write (u, "(1x," // FMT_19 // ")") node%rval
	else
	write (u, "(1x,A)") "[unknown real]"
	end if
	case (V_CMPLX)
	if (node%value_is_known) then
	write (u, "(1x,'('," // FMT_19 // ",','," // &
	FMT_19 // ",')')") node%cval
	else
	write (u, "(1x,A)") "[unknown complex]"
	end if
	case (V_SEV)
	if (char (node%tag) == "@evt") then
	write (u, "(1x,A)") "[event subevent]"
	else if (node%value_is_known) then
	- call subevt_write &
	- (node%pval, unit, prefix = repeat ("\| ", ind + 1))
	+ call node%pval%write (unit, prefix = repeat ("\| ", ind + 1))
	else
	write (u, "(1x,A)") "[unknown subevent]"
	end if
	case (V_PDG)
	write (u, "(1x)", advance="no")
	- call pdg_array_write (node%aval, u); write (u, *)
	+ call node%aval%write (u); write (u, *)
	case (V_STR)
	if (node%value_is_known) then
	write (u, "(A)") '"' // char (node%sval) // '"'
	else
	write (u, "(1x,A)") "[unknown string]"
	end if
	case default
	write (u, "(1x,A)") "[empty]"
	end select
	select case (node%type)
	case (EN_OBS1_INT, EN_OBS1_REAL)
	write (u, "(A,6x,A)", advance="no") repeat ("\| ", ind), "prt1 ="
	call prt_write (node%prt1, unit)
	case (EN_OBS2_INT, EN_OBS2_REAL)
	write (u, "(A,6x,A)", advance="no") repeat ("\| ", ind), "prt1 ="
	call prt_write (node%prt1, unit)
	write (u, "(A,6x,A)", advance="no") repeat ("\| ", ind), "prt2 ="
	call prt_write (node%prt2, unit)
	end select
	end subroutine eval_node_write

	recursive subroutine eval_node_write_rec (node, unit, indent)
	type(eval_node_t), intent(in) :: node
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: indent
	integer :: u, ind
	u = given_output_unit (unit); if (u < 0) return
	ind = 0; if (present (indent)) ind = indent
	call eval_node_write (node, unit, indent)
	select case (node%type)
	case (EN_UNARY)
	if (associated (node%arg0)) &
	call eval_node_write_rec (node%arg0, unit, ind+1)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	case (EN_BINARY)
	if (associated (node%arg0)) &
	call eval_node_write_rec (node%arg0, unit, ind+1)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	call eval_node_write_rec (node%arg2, unit, ind+1)
	case (EN_BLOCK)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	call eval_node_write_rec (node%arg0, unit, ind+1)
	case (EN_CONDITIONAL)
	call eval_node_write_rec (node%arg0, unit, ind+1)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	call eval_node_write_rec (node%arg2, unit, ind+1)
	case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
	EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY, &
	EN_REAL_FUN_CUM)
	if (associated (node%arg0)) &
	call eval_node_write_rec (node%arg0, unit, ind+1)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
	EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
	if (associated (node%arg0)) &
	call eval_node_write_rec (node%arg0, unit, ind+1)
	call eval_node_write_rec (node%arg1, unit, ind+1)
	call eval_node_write_rec (node%arg2, unit, ind+1)
	case (EN_RECORD_CMD)
	if (associated (node%arg1)) then
	call eval_node_write_rec (node%arg1, unit, ind+1)
	if (associated (node%arg2)) then
	call eval_node_write_rec (node%arg2, unit, ind+1)
	if (associated (node%arg3)) then
	call eval_node_write_rec (node%arg3, unit, ind+1)
	if (associated (node%arg4)) then
	call eval_node_write_rec (node%arg4, unit, ind+1)
	end if
	end if
	end if
	end if
	end select
	end subroutine eval_node_write_rec

	@ %def eval_node_write eval_node_write_rec
	@
	\subsection{Operation types}
	For the operations associated to evaluation tree nodes, we define
	abstract interfaces for all cases.

	Particles/subevents are transferred by-reference, to avoid
	unnecessary copying. Therefore, subroutines instead of functions.
	<<Eval trees: interfaces>>=
	abstract interface
	logical function unary_log (arg)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg
	end function unary_log
	end interface
	abstract interface
	integer function unary_int (arg)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg
	end function unary_int
	end interface
	abstract interface
	real(default) function unary_real (arg)
	import default
	import eval_node_t
	type(eval_node_t), intent(in) :: arg
	end function unary_real
	end interface
	abstract interface
	complex(default) function unary_cmplx (arg)
	import default
	import eval_node_t
	type(eval_node_t), intent(in) :: arg
	end function unary_cmplx
	end interface
	abstract interface
	subroutine unary_pdg (pdg_array, arg)
	import pdg_array_t
	import eval_node_t
	type(pdg_array_t), intent(out) :: pdg_array
	type(eval_node_t), intent(in) :: arg
	end subroutine unary_pdg
	end interface
	abstract interface
	subroutine unary_sev (subevt, arg, arg0)
	import subevt_t
	import eval_node_t
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: arg
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine unary_sev
	end interface
	abstract interface
	subroutine unary_str (string, arg)
	import string_t
	import eval_node_t
	type(string_t), intent(out) :: string
	type(eval_node_t), intent(in) :: arg
	end subroutine unary_str
	end interface
	abstract interface
	logical function unary_cut (arg1, arg0)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1
	type(eval_node_t), intent(inout) :: arg0
	end function unary_cut
	end interface
	abstract interface
	subroutine unary_evi (ival, arg1, arg0)
	import eval_node_t
	integer, intent(out) :: ival
	type(eval_node_t), intent(in) :: arg1
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine unary_evi
	end interface
	abstract interface
	subroutine unary_evr (rval, arg1, arg0)
	import eval_node_t, default
	real(default), intent(out) :: rval
	type(eval_node_t), intent(in) :: arg1
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine unary_evr
	end interface
	abstract interface
	logical function binary_log (arg1, arg2)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1, arg2
	end function binary_log
	end interface
	abstract interface
	integer function binary_int (arg1, arg2)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1, arg2
	end function binary_int
	end interface
	abstract interface
	real(default) function binary_real (arg1, arg2)
	import default
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1, arg2
	end function binary_real
	end interface
	abstract interface
	complex(default) function binary_cmplx (arg1, arg2)
	import default
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1, arg2
	end function binary_cmplx
	end interface
	abstract interface
	subroutine binary_pdg (pdg_array, arg1, arg2)
	import pdg_array_t
	import eval_node_t
	type(pdg_array_t), intent(out) :: pdg_array
	type(eval_node_t), intent(in) :: arg1, arg2
	end subroutine binary_pdg
	end interface
	abstract interface
	subroutine binary_sev (subevt, arg1, arg2, arg0)
	import subevt_t
	import eval_node_t
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: arg1, arg2
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine binary_sev
	end interface
	abstract interface
	subroutine binary_str (string, arg1, arg2)
	import string_t
	import eval_node_t
	type(string_t), intent(out) :: string
	type(eval_node_t), intent(in) :: arg1, arg2
	end subroutine binary_str
	end interface
	abstract interface
	logical function binary_cut (arg1, arg2, arg0)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1, arg2
	type(eval_node_t), intent(inout) :: arg0
	end function binary_cut
	end interface
	abstract interface
	subroutine binary_evi (ival, arg1, arg2, arg0)
	import eval_node_t
	integer, intent(out) :: ival
	type(eval_node_t), intent(in) :: arg1, arg2
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine binary_evi
	end interface
	abstract interface
	subroutine binary_evr (rval, arg1, arg2, arg0)
	import eval_node_t, default
	real(default), intent(out) :: rval
	type(eval_node_t), intent(in) :: arg1, arg2
	type(eval_node_t), intent(inout), optional :: arg0
	end subroutine binary_evr
	end interface
	abstract interface
	integer function cum_evi (arg1, arg0)
	import eval_node_t
	type(eval_node_t), intent(in) :: arg1
	type(eval_node_t), intent(inout) :: arg0
	end function cum_evi
	end interface
	abstract interface
	real(default) function cum_evr (arg1, arg0)
	import eval_node_t, default
	type(eval_node_t), intent(in) :: arg1
	type(eval_node_t), intent(inout) :: arg0
	end function cum_evr
	end interface

	@ The following subroutines set the procedure pointer:
	<<Eval trees: procedures>>=
	subroutine eval_node_set_op1_log (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_log) :: op
	en%op1_log => op
	end subroutine eval_node_set_op1_log

	subroutine eval_node_set_op1_int (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_int) :: op
	en%op1_int => op
	end subroutine eval_node_set_op1_int

	subroutine eval_node_set_op1_real (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_real) :: op
	en%op1_real => op
	end subroutine eval_node_set_op1_real

	subroutine eval_node_set_op1_cmplx (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_cmplx) :: op
	en%op1_cmplx => op
	end subroutine eval_node_set_op1_cmplx

	subroutine eval_node_set_op1_pdg (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_pdg) :: op
	en%op1_pdg => op
	end subroutine eval_node_set_op1_pdg

	subroutine eval_node_set_op1_sev (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_sev) :: op
	en%op1_sev => op
	end subroutine eval_node_set_op1_sev

	subroutine eval_node_set_op1_str (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(unary_str) :: op
	en%op1_str => op
	end subroutine eval_node_set_op1_str

	subroutine eval_node_set_op2_log (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_log) :: op
	en%op2_log => op
	end subroutine eval_node_set_op2_log

	subroutine eval_node_set_op2_int (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_int) :: op
	en%op2_int => op
	end subroutine eval_node_set_op2_int

	subroutine eval_node_set_op2_real (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_real) :: op
	en%op2_real => op
	end subroutine eval_node_set_op2_real

	subroutine eval_node_set_op2_cmplx (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_cmplx) :: op
	en%op2_cmplx => op
	end subroutine eval_node_set_op2_cmplx

	subroutine eval_node_set_op2_pdg (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_pdg) :: op
	en%op2_pdg => op
	end subroutine eval_node_set_op2_pdg

	subroutine eval_node_set_op2_sev (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_sev) :: op
	en%op2_sev => op
	end subroutine eval_node_set_op2_sev

	subroutine eval_node_set_op2_str (en, op)
	type(eval_node_t), intent(inout) :: en
	procedure(binary_str) :: op
	en%op2_str => op
	end subroutine eval_node_set_op2_str

	@ %def eval_node_set_operator
	@
	\subsection{Specific operators}

	Our expression syntax contains all Fortran functions that make sense.
	These functions have to be provided in a form that they can be used in
	procedures pointers, and have the abstract interfaces above.
	For some intrinsic functions, we could use specific versions provided
	by Fortran directly. However, this has two drawbacks: (i) We should
	work with the values instead of the eval-nodes as argument, which
	complicates the interface; (ii) more importantly, the [[default]] real
	type need not be equivalent to double precision. This would, at
	least, introduce system dependencies. Finally, for operators there
	are no specific versions.

	Therefore, we write wrappers for all possible functions, at the
	expense of some overhead.
	\subsubsection{Binary numerical functions}
	<<Eval trees: procedures>>=
	integer function add_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival + en2%ival
	end function add_ii
	real(default) function add_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival + en2%rval
	end function add_ir
	complex(default) function add_ic (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival + en2%cval
	end function add_ic
	real(default) function add_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval + en2%ival
	end function add_ri
	complex(default) function add_ci (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval + en2%ival
	end function add_ci
	complex(default) function add_cr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval + en2%rval
	end function add_cr
	complex(default) function add_rc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval + en2%cval
	end function add_rc
	real(default) function add_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval + en2%rval
	end function add_rr
	complex(default) function add_cc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval + en2%cval
	end function add_cc

	integer function sub_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival - en2%ival
	end function sub_ii
	real(default) function sub_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival - en2%rval
	end function sub_ir
	real(default) function sub_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval - en2%ival
	end function sub_ri
	complex(default) function sub_ic (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival - en2%cval
	end function sub_ic
	complex(default) function sub_ci (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval - en2%ival
	end function sub_ci
	complex(default) function sub_cr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval - en2%rval
	end function sub_cr
	complex(default) function sub_rc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval - en2%cval
	end function sub_rc
	real(default) function sub_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval - en2%rval
	end function sub_rr
	complex(default) function sub_cc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval - en2%cval
	end function sub_cc

	integer function mul_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival * en2%ival
	end function mul_ii
	real(default) function mul_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival * en2%rval
	end function mul_ir
	real(default) function mul_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval * en2%ival
	end function mul_ri
	complex(default) function mul_ic (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival * en2%cval
	end function mul_ic
	complex(default) function mul_ci (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval * en2%ival
	end function mul_ci
	complex(default) function mul_rc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval * en2%cval
	end function mul_rc
	complex(default) function mul_cr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval * en2%rval
	end function mul_cr
	real(default) function mul_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval * en2%rval
	end function mul_rr
	complex(default) function mul_cc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval * en2%cval
	end function mul_cc

	integer function div_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (en2%ival == 0) then
	if (en1%ival >= 0) then
	call msg_warning ("division by zero: " // int2char (en1%ival) // &
	" / 0 ; result set to 0")
	else
	call msg_warning ("division by zero: (" // int2char (en1%ival) // &
	") / 0 ; result set to 0")
	end if
	y = 0
	return
	end if
	y = en1%ival / en2%ival
	end function div_ii
	real(default) function div_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival / en2%rval
	end function div_ir
	real(default) function div_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval / en2%ival
	end function div_ri
	complex(default) function div_ic (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival / en2%cval
	end function div_ic
	complex(default) function div_ci (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval / en2%ival
	end function div_ci
	complex(default) function div_rc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval / en2%cval
	end function div_rc
	complex(default) function div_cr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval / en2%rval
	end function div_cr
	real(default) function div_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval / en2%rval
	end function div_rr
	complex(default) function div_cc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval / en2%cval
	end function div_cc

	integer function pow_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	integer :: a, b
	real(default) :: rres
	a = en1%ival
	b = en2%ival
	if ((a == 0) .and. (b < 0)) then
	call msg_warning ("division by zero: " // int2char (a) // &
	" ^ (" // int2char (b) // ") ; result set to 0")
	y = 0
	return
	end if
	rres = real(a, default) ** b
	y = rres
	if (real(y, default) /= rres) then
	if (b < 0) then
	call msg_warning ("result of all-integer operation " // &
	int2char (a) // " ^ (" // int2char (b) // &
	") has been trucated to "// int2char (y), &
	[ var_str ("Chances are that you want to use " // &
	"reals instead of integers at this point.") ])
	else
	call msg_warning ("integer overflow in " // int2char (a) // &
	" ^ " // int2char (b) // " ; result is " // int2char (y), &
	[ var_str ("Using reals instead of integers might help.")])
	end if
	end if
	end function pow_ii
	real(default) function pow_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval ** en2%ival
	end function pow_ri
	complex(default) function pow_ci (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval ** en2%ival
	end function pow_ci
	real(default) function pow_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival ** en2%rval
	end function pow_ir
	real(default) function pow_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval ** en2%rval
	end function pow_rr
	complex(default) function pow_cr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval ** en2%rval
	end function pow_cr
	complex(default) function pow_ic (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival ** en2%cval
	end function pow_ic
	complex(default) function pow_rc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval ** en2%cval
	end function pow_rc
	complex(default) function pow_cc (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%cval ** en2%cval
	end function pow_cc

	integer function max_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = max (en1%ival, en2%ival)
	end function max_ii
	real(default) function max_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = max (real (en1%ival, default), en2%rval)
	end function max_ir
	real(default) function max_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = max (en1%rval, real (en2%ival, default))
	end function max_ri
	real(default) function max_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = max (en1%rval, en2%rval)
	end function max_rr
	integer function min_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = min (en1%ival, en2%ival)
	end function min_ii
	real(default) function min_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = min (real (en1%ival, default), en2%rval)
	end function min_ir
	real(default) function min_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = min (en1%rval, real (en2%ival, default))
	end function min_ri
	real(default) function min_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = min (en1%rval, en2%rval)
	end function min_rr

	integer function mod_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = mod (en1%ival, en2%ival)
	end function mod_ii
	real(default) function mod_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = mod (real (en1%ival, default), en2%rval)
	end function mod_ir
	real(default) function mod_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = mod (en1%rval, real (en2%ival, default))
	end function mod_ri
	real(default) function mod_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = mod (en1%rval, en2%rval)
	end function mod_rr
	integer function modulo_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = modulo (en1%ival, en2%ival)
	end function modulo_ii
	real(default) function modulo_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = modulo (real (en1%ival, default), en2%rval)
	end function modulo_ir
	real(default) function modulo_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = modulo (en1%rval, real (en2%ival, default))
	end function modulo_ri
	real(default) function modulo_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = modulo (en1%rval, en2%rval)
	end function modulo_rr

	@
	\subsubsection{Unary numeric functions}
	<<Eval trees: procedures>>=
	real(default) function real_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%ival
	end function real_i
	real(default) function real_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%cval
	end function real_c
	integer function int_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%rval
	end function int_r
	complex(default) function cmplx_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%ival
	end function cmplx_i
	integer function int_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%cval
	end function int_c
	complex(default) function cmplx_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%rval
	end function cmplx_r
	integer function nint_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = nint (en%rval)
	end function nint_r
	integer function floor_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = floor (en%rval)
	end function floor_r
	integer function ceiling_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = ceiling (en%rval)
	end function ceiling_r

	integer function neg_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = - en%ival
	end function neg_i
	real(default) function neg_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = - en%rval
	end function neg_r
	complex(default) function neg_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = - en%cval
	end function neg_c
	integer function abs_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = abs (en%ival)
	end function abs_i
	real(default) function abs_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = abs (en%rval)
	end function abs_r
	real(default) function abs_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = abs (en%cval)
	end function abs_c
	integer function conjg_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%ival
	end function conjg_i
	real(default) function conjg_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = en%rval
	end function conjg_r
	complex(default) function conjg_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = conjg (en%cval)
	end function conjg_c
	integer function sgn_i (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sign (1, en%ival)
	end function sgn_i
	real(default) function sgn_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sign (1._default, en%rval)
	end function sgn_r

	real(default) function sqrt_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sqrt (en%rval)
	end function sqrt_r
	real(default) function exp_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = exp (en%rval)
	end function exp_r
	real(default) function log_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = log (en%rval)
	end function log_r
	real(default) function log10_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = log10 (en%rval)
	end function log10_r

	complex(default) function sqrt_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sqrt (en%cval)
	end function sqrt_c
	complex(default) function exp_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = exp (en%cval)
	end function exp_c
	complex(default) function log_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = log (en%cval)
	end function log_c

	real(default) function sin_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sin (en%rval)
	end function sin_r
	real(default) function cos_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = cos (en%rval)
	end function cos_r
	real(default) function tan_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = tan (en%rval)
	end function tan_r
	real(default) function asin_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = asin (en%rval)
	end function asin_r
	real(default) function acos_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = acos (en%rval)
	end function acos_r
	real(default) function atan_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = atan (en%rval)
	end function atan_r

	complex(default) function sin_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sin (en%cval)
	end function sin_c
	complex(default) function cos_c (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = cos (en%cval)
	end function cos_c

	real(default) function sinh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = sinh (en%rval)
	end function sinh_r
	real(default) function cosh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = cosh (en%rval)
	end function cosh_r
	real(default) function tanh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = tanh (en%rval)
	end function tanh_r
	real(default) function asinh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = asinh (en%rval)
	end function asinh_r
	real(default) function acosh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = acosh (en%rval)
	end function acosh_r
	real(default) function atanh_r (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = atanh (en%rval)
	end function atanh_r

	@
	\subsubsection{Binary logical functions}
	Logical expressions:
	<<Eval trees: procedures>>=
	logical function ignore_first_ll (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en2%lval
	end function ignore_first_ll
	logical function or_ll (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%lval .or. en2%lval
	end function or_ll
	logical function and_ll (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%lval .and. en2%lval
	end function and_ll

	@ Comparisons:
	<<Eval trees: procedures>>=
	logical function comp_lt_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival < en2%ival
	end function comp_lt_ii
	logical function comp_lt_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival < en2%rval
	end function comp_lt_ir
	logical function comp_lt_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval < en2%ival
	end function comp_lt_ri
	logical function comp_lt_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval < en2%rval
	end function comp_lt_rr

	logical function comp_gt_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival > en2%ival
	end function comp_gt_ii
	logical function comp_gt_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival > en2%rval
	end function comp_gt_ir
	logical function comp_gt_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval > en2%ival
	end function comp_gt_ri
	logical function comp_gt_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval > en2%rval
	end function comp_gt_rr

	logical function comp_le_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival <= en2%ival
	end function comp_le_ii
	logical function comp_le_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival <= en2%rval
	end function comp_le_ir
	logical function comp_le_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval <= en2%ival
	end function comp_le_ri
	logical function comp_le_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval <= en2%rval
	end function comp_le_rr

	logical function comp_ge_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival >= en2%ival
	end function comp_ge_ii
	logical function comp_ge_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival >= en2%rval
	end function comp_ge_ir
	logical function comp_ge_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval >= en2%ival
	end function comp_ge_ri
	logical function comp_ge_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval >= en2%rval
	end function comp_ge_rr

	logical function comp_eq_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival == en2%ival
	end function comp_eq_ii
	logical function comp_eq_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival == en2%rval
	end function comp_eq_ir
	logical function comp_eq_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval == en2%ival
	end function comp_eq_ri
	logical function comp_eq_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval == en2%rval
	end function comp_eq_rr
	logical function comp_eq_ss (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%sval == en2%sval
	end function comp_eq_ss

	logical function comp_ne_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival /= en2%ival
	end function comp_ne_ii
	logical function comp_ne_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%ival /= en2%rval
	end function comp_ne_ir
	logical function comp_ne_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval /= en2%ival
	end function comp_ne_ri
	logical function comp_ne_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%rval /= en2%rval
	end function comp_ne_rr
	logical function comp_ne_ss (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	y = en1%sval /= en2%sval
	end function comp_ne_ss

	@ Comparisons with tolerance:
	<<Eval trees: procedures>>=
	logical function comp_se_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%ival - en2%ival) <= en1%tolerance
	else
	y = en1%ival == en2%ival
	end if
	end function comp_se_ii
	logical function comp_se_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%rval - en2%ival) <= en1%tolerance
	else
	y = en1%rval == en2%ival
	end if
	end function comp_se_ri
	logical function comp_se_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%ival - en2%rval) <= en1%tolerance
	else
	y = en1%ival == en2%rval
	end if
	end function comp_se_ir
	logical function comp_se_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%rval - en2%rval) <= en1%tolerance
	else
	y = en1%rval == en2%rval
	end if
	end function comp_se_rr
	logical function comp_ns_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%ival - en2%ival) > en1%tolerance
	else
	y = en1%ival /= en2%ival
	end if
	end function comp_ns_ii
	logical function comp_ns_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%rval - en2%ival) > en1%tolerance
	else
	y = en1%rval /= en2%ival
	end if
	end function comp_ns_ri
	logical function comp_ns_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%ival - en2%rval) > en1%tolerance
	else
	y = en1%ival /= en2%rval
	end if
	end function comp_ns_ir
	logical function comp_ns_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = abs (en1%rval - en2%rval) > en1%tolerance
	else
	y = en1%rval /= en2%rval
	end if
	end function comp_ns_rr

	logical function comp_ls_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival <= en2%ival + en1%tolerance
	else
	y = en1%ival <= en2%ival
	end if
	end function comp_ls_ii
	logical function comp_ls_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval <= en2%ival + en1%tolerance
	else
	y = en1%rval <= en2%ival
	end if
	end function comp_ls_ri
	logical function comp_ls_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival <= en2%rval + en1%tolerance
	else
	y = en1%ival <= en2%rval
	end if
	end function comp_ls_ir
	logical function comp_ls_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval <= en2%rval + en1%tolerance
	else
	y = en1%rval <= en2%rval
	end if
	end function comp_ls_rr

	logical function comp_ll_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival < en2%ival - en1%tolerance
	else
	y = en1%ival < en2%ival
	end if
	end function comp_ll_ii
	logical function comp_ll_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval < en2%ival - en1%tolerance
	else
	y = en1%rval < en2%ival
	end if
	end function comp_ll_ri
	logical function comp_ll_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival < en2%rval - en1%tolerance
	else
	y = en1%ival < en2%rval
	end if
	end function comp_ll_ir
	logical function comp_ll_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval < en2%rval - en1%tolerance
	else
	y = en1%rval < en2%rval
	end if
	end function comp_ll_rr

	logical function comp_gs_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival >= en2%ival - en1%tolerance
	else
	y = en1%ival >= en2%ival
	end if
	end function comp_gs_ii
	logical function comp_gs_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval >= en2%ival - en1%tolerance
	else
	y = en1%rval >= en2%ival
	end if
	end function comp_gs_ri
	logical function comp_gs_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival >= en2%rval - en1%tolerance
	else
	y = en1%ival >= en2%rval
	end if
	end function comp_gs_ir
	logical function comp_gs_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval >= en2%rval - en1%tolerance
	else
	y = en1%rval >= en2%rval
	end if
	end function comp_gs_rr

	logical function comp_gg_ii (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival > en2%ival + en1%tolerance
	else
	y = en1%ival > en2%ival
	end if
	end function comp_gg_ii
	logical function comp_gg_ri (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval > en2%ival + en1%tolerance
	else
	y = en1%rval > en2%ival
	end if
	end function comp_gg_ri
	logical function comp_gg_ir (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%ival > en2%rval + en1%tolerance
	else
	y = en1%ival > en2%rval
	end if
	end function comp_gg_ir
	logical function comp_gg_rr (en1, en2) result (y)
	type(eval_node_t), intent(in) :: en1, en2
	if (associated (en1%tolerance)) then
	y = en1%rval > en2%rval + en1%tolerance
	else
	y = en1%rval > en2%rval
	end if
	end function comp_gg_rr

	@
	\subsubsection{Unary logical functions}
	<<Eval trees: procedures>>=
	logical function not_l (en) result (y)
	type(eval_node_t), intent(in) :: en
	y = .not. en%lval
	end function not_l

	@
	\subsubsection{Unary PDG-array functions}
	Make a PDG-array object from an integer.
	<<Eval trees: procedures>>=
	subroutine pdg_i (pdg_array, en)
	type(pdg_array_t), intent(out) :: pdg_array
	type(eval_node_t), intent(in) :: en
	pdg_array = en%ival
	end subroutine pdg_i

	@
	\subsubsection{Binary PDG-array functions}
	Concatenate two PDG-array objects.
	<<Eval trees: procedures>>=
	subroutine concat_cc (pdg_array, en1, en2)
	type(pdg_array_t), intent(out) :: pdg_array
	type(eval_node_t), intent(in) :: en1, en2
	pdg_array = en1%aval // en2%aval
	end subroutine concat_cc

	@
	\subsubsection{Unary particle-list functions}
	Combine all particles of the first argument. If [[en0]] is present,
	create a mask which is true only for those particles that pass the
	test.
	<<Eval trees: procedures>>=
	subroutine collect_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	if (present (en0)) then
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval
	end do
	else
	mask1 = .true.
	end if
	call subevt_collect (subevt, en1%pval, mask1)
	end subroutine collect_p

	@ %def collect_p
	@ Cluster the particles of the first argument. If [[en0]] is present,
	create a mask which is true only for those particles that pass the
	test.
	<<Eval trees: procedures>>=
	subroutine cluster_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	!!! Should not be initialized for every event
	type(jet_definition_t) :: jet_def
	logical :: keep_jets, exclusive
	call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut)
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	if (present (en0)) then
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval
	end do
	else
	mask1 = .true.
	end if
	if (associated (en1%var_list)) then
	keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering"))
	else
	keep_jets = .false.
	end if
	exclusive = .false.
	select case (en1%jet_algorithm)
	case (ee_kt_algorithm)
	exclusive = .true.
	case (ee_genkt_algorithm)
	if (en1%jet_r > Pi) exclusive = .true.
	end select
	call subevt_cluster (subevt, en1%pval, en1%jet_dcut, mask1, &
	jet_def, keep_jets, exclusive)
	call jet_def%final ()
	end subroutine cluster_p

	@ %def cluster_p
	@ Recombine photons with other particles (usually charged leptons and
	maybe quarks) given in the same subevent. If [[en0]] is present,
	create a mask which is true only for those particles that pass the test.
	<<Eval trees: procedures>>=
	subroutine photon_recombination_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	type(prt_t), dimension(:), allocatable :: prt
	integer :: n, i
	real(default) :: reco_r0
	logical :: keep_flv
	reco_r0 = en1%photon_rec_r0
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (prt (n))
	do i = 1, n
	- prt(i) = subevt_get_prt (en1%pval, i)
	+ prt(i) = en1%pval%get_prt (i)
	if (.not. prt_is_recombinable (prt (i))) then
	call msg_fatal ("Only charged leptons, quarks, and " //&
	"photons can be included in photon recombination.")
	end if
	end do
	if (count (prt_is_photon (prt)) > 1) &
	call msg_fatal ("Photon recombination is supported " // &
	"only for single photons.")
	allocate (mask1 (n))
	if (present (en0)) then
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval
	end do
	else
	mask1 = .true.
	end if
	if (associated (en1%var_list)) then
	keep_flv = en1%var_list%get_lval &
	(var_str("?keep_flavors_when_recombining"))
	else
	keep_flv = .false.
	end if
	call subevt_recombine &
	(subevt, en1%pval, mask1, reco_r0, keep_flv)
	end subroutine photon_recombination_p

	@ %def photon_recombination_p
	@ Select all particles of the first argument. If [[en0]] is present,
	create a mask which is true only for those particles that pass the
	test.
	<<Eval trees: procedures>>=
	subroutine select_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	if (present (en0)) then
	- do i = 1, subevt_get_length (en1%pval)
	+ do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval
	end do
	else
	mask1 = .true.
	end if
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_p

	@ %def select_p
	[[select_b_jet_p]], [[select_non_b_jet_p]], [[select_c_jet_p]], and
	[[select_light_jet_p]] are special selection function acting on a
	subevent of combined particles (jets) and result in a list of $b$
	jets, non-$b$ jets (i.e. $c$ and light jets), $c$ jets, and light
	jets, respectively.
	<<Eval trees: procedures>>=
	subroutine select_b_jet_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	- do i = 1, subevt_get_length (en1%pval)
	- mask1(i) = prt_is_b_jet (subevt_get_prt (en1%pval, i))
	+ do i = 1, n
	+ mask1(i) = prt_is_b_jet (en1%pval%get_prt (i))
	if (present (en0)) then
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval .and. mask1(i)
	end if
	end do
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_b_jet_p

	@ %def select_b_jet_p
	<<Eval trees: procedures>>=
	subroutine select_non_b_jet_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	- do i = 1, subevt_get_length (en1%pval)
	- mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i))
	+ do i = 1, n
	+ mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i))
	if (present (en0)) then
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval .and. mask1(i)
	end if
	end do
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_non_b_jet_p

	@ %def select_non_b_jet_p
	<<Eval trees: procedures>>=
	subroutine select_c_jet_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	- do i = 1, subevt_get_length (en1%pval)
	- mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
	- .and. prt_is_c_jet (subevt_get_prt (en1%pval, i))
	+ do i = 1, n
	+ mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i)) &
	+ .and. prt_is_c_jet (en1%pval%get_prt (i))
	if (present (en0)) then
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval .and. mask1(i)
	end if
	end do
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_c_jet_p

	@ %def select_c_jet_p
	<<Eval trees: procedures>>=
	subroutine select_light_jet_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: n, i
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	allocate (mask1 (n))
	- do i = 1, subevt_get_length (en1%pval)
	- mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
	- .and. .not. prt_is_c_jet (subevt_get_prt (en1%pval, i))
	+ do i = 1, n
	+ mask1(i) = .not. prt_is_b_jet (en1%pval%get_prt (i)) &
	+ .and. .not. prt_is_c_jet (en1%pval%get_prt (i))
	if (present (en0)) then
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	mask1(i) = en0%lval .and. mask1(i)
	end if
	end do
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_light_jet_p

	@ %def select_light_jet_p
	@ Extract the particle with index given by [[en0]] from the argument
	list. Negative indices count from the end. If [[en0]] is absent,
	extract the first particle. The result is a list with a single entry,
	or no entries if the original list was empty or if the index is out of
	range.

	This function has no counterpart with two arguments.
	<<Eval trees: procedures>>=
	subroutine extract_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	integer :: index
	if (present (en0)) then
	call eval_node_evaluate (en0)
	select case (en0%result_type)
	case (V_INT); index = en0%ival
	case default
	call eval_node_write (en0)
	call msg_fatal (" Index parameter of 'extract' must be integer.")
	end select
	else
	index = 1
	end if
	call subevt_extract (subevt, en1%pval, index)
	end subroutine extract_p

	@ %def extract_p
	@ Sort the subevent according to the result of evaluating
	[[en0]]. If [[en0]] is absent, sort by default method (PDG code,
	particles before antiparticles).
	<<Eval trees: procedures>>=
	subroutine sort_p (subevt, en1, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	integer, dimension(:), allocatable :: ival
	real(default), dimension(:), allocatable :: rval
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	if (present (en0)) then
	select case (en0%result_type)
	case (V_INT); allocate (ival (n))
	case (V_REAL); allocate (rval (n))
	end select
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	select case (en0%result_type)
	case (V_INT); ival(i) = en0%ival
	case (V_REAL); rval(i) = en0%rval
	end select
	end do
	select case (en0%result_type)
	case (V_INT); call subevt_sort (subevt, en1%pval, ival)
	case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
	end select
	else
	call subevt_sort (subevt, en1%pval)
	end if
	end subroutine sort_p

	@ %def sort_p
	@ The following functions return a logical value. [[all]] evaluates
	to true if the condition [[en0]] is true for all elements of the
	subevent. [[any]] and [[no]] are analogous.
	<<Eval trees: procedures>>=
	function all_p (en1, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout) :: en0
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	lval = .true.
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	lval = en0%lval
	if (.not. lval) exit
	end do
	end function all_p

	function any_p (en1, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout) :: en0
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	lval = .false.
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	lval = en0%lval
	if (lval) exit
	end do
	end function any_p

	function no_p (en1, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout) :: en0
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	lval = .true.
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	lval = .not. en0%lval
	if (lval) exit
	end do
	end function no_p

	@ %def all_p any_p no_p
	@ The following function returns an integer value, namely the number
	of particles for which the condition is true. If there is no
	condition, it returns simply the length of the subevent.
	<<Eval trees: procedures>>=
	subroutine count_a (ival, en1, en0)
	integer, intent(out) :: ival
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout), optional :: en0
	integer :: i, n, count
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	if (present (en0)) then
	count = 0
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	if (en0%lval) count = count + 1
	end do
	ival = count
	else
	ival = n
	end if
	end subroutine count_a

	@ %def count_a
	@ The following functions return either an integer or a real
	value, namely the sum or the product of the values of the
	corresponding expression.
	<<Eval trees: procedures>>=
	function sum_a (en1, en0) result (rval)
	real(default) :: rval
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout) :: en0
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	rval = 0._default
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	rval = rval + en0%rval
	end do
	end function sum_a

	function prod_a (en1, en0) result (rval)
	real(default) :: rval
	type(eval_node_t), intent(in) :: en1
	type(eval_node_t), intent(inout) :: en0
	integer :: i, n
	- n = subevt_get_length (en1%pval)
	+ n = en1%pval%get_length ()
	rval = 1._default
	do i = 1, n
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	call eval_node_evaluate (en0)
	rval = rval * en0%rval
	end do
	end function prod_a

	@ %def sum_a prod_a
	\subsubsection{Binary particle-list functions}
	This joins two subevents, stored in the evaluation nodes [[en1]]
	and [[en2]]. If [[en0]] is also present, it amounts to a logical test
	returning true or false for every pair of particles. A particle of
	the second list gets a mask entry only if it passes the test for all
	particles of the first list.
	<<Eval trees: procedures>>=
	subroutine join_pp (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask2
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	allocate (mask2 (n2))
	mask2 = .true.
	if (present (en0)) then
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	call eval_node_evaluate (en0)
	mask2(j) = mask2(j) .and. en0%lval
	end do
	end do
	end if
	call subevt_join (subevt, en1%pval, en2%pval, mask2)
	end subroutine join_pp

	@ %def join_pp
	@ Combine two subevents, i.e., make a list of composite particles
	built from all possible particle pairs from the two lists. If [[en0]]
	is present, create a mask which is true only for those pairs that pass
	the test.
	<<Eval trees: procedures>>=
	subroutine combine_pp (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:,:), allocatable :: mask12
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	if (present (en0)) then
	allocate (mask12 (n1, n2))
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	call eval_node_evaluate (en0)
	mask12(i,j) = en0%lval
	end do
	end do
	call subevt_combine (subevt, en1%pval, en2%pval, mask12)
	else
	call subevt_combine (subevt, en1%pval, en2%pval)
	end if
	end subroutine combine_pp

	@ %def combine_pp
	@ Combine all particles of the first argument. If [[en0]] is present,
	create a mask which is true only for those particles that pass the
	test w.r.t. all particles in the second argument. If [[en0]] is
	absent, the second argument is ignored.
	<<Eval trees: procedures>>=
	subroutine collect_pp (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	allocate (mask1 (n1))
	mask1 = .true.
	if (present (en0)) then
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	call eval_node_evaluate (en0)
	mask1(i) = mask1(i) .and. en0%lval
	end do
	end do
	end if
	call subevt_collect (subevt, en1%pval, mask1)
	end subroutine collect_pp

	@ %def collect_pp
	@ Select all particles of the first argument. If [[en0]] is present,
	create a mask which is true only for those particles that pass the
	test w.r.t. all particles in the second argument. If [[en0]] is
	absent, the second argument is ignored, and the first argument is
	transferred unchanged. (This case is not very useful, of course.)
	<<Eval trees: procedures>>=
	subroutine select_pp (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	logical, dimension(:), allocatable :: mask1
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	allocate (mask1 (n1))
	mask1 = .true.
	if (present (en0)) then
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	call eval_node_evaluate (en0)
	mask1(i) = mask1(i) .and. en0%lval
	end do
	end do
	end if
	call subevt_select (subevt, en1%pval, mask1)
	end subroutine select_pp

	@ %def select_pp
	@ Sort the first subevent according to the result of evaluating
	[[en0]]. From the second subevent, only the first element is
	taken as reference. If [[en0]] is absent, we sort by default method
	(PDG code, particles before antiparticles).
	<<Eval trees: procedures>>=
	subroutine sort_pp (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	integer, dimension(:), allocatable :: ival
	real(default), dimension(:), allocatable :: rval
	integer :: i, n1
	- n1 = subevt_get_length (en1%pval)
	+ n1 = en1%pval%get_length ()
	if (present (en0)) then
	select case (en0%result_type)
	case (V_INT); allocate (ival (n1))
	case (V_REAL); allocate (rval (n1))
	end select
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	- en0%prt2 = subevt_get_prt (en2%pval, 1)
	+ en0%prt1 = en1%pval%get_prt (i)
	+ en0%prt2 = en2%pval%get_prt (1)
	call eval_node_evaluate (en0)
	select case (en0%result_type)
	case (V_INT); ival(i) = en0%ival
	case (V_REAL); rval(i) = en0%rval
	end select
	end do
	select case (en0%result_type)
	case (V_INT); call subevt_sort (subevt, en1%pval, ival)
	case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
	end select
	else
	call subevt_sort (subevt, en1%pval)
	end if
	end subroutine sort_pp

	@ %def sort_pp
	@ The following functions return a logical value. [[all]] evaluates
	to true if the condition [[en0]] is true for all valid element pairs
	of both subevents. Invalid pairs (with common [[src]] entry) are
	ignored.

	[[any]] and [[no]] are analogous.
	<<Eval trees: procedures>>=
	function all_pp (en1, en2, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout) :: en0
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	lval = .true.
	LOOP1: do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	if (are_disjoint (en0%prt1, en0%prt2)) then
	call eval_node_evaluate (en0)
	lval = en0%lval
	if (.not. lval) exit LOOP1
	end if
	end do
	end do LOOP1
	end function all_pp

	function any_pp (en1, en2, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout) :: en0
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	lval = .false.
	LOOP1: do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	if (are_disjoint (en0%prt1, en0%prt2)) then
	call eval_node_evaluate (en0)
	lval = en0%lval
	if (lval) exit LOOP1
	end if
	end do
	end do LOOP1
	end function any_pp

	function no_pp (en1, en2, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout) :: en0
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	lval = .true.
	LOOP1: do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	if (are_disjoint (en0%prt1, en0%prt2)) then
	call eval_node_evaluate (en0)
	lval = .not. en0%lval
	if (lval) exit LOOP1
	end if
	end do
	end do LOOP1
	end function no_pp

	@ %def all_pp any_pp no_pp
	The conditional restriction encoded in the [[eval_node_t]] [[en_0]] is
	applied only to the photons from [[en1]], not to the objects being
	isolated from in [[en2]].
	<<Eval trees: procedures>>=
	function photon_isolation_pp (en1, en2, en0) result (lval)
	logical :: lval
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout) :: en0
	type(prt_t) :: prt
	type(prt_t), dimension(:), allocatable :: prt_gam0, prt_lep
	type(vector4_t), dimension(:), allocatable :: &
	p_gam0, p_lep0, p_lep, p_par
	integer :: i, j, n1, n2, n_par, n_lep, n_gam, n_delta
	real(default), dimension(:), allocatable :: delta_r, et_sum
	integer, dimension(:), allocatable :: index
	real(default) :: eps, iso_n, r0, pt_gam
	logical, dimension(:,:), allocatable :: photon_mask
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	allocate (p_gam0 (n1), prt_gam0 (n1))
	eps = en1%photon_iso_eps
	iso_n = en1%photon_iso_n
	r0 = en1%photon_iso_r0
	lval = .true.
	do i = 1, n1
	en0%index = i
	- prt = subevt_get_prt (en1%pval, i)
	+ prt = en1%pval%get_prt (i)
	prt_gam0(i) = prt
	if (.not. prt_is_photon (prt_gam0(i))) &
	call msg_fatal ("Photon isolation can only " // &
	"be applied to photons.")
	p_gam0(i) = prt_get_momentum (prt_gam0(i))
	en0%prt1 = prt
	call eval_node_evaluate (en0)
	lval = en0%lval
	if (.not. lval) return
	end do
	if (n1 == 0) then
	call msg_fatal ("Photon isolation applied on empty photon sample.")
	end if
	n_par = 0
	n_lep = 0
	n_gam = 0
	do i = 1, n2
	- prt = subevt_get_prt (en2%pval, i)
	+ prt = en2%pval%get_prt (i)
	if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
	n_par = n_par + 1
	end if
	if (prt_is_lepton (prt)) then
	n_lep = n_lep + 1
	end if
	if (prt_is_photon (prt)) then
	n_gam = n_gam + 1
	end if
	end do
	if (n_lep > 0 .and. n_gam == 0) then
	call msg_fatal ("Photon isolation from EM energy: photons " // &
	"have to be included.")
	end if
	if (n_lep > 0 .and. n_gam /= n1) then
	call msg_fatal ("Photon isolation: photon samples do not match.")
	end if
	allocate (p_par (n_par))
	allocate (p_lep0 (n_gam+n_lep), prt_lep(n_gam+n_lep))
	n_par = 0
	n_lep = 0
	do i = 1, n2
	- prt = subevt_get_prt (en2%pval, i)
	+ prt = en2%pval%get_prt (i)
	if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
	n_par = n_par + 1
	p_par(n_par) = prt_get_momentum (prt)
	end if
	if (prt_is_lepton (prt) .or. prt_is_photon(prt)) then
	n_lep = n_lep + 1
	prt_lep(n_lep) = prt
	p_lep0(n_lep) = prt_get_momentum (prt_lep(n_lep))
	end if
	end do
	if (n_par > 0) then
	allocate (delta_r (n_par), index (n_par))
	HADRON_ISOLATION: do i = 1, n1
	pt_gam = transverse_part (p_gam0(i))
	delta_r(1:n_par) = sort (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
	index(1:n_par) = order (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
	n_delta = count (delta_r < r0)
	allocate (et_sum(n_delta))
	do j = 1, n_delta
	et_sum(j) = sum (transverse_part (p_par (index (1:j))))
	if (.not. et_sum(j) <= &
	iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
	lval = .false.
	return
	end if
	end do
	deallocate (et_sum)
	end do HADRON_ISOLATION
	deallocate (delta_r)
	deallocate (index)
	end if
	if (n_lep > 0) then
	allocate (photon_mask(n1,n_lep))
	do i = 1, n1
	photon_mask(i,:) = .not. (prt_gam0(i) .match. prt_lep(:))
	end do
	allocate (delta_r (n_lep-1), index (n_lep-1), p_lep(n_lep-1))
	EM_ISOLATION: do i = 1, n1
	pt_gam = transverse_part (p_gam0(i))
	p_lep = pack (p_lep0, photon_mask(i,:))
	delta_r(1:n_lep-1) = sort (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
	index(1:n_lep-1) = order (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
	n_delta = count (delta_r < r0)
	allocate (et_sum(n_delta))
	do j = 1, n_delta
	et_sum(j) = sum (transverse_part (p_lep (index(1:j))))
	if (.not. et_sum(j) <= &
	iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
	lval = .false.
	return
	end if
	end do
	deallocate (et_sum)
	end do EM_ISOLATION
	deallocate (delta_r)
	deallocate (index)
	end if
	contains
	function iso_chi_gamma (dr, r0_gam, n_gam, eps_gam, pt_gam) result (iso)
	real(default) :: iso
	real(default), intent(in) :: dr, r0_gam, n_gam, eps_gam, pt_gam
	iso = eps_gam * pt_gam
	if (.not. nearly_equal (abs(n_gam), 0._default)) then
	iso = iso * ((1._default - cos(dr)) / &
	(1._default - cos(r0_gam)))**abs(n_gam)
	end if
	end function iso_chi_gamma
	end function photon_isolation_pp

	@ %def photon_isolation_pp
	@ This function evaluates an observable for a pair of particles. From the two
	particle lists, we take the first pair without [[src]] overlap. If there is
	no valid pair, we revert the status of the value to unknown.
	<<Eval trees: procedures>>=
	subroutine eval_pp (en1, en2, en0, rval, is_known)
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout) :: en0
	real(default), intent(out) :: rval
	logical, intent(out) :: is_known
	integer :: i, j, n1, n2
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	rval = 0
	is_known = .false.
	LOOP1: do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	if (are_disjoint (en0%prt1, en0%prt2)) then
	call eval_node_evaluate (en0)
	rval = en0%rval
	is_known = .true.
	exit LOOP1
	end if
	end do
	end do LOOP1
	end subroutine eval_pp

	@ %def eval_ppp
	@ The following function returns an integer value, namely the number
	of valid particle-pairs from both lists for which the condition is
	true. Invalid pairs (with common [[src]] entry) are ignored. If
	there is no condition, it returns the number of valid particle pairs.
	<<Eval trees: procedures>>=
	subroutine count_pp (ival, en1, en2, en0)
	integer, intent(out) :: ival
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	integer :: i, j, n1, n2, count
	- n1 = subevt_get_length (en1%pval)
	- n2 = subevt_get_length (en2%pval)
	+ n1 = en1%pval%get_length ()
	+ n2 = en2%pval%get_length ()
	if (present (en0)) then
	count = 0
	do i = 1, n1
	en0%index = i
	- en0%prt1 = subevt_get_prt (en1%pval, i)
	+ en0%prt1 = en1%pval%get_prt (i)
	do j = 1, n2
	- en0%prt2 = subevt_get_prt (en2%pval, j)
	+ en0%prt2 = en2%pval%get_prt (j)
	if (are_disjoint (en0%prt1, en0%prt2)) then
	call eval_node_evaluate (en0)
	if (en0%lval) count = count + 1
	end if
	end do
	end do
	else
	count = 0
	do i = 1, n1
	do j = 1, n2
	- if (are_disjoint (subevt_get_prt (en1%pval, i), &
	- subevt_get_prt (en2%pval, j))) then
	+ if (are_disjoint (en1%pval%get_prt (i), &
	+ en2%pval%get_prt (j))) then
	count = count + 1
	end if
	end do
	end do
	end if
	ival = count
	end subroutine count_pp

	@ %def count_pp
	@ This function makes up a subevent from the second argument
	which consists only of particles which match the PDG code array (first
	argument).
	<<Eval trees: procedures>>=
	subroutine select_pdg_ca (subevt, en1, en2, en0)
	type(subevt_t), intent(inout) :: subevt
	type(eval_node_t), intent(in) :: en1, en2
	type(eval_node_t), intent(inout), optional :: en0
	if (present (en0)) then
	call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival)
	else
	call subevt_select_pdg_code (subevt, en1%aval, en2%pval)
	end if
	end subroutine select_pdg_ca

	@ %def select_pdg_ca
	@
	\subsubsection{Binary string functions}
	Currently, the only string operation is concatenation.
	<<Eval trees: procedures>>=
	subroutine concat_ss (string, en1, en2)
	type(string_t), intent(out) :: string
	type(eval_node_t), intent(in) :: en1, en2
	string = en1%sval // en2%sval
	end subroutine concat_ss

	@ %def concat_ss
	@
	\subsection{Compiling the parse tree}
	The evaluation tree is built recursively by following a parse tree.
	Evaluate an expression. The requested type is given as an optional
	argument; default is numeric (integer or real).
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_genexpr &
	(en, pn, var_list, result_type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in), optional :: result_type
	if (debug_active (D_MODEL_F)) then
	print *, "read genexpr"; call parse_node_write (pn)
	end if
	if (present (result_type)) then
	select case (result_type)
	case (V_INT, V_REAL, V_CMPLX)
	call eval_node_compile_expr (en, pn, var_list)
	case (V_LOG)
	call eval_node_compile_lexpr (en, pn, var_list)
	case (V_SEV)
	call eval_node_compile_pexpr (en, pn, var_list)
	case (V_PDG)
	call eval_node_compile_cexpr (en, pn, var_list)
	case (V_STR)
	call eval_node_compile_sexpr (en, pn, var_list)
	end select
	else
	call eval_node_compile_expr (en, pn, var_list)
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done genexpr"
	end if
	end subroutine eval_node_compile_genexpr

	@ %def eval_node_compile_genexpr
	@
	\subsubsection{Numeric expressions}
	This procedure compiles a numerical expression. This is a single term
	or a sum or difference of terms. We have to account for all
	combinations of integer and real arguments. If both are constant, we
	immediately do the calculation and allocate a constant node.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_expr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(string_t) :: key
	integer :: t1, t2, t
	if (debug_active (D_MODEL_F)) then
	print *, "read expr"; call parse_node_write (pn)
	end if
	pn_term => parse_node_get_sub_ptr (pn)
	select case (char (parse_node_get_rule_key (pn_term)))
	case ("term")
	call eval_node_compile_term (en, pn_term, var_list)
	pn_addition => parse_node_get_next_ptr (pn_term, tag="addition")
	case ("addition")
	en => null ()
	pn_addition => pn_term
	case default
	call parse_node_mismatch ("term\|addition", pn)
	end select
	do while (associated (pn_addition))
	pn_op => parse_node_get_sub_ptr (pn_addition)
	pn_arg => parse_node_get_next_ptr (pn_op, tag="term")
	call eval_node_compile_term (en2, pn_arg, var_list)
	t2 = en2%result_type
	if (associated (en)) then
	en1 => en
	t1 = en1%result_type
	else
	allocate (en1)
	select case (t2)
	case (V_INT); call eval_node_init_int (en1, 0)
	case (V_REAL); call eval_node_init_real (en1, 0._default)
	case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx &
	(0._default, 0._default, kind=default))
	end select
	t1 = t2
	end if
	t = numeric_result_type (t1, t2)
	allocate (en)
	key = parse_node_get_key (pn_op)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	select case (char (key))
	case ("+")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, add_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, add_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2))
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_init_cmplx (en, add_ci (en1, en2))
	case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2))
	end select
	end select
	case ("-")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, sub_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, sub_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2))
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_init_cmplx (en, sub_ci (en1, en2))
	case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2))
	end select
	end select
	end select
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch (en, key, t, en1, en2)
	select case (char (key))
	case ("+")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, add_ii)
	case (V_REAL); call eval_node_set_op2_real (en, add_ir)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_ic)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, add_ri)
	case (V_REAL); call eval_node_set_op2_real (en, add_rr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_rc)
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_set_op2_cmplx (en, add_ci)
	case (V_REAL); call eval_node_set_op2_cmplx (en, add_cr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_cc)
	end select
	end select
	case ("-")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, sub_ii)
	case (V_REAL); call eval_node_set_op2_real (en, sub_ir)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_ic)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, sub_ri)
	case (V_REAL); call eval_node_set_op2_real (en, sub_rr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_rc)
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_set_op2_cmplx (en, sub_ci)
	case (V_REAL); call eval_node_set_op2_cmplx (en, sub_cr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_cc)
	end select
	end select
	end select
	end if
	pn_addition => parse_node_get_next_ptr (pn_addition)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done expr"
	end if
	end subroutine eval_node_compile_expr

	@ %def eval_node_compile_expr
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_term (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(string_t) :: key
	integer :: t1, t2, t
	if (debug_active (D_MODEL_F)) then
	print *, "read term"; call parse_node_write (pn)
	end if
	pn_factor => parse_node_get_sub_ptr (pn, tag="factor")
	call eval_node_compile_factor (en, pn_factor, var_list)
	pn_multiplication => &
	parse_node_get_next_ptr (pn_factor, tag="multiplication")
	do while (associated (pn_multiplication))
	pn_op => parse_node_get_sub_ptr (pn_multiplication)
	pn_arg => parse_node_get_next_ptr (pn_op, tag="factor")
	en1 => en
	call eval_node_compile_factor (en2, pn_arg, var_list)
	t1 = en1%result_type
	t2 = en2%result_type
	t = numeric_result_type (t1, t2)
	allocate (en)
	key = parse_node_get_key (pn_op)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	select case (char (key))
	case ("*")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, mul_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, mul_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2))
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_init_cmplx (en, mul_ci (en1, en2))
	case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2))
	end select
	end select
	case ("/")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, div_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2))
	case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, div_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2))
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_init_cmplx (en, div_ci (en1, en2))
	case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2))
	end select
	end select
	end select
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch (en, key, t, en1, en2)
	select case (char (key))
	case ("*")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, mul_ii)
	case (V_REAL); call eval_node_set_op2_real (en, mul_ir)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_ic)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, mul_ri)
	case (V_REAL); call eval_node_set_op2_real (en, mul_rr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_rc)
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_set_op2_cmplx (en, mul_ci)
	case (V_REAL); call eval_node_set_op2_cmplx (en, mul_cr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_cc)
	end select
	end select
	case ("/")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, div_ii)
	case (V_REAL); call eval_node_set_op2_real (en, div_ir)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_ic)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, div_ri)
	case (V_REAL); call eval_node_set_op2_real (en, div_rr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_rc)
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_set_op2_cmplx (en, div_ci)
	case (V_REAL); call eval_node_set_op2_cmplx (en, div_cr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_cc)
	end select
	end select
	end select
	end if
	pn_multiplication => parse_node_get_next_ptr (pn_multiplication)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done term"
	end if
	end subroutine eval_node_compile_term

	@ %def eval_node_compile_term
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_factor (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(string_t) :: key
	integer :: t1, t2, t
	if (debug_active (D_MODEL_F)) then
	print *, "read factor"; call parse_node_write (pn)
	end if
	pn_value => parse_node_get_sub_ptr (pn)
	call eval_node_compile_signed_value (en, pn_value, var_list)
	pn_exponentiation => &
	parse_node_get_next_ptr (pn_value, tag="exponentiation")
	if (associated (pn_exponentiation)) then
	pn_op => parse_node_get_sub_ptr (pn_exponentiation)
	pn_arg => parse_node_get_next_ptr (pn_op)
	en1 => en
	call eval_node_compile_signed_value (en2, pn_arg, var_list)
	t1 = en1%result_type
	t2 = en2%result_type
	t = numeric_result_type (t1, t2)
	allocate (en)
	key = parse_node_get_key (pn_op)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, pow_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, pow_ir (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, pow_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, pow_rr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2))
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_init_cmplx (en, pow_ci (en1, en2))
	case (V_REAL); call eval_node_init_cmplx (en, pow_cr (en1, en2))
	case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2))
	end select
	end select
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch (en, key, t, en1, en2)
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, pow_ii)
	case (V_REAL,V_CMPLX); call eval_type_error (pn, "exponentiation", t1)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, pow_ri)
	case (V_REAL); call eval_node_set_op2_real (en, pow_rr)
	case (V_CMPLX); call eval_type_error (pn, "exponentiation", t1)
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT); call eval_node_set_op2_cmplx (en, pow_ci)
	case (V_REAL); call eval_node_set_op2_cmplx (en, pow_cr)
	case (V_CMPLX); call eval_node_set_op2_cmplx (en, pow_cc)
	end select
	end select
	end if
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done factor"
	end if
	end subroutine eval_node_compile_factor

	@ %def eval_node_compile_factor
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_signed_value (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_arg
	type(eval_node_t), pointer :: en1
	integer :: t
	if (debug_active (D_MODEL_F)) then
	print *, "read signed value"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("signed_value")
	pn_arg => parse_node_get_sub_ptr (pn, 2)
	call eval_node_compile_value (en1, pn_arg, var_list)
	t = en1%result_type
	allocate (en)
	if (en1%type == EN_CONSTANT) then
	select case (t)
	case (V_INT); call eval_node_init_int (en, neg_i (en1))
	case (V_REAL); call eval_node_init_real (en, neg_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1))
	end select
	call eval_node_final_rec (en1)
	deallocate (en1)
	else
	call eval_node_init_branch (en, var_str ("-"), t, en1)
	select case (t)
	case (V_INT); call eval_node_set_op1_int (en, neg_i)
	case (V_REAL); call eval_node_set_op1_real (en, neg_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c)
	end select
	end if
	case default
	call eval_node_compile_value (en, pn, var_list)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done signed value"
	end if
	end subroutine eval_node_compile_signed_value

	@ %def eval_node_compile_signed_value
	@ Integer, real and complex values have an optional unit. The unit is
	extracted and applied immediately. An integer with unit evaluates to
	a real constant.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_value (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	if (debug_active (D_MODEL_F)) then
	print *, "read value"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("integer_value", "real_value", "complex_value")
	call eval_node_compile_numeric_value (en, pn)
	case ("pi")
	call eval_node_compile_constant (en, pn)
	case ("I")
	call eval_node_compile_constant (en, pn)
	case ("variable")
	call eval_node_compile_variable (en, pn, var_list)
	case ("result")
	call eval_node_compile_result (en, pn, var_list)
	case ("expr")
	call eval_node_compile_expr (en, pn, var_list)
	case ("block_expr")
	call eval_node_compile_block_expr (en, pn, var_list)
	case ("conditional_expr")
	call eval_node_compile_conditional (en, pn, var_list)
	case ("unary_function")
	call eval_node_compile_unary_function (en, pn, var_list)
	case ("binary_function")
	call eval_node_compile_binary_function (en, pn, var_list)
	case ("eval_fun")
	call eval_node_compile_eval_function (en, pn, var_list)
	case ("count_fun")
	call eval_node_compile_count_function (en, pn, var_list)
	case ("sum_fun", "prod_fun")
	call eval_node_compile_numeric_function (en, pn, var_list)
	case default
	call parse_node_mismatch &
	("integer\|real\|complex\|constant\|variable\|" // &
	"expr\|block_expr\|conditional_expr\|" // &
	"unary_function\|binary_function\|numeric_pexpr", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done value"
	end if
	end subroutine eval_node_compile_value

	@ %def eval_node_compile_value
	@ Real, complex and integer values are numeric literals with an
	optional unit attached. In case of an integer, the unit actually
	makes it a real value in disguise. The signed version of real values
	is not possible in generic expressions; it is a special case for
	numeric constants in model files (see below). We do not introduce
	signed versions of complex values.
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_numeric_value (en, pn)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(parse_node_t), pointer :: pn_val, pn_unit
	allocate (en)
	pn_val => parse_node_get_sub_ptr (pn)
	pn_unit => parse_node_get_next_ptr (pn_val)
	select case (char (parse_node_get_rule_key (pn)))
	case ("integer_value")
	if (associated (pn_unit)) then
	call eval_node_init_real (en, &
	parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit))
	else
	call eval_node_init_int (en, parse_node_get_integer (pn_val))
	end if
	case ("real_value")
	if (associated (pn_unit)) then
	call eval_node_init_real (en, &
	parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
	else
	call eval_node_init_real (en, parse_node_get_real (pn_val))
	end if
	case ("complex_value")
	if (associated (pn_unit)) then
	call eval_node_init_cmplx (en, &
	parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit))
	else
	call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val))
	end if
	case ("neg_real_value")
	pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
	pn_unit => parse_node_get_next_ptr (pn_val)
	if (associated (pn_unit)) then
	call eval_node_init_real (en, &
	- parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
	else
	call eval_node_init_real (en, - parse_node_get_real (pn_val))
	end if
	case ("pos_real_value")
	pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
	pn_unit => parse_node_get_next_ptr (pn_val)
	if (associated (pn_unit)) then
	call eval_node_init_real (en, &
	parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
	else
	call eval_node_init_real (en, parse_node_get_real (pn_val))
	end if
	case default
	call parse_node_mismatch &
	("integer_value\|real_value\|complex_value\|neg_real_value\|pos_real_value", pn)
	end select
	end subroutine eval_node_compile_numeric_value

	@ %def eval_node_compile_numeric_value
	@ These are the units, predefined and hardcoded. The default energy
	unit is GeV, the default angular unit is radians. We include units
	for observables of dimension energy squared. Luminosities are
	normalized in inverse femtobarns.
	<<Eval trees: procedures>>=
	function parse_node_get_unit (pn) result (factor)
	real(default) :: factor
	real(default) :: unit
	type(parse_node_t), intent(in) :: pn
	type(parse_node_t), pointer :: pn_unit, pn_unit_power
	type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den
	integer :: num, den
	pn_unit => parse_node_get_sub_ptr (pn)
	select case (char (parse_node_get_key (pn_unit)))
	case ("TeV"); unit = 1.e3_default
	case ("GeV"); unit = 1
	case ("MeV"); unit = 1.e-3_default
	case ("keV"); unit = 1.e-6_default
	case ("eV"); unit = 1.e-9_default
	case ("meV"); unit = 1.e-12_default
	case ("nbarn"); unit = 1.e6_default
	case ("pbarn"); unit = 1.e3_default
	case ("fbarn"); unit = 1
	case ("abarn"); unit = 1.e-3_default
	case ("rad"); unit = 1
	case ("mrad"); unit = 1.e-3_default
	case ("degree"); unit = degree
	case ("%"); unit = 1.e-2_default
	case default
	call msg_bug (" Unit '" // &
	char (parse_node_get_key (pn)) // "' is undefined.")
	end select
	pn_unit_power => parse_node_get_next_ptr (pn_unit)
	if (associated (pn_unit_power)) then
	pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2)
	pn_num => parse_node_get_sub_ptr (pn_frac)
	select case (char (parse_node_get_rule_key (pn_num)))
	case ("neg_int")
	pn_int => parse_node_get_sub_ptr (pn_num, 2)
	num = - parse_node_get_integer (pn_int)
	case ("pos_int")
	pn_int => parse_node_get_sub_ptr (pn_num, 2)
	num = parse_node_get_integer (pn_int)
	case ("integer_literal")
	num = parse_node_get_integer (pn_num)
	case default
	call parse_node_mismatch ("neg_int\|pos_int\|integer_literal", pn_num)
	end select
	pn_div => parse_node_get_next_ptr (pn_num)
	if (associated (pn_div)) then
	pn_den => parse_node_get_sub_ptr (pn_div, 2)
	den = parse_node_get_integer (pn_den)
	else
	den = 1
	end if
	else
	num = 1
	den = 1
	end if
	factor = unit ** (real (num, default) / den)
	end function parse_node_get_unit

	@ %def parse_node_get_unit
	@ There are only two predefined constants, but more can be added easily.
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_constant (en, pn)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	if (debug_active (D_MODEL_F)) then
	print *, "read constant"; call parse_node_write (pn)
	end if
	allocate (en)
	select case (char (parse_node_get_key (pn)))
	case ("pi"); call eval_node_init_real (en, pi)
	case ("I"); call eval_node_init_cmplx (en, imago)
	case default
	call parse_node_mismatch ("pi or I", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done constant"
	end if
	end subroutine eval_node_compile_constant

	@ %def eval_node_compile_constant
	@ Compile a variable, with or without a specified type.
	Take the list of variables, look for the name and make a node with a
	pointer to the value. If no type is provided, the variable is
	numeric, and the stored value determines whether it is real or integer.

	We explicitly demand that the variable is defined, so we do not accidentally
	point to variables that are declared only later in the script but have come
	into existence in a previous compilation pass.

	Variables may actually be anonymous, these are expressions in disguise. In
	that case, the expression replaces the variable name in the parse tree, and we
	allocate an ordinary expression node in the eval tree.

	Variables of type [[V_PDG]] (pdg-code array) are not treated here.
	They are handled by [[eval_node_compile_cvariable]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in), optional :: var_type
	type(parse_node_t), pointer :: pn_name
	type(string_t) :: var_name
	logical, target, save :: no_lval
	real(default), target, save :: no_rval
	type(subevt_t), target, save :: no_pval
	type(string_t), target, save :: no_sval
	logical, target, save :: unknown = .false.
	integer :: type
	logical :: defined
	logical, pointer :: known
	logical, pointer :: lptr
	integer, pointer :: iptr
	real(default), pointer :: rptr
	complex(default), pointer :: cptr
	type(subevt_t), pointer :: pptr
	type(string_t), pointer :: sptr
	procedure(obs_unary_int), pointer :: obs1_iptr
	procedure(obs_unary_real), pointer :: obs1_rptr
	procedure(obs_binary_int), pointer :: obs2_iptr
	procedure(obs_binary_real), pointer :: obs2_rptr
	procedure(obs_sev_int), pointer :: obsev_iptr
	procedure(obs_sev_real), pointer :: obsev_rptr
	type(prt_t), pointer :: p1, p2
	if (debug_active (D_MODEL_F)) then
	print *, "read variable"; call parse_node_write (pn)
	end if
	if (present (var_type)) then
	select case (var_type)
	case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
	V_OBS2_INT, V_CMPLX)
	pn_name => pn
	case default
	pn_name => parse_node_get_sub_ptr (pn, 2)
	end select
	else
	pn_name => pn
	end if
	select case (char (parse_node_get_rule_key (pn_name)))
	case ("expr")
	call eval_node_compile_expr (en, pn_name, var_list)
	case ("lexpr")
	call eval_node_compile_lexpr (en, pn_name, var_list)
	case ("sexpr")
	call eval_node_compile_sexpr (en, pn_name, var_list)
	case ("pexpr")
	call eval_node_compile_pexpr (en, pn_name, var_list)
	case ("variable")
	var_name = parse_node_get_string (pn_name)
	if (present (var_type)) then
	select case (var_type)
	case (V_LOG); var_name = "?" // var_name
	case (V_SEV); var_name = "@" // var_name
	case (V_STR); var_name = "$" // var_name ! $ sign
	end select
	end if
	call var_list%get_var_properties &
	(var_name, req_type=var_type, type=type, is_defined=defined)
	allocate (en)
	if (defined) then
	select case (type)
	case (V_LOG)
	call var_list%get_lptr (var_name, lptr, known)
	call eval_node_init_log_ptr (en, var_name, lptr, known)
	case (V_INT)
	call var_list%get_iptr (var_name, iptr, known)
	call eval_node_init_int_ptr (en, var_name, iptr, known)
	case (V_REAL)
	call var_list%get_rptr (var_name, rptr, known)
	call eval_node_init_real_ptr (en, var_name, rptr, known)
	case (V_CMPLX)
	call var_list%get_cptr (var_name, cptr, known)
	call eval_node_init_cmplx_ptr (en, var_name, cptr, known)
	case (V_SEV)
	call var_list%get_pptr (var_name, pptr, known)
	call eval_node_init_subevt_ptr (en, var_name, pptr, known)
	case (V_STR)
	call var_list%get_sptr (var_name, sptr, known)
	call eval_node_init_string_ptr (en, var_name, sptr, known)
	case (V_OBS1_INT)
	call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
	call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1)
	case (V_OBS2_INT)
	call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2)
	call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2)
	case (V_OBSEV_INT)
	call var_list%get_obsev_iptr (var_name, obsev_iptr, pptr)
	call eval_node_init_obsev_int_ptr (en, var_name, obsev_iptr, pptr)
	case (V_OBS1_REAL)
	call var_list%get_obs1_rptr (var_name, obs1_rptr, p1)
	call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1)
	case (V_OBS2_REAL)
	call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2)
	call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2)
	case (V_OBSEV_REAL)
	call var_list%get_obsev_rptr (var_name, obsev_rptr, pptr)
	call eval_node_init_obsev_real_ptr (en, var_name, obsev_rptr, pptr)
	case default
	call parse_node_write (pn)
	call msg_fatal ("Variable of this type " // &
	"is not allowed in the present context")
	if (present (var_type)) then
	select case (var_type)
	case (V_LOG)
	call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
	case (V_SEV)
	call eval_node_init_subevt_ptr &
	(en, var_name, no_pval, unknown)
	case (V_STR)
	call eval_node_init_string_ptr &
	(en, var_name, no_sval, unknown)
	end select
	else
	call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
	end if
	end select
	else
	call parse_node_write (pn)
	call msg_error ("This variable is undefined at this point")
	if (present (var_type)) then
	select case (var_type)
	case (V_LOG)
	call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
	case (V_SEV)
	call eval_node_init_subevt_ptr &
	(en, var_name, no_pval, unknown)
	case (V_STR)
	call eval_node_init_string_ptr (en, var_name, no_sval, unknown)
	end select
	else
	call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
	end if
	end if
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done variable"
	end if
	end subroutine eval_node_compile_variable

	@ %def eval_node_compile_variable
	@ In a given context, a variable has to have a certain type.
	<<Eval trees: procedures>>=
	subroutine check_var_type (pn, ok, type_actual, type_requested)
	type(parse_node_t), intent(in) :: pn
	logical, intent(out) :: ok
	integer, intent(in) :: type_actual
	integer, intent(in), optional :: type_requested
	if (present (type_requested)) then
	select case (type_requested)
	case (V_LOG)
	select case (type_actual)
	case (V_LOG)
	case default
	call parse_node_write (pn)
	call msg_fatal ("Variable type is invalid (should be logical)")
	ok = .false.
	end select
	case (V_SEV)
	select case (type_actual)
	case (V_SEV)
	case default
	call parse_node_write (pn)
	call msg_fatal &
	("Variable type is invalid (should be particle set)")
	ok = .false.
	end select
	case (V_PDG)
	select case (type_actual)
	case (V_PDG)
	case default
	call parse_node_write (pn)
	call msg_fatal &
	("Variable type is invalid (should be PDG array)")
	ok = .false.
	end select
	case (V_STR)
	select case (type_actual)
	case (V_STR)
	case default
	call parse_node_write (pn)
	call msg_fatal &
	("Variable type is invalid (should be string)")
	ok = .false.
	end select
	case default
	call parse_node_write (pn)
	call msg_bug ("Variable type is unknown")
	end select
	else
	select case (type_actual)
	case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
	V_OBS2_INT, V_CMPLX)
	case default
	call parse_node_write (pn)
	call msg_fatal ("Variable type is invalid (should be numeric)")
	ok = .false.
	end select
	end if
	ok = .true.
	end subroutine check_var_type

	@ %def check_var_type
	@ Retrieve the result of an integration. If the requested process has
	been integrated, the results are available as special variables. (The
	variables cannot be accessed in the usual way since they contain
	brackets in their names.)

	Since this compilation step may occur before the processes have been
	loaded, we have to initialize the required variables before they are
	used.
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_result (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_key, pn_prc_id
	type(string_t) :: key, prc_id, var_name
	integer, pointer :: iptr
	real(default), pointer :: rptr
	logical, pointer :: known
	if (debug_active (D_MODEL_F)) then
	print *, "read result"; call parse_node_write (pn)
	end if
	pn_key => parse_node_get_sub_ptr (pn)
	pn_prc_id => parse_node_get_next_ptr (pn_key)
	key = parse_node_get_key (pn_key)
	prc_id = parse_node_get_string (pn_prc_id)
	var_name = key // "(" // prc_id // ")"
	if (var_list%contains (var_name)) then
	allocate (en)
	select case (char(key))
	case ("num_id", "n_calls")
	call var_list%get_iptr (var_name, iptr, known)
	call eval_node_init_int_ptr (en, var_name, iptr, known)
	case ("integral", "error")
	call var_list%get_rptr (var_name, rptr, known)
	call eval_node_init_real_ptr (en, var_name, rptr, known)
	end select
	else
	call msg_fatal ("Result variable '" // char (var_name) &
	// "' is undefined (call 'integrate' before use)")
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done result"
	end if
	end subroutine eval_node_compile_result

	@ %def eval_node_compile_result
	@ Functions with a single argument. For non-constant arguments, watch
	for functions which convert their argument to a different type.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_unary_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_fname, pn_arg
	type(eval_node_t), pointer :: en1
	type(string_t) :: key
	integer :: t
	if (debug_active (D_MODEL_F)) then
	print *, "read unary function"; call parse_node_write (pn)
	end if
	pn_fname => parse_node_get_sub_ptr (pn)
	pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1")
	call eval_node_compile_expr &
	(en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
	t = en1%result_type
	allocate (en)
	key = parse_node_get_key (pn_fname)
	if (en1%type == EN_CONSTANT) then
	select case (char (key))
	case ("complex")
	select case (t)
	case (V_INT); call eval_node_init_cmplx (en, cmplx_i (en1))
	case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1))
	case (V_CMPLX); deallocate (en); en => en1; en1 => null ()
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("real")
	select case (t)
	case (V_INT); call eval_node_init_real (en, real_i (en1))
	case (V_REAL); deallocate (en); en => en1; en1 => null ()
	case (V_CMPLX); call eval_node_init_real (en, real_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("int")
	select case (t)
	case (V_INT); deallocate (en); en => en1; en1 => null ()
	case (V_REAL); call eval_node_init_int (en, int_r (en1))
	case (V_CMPLX); call eval_node_init_int (en, int_c (en1))
	end select
	case ("nint")
	select case (t)
	case (V_INT); deallocate (en); en => en1; en1 => null ()
	case (V_REAL); call eval_node_init_int (en, nint_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("floor")
	select case (t)
	case (V_INT); deallocate (en); en => en1; en1 => null ()
	case (V_REAL); call eval_node_init_int (en, floor_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("ceiling")
	select case (t)
	case (V_INT); deallocate (en); en => en1; en1 => null ()
	case (V_REAL); call eval_node_init_int (en, ceiling_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("abs")
	select case (t)
	case (V_INT); call eval_node_init_int (en, abs_i (en1))
	case (V_REAL); call eval_node_init_real (en, abs_r (en1))
	case (V_CMPLX); call eval_node_init_real (en, abs_c (en1))
	end select
	case ("conjg")
	select case (t)
	case (V_INT); call eval_node_init_int (en, conjg_i (en1))
	case (V_REAL); call eval_node_init_real (en, conjg_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1))
	end select
	case ("sgn")
	select case (t)
	case (V_INT); call eval_node_init_int (en, sgn_i (en1))
	case (V_REAL); call eval_node_init_real (en, sgn_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sqrt")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, sqrt_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("exp")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, exp_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("log")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, log_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("log10")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, log10_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sin")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, sin_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("cos")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, cos_r (en1))
	case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("tan")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, tan_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("asin")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, asin_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("acos")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, acos_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("atan")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, atan_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sinh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, sinh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("cosh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, cosh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("tanh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, tanh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("asinh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, asinh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("acosh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, acosh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("atanh")
	select case (t)
	case (V_REAL); call eval_node_init_real (en, atanh_r (en1))
	case default; call eval_type_error (pn, char (key), t)
	end select
	case default
	call parse_node_mismatch ("function name", pn_fname)
	end select
	if (associated (en1)) then
	call eval_node_final_rec (en1)
	deallocate (en1)
	end if
	else
	select case (char (key))
	case ("complex")
	call eval_node_init_branch (en, key, V_CMPLX, en1)
	case ("real")
	call eval_node_init_branch (en, key, V_REAL, en1)
	case ("int", "nint", "floor", "ceiling")
	call eval_node_init_branch (en, key, V_INT, en1)
	case default
	call eval_node_init_branch (en, key, t, en1)
	end select
	select case (char (key))
	case ("complex")
	select case (t)
	case (V_INT); call eval_node_set_op1_cmplx (en, cmplx_i)
	case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r)
	case (V_CMPLX); deallocate (en); en => en1
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("real")
	select case (t)
	case (V_INT); call eval_node_set_op1_real (en, real_i)
	case (V_REAL); deallocate (en); en => en1
	case (V_CMPLX); call eval_node_set_op1_real (en, real_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("int")
	select case (t)
	case (V_INT); deallocate (en); en => en1
	case (V_REAL); call eval_node_set_op1_int (en, int_r)
	case (V_CMPLX); call eval_node_set_op1_int (en, int_c)
	end select
	case ("nint")
	select case (t)
	case (V_INT); deallocate (en); en => en1
	case (V_REAL); call eval_node_set_op1_int (en, nint_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("floor")
	select case (t)
	case (V_INT); deallocate (en); en => en1
	case (V_REAL); call eval_node_set_op1_int (en, floor_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("ceiling")
	select case (t)
	case (V_INT); deallocate (en); en => en1
	case (V_REAL); call eval_node_set_op1_int (en, ceiling_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("abs")
	select case (t)
	case (V_INT); call eval_node_set_op1_int (en, abs_i)
	case (V_REAL); call eval_node_set_op1_real (en, abs_r)
	case (V_CMPLX);
	call eval_node_init_branch (en, key, V_REAL, en1)
	call eval_node_set_op1_real (en, abs_c)
	end select
	case ("conjg")
	select case (t)
	case (V_INT); call eval_node_set_op1_int (en, conjg_i)
	case (V_REAL); call eval_node_set_op1_real (en, conjg_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, conjg_c)
	end select
	case ("sgn")
	select case (t)
	case (V_INT); call eval_node_set_op1_int (en, sgn_i)
	case (V_REAL); call eval_node_set_op1_real (en, sgn_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sqrt")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, sqrt_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("exp")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, exp_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("log")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, log_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("log10")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, log10_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sin")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, sin_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("cos")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, cos_r)
	case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("tan")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, tan_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("asin")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, asin_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("acos")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, acos_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("atan")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, atan_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("sinh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, sinh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("cosh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, cosh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("tanh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, tanh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("asinh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, asinh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("acosh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, acosh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case ("atanh")
	select case (t)
	case (V_REAL); call eval_node_set_op1_real (en, atanh_r)
	case default; call eval_type_error (pn, char (key), t)
	end select
	case default
	call parse_node_mismatch ("function name", pn_fname)
	end select
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done function"
	end if
	end subroutine eval_node_compile_unary_function

	@ %def eval_node_compile_unary_function
	@ Functions with two arguments.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_binary_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en1, en2
	type(string_t) :: key
	integer :: t1, t2
	if (debug_active (D_MODEL_F)) then
	print *, "read binary function"; call parse_node_write (pn)
	end if
	pn_fname => parse_node_get_sub_ptr (pn)
	pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2")
	pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr")
	pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr")
	call eval_node_compile_expr (en1, pn_arg1, var_list)
	call eval_node_compile_expr (en2, pn_arg2, var_list)
	t1 = en1%result_type
	t2 = en2%result_type
	allocate (en)
	key = parse_node_get_key (pn_fname)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	select case (char (key))
	case ("max")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, max_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, max_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t1)
	end select
	case ("min")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, min_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, min_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t1)
	end select
	case ("mod")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, mod_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, mod_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t1)
	end select
	case ("modulo")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_int (en, modulo_ii (en1, en2))
	case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_real (en, modulo_ri (en1, en2))
	case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2))
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default
	call parse_node_mismatch ("function name", pn_fname)
	end select
	call eval_node_final_rec (en1)
	deallocate (en1)
	else
	call eval_node_init_branch (en, key, t1, en1, en2)
	select case (char (key))
	case ("max")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, max_ii)
	case (V_REAL); call eval_node_set_op2_real (en, max_ir)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, max_ri)
	case (V_REAL); call eval_node_set_op2_real (en, max_rr)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case ("min")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, min_ii)
	case (V_REAL); call eval_node_set_op2_real (en, min_ir)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, min_ri)
	case (V_REAL); call eval_node_set_op2_real (en, min_rr)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case ("mod")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, mod_ii)
	case (V_REAL); call eval_node_set_op2_real (en, mod_ir)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, mod_ri)
	case (V_REAL); call eval_node_set_op2_real (en, mod_rr)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case ("modulo")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_int (en, modulo_ii)
	case (V_REAL); call eval_node_set_op2_real (en, modulo_ir)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_real (en, modulo_ri)
	case (V_REAL); call eval_node_set_op2_real (en, modulo_rr)
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default; call eval_type_error (pn, char (key), t2)
	end select
	case default
	call parse_node_mismatch ("function name", pn_fname)
	end select
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done function"
	end if
	end subroutine eval_node_compile_binary_function

	@ %def eval_node_compile_binary_function
	@
	\subsubsection{Variable definition}
	A block expression contains a variable definition (first argument) and
	an expression where the definition can be used (second argument). The
	[[result_type]] decides which type of expression is expected for the
	second argument. For numeric variables, if there is a mismatch
	between real and integer type, insert an extra node for type
	conversion.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_block_expr &
	(en, pn, var_list, result_type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in), optional :: result_type
	type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec
	type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr
	type(parse_node_t), pointer :: pn_expr
	type(string_t) :: var_name
	type(eval_node_t), pointer :: en1, en2
	integer :: var_type
	logical :: new
	if (debug_active (D_MODEL_F)) then
	print *, "read block expr"; call parse_node_write (pn)
	end if
	new = .false.
	pn_var_spec => parse_node_get_sub_ptr (pn, 2)
	select case (char (parse_node_get_rule_key (pn_var_spec)))
	case ("var_num"); var_type = V_NONE
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec)
	case ("var_int"); var_type = V_INT
	new = .true.
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_real"); var_type = V_REAL
	new = .true.
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_cmplx"); var_type = V_CMPLX
	new = .true.
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_logical_new"); var_type = V_LOG
	new = .true.
	pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
	pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
	case ("var_logical_spec"); var_type = V_LOG
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_plist_new"); var_type = V_SEV
	new = .true.
	pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
	pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
	case ("var_plist_spec"); var_type = V_SEV
	new = .true.
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_alias"); var_type = V_PDG
	new = .true.
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case ("var_string_new"); var_type = V_STR
	new = .true.
	pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
	pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
	case ("var_string_spec"); var_type = V_STR
	pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
	case default
	call parse_node_mismatch &
	("logical\|int\|real\|plist\|alias", pn_var_type)
	end select
	pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2)
	pn_expr => parse_node_get_next_ptr (pn_var_spec, 2)
	var_name = parse_node_get_string (pn_var_name)
	select case (var_type)
	case (V_LOG); var_name = "?" // var_name
	case (V_SEV); var_name = "@" // var_name
	case (V_STR); var_name = "$" // var_name ! $ sign
	end select
	call var_list_check_user_var (var_list, var_name, var_type, new)
	call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type)
	call insert_conversion_node (en1, var_type)
	allocate (en)
	call eval_node_init_block (en, var_name, var_type, en1, var_list)
	call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type)
	call eval_node_set_expr (en, en2)
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done block expr"
	end if
	end subroutine eval_node_compile_block_expr

	@ %def eval_node_compile_block_expr
	@ Insert a conversion node for integer/real/complex transformation if necessary.
	What shall we do for the complex to integer/real conversion?
	<<Eval trees: procedures>>=
	subroutine insert_conversion_node (en, result_type)
	type(eval_node_t), pointer :: en
	integer, intent(in) :: result_type
	type(eval_node_t), pointer :: en_conv
	select case (en%result_type)
	case (V_INT)
	select case (result_type)
	case (V_REAL)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
	call eval_node_set_op1_real (en_conv, real_i)
	en => en_conv
	case (V_CMPLX)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
	call eval_node_set_op1_cmplx (en_conv, cmplx_i)
	en => en_conv
	end select
	case (V_REAL)
	select case (result_type)
	case (V_INT)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
	call eval_node_set_op1_int (en_conv, int_r)
	en => en_conv
	case (V_CMPLX)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
	call eval_node_set_op1_cmplx (en_conv, cmplx_r)
	en => en_conv
	end select
	case (V_CMPLX)
	select case (result_type)
	case (V_INT)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
	call eval_node_set_op1_int (en_conv, int_c)
	en => en_conv
	case (V_REAL)
	allocate (en_conv)
	call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
	call eval_node_set_op1_real (en_conv, real_c)
	en => en_conv
	end select
	case default
	end select
	end subroutine insert_conversion_node

	@ %def insert_conversion_node
	@
	\subsubsection{Conditionals}
	A conditional has the structure if lexpr then expr else expr. So we
	first evaluate the logical expression, then depending on the result
	the first or second expression. Note that the second expression is
	mandatory.

	The [[result_type]], if present, defines the requested type of the
	[[then]] and [[else]] clauses. Default is numeric (int/real). If
	there is a mismatch between real and integer result types, insert
	conversion nodes.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_conditional &
	(en, pn, var_list, result_type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in), optional :: result_type
	type(parse_node_t), pointer :: pn_condition, pn_expr
	type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch
	type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr
	type(eval_node_t), pointer :: en0, en1, en2
	integer :: restype
	if (debug_active (D_MODEL_F)) then
	print *, "read conditional"; call parse_node_write (pn)
	end if
	pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
	pn_expr => parse_node_get_next_ptr (pn_condition, 2)
	call eval_node_compile_lexpr (en0, pn_condition, var_list)
	call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
	if (present (result_type)) then
	restype = major_result_type (result_type, en1%result_type)
	else
	restype = en1%result_type
	end if
	pn_maybe_elsif => parse_node_get_next_ptr (pn_expr)
	select case (char (parse_node_get_rule_key (pn_maybe_elsif)))
	case ("maybe_elsif_expr", &
	"maybe_elsif_lexpr", &
	"maybe_elsif_pexpr", &
	"maybe_elsif_cexpr", &
	"maybe_elsif_sexpr")
	pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif)
	pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif)
	select case (char (parse_node_get_rule_key (pn_maybe_else)))
	case ("maybe_else_expr", &
	"maybe_else_lexpr", &
	"maybe_else_pexpr", &
	"maybe_else_cexpr", &
	"maybe_else_sexpr")
	pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
	pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
	case default
	pn_else_expr => null ()
	end select
	call eval_node_compile_elsif &
	(en2, pn_elsif_branch, pn_else_expr, var_list, restype)
	case ("maybe_else_expr", &
	"maybe_else_lexpr", &
	"maybe_else_pexpr", &
	"maybe_else_cexpr", &
	"maybe_else_sexpr")
	pn_maybe_else => pn_maybe_elsif
	pn_maybe_elsif => null ()
	pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
	pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
	call eval_node_compile_genexpr &
	(en2, pn_else_expr, var_list, restype)
	case ("endif")
	call eval_node_compile_default_else (en2, restype)
	case default
	call msg_bug ("Broken conditional: unexpected " &
	// char (parse_node_get_rule_key (pn_maybe_elsif)))
	end select
	call eval_node_create_conditional (en, en0, en1, en2, restype)
	call conditional_insert_conversion_nodes (en, restype)
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done conditional"
	end if
	end subroutine eval_node_compile_conditional

	@ %def eval_node_compile_conditional
	@ This recursively generates 'elsif' conditionals as a chain of sub-nodes of
	the main conditional.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_elsif &
	(en, pn, pn_else_expr, var_list, result_type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(parse_node_t), pointer :: pn_else_expr
	type(var_list_t), intent(in), target :: var_list
	integer, intent(inout) :: result_type
	type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr
	type(eval_node_t), pointer :: en0, en1, en2
	pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
	pn_expr => parse_node_get_next_ptr (pn_condition, 2)
	call eval_node_compile_lexpr (en0, pn_condition, var_list)
	call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
	result_type = major_result_type (result_type, en1%result_type)
	pn_next => parse_node_get_next_ptr (pn)
	if (associated (pn_next)) then
	call eval_node_compile_elsif &
	(en2, pn_next, pn_else_expr, var_list, result_type)
	result_type = major_result_type (result_type, en2%result_type)
	else if (associated (pn_else_expr)) then
	call eval_node_compile_genexpr &
	(en2, pn_else_expr, var_list, result_type)
	result_type = major_result_type (result_type, en2%result_type)
	else
	call eval_node_compile_default_else (en2, result_type)
	end if
	call eval_node_create_conditional (en, en0, en1, en2, result_type)
	end subroutine eval_node_compile_elsif

	@ %def eval_node_compile_elsif
	@ This makes a default 'else' branch in case it was omitted. The default value
	just depends on the expected type.
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_default_else (en, result_type)
	type(eval_node_t), pointer :: en
	integer, intent(in) :: result_type
	type(subevt_t) :: pval_empty
	type(pdg_array_t) :: aval_undefined
	allocate (en)
	select case (result_type)
	case (V_LOG); call eval_node_init_log (en, .false.)
	case (V_INT); call eval_node_init_int (en, 0)
	case (V_REAL); call eval_node_init_real (en, 0._default)
	case (V_CMPLX)
	call eval_node_init_cmplx (en, (0._default, 0._default))
	case (V_SEV)
	call subevt_init (pval_empty)
	call eval_node_init_subevt (en, pval_empty)
	case (V_PDG)
	call eval_node_init_pdg_array (en, aval_undefined)
	case (V_STR)
	call eval_node_init_string (en, var_str (""))
	case default
	call msg_bug ("Undefined type for 'else' branch in conditional")
	end select
	end subroutine eval_node_compile_default_else

	@ %def eval_node_compile_default_else
	@ If the logical expression is constant, we can simplify the conditional node
	by replacing it with the selected branch. Otherwise, we initialize a true
	branching.
	<<Eval trees: procedures>>=
	subroutine eval_node_create_conditional (en, en0, en1, en2, result_type)
	type(eval_node_t), pointer :: en, en0, en1, en2
	integer, intent(in) :: result_type
	if (en0%type == EN_CONSTANT) then
	if (en0%lval) then
	en => en1
	call eval_node_final_rec (en2)
	deallocate (en2)
	else
	en => en2
	call eval_node_final_rec (en1)
	deallocate (en1)
	end if
	else
	allocate (en)
	call eval_node_init_conditional (en, result_type, en0, en1, en2)
	end if
	end subroutine eval_node_create_conditional

	@ %def eval_node_create_conditional
	@ Return the numerical result type which should be used for the combination of
	the two result types.
	<<Eval trees: procedures>>=
	function major_result_type (t1, t2) result (t)
	integer :: t
	integer, intent(in) :: t1, t2
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT, V_REAL, V_CMPLX)
	t = t2
	case default
	call type_mismatch ()
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT)
	t = t1
	case (V_REAL, V_CMPLX)
	t = t2
	case default
	call type_mismatch ()
	end select
	case (V_CMPLX)
	select case (t2)
	case (V_INT, V_REAL, V_CMPLX)
	t = t1
	case default
	call type_mismatch ()
	end select
	case default
	if (t1 == t2) then
	t = t1
	else
	call type_mismatch ()
	end if
	end select
	contains
	subroutine type_mismatch ()
	call msg_bug ("Type mismatch in branches of a conditional expression")
	end subroutine type_mismatch
	end function major_result_type

	@ %def major_result_type
	@ Recursively insert conversion nodes where necessary.
	<<Eval trees: procedures>>=
	recursive subroutine conditional_insert_conversion_nodes (en, result_type)
	type(eval_node_t), intent(inout), target :: en
	integer, intent(in) :: result_type
	select case (result_type)
	case (V_INT, V_REAL, V_CMPLX)
	call insert_conversion_node (en%arg1, result_type)
	if (en%arg2%type == EN_CONDITIONAL) then
	call conditional_insert_conversion_nodes (en%arg2, result_type)
	else
	call insert_conversion_node (en%arg2, result_type)
	end if
	end select
	end subroutine conditional_insert_conversion_nodes

	@ %def conditional_insert_conversion_nodes
	@
	\subsubsection{Logical expressions}
	A logical expression consists of one or more singlet logical expressions
	concatenated by [[;]]. This is for allowing side-effects, only the last value
	is used.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_lexpr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg
	type(eval_node_t), pointer :: en1, en2
	if (debug_active (D_MODEL_F)) then
	print *, "read lexpr"; call parse_node_write (pn)
	end if
	pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet")
	call eval_node_compile_lsinglet (en, pn_term, var_list)
	pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel")
	do while (associated (pn_sequel))
	pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet")
	en1 => en
	call eval_node_compile_lsinglet (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call eval_node_init_log (en, ignore_first_ll (en1, en2))
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("lsequel"), V_LOG, en1, en2)
	call eval_node_set_op2_log (en, ignore_first_ll)
	end if
	pn_sequel => parse_node_get_next_ptr (pn_sequel)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done lexpr"
	end if
	end subroutine eval_node_compile_lexpr

	@ %def eval_node_compile_lexpr
	@ A logical singlet expression consists of one or more logical terms
	concatenated by [[or]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_lsinglet (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg
	type(eval_node_t), pointer :: en1, en2
	if (debug_active (D_MODEL_F)) then
	print *, "read lsinglet"; call parse_node_write (pn)
	end if
	pn_term => parse_node_get_sub_ptr (pn, tag="lterm")
	call eval_node_compile_lterm (en, pn_term, var_list)
	pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative")
	do while (associated (pn_alternative))
	pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm")
	en1 => en
	call eval_node_compile_lterm (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call eval_node_init_log (en, or_ll (en1, en2))
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("alternative"), V_LOG, en1, en2)
	call eval_node_set_op2_log (en, or_ll)
	end if
	pn_alternative => parse_node_get_next_ptr (pn_alternative)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done lsinglet"
	end if
	end subroutine eval_node_compile_lsinglet

	@ %def eval_node_compile_lsinglet
	@ A logical term consists of one or more logical values
	concatenated by [[and]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_lterm (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg
	type(eval_node_t), pointer :: en1, en2
	if (debug_active (D_MODEL_F)) then
	print *, "read lterm"; call parse_node_write (pn)
	end if
	pn_term => parse_node_get_sub_ptr (pn)
	call eval_node_compile_lvalue (en, pn_term, var_list)
	pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence")
	do while (associated (pn_coincidence))
	pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2)
	en1 => en
	call eval_node_compile_lvalue (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call eval_node_init_log (en, and_ll (en1, en2))
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("coincidence"), V_LOG, en1, en2)
	call eval_node_set_op2_log (en, and_ll)
	end if
	pn_coincidence => parse_node_get_next_ptr (pn_coincidence)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done lterm"
	end if
	end subroutine eval_node_compile_lterm

	@ %def eval_node_compile_lterm
	@ Logical variables are disabled, because they are confused with the
	l.h.s.\ of compared expressions.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_lvalue (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	if (debug_active (D_MODEL_F)) then
	print *, "read lvalue"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("true")
	allocate (en)
	call eval_node_init_log (en, .true.)
	case ("false")
	allocate (en)
	call eval_node_init_log (en, .false.)
	case ("negation")
	call eval_node_compile_negation (en, pn, var_list)
	case ("lvariable")
	call eval_node_compile_variable (en, pn, var_list, V_LOG)
	case ("lexpr")
	call eval_node_compile_lexpr (en, pn, var_list)
	case ("block_lexpr")
	call eval_node_compile_block_expr (en, pn, var_list, V_LOG)
	case ("conditional_lexpr")
	call eval_node_compile_conditional (en, pn, var_list, V_LOG)
	case ("compared_expr")
	call eval_node_compile_compared_expr (en, pn, var_list, V_REAL)
	case ("compared_sexpr")
	call eval_node_compile_compared_expr (en, pn, var_list, V_STR)
	case ("all_fun", "any_fun", "no_fun", "photon_isolation_fun")
	call eval_node_compile_log_function (en, pn, var_list)
	case ("record_cmd")
	call eval_node_compile_record_cmd (en, pn, var_list)
	case default
	call parse_node_mismatch &
	("true\|false\|negation\|lvariable\|" // &
	"lexpr\|block_lexpr\|conditional_lexpr\|" // &
	"compared_expr\|compared_sexpr\|logical_pexpr", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done lvalue"
	end if
	end subroutine eval_node_compile_lvalue

	@ %def eval_node_compile_lvalue
	@ A negation consists of the keyword [[not]] and a logical value.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_negation (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_arg
	type(eval_node_t), pointer :: en1
	if (debug_active (D_MODEL_F)) then
	print *, "read negation"; call parse_node_write (pn)
	end if
	pn_arg => parse_node_get_sub_ptr (pn, 2)
	call eval_node_compile_lvalue (en1, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT) then
	call eval_node_init_log (en, not_l (en1))
	call eval_node_final_rec (en1)
	deallocate (en1)
	else
	call eval_node_init_branch (en, var_str ("not"), V_LOG, en1)
	call eval_node_set_op1_log (en, not_l)
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done negation"
	end if
	end subroutine eval_node_compile_negation

	@ %def eval_node_compile_negation
	@
	\subsubsection{Comparisons}
	Up to the loop, this is easy. There is always at least one
	comparison. This is evaluated, and the result is the logical node
	[[en]]. If it is constant, we keep its second sub-node as [[en2]].
	(Thus, at the very end [[en2]] has to be deleted if [[en]] is (still)
	constant.)

	If there is another comparison, we first check if the first comparison
	was constant. In that case, there are two possibilities: (i) it was
	true. Then, its right-hand side is compared with the new right-hand
	side, and the result replaces the previous one which is deleted. (ii)
	it was false. In this case, the result of the whole comparison is
	false, and we can exit the loop without evaluating anything else.

	Now assume that the first comparison results in a valid branch, its
	second sub-node kept as [[en2]]. We first need a copy of this, which
	becomes the new left-hand side. If [[en2]] is constant, we make an
	identical constant node [[en1]]. Otherwise, we make [[en1]] an
	appropriate pointer node. Next, the first branch is saved as [[en0]]
	and we evaluate the comparison between [[en1]] and the a right-hand
	side. If this turns out to be constant, there are again two
	possibilities: (i) true, then we revert to the previous result. (ii)
	false, then the wh
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in) :: type
	type(parse_node_t), pointer :: pn_comparison, pn_expr1
	type(eval_node_t), pointer :: en0, en1, en2
	if (debug_active (D_MODEL_F)) then
	print *, "read comparison"; call parse_node_write (pn)
	end if
	select case (type)
	case (V_INT, V_REAL)
	pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr")
	call eval_node_compile_expr (en1, pn_expr1, var_list)
	pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison")
	case (V_STR)
	pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr")
	call eval_node_compile_sexpr (en1, pn_expr1, var_list)
	pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison")
	end select
	call eval_node_compile_comparison &
	(en, en1, en2, pn_comparison, var_list, type)
	pn_comparison => parse_node_get_next_ptr (pn_comparison)
	SCAN_FURTHER: do while (associated (pn_comparison))
	if (en%type == EN_CONSTANT) then
	if (en%lval) then
	en1 => en2
	call eval_node_final_rec (en); deallocate (en)
	call eval_node_compile_comparison &
	(en, en1, en2, pn_comparison, var_list, type)
	else
	exit SCAN_FURTHER
	end if
	else
	allocate (en1)
	if (en2%type == EN_CONSTANT) then
	select case (en2%result_type)
	case (V_INT); call eval_node_init_int (en1, en2%ival)
	case (V_REAL); call eval_node_init_real (en1, en2%rval)
	case (V_STR); call eval_node_init_string (en1, en2%sval)
	end select
	else
	select case (en2%result_type)
	case (V_INT); call eval_node_init_int_ptr &
	(en1, var_str ("(previous)"), en2%ival, en2%value_is_known)
	case (V_REAL); call eval_node_init_real_ptr &
	(en1, var_str ("(previous)"), en2%rval, en2%value_is_known)
	case (V_STR); call eval_node_init_string_ptr &
	(en1, var_str ("(previous)"), en2%sval, en2%value_is_known)
	end select
	end if
	en0 => en
	call eval_node_compile_comparison &
	(en, en1, en2, pn_comparison, var_list, type)
	if (en%type == EN_CONSTANT) then
	if (en%lval) then
	call eval_node_final_rec (en); deallocate (en)
	en => en0
	else
	call eval_node_final_rec (en0); deallocate (en0)
	exit SCAN_FURTHER
	end if
	else
	en1 => en
	allocate (en)
	call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1)
	call eval_node_set_op2_log (en, and_ll)
	end if
	end if
	pn_comparison => parse_node_get_next_ptr (pn_comparison)
	end do SCAN_FURTHER
	if (en%type == EN_CONSTANT .and. associated (en2)) then
	call eval_node_final_rec (en2); deallocate (en2)
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done compared_expr"
	end if
	end subroutine eval_node_compile_compared_expr

	@ %dev eval_node_compile_compared_expr
	@ This takes two extra arguments: [[en1]], the left-hand-side of the
	comparison, is already allocated and evaluated. [[en2]] (the
	right-hand side) and [[en]] (the result) are allocated by the
	routine. [[pn]] is the parse node which contains the operator and the
	right-hand side as subnodes.

	If the result of the comparison is constant, [[en1]] is deleted but
	[[en2]] is kept, because it may be used in a subsequent comparison.
	[[en]] then becomes a constant. If the result is variable, [[en]]
	becomes a branch node which refers to [[en1]] and [[en2]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_comparison &
	(en, en1, en2, pn, var_list, type)
	type(eval_node_t), pointer :: en, en1, en2
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(in) :: type
	type(parse_node_t), pointer :: pn_op, pn_arg
	type(string_t) :: key
	integer :: t1, t2
	real(default), pointer :: tolerance_ptr
	pn_op => parse_node_get_sub_ptr (pn)
	key = parse_node_get_key (pn_op)
	select case (type)
	case (V_INT, V_REAL)
	pn_arg => parse_node_get_next_ptr (pn_op, tag="expr")
	call eval_node_compile_expr (en2, pn_arg, var_list)
	case (V_STR)
	pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr")
	call eval_node_compile_sexpr (en2, pn_arg, var_list)
	end select
	t1 = en1%result_type
	t2 = en2%result_type
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
	en1%tolerance => tolerance_ptr
	select case (char (key))
	case ("<")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_lt_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_ll_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2))
	end select
	end select
	case (">")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_gt_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_gg_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2))
	end select
	end select
	case ("<=")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_le_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_ls_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2))
	end select
	end select
	case (">=")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_ge_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_gs_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2))
	end select
	end select
	case ("==")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_eq_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_se_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2))
	end select
	case (V_STR)
	select case (t2)
	case (V_STR); call eval_node_init_log (en, comp_eq_ss (en1, en2))
	end select
	end select
	case ("<>")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_ne_ii (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2))
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_init_log (en, comp_ns_ri (en1, en2))
	case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2))
	end select
	case (V_STR)
	select case (t2)
	case (V_STR); call eval_node_init_log (en, comp_ne_ss (en1, en2))
	end select
	end select
	end select
	call eval_node_final_rec (en1)
	deallocate (en1)
	else
	call eval_node_init_branch (en, key, V_LOG, en1, en2)
	select case (char (key))
	case ("<")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_lt_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_ll_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr)
	end select
	end select
	case (">")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_gt_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_gg_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr)
	end select
	end select
	case ("<=")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_le_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_ls_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr)
	end select
	end select
	case (">=")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_ge_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_gs_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr)
	end select
	end select
	case ("==")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_eq_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_se_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr)
	end select
	case (V_STR)
	select case (t2)
	case (V_STR); call eval_node_set_op2_log (en, comp_eq_ss)
	end select
	end select
	case ("<>")
	select case (t1)
	case (V_INT)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_ne_ii)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir)
	end select
	case (V_REAL)
	select case (t2)
	case (V_INT); call eval_node_set_op2_log (en, comp_ns_ri)
	case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr)
	end select
	case (V_STR)
	select case (t2)
	case (V_STR); call eval_node_set_op2_log (en, comp_ne_ss)
	end select
	end select
	end select
	call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
	en1%tolerance => tolerance_ptr
	end if
	end subroutine eval_node_compile_comparison

	@ %def eval_node_compile_comparison
	@
	\subsubsection{Recording analysis data}
	The [[record]] command is actually a logical expression which always
	evaluates [[true]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_record_cmd (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg
	type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4
	type(eval_node_t), pointer :: en0, en1, en2, en3, en4
	real(default), pointer :: event_weight
	if (debug_active (D_MODEL_F)) then
	print *, "read record_cmd"; call parse_node_write (pn)
	end if
	pn_key => parse_node_get_sub_ptr (pn)
	pn_tag => parse_node_get_next_ptr (pn_key)
	pn_arg => parse_node_get_next_ptr (pn_tag)
	select case (char (parse_node_get_key (pn_key)))
	case ("record")
	call var_list%get_rptr (var_str ("event_weight"), event_weight)
	case ("record_unweighted")
	event_weight => null ()
	case ("record_excess")
	call var_list%get_rptr (var_str ("event_excess"), event_weight)
	end select
	select case (char (parse_node_get_rule_key (pn_tag)))
	case ("analysis_id")
	allocate (en0)
	call eval_node_init_string (en0, parse_node_get_string (pn_tag))
	case default
	call eval_node_compile_sexpr (en0, pn_tag, var_list)
	end select
	allocate (en)
	if (associated (pn_arg)) then
	pn_arg1 => parse_node_get_sub_ptr (pn_arg)
	call eval_node_compile_expr (en1, pn_arg1, var_list)
	if (en1%result_type == V_INT) &
	call insert_conversion_node (en1, V_REAL)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	if (associated (pn_arg2)) then
	call eval_node_compile_expr (en2, pn_arg2, var_list)
	if (en2%result_type == V_INT) &
	call insert_conversion_node (en2, V_REAL)
	pn_arg3 => parse_node_get_next_ptr (pn_arg2)
	if (associated (pn_arg3)) then
	call eval_node_compile_expr (en3, pn_arg3, var_list)
	if (en3%result_type == V_INT) &
	call insert_conversion_node (en3, V_REAL)
	pn_arg4 => parse_node_get_next_ptr (pn_arg3)
	if (associated (pn_arg4)) then
	call eval_node_compile_expr (en4, pn_arg4, var_list)
	if (en4%result_type == V_INT) &
	call insert_conversion_node (en4, V_REAL)
	call eval_node_init_record_cmd &
	(en, event_weight, en0, en1, en2, en3, en4)
	else
	call eval_node_init_record_cmd &
	(en, event_weight, en0, en1, en2, en3)
	end if
	else
	call eval_node_init_record_cmd (en, event_weight, en0, en1, en2)
	end if
	else
	call eval_node_init_record_cmd (en, event_weight, en0, en1)
	end if
	else
	call eval_node_init_record_cmd (en, event_weight, en0)
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done record_cmd"
	end if
	end subroutine eval_node_compile_record_cmd

	@ %def eval_node_compile_record_cmd
	@
	\subsubsection{Particle-list expressions}
	A particle expression is a subevent or a concatenation of
	particle-list terms (using \verb\|join\|).
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_pexpr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(subevt_t) :: subevt
	if (debug_active (D_MODEL_F)) then
	print *, "read pexpr"; call parse_node_write (pn)
	end if
	pn_pterm => parse_node_get_sub_ptr (pn)
	call eval_node_compile_pterm (en, pn_pterm, var_list)
	pn_concatenation => &
	parse_node_get_next_ptr (pn_pterm, tag="pconcatenation")
	do while (associated (pn_concatenation))
	pn_op => parse_node_get_sub_ptr (pn_concatenation)
	pn_arg => parse_node_get_next_ptr (pn_op)
	en1 => en
	call eval_node_compile_pterm (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call subevt_join (subevt, en1%pval, en2%pval)
	call eval_node_init_subevt (en, subevt)
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("join"), V_SEV, en1, en2)
	call eval_node_set_op2_sev (en, join_pp)
	end if
	pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done pexpr"
	end if
	end subroutine eval_node_compile_pexpr

	@ %def eval_node_compile_pexpr
	@ A particle term is a subevent or a combination of
	particle-list values (using \verb\|combine\|).
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_pterm (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(subevt_t) :: subevt
	if (debug_active (D_MODEL_F)) then
	print *, "read pterm"; call parse_node_write (pn)
	end if
	pn_pvalue => parse_node_get_sub_ptr (pn)
	call eval_node_compile_pvalue (en, pn_pvalue, var_list)
	pn_combination => &
	parse_node_get_next_ptr (pn_pvalue, tag="pcombination")
	do while (associated (pn_combination))
	pn_op => parse_node_get_sub_ptr (pn_combination)
	pn_arg => parse_node_get_next_ptr (pn_op)
	en1 => en
	call eval_node_compile_pvalue (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call subevt_combine (subevt, en1%pval, en2%pval)
	call eval_node_init_subevt (en, subevt)
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("combine"), V_SEV, en1, en2)
	call eval_node_set_op2_sev (en, combine_pp)
	end if
	pn_combination => parse_node_get_next_ptr (pn_combination)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done pterm"
	end if
	end subroutine eval_node_compile_pterm

	@ %def eval_node_compile_pterm
	@ A particle-list value is a PDG-code array, a particle identifier, a
	variable, a (grouped) pexpr, a block pexpr, a conditional, or a
	particle-list function.

	The [[cexpr]] node is responsible for transforming a constant PDG-code
	array into a subevent. It takes the code array as its first
	argument, the event subevent as its second argument, and the
	requested particle type (incoming/outgoing) as its zero-th argument.
	The result is the list of particles in the event that match the code
	array.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_pvalue (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_prefix_cexpr
	type(eval_node_t), pointer :: en1, en2, en0
	type(string_t) :: key
	type(subevt_t), pointer :: evt_ptr
	logical, pointer :: known
	if (debug_active (D_MODEL_F)) then
	print *, "read pvalue"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("pexpr_src")
	call eval_node_compile_prefix_cexpr (en1, pn, var_list)
	allocate (en2)
	if (var_list%contains (var_str ("@evt"))) then
	call var_list%get_pptr (var_str ("@evt"), evt_ptr, known)
	call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known)
	allocate (en)
	call eval_node_init_branch &
	(en, var_str ("prt_selection"), V_SEV, en1, en2)
	call eval_node_set_op2_sev (en, select_pdg_ca)
	allocate (en0)
	pn_prefix_cexpr => parse_node_get_sub_ptr (pn)
	key = parse_node_get_rule_key (pn_prefix_cexpr)
	select case (char (key))
	case ("beam_prt")
	call eval_node_init_int (en0, PRT_BEAM)
	en%arg0 => en0
	case ("incoming_prt")
	call eval_node_init_int (en0, PRT_INCOMING)
	en%arg0 => en0
	case ("outgoing_prt")
	call eval_node_init_int (en0, PRT_OUTGOING)
	en%arg0 => en0
	case ("unspecified_prt")
	call eval_node_init_int (en0, PRT_OUTGOING)
	en%arg0 => en0
	end select
	else
	call parse_node_write (pn)
	call msg_bug (" Missing event data while compiling pvalue")
	end if
	case ("pvariable")
	call eval_node_compile_variable (en, pn, var_list, V_SEV)
	case ("pexpr")
	call eval_node_compile_pexpr (en, pn, var_list)
	case ("block_pexpr")
	call eval_node_compile_block_expr (en, pn, var_list, V_SEV)
	case ("conditional_pexpr")
	call eval_node_compile_conditional (en, pn, var_list, V_SEV)
	case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", &
	"select_fun", "extract_fun", "sort_fun", "select_b_jet_fun", &
	"select_non_bjet_fun", "select_c_jet_fun", &
	"select_light_jet_fun", "photon_reco_fun")
	call eval_node_compile_prt_function (en, pn, var_list)
	case default
	call parse_node_mismatch &
	("prefix_cexpr\|pvariable\|" // &
	"grouped_pexpr\|block_pexpr\|conditional_pexpr\|" // &
	"prt_function", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done pvalue"
	end if
	end subroutine eval_node_compile_pvalue

	@ %def eval_node_compile_pvalue
	@
	\subsubsection{Particle functions}
	This combines the treatment of 'join', 'combine', 'collect', 'cluster',
	'select', and 'extract', as well as the functions for $b$, $c$ and
	light jet selection and photon recombnation which all have the same
	syntax. The one or two argument nodes are allocated. If there is a
	condition, the condition node is also allocated as a logical
	expression, for which the variable list is augmented by the
	appropriate (unary/binary) observables.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_prt_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
	type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en0, en1, en2
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read prt_function"; call parse_node_write (pn)
	end if
	pn_clause => parse_node_get_sub_ptr (pn)
	pn_key => parse_node_get_sub_ptr (pn_clause)
	pn_cond => parse_node_get_next_ptr (pn_key)
	if (associated (pn_cond)) &
	pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
	pn_args => parse_node_get_next_ptr (pn_clause)
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	key = parse_node_get_key (pn_key)
	call eval_node_compile_pexpr (en1, pn_arg1, var_list)
	allocate (en)
	if (.not. associated (pn_arg2)) then
	select case (char (key))
	case ("collect")
	call eval_node_init_prt_fun_unary (en, en1, key, collect_p)
	case ("cluster")
	if (fastjet_available ()) then
	call fastjet_init ()
	else
	call msg_fatal &
	("'cluster' function requires FastJet, which is not enabled")
	end if
	en1%var_list => var_list
	call eval_node_init_prt_fun_unary (en, en1, key, cluster_p)
	call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm)
	call var_list%get_rptr (var_str ("jet_r"), en1%jet_r)
	call var_list%get_rptr (var_str ("jet_p"), en1%jet_p)
	call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut)
	call var_list%get_rptr (var_str ("jet_dcut"), en1%jet_dcut)
	case ("photon_recombination")
	en1%var_list => var_list
	call eval_node_init_prt_fun_unary &
	(en, en1, key, photon_recombination_p)
	call var_list%get_rptr (var_str ("photon_rec_r0"), en1%photon_rec_r0)
	case ("select")
	call eval_node_init_prt_fun_unary (en, en1, key, select_p)
	case ("extract")
	call eval_node_init_prt_fun_unary (en, en1, key, extract_p)
	case ("sort")
	call eval_node_init_prt_fun_unary (en, en1, key, sort_p)
	case ("select_b_jet")
	call eval_node_init_prt_fun_unary (en, en1, key, select_b_jet_p)
	case ("select_non_b_jet")
	call eval_node_init_prt_fun_unary (en, en1, key, select_non_b_jet_p)
	case ("select_c_jet")
	call eval_node_init_prt_fun_unary (en, en1, key, select_c_jet_p)
	case ("select_light_jet")
	call eval_node_init_prt_fun_unary (en, en1, key, select_light_jet_p)
	case default
	call msg_bug (" Unary particle function '" // char (key) // &
	"' undefined")
	end select
	else
	call eval_node_compile_pexpr (en2, pn_arg2, var_list)
	select case (char (key))
	case ("join")
	call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp)
	case ("combine")
	call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp)
	case ("collect")
	call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp)
	case ("select")
	call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp)
	case ("sort")
	call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp)
	case default
	call msg_bug (" Binary particle function '" // char (key) // &
	"' undefined")
	end select
	end if
	if (associated (pn_cond)) then
	call eval_node_set_observables (en, var_list)
	select case (char (key))
	case ("extract", "sort")
	call eval_node_compile_expr (en0, pn_arg0, en%var_list)
	case default
	call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
	end select
	en%arg0 => en0
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done prt_function"
	end if
	end subroutine eval_node_compile_prt_function

	@ %def eval_node_compile_prt_function
	@ The [[eval]] expression is similar, but here the expression [[arg0]]
	is mandatory, and the whole thing evaluates to a numeric value. To
	guarantee initialization of variables defined on subevents instead of
	a single (namely the first) particle of a subevent, we make sure that
	[[en]] points to the subevent stored in [[en1]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_eval_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en0, en1, en2
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read eval_function"; call parse_node_write (pn)
	end if
	pn_key => parse_node_get_sub_ptr (pn)
	pn_arg0 => parse_node_get_next_ptr (pn_key)
	pn_args => parse_node_get_next_ptr (pn_arg0)
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	key = parse_node_get_key (pn_key)
	call eval_node_compile_pexpr (en1, pn_arg1, var_list)
	allocate (en)
	if (.not. associated (pn_arg2)) then
	call eval_node_init_eval_fun_unary (en, en1, key)
	else
	call eval_node_compile_pexpr (en2, pn_arg2, var_list)
	call eval_node_init_eval_fun_binary (en, en1, en2, key)
	end if
	en%pval => en1%pval
	call eval_node_set_observables (en, var_list)
	call eval_node_compile_expr (en0, pn_arg0, en%var_list)
	if (en0%result_type == V_INT) &
	call insert_conversion_node (en0, V_REAL)
	if (en0%result_type /= V_REAL) &
	call msg_fatal (" 'eval' function does not result in real value")
	call eval_node_set_expr (en, en0)
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done eval_function"
	end if
	end subroutine eval_node_compile_eval_function

	@ %def eval_node_compile_eval_function
	@ Logical functions of subevents. For [[photon_isolation]] there is a
	conditional selection expression instead of a mandatory logical
	expression, so in the case of the absence of the selection we have to
	create a logical [[eval_node_t]] with value [[.true.]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_log_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_clause, pn_key, pn_str, pn_cond
	type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en0, en1, en2
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read log_function"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("all_fun", "any_fun", "no_fun")
	pn_key => parse_node_get_sub_ptr (pn)
	pn_arg0 => parse_node_get_next_ptr (pn_key)
	pn_args => parse_node_get_next_ptr (pn_arg0)
	case ("photon_isolation_fun")
	pn_clause => parse_node_get_sub_ptr (pn)
	pn_key => parse_node_get_sub_ptr (pn_clause)
	pn_cond => parse_node_get_next_ptr (pn_key)
	if (associated (pn_cond)) then
	pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
	else
	pn_arg0 => null ()
	end if
	pn_args => parse_node_get_next_ptr (pn_clause)
	case default
	call parse_node_mismatch ("all_fun\|any_fun\|" // &
	"no_fun\|photon_isolation_fun", pn)
	end select
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	key = parse_node_get_key (pn_key)
	call eval_node_compile_pexpr (en1, pn_arg1, var_list)
	allocate (en)
	if (.not. associated (pn_arg2)) then
	select case (char (key))
	case ("all")
	call eval_node_init_log_fun_unary (en, en1, key, all_p)
	case ("any")
	call eval_node_init_log_fun_unary (en, en1, key, any_p)
	case ("no")
	call eval_node_init_log_fun_unary (en, en1, key, no_p)
	case default
	call msg_bug ("Unary logical particle function '" // char (key) // &
	"' undefined")
	end select
	else
	call eval_node_compile_pexpr (en2, pn_arg2, var_list)
	select case (char (key))
	case ("all")
	call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp)
	case ("any")
	call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp)
	case ("no")
	call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp)
	case ("photon_isolation")
	en1%var_list => var_list
	call var_list%get_rptr (var_str ("photon_iso_eps"), en1%photon_iso_eps)
	call var_list%get_rptr (var_str ("photon_iso_n"), en1%photon_iso_n)
	call var_list%get_rptr (var_str ("photon_iso_r0"), en1%photon_iso_r0)
	call eval_node_init_log_fun_binary (en, en1, en2, key, photon_isolation_pp)
	case default
	call msg_bug ("Binary logical particle function '" // char (key) // &
	"' undefined")
	end select
	end if
	if (associated (pn_arg0)) then
	call eval_node_set_observables (en, var_list)
	select case (char (key))
	case ("all", "any", "no", "photon_isolation")
	call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
	case default
	call msg_bug ("Compiling logical particle function: missing mode")
	end select
	call eval_node_set_expr (en, en0, V_LOG)
	else
	select case (char (key))
	case ("photon_isolation")
	allocate (en0)
	call eval_node_init_log (en0, .true.)
	call eval_node_set_expr (en, en0, V_LOG)
	case default
	call msg_bug ("Only photon isolation can be called unconditionally")
	end select
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done log_function"
	end if
	end subroutine eval_node_compile_log_function

	@ %def eval_node_compile_log_function
	@ Count function of subevents.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_count_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
	type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en0, en1, en2
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read count_function"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("count_fun")
	pn_clause => parse_node_get_sub_ptr (pn)
	pn_key => parse_node_get_sub_ptr (pn_clause)
	pn_cond => parse_node_get_next_ptr (pn_key)
	if (associated (pn_cond)) then
	pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
	else
	pn_arg0 => null ()
	end if
	pn_args => parse_node_get_next_ptr (pn_clause)
	end select
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	key = parse_node_get_key (pn_key)
	call eval_node_compile_pexpr (en1, pn_arg1, var_list)
	allocate (en)
	if (.not. associated (pn_arg2)) then
	select case (char (key))
	case ("count")
	call eval_node_init_int_fun_unary (en, en1, key, count_a)
	case default
	call msg_bug ("Unary subevent function '" // char (key) // &
	"' undefined")
	end select
	else
	call eval_node_compile_pexpr (en2, pn_arg2, var_list)
	select case (char (key))
	case ("count")
	call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp)
	case default
	call msg_bug ("Binary subevent function '" // char (key) // &
	"' undefined")
	end select
	end if
	if (associated (pn_arg0)) then
	call eval_node_set_observables (en, var_list)
	select case (char (key))
	case ("count")
	call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
	call eval_node_set_expr (en, en0, V_INT)
	end select
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done count_function"
	end if
	end subroutine eval_node_compile_count_function

	@ %def eval_node_compile_count_function
	@ Numeric functions of subevents.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_numeric_function (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_key, pn_args
	type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
	type(eval_node_t), pointer :: en0, en1
	type(string_t) :: key
	type(var_entry_t), pointer :: var
	if (debug_active (D_MODEL_F)) then
	print *, "read numeric_function"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("sum_fun", "prod_fun")
	if (debug_active (D_MODEL_F)) then
	print *, "read sum_fun"; call parse_node_write (pn)
	end if
	pn_key => parse_node_get_sub_ptr (pn)
	pn_arg0 => parse_node_get_next_ptr (pn_key)
	pn_args => parse_node_get_next_ptr (pn_arg0)
	end select
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	key = parse_node_get_key (pn_key)
	call eval_node_compile_pexpr (en1, pn_arg1, var_list)
	if (associated (pn_arg2)) then
	call msg_fatal ("The " // char (key) // &
	" function can only be used for unary observables.")
	end if
	allocate (en)
	select case (char (key))
	case ("sum")
	call eval_node_init_real_fun_cum (en, en1, key, sum_a)
	case ("prod")
	call eval_node_init_real_fun_cum (en, en1, key, prod_a)
	case default
	call msg_bug ("Unary subevent function '" // char (key) // &
	"' undefined")
	end select
	call eval_node_set_observables (en, var_list)
	call eval_node_compile_expr (en0, pn_arg0, en%var_list)
	if (en0%result_type == V_INT) &
	call insert_conversion_node (en0, V_REAL)
	call eval_node_set_expr (en, en0, V_REAL)
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done numeric_function"
	end if
	end subroutine eval_node_compile_numeric_function

	@ %def eval_node_compile_numeric_function
	@
	\subsubsection{PDG-code arrays}
	A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or
	[[outgoing]], a block, or a conditional. In any case, it evaluates to
	a constant.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_avalue, pn_prt
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read prefix_cexpr"; call parse_node_write (pn)
	end if
	pn_avalue => parse_node_get_sub_ptr (pn)
	key = parse_node_get_rule_key (pn_avalue)
	select case (char (key))
	case ("beam_prt")
	pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
	call eval_node_compile_cexpr (en, pn_prt, var_list)
	case ("incoming_prt")
	pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
	call eval_node_compile_cexpr (en, pn_prt, var_list)
	case ("outgoing_prt")
	pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
	call eval_node_compile_cexpr (en, pn_prt, var_list)
	case ("unspecified_prt")
	pn_prt => parse_node_get_sub_ptr (pn_avalue, 1)
	call eval_node_compile_cexpr (en, pn_prt, var_list)
	case default
	call parse_node_mismatch &
	("beam_prt\|incoming_prt\|outgoing_prt\|unspecified_prt", &
	pn_avalue)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done prefix_cexpr"
	end if
	end subroutine eval_node_compile_prefix_cexpr

	@ %def eval_node_compile_prefix_cexpr
	@ A PDG array is a string of PDG code definitions (or aliases),
	concatenated by ':'. The code definitions may be variables which are
	not defined at compile time, so we have to allocate sub-nodes. This
	analogous to [[eval_node_compile_term]].
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_cexpr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_prt, pn_concatenation
	type(eval_node_t), pointer :: en1, en2
	type(pdg_array_t) :: aval
	if (debug_active (D_MODEL_F)) then
	print *, "read cexpr"; call parse_node_write (pn)
	end if
	pn_prt => parse_node_get_sub_ptr (pn)
	call eval_node_compile_avalue (en, pn_prt, var_list)
	pn_concatenation => parse_node_get_next_ptr (pn_prt)
	do while (associated (pn_concatenation))
	pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2)
	en1 => en
	call eval_node_compile_avalue (en2, pn_prt, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call concat_cc (aval, en1, en2)
	call eval_node_init_pdg_array (en, aval)
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2)
	call eval_node_set_op2_pdg (en, concat_cc)
	end if
	pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done cexpr"
	end if
	end subroutine eval_node_compile_cexpr

	@ %def eval_node_compile_cexpr
	@ Compile a PDG-code type value. It may be either an integer expression
	or a variable of type PDG array, optionally quoted.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_avalue (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	if (debug_active (D_MODEL_F)) then
	print *, "read avalue"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("pdg_code")
	call eval_node_compile_pdg_code (en, pn, var_list)
	case ("cvariable", "variable", "prt_name")
	call eval_node_compile_cvariable (en, pn, var_list)
	case ("cexpr")
	call eval_node_compile_cexpr (en, pn, var_list)
	case ("block_cexpr")
	call eval_node_compile_block_expr (en, pn, var_list, V_PDG)
	case ("conditional_cexpr")
	call eval_node_compile_conditional (en, pn, var_list, V_PDG)
	case default
	call parse_node_mismatch &
	("grouped_cexpr\|block_cexpr\|conditional_cexpr\|" // &
	"pdg_code\|cvariable\|prt_name", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done avalue"
	end if
	end subroutine eval_node_compile_avalue

	@ %def eval_node_compile_avalue
	@ Compile a PDG-code expression, which is the key [[PDG]] with an
	integer expression as argument. The procedure is analogous to
	[[eval_node_compile_unary_function]].
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_pdg_code (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_arg
	type(eval_node_t), pointer :: en1
	type(string_t) :: key
	type(pdg_array_t) :: aval
	integer :: t
	if (debug_active (D_MODEL_F)) then
	print *, "read PDG code"; call parse_node_write (pn)
	end if
	pn_arg => parse_node_get_sub_ptr (pn, 2)
	call eval_node_compile_expr &
	(en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
	t = en1%result_type
	allocate (en)
	key = "PDG"
	if (en1%type == EN_CONSTANT) then
	select case (t)
	case (V_INT)
	call pdg_i (aval, en1)
	call eval_node_init_pdg_array (en, aval)
	case default; call eval_type_error (pn, char (key), t)
	end select
	call eval_node_final_rec (en1)
	deallocate (en1)
	else
	select case (t)
	case (V_INT); call eval_node_set_op1_pdg (en, pdg_i)
	case default; call eval_type_error (pn, char (key), t)
	end select
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done function"
	end if
	end subroutine eval_node_compile_pdg_code

	@ %def eval_node_compile_pdg_code
	@ This is entirely analogous to [[eval_node_compile_variable]].
	However, PDG-array variables occur in different contexts.

	To avoid name clashes between PDG-array variables and ordinary
	variables, we prepend a character ([[*]]). This is not visible to the
	user.
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_cvariable (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_name
	type(string_t) :: var_name
	type(pdg_array_t), pointer :: aptr
	type(pdg_array_t), target, save :: no_aval
	logical, pointer :: known
	logical, target, save :: unknown = .false.
	if (debug_active (D_MODEL_F)) then
	print *, "read cvariable"; call parse_node_write (pn)
	end if
	pn_name => pn
	var_name = parse_node_get_string (pn_name)
	allocate (en)
	if (var_list%contains (var_name)) then
	call var_list%get_aptr (var_name, aptr, known)
	call eval_node_init_pdg_array_ptr (en, var_name, aptr, known)
	else
	call parse_node_write (pn)
	call msg_error ("This PDG-array variable is undefined at this point")
	call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown)
	end if
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done cvariable"
	end if
	end subroutine eval_node_compile_cvariable

	@ %def eval_node_compile_cvariable
	@
	\subsubsection{String expressions}
	A string expression is either a string value or a concatenation of
	string values.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_sexpr (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg
	type(eval_node_t), pointer :: en1, en2
	type(string_t) :: string
	if (debug_active (D_MODEL_F)) then
	print *, "read sexpr"; call parse_node_write (pn)
	end if
	pn_svalue => parse_node_get_sub_ptr (pn)
	call eval_node_compile_svalue (en, pn_svalue, var_list)
	pn_concatenation => &
	parse_node_get_next_ptr (pn_svalue, tag="str_concatenation")
	do while (associated (pn_concatenation))
	pn_op => parse_node_get_sub_ptr (pn_concatenation)
	pn_arg => parse_node_get_next_ptr (pn_op)
	en1 => en
	call eval_node_compile_svalue (en2, pn_arg, var_list)
	allocate (en)
	if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
	call concat_ss (string, en1, en2)
	call eval_node_init_string (en, string)
	call eval_node_final_rec (en1)
	call eval_node_final_rec (en2)
	deallocate (en1, en2)
	else
	call eval_node_init_branch &
	(en, var_str ("concat"), V_STR, en1, en2)
	call eval_node_set_op2_str (en, concat_ss)
	end if
	pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
	end do
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done sexpr"
	end if
	end subroutine eval_node_compile_sexpr

	@ %def eval_node_compile_sexpr
	@ A string value is a string literal, a
	variable, a (grouped) sexpr, a block sexpr, or a conditional.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_svalue (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	if (debug_active (D_MODEL_F)) then
	print *, "read svalue"; call parse_node_write (pn)
	end if
	select case (char (parse_node_get_rule_key (pn)))
	case ("svariable")
	call eval_node_compile_variable (en, pn, var_list, V_STR)
	case ("sexpr")
	call eval_node_compile_sexpr (en, pn, var_list)
	case ("block_sexpr")
	call eval_node_compile_block_expr (en, pn, var_list, V_STR)
	case ("conditional_sexpr")
	call eval_node_compile_conditional (en, pn, var_list, V_STR)
	case ("sprintf_fun")
	call eval_node_compile_sprintf (en, pn, var_list)
	case ("string_literal")
	allocate (en)
	call eval_node_init_string (en, parse_node_get_string (pn))
	case default
	call parse_node_mismatch &
	("svariable\|" // &
	"grouped_sexpr\|block_sexpr\|conditional_sexpr\|" // &
	"string_function\|string_literal", pn)
	end select
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done svalue"
	end if
	end subroutine eval_node_compile_svalue

	@ %def eval_node_compile_svalue
	@ There is currently one string function, [[sprintf]]. For
	[[sprintf]], the first argument (no brackets) is the format string, the
	optional arguments in brackets are the expressions or variables to be
	formatted.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_compile_sprintf (en, pn, var_list)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_clause, pn_key, pn_args
	type(parse_node_t), pointer :: pn_arg0
	type(eval_node_t), pointer :: en0, en1
	integer :: n_args
	type(string_t) :: key
	if (debug_active (D_MODEL_F)) then
	print *, "read sprintf_fun"; call parse_node_write (pn)
	end if
	pn_clause => parse_node_get_sub_ptr (pn)
	pn_key => parse_node_get_sub_ptr (pn_clause)
	pn_arg0 => parse_node_get_next_ptr (pn_key)
	pn_args => parse_node_get_next_ptr (pn_clause)
	call eval_node_compile_sexpr (en0, pn_arg0, var_list)
	if (associated (pn_args)) then
	call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args)
	else
	n_args = 0
	en1 => null ()
	end if
	allocate (en)
	key = parse_node_get_key (pn_key)
	call eval_node_init_format_string (en, en0, en1, key, n_args)
	if (debug_active (D_MODEL_F)) then
	call eval_node_write (en)
	print *, "done sprintf_fun"
	end if
	end subroutine eval_node_compile_sprintf

	@ %def eval_node_compile_sprintf
	<<Eval trees: procedures>>=
	subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args)
	type(eval_node_t), pointer :: en
	type(parse_node_t), intent(in) :: pn
	type(var_list_t), intent(in), target :: var_list
	integer, intent(out) :: n_args
	type(parse_node_t), pointer :: pn_arg
	integer :: i
	type(eval_node_t), pointer :: en1, en2
	n_args = parse_node_get_n_sub (pn)
	en => null ()
	do i = n_args, 1, -1
	pn_arg => parse_node_get_sub_ptr (pn, i)
	select case (char (parse_node_get_rule_key (pn_arg)))
	case ("lvariable")
	call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG)
	case ("svariable")
	call eval_node_compile_variable (en1, pn_arg, var_list, V_STR)
	case ("expr")
	call eval_node_compile_expr (en1, pn_arg, var_list)
	case default
	call parse_node_mismatch ("variable\|svariable\|lvariable\|expr", pn_arg)
	end select
	if (associated (en)) then
	en2 => en
	allocate (en)
	call eval_node_init_branch &
	(en, var_str ("sprintf_arg"), V_NONE, en1, en2)
	else
	allocate (en)
	call eval_node_init_branch &
	(en, var_str ("sprintf_arg"), V_NONE, en1)
	end if
	end do
	end subroutine eval_node_compile_sprintf_args

	@ %def eval_node_compile_sprintf_args
	@ Evaluation. We allocate the argument list and apply the Fortran wrapper for
	the [[sprintf]] function.
	<<Eval trees: procedures>>=
	subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg)
	type(string_t), intent(out) :: string
	integer, intent(in) :: n_args
	type(eval_node_t), pointer :: en_fmt
	type(eval_node_t), intent(in), optional, target :: en_arg
	type(eval_node_t), pointer :: en_branch, en_var
	type(sprintf_arg_t), dimension(:), allocatable :: arg
	type(string_t) :: fmt
	logical :: autoformat
	integer :: i, j, sprintf_argc
	autoformat = .not. associated (en_fmt)
	if (autoformat) fmt = ""
	if (present (en_arg)) then
	sprintf_argc = 0
	en_branch => en_arg
	do i = 1, n_args
	select case (en_branch%arg1%result_type)
	case (V_CMPLX); sprintf_argc = sprintf_argc + 2
	case default ; sprintf_argc = sprintf_argc + 1
	end select
	en_branch => en_branch%arg2
	end do
	allocate (arg (sprintf_argc))
	j = 1
	en_branch => en_arg
	do i = 1, n_args
	en_var => en_branch%arg1
	select case (en_var%result_type)
	case (V_LOG)
	call sprintf_arg_init (arg(j), en_var%lval)
	if (autoformat) fmt = fmt // "%s "
	case (V_INT);
	call sprintf_arg_init (arg(j), en_var%ival)
	if (autoformat) fmt = fmt // "%i "
	case (V_REAL);
	call sprintf_arg_init (arg(j), en_var%rval)
	if (autoformat) fmt = fmt // "%g "
	case (V_STR)
	call sprintf_arg_init (arg(j), en_var%sval)
	if (autoformat) fmt = fmt // "%s "
	case (V_CMPLX)
	call sprintf_arg_init (arg(j), real (en_var%cval, default))
	j = j + 1
	call sprintf_arg_init (arg(j), aimag (en_var%cval))
	if (autoformat) fmt = fmt // "(%g + %g * I) "
	case default
	call eval_node_write (en_var)
	call msg_error ("sprintf is implemented " &
	// "for logical, integer, real, and string values only")
	end select
	j = j + 1
	en_branch => en_branch%arg2
	end do
	else
	allocate (arg(0))
	end if
	if (autoformat) then
	string = sprintf (trim (fmt), arg)
	else
	string = sprintf (en_fmt%sval, arg)
	end if
	end subroutine evaluate_sprintf

	@ %def evaluate_sprintf
	@
	\subsection{Auxiliary functions for the compiler}
	Issue an error that the current node could not be compiled because of
	type mismatch:
	<<Eval trees: procedures>>=
	subroutine eval_type_error (pn, string, t)
	type(parse_node_t), intent(in) :: pn
	character(*), intent(in) :: string
	integer, intent(in) :: t
	type(string_t) :: type
	select case (t)
	case (V_NONE); type = "(none)"
	case (V_LOG); type = "'logical'"
	case (V_INT); type = "'integer'"
	case (V_REAL); type = "'real'"
	case (V_CMPLX); type = "'complex'"
	case default; type = "(unknown)"
	end select
	call parse_node_write (pn)
	call msg_fatal (" The " // string // &
	" operation is not defined for the given argument type " // &
	char (type))
	end subroutine eval_type_error

	@ %def eval_type_error
	@
	If two numerics are combined, the result is integer if both
	arguments are integer, if one is integer and the other real or both
	are real, than its argument is real, otherwise complex.
	<<Eval trees: procedures>>=
	function numeric_result_type (t1, t2) result (t)
	integer, intent(in) :: t1, t2
	integer :: t
	if (t1 == V_INT .and. t2 == V_INT) then
	t = V_INT
	else if (t1 == V_INT .and. t2 == V_REAL) then
	t = V_REAL
	else if (t1 == V_REAL .and. t2 == V_INT) then
	t = V_REAL
	else if (t1 == V_REAL .and. t2 == V_REAL) then
	t = V_REAL
	else
	t = V_CMPLX
	end if
	end function numeric_result_type

	@ %def numeric_type
	@
	\subsection{Evaluation}
	Evaluation is done recursively. For leaf nodes nothing is to be done.

	Evaluating particle-list functions: First, we evaluate the particle
	lists. If a condition is present, we assign the particle pointers of
	the condition node to the allocated particle entries in the parent
	node, keeping in mind that the observables in the variable stack used
	for the evaluation of the condition also contain pointers to these
	entries. Then, the assigned procedure is evaluated, which sets the
	subevent in the parent node. If required, the procedure
	evaluates the condition node once for each (pair of) particles to
	determine the result.
	<<Eval trees: procedures>>=
	recursive subroutine eval_node_evaluate (en)
	type(eval_node_t), intent(inout) :: en
	logical :: exist
	select case (en%type)
	case (EN_UNARY)
	if (associated (en%arg1)) then
	call eval_node_evaluate (en%arg1)
	en%value_is_known = en%arg1%value_is_known
	else
	en%value_is_known = .false.
	end if
	if (en%value_is_known) then
	select case (en%result_type)
	case (V_LOG); en%lval = en%op1_log (en%arg1)
	case (V_INT); en%ival = en%op1_int (en%arg1)
	case (V_REAL); en%rval = en%op1_real (en%arg1)
	case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1)
	case (V_PDG);
	call en%op1_pdg (en%aval, en%arg1)
	case (V_SEV)
	if (associated (en%arg0)) then
	call en%op1_sev (en%pval, en%arg1, en%arg0)
	else
	call en%op1_sev (en%pval, en%arg1)
	end if
	case (V_STR)
	call en%op1_str (en%sval, en%arg1)
	end select
	end if
	case (EN_BINARY)
	if (associated (en%arg1) .and. associated (en%arg2)) then
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = &
	en%arg1%value_is_known .and. en%arg2%value_is_known
	else
	en%value_is_known = .false.
	end if
	if (en%value_is_known) then
	select case (en%result_type)
	case (V_LOG); en%lval = en%op2_log (en%arg1, en%arg2)
	case (V_INT); en%ival = en%op2_int (en%arg1, en%arg2)
	case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2)
	case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2)
	case (V_PDG)
	call en%op2_pdg (en%aval, en%arg1, en%arg2)
	case (V_SEV)
	if (associated (en%arg0)) then
	call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
	else
	call en%op2_sev (en%pval, en%arg1, en%arg2)
	end if
	case (V_STR)
	call en%op2_str (en%sval, en%arg1, en%arg2)
	end select
	end if
	case (EN_BLOCK)
	if (associated (en%arg1) .and. associated (en%arg0)) then
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg0)
	en%value_is_known = en%arg0%value_is_known
	else
	en%value_is_known = .false.
	end if
	if (en%value_is_known) then
	select case (en%result_type)
	case (V_LOG); en%lval = en%arg0%lval
	case (V_INT); en%ival = en%arg0%ival
	case (V_REAL); en%rval = en%arg0%rval
	case (V_CMPLX); en%cval = en%arg0%cval
	case (V_PDG); en%aval = en%arg0%aval
	case (V_SEV); en%pval = en%arg0%pval
	case (V_STR); en%sval = en%arg0%sval
	end select
	end if
	case (EN_CONDITIONAL)
	if (associated (en%arg0)) then
	call eval_node_evaluate (en%arg0)
	en%value_is_known = en%arg0%value_is_known
	else
	en%value_is_known = .false.
	end if
	if (en%arg0%value_is_known) then
	if (en%arg0%lval) then
	call eval_node_evaluate (en%arg1)
	en%value_is_known = en%arg1%value_is_known
	if (en%value_is_known) then
	select case (en%result_type)
	case (V_LOG); en%lval = en%arg1%lval
	case (V_INT); en%ival = en%arg1%ival
	case (V_REAL); en%rval = en%arg1%rval
	case (V_CMPLX); en%cval = en%arg1%cval
	case (V_PDG); en%aval = en%arg1%aval
	case (V_SEV); en%pval = en%arg1%pval
	case (V_STR); en%sval = en%arg1%sval
	end select
	end if
	else
	call eval_node_evaluate (en%arg2)
	en%value_is_known = en%arg2%value_is_known
	if (en%value_is_known) then
	select case (en%result_type)
	case (V_LOG); en%lval = en%arg2%lval
	case (V_INT); en%ival = en%arg2%ival
	case (V_REAL); en%rval = en%arg2%rval
	case (V_CMPLX); en%cval = en%arg2%cval
	case (V_PDG); en%aval = en%arg2%aval
	case (V_SEV); en%pval = en%arg2%pval
	case (V_STR); en%sval = en%arg2%sval
	end select
	end if
	end if
	end if
	case (EN_RECORD_CMD)
	exist = .true.
	en%lval = .false.
	call eval_node_evaluate (en%arg0)
	if (en%arg0%value_is_known) then
	if (associated (en%arg1)) then
	call eval_node_evaluate (en%arg1)
	if (en%arg1%value_is_known) then
	if (associated (en%arg2)) then
	call eval_node_evaluate (en%arg2)
	if (en%arg2%value_is_known) then
	if (associated (en%arg3)) then
	call eval_node_evaluate (en%arg3)
	if (en%arg3%value_is_known) then
	if (associated (en%arg4)) then
	call eval_node_evaluate (en%arg4)
	if (en%arg4%value_is_known) then
	if (associated (en%rval)) then
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	en%arg3%rval, en%arg4%rval, &
	weight=en%rval, exist=exist, &
	success=en%lval)
	else
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	en%arg3%rval, en%arg4%rval, &
	exist=exist, success=en%lval)
	end if
	end if
	else
	if (associated (en%rval)) then
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	en%arg3%rval, &
	weight=en%rval, exist=exist, &
	success=en%lval)
	else
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	en%arg3%rval, &
	exist=exist, success=en%lval)
	end if
	end if
	end if
	else
	if (associated (en%rval)) then
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	weight=en%rval, exist=exist, &
	success=en%lval)
	else
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, en%arg2%rval, &
	exist=exist, success=en%lval)
	end if
	end if
	end if
	else
	if (associated (en%rval)) then
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, &
	weight=en%rval, exist=exist, success=en%lval)
	else
	call analysis_record_data (en%arg0%sval, &
	en%arg1%rval, &
	exist=exist, success=en%lval)
	end if
	end if
	end if
	else
	if (associated (en%rval)) then
	call analysis_record_data (en%arg0%sval, 1._default, &
	weight=en%rval, exist=exist, success=en%lval)
	else
	call analysis_record_data (en%arg0%sval, 1._default, &
	exist=exist, success=en%lval)
	end if
	end if
	if (.not. exist) then
	call msg_error ("Analysis object '" // char (en%arg0%sval) &
	// "' is undefined")
	en%arg0%value_is_known = .false.
	end if
	end if
	case (EN_OBS1_INT)
	en%ival = en%obs1_int (en%prt1)
	en%value_is_known = .true.
	case (EN_OBS2_INT)
	en%ival = en%obs2_int (en%prt1, en%prt2)
	en%value_is_known = .true.
	case (EN_OBSEV_INT)
	en%ival = en%obsev_int (en%pval)
	en%value_is_known = .true.
	case (EN_OBS1_REAL)
	en%rval = en%obs1_real (en%prt1)
	en%value_is_known = .true.
	case (EN_OBS2_REAL)
	en%rval = en%obs2_real (en%prt1, en%prt2)
	en%value_is_known = .true.
	case (EN_OBSEV_REAL)
	en%rval = en%obsev_real (en%pval)
	en%value_is_known = .true.
	case (EN_PRT_FUN_UNARY)
	call eval_node_evaluate (en%arg1)
	en%value_is_known = en%arg1%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	call en%op1_sev (en%pval, en%arg1, en%arg0)
	else
	call en%op1_sev (en%pval, en%arg1)
	end if
	end if
	case (EN_PRT_FUN_BINARY)
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = &
	en%arg1%value_is_known .and. en%arg2%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%arg0%prt2 => en%prt2
	call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
	else
	call en%op2_sev (en%pval, en%arg1, en%arg2)
	end if
	end if
	case (EN_EVAL_FUN_UNARY)
	call eval_node_evaluate (en%arg1)
	- en%value_is_known = subevt_is_nonempty (en%arg1%pval)
	+ en%value_is_known = en%arg1%pval%is_nonempty ()
	if (en%value_is_known) then
	en%arg0%index => en%index
	en%index = 1
	en%arg0%prt1 => en%prt1
	- en%prt1 = subevt_get_prt (en%arg1%pval, 1)
	+ en%prt1 = en%arg1%pval%get_prt (1)
	call eval_node_evaluate (en%arg0)
	en%rval = en%arg0%rval
	end if
	case (EN_EVAL_FUN_BINARY)
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = &
	- subevt_is_nonempty (en%arg1%pval) .and. &
	- subevt_is_nonempty (en%arg2%pval)
	+ en%arg1%pval%is_nonempty () .and. en%arg2%pval%is_nonempty ()
	if (en%value_is_known) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%arg0%prt2 => en%prt2
	en%index = 1
	call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known)
	end if
	case (EN_LOG_FUN_UNARY)
	call eval_node_evaluate (en%arg1)
	en%value_is_known = .true.
	if (en%value_is_known) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%lval = en%op1_cut (en%arg1, en%arg0)
	end if
	case (EN_LOG_FUN_BINARY)
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = .true.
	if (en%value_is_known) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%arg0%prt2 => en%prt2
	en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0)
	end if
	case (EN_INT_FUN_UNARY)
	call eval_node_evaluate (en%arg1)
	en%value_is_known = en%arg1%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	call en%op1_evi (en%ival, en%arg1, en%arg0)
	else
	call en%op1_evi (en%ival, en%arg1)
	end if
	end if
	case (EN_INT_FUN_BINARY)
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = &
	en%arg1%value_is_known .and. &
	en%arg2%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%arg0%prt2 => en%prt2
	call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0)
	else
	call en%op2_evi (en%ival, en%arg1, en%arg2)
	end if
	end if
	case (EN_REAL_FUN_UNARY)
	call eval_node_evaluate (en%arg1)
	en%value_is_known = en%arg1%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	call en%op1_evr (en%rval, en%arg1, en%arg0)
	else
	call en%op1_evr (en%rval, en%arg1)
	end if
	end if
	case (EN_REAL_FUN_BINARY)
	call eval_node_evaluate (en%arg1)
	call eval_node_evaluate (en%arg2)
	en%value_is_known = &
	en%arg1%value_is_known .and. &
	en%arg2%value_is_known
	if (en%value_is_known) then
	if (associated (en%arg0)) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%arg0%prt2 => en%prt2
	call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0)
	else
	call en%op2_evr (en%rval, en%arg1, en%arg2)
	end if
	end if
	case (EN_REAL_FUN_CUM)
	call eval_node_evaluate (en%arg1)
	en%value_is_known = .true.
	if (en%value_is_known) then
	en%arg0%index => en%index
	en%arg0%prt1 => en%prt1
	en%rval = en%opcum_evr (en%arg1, en%arg0)
	end if
	case (EN_FORMAT_STR)
	if (associated (en%arg0)) then
	call eval_node_evaluate (en%arg0)
	en%value_is_known = en%arg0%value_is_known
	else
	en%value_is_known = .true.
	end if
	if (associated (en%arg1)) then
	call eval_node_evaluate (en%arg1)
	en%value_is_known = &
	en%value_is_known .and. en%arg1%value_is_known
	if (en%value_is_known) then
	call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1)
	end if
	else
	if (en%value_is_known) then
	call evaluate_sprintf (en%sval, en%ival, en%arg0)
	end if
	end if
	end select
	if (debug2_active (D_MODEL_F)) then
	print *, "eval_node_evaluate"
	call eval_node_write (en)
	end if
	end subroutine eval_node_evaluate

	@ %def eval_node_evaluate
	@
	\subsubsection{Test method}
	This is called from a unit test: initialize a particular observable.
	<<Eval trees: eval node: TBP>>=
	procedure :: test_obs => eval_node_test_obs
	<<Eval trees: procedures>>=
	subroutine eval_node_test_obs (node, var_list, var_name)
	class(eval_node_t), intent(inout) :: node
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: var_name
	procedure(obs_unary_int), pointer :: obs1_iptr
	type(prt_t), pointer :: p1
	call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
	call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1)
	end subroutine eval_node_test_obs

	@ %def eval_node_test_obs
	@
	\subsection{Evaluation syntax}
	We have two different flavors of the syntax: with and without particles.
	<<Eval trees: public>>=
	public :: syntax_expr
	public :: syntax_pexpr
	<<Eval trees: variables>>=
	type(syntax_t), target, save :: syntax_expr
	type(syntax_t), target, save :: syntax_pexpr

	@ %def syntax_expr syntax_pexpr
	@ These are for testing only and may be removed:
	<<Eval trees: public>>=
	public :: syntax_expr_init
	public :: syntax_pexpr_init
	<<Eval trees: procedures>>=
	subroutine syntax_expr_init ()
	type(ifile_t) :: ifile
	call define_expr_syntax (ifile, particles=.false., analysis=.false.)
	call syntax_init (syntax_expr, ifile)
	call ifile_final (ifile)
	end subroutine syntax_expr_init

	subroutine syntax_pexpr_init ()
	type(ifile_t) :: ifile
	call define_expr_syntax (ifile, particles=.true., analysis=.false.)
	call syntax_init (syntax_pexpr, ifile)
	call ifile_final (ifile)
	end subroutine syntax_pexpr_init

	@ %def syntax_expr_init syntax_pexpr_init
	<<Eval trees: public>>=
	public :: syntax_expr_final
	public :: syntax_pexpr_final
	<<Eval trees: procedures>>=
	subroutine syntax_expr_final ()
	call syntax_final (syntax_expr)
	end subroutine syntax_expr_final

	subroutine syntax_pexpr_final ()
	call syntax_final (syntax_pexpr)
	end subroutine syntax_pexpr_final

	@ %def syntax_expr_final syntax_pexpr_final
	<<Eval trees: public>>=
	public :: syntax_pexpr_write
	<<Eval trees: procedures>>=
	subroutine syntax_pexpr_write (unit)
	integer, intent(in), optional :: unit
	call syntax_write (syntax_pexpr, unit)
	end subroutine syntax_pexpr_write

	@ %def syntax_pexpr_write
	<<Eval trees: public>>=
	public :: define_expr_syntax
	@ Numeric expressions.
	<<Eval trees: procedures>>=
	subroutine define_expr_syntax (ifile, particles, analysis)
	type(ifile_t), intent(inout) :: ifile
	logical, intent(in) :: particles, analysis
	type(string_t) :: numeric_pexpr
	type(string_t) :: var_plist, var_alias
	if (particles) then
	numeric_pexpr = " \| numeric_pexpr"
	var_plist = " \| var_plist"
	var_alias = " \| var_alias"
	else
	numeric_pexpr = ""
	var_plist = ""
	var_alias = ""
	end if
	call ifile_append (ifile, "SEQ expr = subexpr addition*")
	call ifile_append (ifile, "ALT subexpr = addition \| term")
	call ifile_append (ifile, "SEQ addition = plus_or_minus term")
	call ifile_append (ifile, "SEQ term = factor multiplication*")
	call ifile_append (ifile, "SEQ multiplication = times_or_over factor")
	call ifile_append (ifile, "SEQ factor = value exponentiation?")
	call ifile_append (ifile, "SEQ exponentiation = to_the value")
	call ifile_append (ifile, "ALT plus_or_minus = '+' \| '-'")
	call ifile_append (ifile, "ALT times_or_over = '*' \| '/'")
	call ifile_append (ifile, "ALT to_the = '^' \| '**'")
	call ifile_append (ifile, "KEY '+'")
	call ifile_append (ifile, "KEY '-'")
	call ifile_append (ifile, "KEY '*'")
	call ifile_append (ifile, "KEY '/'")
	call ifile_append (ifile, "KEY '^'")
	call ifile_append (ifile, "KEY '**'")
	call ifile_append (ifile, "ALT value = signed_value \| unsigned_value")
	call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value")
	call ifile_append (ifile, "ALT unsigned_value = " // &
	"numeric_value \| constant \| variable \| " // &
	"result \| " // &
	"grouped_expr \| block_expr \| conditional_expr \| " // &
	"unary_function \| binary_function" // &
	numeric_pexpr)
	call ifile_append (ifile, "ALT numeric_value = integer_value \| " &
	// "real_value \| complex_value")
	call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?")
	call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?")
	call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?")
	call ifile_append (ifile, "INT integer_literal")
	call ifile_append (ifile, "REA real_literal")
	call ifile_append (ifile, "COM complex_literal")
	call ifile_append (ifile, "SEQ unit_expr = unit unit_power?")
	call ifile_append (ifile, "ALT unit = " // &
	"TeV \| GeV \| MeV \| keV \| eV \| meV \| " // &
	"nbarn \| pbarn \| fbarn \| abarn \| " // &
	"rad \| mrad \| degree \| '%'")
	call ifile_append (ifile, "KEY TeV")
	call ifile_append (ifile, "KEY GeV")
	call ifile_append (ifile, "KEY MeV")
	call ifile_append (ifile, "KEY keV")
	call ifile_append (ifile, "KEY eV")
	call ifile_append (ifile, "KEY meV")
	call ifile_append (ifile, "KEY nbarn")
	call ifile_append (ifile, "KEY pbarn")
	call ifile_append (ifile, "KEY fbarn")
	call ifile_append (ifile, "KEY abarn")
	call ifile_append (ifile, "KEY rad")
	call ifile_append (ifile, "KEY mrad")
	call ifile_append (ifile, "KEY degree")
	call ifile_append (ifile, "KEY '%'")
	call ifile_append (ifile, "SEQ unit_power = '^' frac_expr")
	call ifile_append (ifile, "ALT frac_expr = frac \| grouped_frac")
	call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )")
	call ifile_append (ifile, "SEQ frac = signed_int div?")
	call ifile_append (ifile, "ALT signed_int = " &
	// "neg_int \| pos_int \| integer_literal")
	call ifile_append (ifile, "SEQ neg_int = '-' integer_literal")
	call ifile_append (ifile, "SEQ pos_int = '+' integer_literal")
	call ifile_append (ifile, "SEQ div = '/' integer_literal")
	call ifile_append (ifile, "ALT constant = pi \| I")
	call ifile_append (ifile, "KEY pi")
	call ifile_append (ifile, "KEY I")
	call ifile_append (ifile, "IDE variable")
	call ifile_append (ifile, "SEQ result = result_key result_arg")
	call ifile_append (ifile, "ALT result_key = " // &
	"num_id \| integral \| error")
	call ifile_append (ifile, "KEY num_id")
	call ifile_append (ifile, "KEY integral")
	call ifile_append (ifile, "KEY error")
	call ifile_append (ifile, "GRO result_arg = ( process_id )")
	call ifile_append (ifile, "IDE process_id")
	call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1")
	call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2")
	call ifile_append (ifile, "ALT fun_unary = " // &
	"complex \| real \| int \| nint \| floor \| ceiling \| abs \| conjg \| sgn \| " // &
	"sqrt \| exp \| log \| log10 \| " // &
	"sin \| cos \| tan \| asin \| acos \| atan \| " // &
	"sinh \| cosh \| tanh \| asinh \| acosh \| atanh")
	call ifile_append (ifile, "KEY complex")
	call ifile_append (ifile, "KEY real")
	call ifile_append (ifile, "KEY int")
	call ifile_append (ifile, "KEY nint")
	call ifile_append (ifile, "KEY floor")
	call ifile_append (ifile, "KEY ceiling")
	call ifile_append (ifile, "KEY abs")
	call ifile_append (ifile, "KEY conjg")
	call ifile_append (ifile, "KEY sgn")
	call ifile_append (ifile, "KEY sqrt")
	call ifile_append (ifile, "KEY exp")
	call ifile_append (ifile, "KEY log")
	call ifile_append (ifile, "KEY log10")
	call ifile_append (ifile, "KEY sin")
	call ifile_append (ifile, "KEY cos")
	call ifile_append (ifile, "KEY tan")
	call ifile_append (ifile, "KEY asin")
	call ifile_append (ifile, "KEY acos")
	call ifile_append (ifile, "KEY atan")
	call ifile_append (ifile, "KEY sinh")
	call ifile_append (ifile, "KEY cosh")
	call ifile_append (ifile, "KEY tanh")
	call ifile_append (ifile, "KEY asinh")
	call ifile_append (ifile, "KEY acosh")
	call ifile_append (ifile, "KEY atanh")
	call ifile_append (ifile, "ALT fun_binary = max \| min \| mod \| modulo")
	call ifile_append (ifile, "KEY max")
	call ifile_append (ifile, "KEY min")
	call ifile_append (ifile, "KEY mod")
	call ifile_append (ifile, "KEY modulo")
	call ifile_append (ifile, "ARG function_arg1 = ( expr )")
	call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )")
	call ifile_append (ifile, "GRO grouped_expr = ( expr )")
	call ifile_append (ifile, "SEQ block_expr = let var_spec in expr")
	call ifile_append (ifile, "KEY let")
	call ifile_append (ifile, "ALT var_spec = " // &
	"var_num \| var_int \| var_real \| var_complex \| " // &
	"var_logical" // var_plist // var_alias // " \| var_string")
	call ifile_append (ifile, "SEQ var_num = var_name '=' expr")
	call ifile_append (ifile, "SEQ var_int = int var_name '=' expr")
	call ifile_append (ifile, "SEQ var_real = real var_name '=' expr")
	call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr")
	call ifile_append (ifile, "ALT complex_expr = " // &
	"cexpr_real \| cexpr_complex")
	call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )")
	call ifile_append (ifile, "SEQ cexpr_real = expr")
	call ifile_append (ifile, "IDE var_name")
	call ifile_append (ifile, "KEY '='")
	call ifile_append (ifile, "KEY in")
	call ifile_append (ifile, "SEQ conditional_expr = " // &
	"if lexpr then expr maybe_elsif_expr maybe_else_expr endif")
	call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*")
	call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?")
	call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr")
	call ifile_append (ifile, "SEQ else_expr = else expr")
	call ifile_append (ifile, "KEY if")
	call ifile_append (ifile, "KEY then")
	call ifile_append (ifile, "KEY elsif")
	call ifile_append (ifile, "KEY else")
	call ifile_append (ifile, "KEY endif")
	call define_lexpr_syntax (ifile, particles, analysis)
	call define_sexpr_syntax (ifile)
	if (particles) then
	call define_pexpr_syntax (ifile)
	call define_cexpr_syntax (ifile)
	call define_var_plist_syntax (ifile)
	call define_var_alias_syntax (ifile)
	call define_numeric_pexpr_syntax (ifile)
	call define_logical_pexpr_syntax (ifile)
	end if

	end subroutine define_expr_syntax

	@ %def define_expr_syntax
	@ Logical expressions.
	<<Eval trees: procedures>>=
	subroutine define_lexpr_syntax (ifile, particles, analysis)
	type(ifile_t), intent(inout) :: ifile
	logical, intent(in) :: particles, analysis
	type(string_t) :: logical_pexpr, record_cmd
	if (particles) then
	logical_pexpr = " \| logical_pexpr"
	else
	logical_pexpr = ""
	end if
	if (analysis) then
	record_cmd = " \| record_cmd"
	else
	record_cmd = ""
	end if
	call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*")
	call ifile_append (ifile, "SEQ lsequel = ';' lsinglet")
	call ifile_append (ifile, "SEQ lsinglet = lterm alternative*")
	call ifile_append (ifile, "SEQ alternative = or lterm")
	call ifile_append (ifile, "SEQ lterm = lvalue coincidence*")
	call ifile_append (ifile, "SEQ coincidence = and lvalue")
	call ifile_append (ifile, "KEY ';'")
	call ifile_append (ifile, "KEY or")
	call ifile_append (ifile, "KEY and")
	call ifile_append (ifile, "ALT lvalue = " // &
	"true \| false \| lvariable \| negation \| " // &
	"grouped_lexpr \| block_lexpr \| conditional_lexpr \| " // &
	"compared_expr \| compared_sexpr" // &
	logical_pexpr // record_cmd)
	call ifile_append (ifile, "KEY true")
	call ifile_append (ifile, "KEY false")
	call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable")
	call ifile_append (ifile, "KEY '?'")
	call ifile_append (ifile, "ALT alt_lvariable = variable \| grouped_lexpr")
	call ifile_append (ifile, "SEQ negation = not lvalue")
	call ifile_append (ifile, "KEY not")
	call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )")
	call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr")
	call ifile_append (ifile, "ALT var_logical = " // &
	"var_logical_new \| var_logical_spec")
	call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec")
	call ifile_append (ifile, "KEY logical")
	call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr")
	call ifile_append (ifile, "SEQ conditional_lexpr = " // &
	"if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif")
	call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*")
	call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?")
	call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr")
	call ifile_append (ifile, "SEQ else_lexpr = else lexpr")
	call ifile_append (ifile, "SEQ compared_expr = expr comparison+")
	call ifile_append (ifile, "SEQ comparison = compare expr")
	call ifile_append (ifile, "ALT compare = " // &
	"'<' \| '>' \| '<=' \| '>=' \| '==' \| '<>'")
	call ifile_append (ifile, "KEY '<'")
	call ifile_append (ifile, "KEY '>'")
	call ifile_append (ifile, "KEY '<='")
	call ifile_append (ifile, "KEY '>='")
	call ifile_append (ifile, "KEY '=='")
	call ifile_append (ifile, "KEY '<>'")
	call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+")
	call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr")
	call ifile_append (ifile, "ALT str_compare = '==' \| '<>'")
	if (analysis) then
	call ifile_append (ifile, "SEQ record_cmd = " // &
	"record_key analysis_tag record_arg?")
	call ifile_append (ifile, "ALT record_key = " // &
	"record \| record_unweighted \| record_excess")
	call ifile_append (ifile, "KEY record")
	call ifile_append (ifile, "KEY record_unweighted")
	call ifile_append (ifile, "KEY record_excess")
	call ifile_append (ifile, "ALT analysis_tag = analysis_id \| sexpr")
	call ifile_append (ifile, "IDE analysis_id")
	call ifile_append (ifile, "ARG record_arg = ( expr+ )")
	end if
	end subroutine define_lexpr_syntax

	@ %def define_lexpr_syntax
	@ String expressions.
	<<Eval trees: procedures>>=
	subroutine define_sexpr_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*")
	call ifile_append (ifile, "SEQ str_concatenation = '&' svalue")
	call ifile_append (ifile, "KEY '&'")
	call ifile_append (ifile, "ALT svalue = " // &
	"grouped_sexpr \| block_sexpr \| conditional_sexpr \| " // &
	"svariable \| string_function \| string_literal")
	call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )")
	call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr")
	call ifile_append (ifile, "SEQ conditional_sexpr = " // &
	"if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif")
	call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*")
	call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?")
	call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr")
	call ifile_append (ifile, "SEQ else_sexpr = else sexpr")
	call ifile_append (ifile, "SEQ svariable = '$' alt_svariable")
	call ifile_append (ifile, "KEY '$'")
	call ifile_append (ifile, "ALT alt_svariable = variable \| grouped_sexpr")
	call ifile_append (ifile, "ALT var_string = " // &
	"var_string_new \| var_string_spec")
	call ifile_append (ifile, "SEQ var_string_new = string var_string_spec")
	call ifile_append (ifile, "KEY string")
	call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $
	call ifile_append (ifile, "ALT string_function = sprintf_fun")
	call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?")
	call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr")
	call ifile_append (ifile, "KEY sprintf")
	call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )")
	call ifile_append (ifile, "ALT sprintf_arg = " &
	// "lvariable \| svariable \| expr")
	call ifile_append (ifile, "QUO string_literal = '""'...'""'")
	end subroutine define_sexpr_syntax

	@ %def define_sexpr_syntax
	@ Eval trees that evaluate to subevents.
	<<Eval trees: procedures>>=
	subroutine define_pexpr_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*")
	call ifile_append (ifile, "SEQ pconcatenation = '&' pterm")
	! call ifile_append (ifile, "KEY '&'") !!! (Key exists already)
	call ifile_append (ifile, "SEQ pterm = pvalue pcombination*")
	call ifile_append (ifile, "SEQ pcombination = '+' pvalue")
	! call ifile_append (ifile, "KEY '+'") !!! (Key exists already)
	call ifile_append (ifile, "ALT pvalue = " // &
	"pexpr_src \| pvariable \| " // &
	"grouped_pexpr \| block_pexpr \| conditional_pexpr \| " // &
	"prt_function")
	call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr")
	call ifile_append (ifile, "ALT prefix_cexpr = " // &
	"beam_prt \| incoming_prt \| outgoing_prt \| unspecified_prt")
	call ifile_append (ifile, "SEQ beam_prt = beam cexpr")
	call ifile_append (ifile, "KEY beam")
	call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr")
	call ifile_append (ifile, "KEY incoming")
	call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr")
	call ifile_append (ifile, "KEY outgoing")
	call ifile_append (ifile, "SEQ unspecified_prt = cexpr")
	call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable")
	call ifile_append (ifile, "KEY '@'")
	call ifile_append (ifile, "ALT alt_pvariable = variable \| grouped_pexpr")
	call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'")
	call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr")
	call ifile_append (ifile, "SEQ conditional_pexpr = " // &
	"if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif")
	call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*")
	call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?")
	call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr")
	call ifile_append (ifile, "SEQ else_pexpr = else pexpr")
	call ifile_append (ifile, "ALT prt_function = " // &
	"join_fun \| combine_fun \| collect_fun \| cluster_fun \| " // &
	"photon_reco_fun \| " // &
	"select_fun \| extract_fun \| sort_fun \| " // &
	"select_b_jet_fun \| select_non_b_jet_fun \| " // &
	"select_c_jet_fun \| select_light_jet_fun")
	call ifile_append (ifile, "SEQ join_fun = join_clause pargs2")
	call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2")
	call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1")
	call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1")
	call ifile_append (ifile, "SEQ photon_reco_fun = photon_reco_clause pargs1")
	call ifile_append (ifile, "SEQ select_fun = select_clause pargs1")
	call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1")
	call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1")
	call ifile_append (ifile, "SEQ select_b_jet_fun = " // &
	"select_b_jet_clause pargs1")
	call ifile_append (ifile, "SEQ select_non_b_jet_fun = " // &
	"select_non_b_jet_clause pargs1")
	call ifile_append (ifile, "SEQ select_c_jet_fun = " // &
	"select_c_jet_clause pargs1")
	call ifile_append (ifile, "SEQ select_light_jet_fun = " // &
	"select_light_jet_clause pargs1")
	call ifile_append (ifile, "SEQ join_clause = join condition?")
	call ifile_append (ifile, "SEQ combine_clause = combine condition?")
	call ifile_append (ifile, "SEQ collect_clause = collect condition?")
	call ifile_append (ifile, "SEQ cluster_clause = cluster condition?")
	call ifile_append (ifile, "SEQ photon_reco_clause = photon_recombination condition?")
	call ifile_append (ifile, "SEQ select_clause = select condition?")
	call ifile_append (ifile, "SEQ extract_clause = extract position?")
	call ifile_append (ifile, "SEQ sort_clause = sort criterion?")
	call ifile_append (ifile, "SEQ select_b_jet_clause = " // &
	"select_b_jet condition?")
	call ifile_append (ifile, "SEQ select_non_b_jet_clause = " // &
	"select_non_b_jet condition?")
	call ifile_append (ifile, "SEQ select_c_jet_clause = " // &
	"select_c_jet condition?")
	call ifile_append (ifile, "SEQ select_light_jet_clause = " // &
	"select_light_jet condition?")
	call ifile_append (ifile, "KEY join")
	call ifile_append (ifile, "KEY combine")
	call ifile_append (ifile, "KEY collect")
	call ifile_append (ifile, "KEY cluster")
	call ifile_append (ifile, "KEY photon_recombination")
	call ifile_append (ifile, "KEY select")
	call ifile_append (ifile, "SEQ condition = if lexpr")
	call ifile_append (ifile, "KEY extract")
	call ifile_append (ifile, "SEQ position = index expr")
	call ifile_append (ifile, "KEY sort")
	call ifile_append (ifile, "KEY select_b_jet")
	call ifile_append (ifile, "KEY select_non_b_jet")
	call ifile_append (ifile, "KEY select_c_jet")
	call ifile_append (ifile, "KEY select_light_jet")
	call ifile_append (ifile, "SEQ criterion = by expr")
	call ifile_append (ifile, "KEY index")
	call ifile_append (ifile, "KEY by")
	call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'")
	call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'")
	end subroutine define_pexpr_syntax

	@ %def define_pexpr_syntax
	@ Eval trees that evaluate to PDG-code arrays.
	<<Eval trees: procedures>>=
	subroutine define_cexpr_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ cexpr = avalue concatenation*")
	call ifile_append (ifile, "SEQ concatenation = ':' avalue")
	call ifile_append (ifile, "KEY ':'")
	call ifile_append (ifile, "ALT avalue = " // &
	"grouped_cexpr \| block_cexpr \| conditional_cexpr \| " // &
	"variable \| pdg_code \| prt_name")
	call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )")
	call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr")
	call ifile_append (ifile, "SEQ conditional_cexpr = " // &
	"if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif")
	call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*")
	call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?")
	call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr")
	call ifile_append (ifile, "SEQ else_cexpr = else cexpr")
	call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg")
	call ifile_append (ifile, "KEY pdg")
	call ifile_append (ifile, "ARG pdg_arg = ( expr )")
	call ifile_append (ifile, "QUO prt_name = '""'...'""'")
	end subroutine define_cexpr_syntax

	@ %def define_cexpr_syntax
	@ Extra variable types.
	<<Eval trees: procedures>>=
	subroutine define_var_plist_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "ALT var_plist = var_plist_new \| var_plist_spec")
	call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec")
	call ifile_append (ifile, "KEY subevt")
	call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr")
	end subroutine define_var_plist_syntax

	subroutine define_var_alias_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr")
	call ifile_append (ifile, "KEY alias")
	end subroutine define_var_alias_syntax

	@ %def define_var_plist_syntax define_var_alias_syntax
	@ Particle-list expressions that evaluate to numeric values
	<<Eval trees: procedures>>=
	subroutine define_numeric_pexpr_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "ALT numeric_pexpr = " &
	// "eval_fun \| count_fun \| sum_fun \| " &
	// "prod_fun")
	call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1")
	call ifile_append (ifile, "SEQ count_fun = count_clause pargs1")
	call ifile_append (ifile, "SEQ count_clause = count condition?")
	call ifile_append (ifile, "SEQ sum_fun = sum expr pargs1")
	call ifile_append (ifile, "SEQ prod_fun = prod expr pargs1")
	call ifile_append (ifile, "KEY eval")
	call ifile_append (ifile, "KEY count")
	call ifile_append (ifile, "KEY sum")
	call ifile_append (ifile, "KEY prod")
	end subroutine define_numeric_pexpr_syntax

	@ %def define_numeric_pexpr_syntax
	@ Particle-list functions that evaluate to logical values.
	<<Eval trees: procedures>>=
	subroutine define_logical_pexpr_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "ALT logical_pexpr = " // &
	"all_fun \| any_fun \| no_fun \| " // &
	"photon_isolation_fun")
	call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1")
	call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1")
	call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1")
	call ifile_append (ifile, "SEQ photon_isolation_fun = " // &
	"photon_isolation_clause pargs2")
	call ifile_append (ifile, "SEQ photon_isolation_clause = " // &
	"photon_isolation condition?")
	call ifile_append (ifile, "KEY all")
	call ifile_append (ifile, "KEY any")
	call ifile_append (ifile, "KEY no")
	call ifile_append (ifile, "KEY photon_isolation")
	end subroutine define_logical_pexpr_syntax

	@ %def define_logical_pexpr_syntax
	@ All characters that can occur in expressions (apart from alphanumeric).
	<<Eval trees: procedures>>=
	subroutine lexer_init_eval_tree (lexer, particles)
	type(lexer_t), intent(out) :: lexer
	logical, intent(in) :: particles
	type(keyword_list_t), pointer :: keyword_list
	if (particles) then
	keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr)
	else
	keyword_list => syntax_get_keyword_list_ptr (syntax_expr)
	end if
	call lexer_init (lexer, &
	comment_chars = "#!", &
	quote_chars = '"', &
	quote_match = '"', &
	single_chars = "()[],;:&%?$@", &
	special_class = [ "+-*/^", "<>=~ " ] , &
	keyword_list = keyword_list)
	end subroutine lexer_init_eval_tree

	@ %def lexer_init_eval_tree
	@
	\subsection{Set up appropriate parse trees}
	Parse an input stream as a specific flavor of expression. The
	appropriate expression syntax has to be available.
	<<Eval trees: public>>=
	public :: parse_tree_init_expr
	public :: parse_tree_init_lexpr
	public :: parse_tree_init_pexpr
	public :: parse_tree_init_cexpr
	public :: parse_tree_init_sexpr
	<<Eval trees: procedures>>=
	subroutine parse_tree_init_expr (parse_tree, stream, particles)
	type(parse_tree_t), intent(out) :: parse_tree
	type(stream_t), intent(inout), target :: stream
	logical, intent(in) :: particles
	type(lexer_t) :: lexer
	call lexer_init_eval_tree (lexer, particles)
	call lexer_assign_stream (lexer, stream)
	if (particles) then
	call parse_tree_init &
	(parse_tree, syntax_pexpr, lexer, var_str ("expr"))
	else
	call parse_tree_init &
	(parse_tree, syntax_expr, lexer, var_str ("expr"))
	end if
	call lexer_final (lexer)
	end subroutine parse_tree_init_expr

	subroutine parse_tree_init_lexpr (parse_tree, stream, particles)
	type(parse_tree_t), intent(out) :: parse_tree
	type(stream_t), intent(inout), target :: stream
	logical, intent(in) :: particles
	type(lexer_t) :: lexer
	call lexer_init_eval_tree (lexer, particles)
	call lexer_assign_stream (lexer, stream)
	if (particles) then
	call parse_tree_init &
	(parse_tree, syntax_pexpr, lexer, var_str ("lexpr"))
	else
	call parse_tree_init &
	(parse_tree, syntax_expr, lexer, var_str ("lexpr"))
	end if
	call lexer_final (lexer)
	end subroutine parse_tree_init_lexpr

	subroutine parse_tree_init_pexpr (parse_tree, stream)
	type(parse_tree_t), intent(out) :: parse_tree
	type(stream_t), intent(inout), target :: stream
	type(lexer_t) :: lexer
	call lexer_init_eval_tree (lexer, .true.)
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init &
	(parse_tree, syntax_pexpr, lexer, var_str ("pexpr"))
	call lexer_final (lexer)
	end subroutine parse_tree_init_pexpr

	subroutine parse_tree_init_cexpr (parse_tree, stream)
	type(parse_tree_t), intent(out) :: parse_tree
	type(stream_t), intent(inout), target :: stream
	type(lexer_t) :: lexer
	call lexer_init_eval_tree (lexer, .true.)
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init &
	(parse_tree, syntax_pexpr, lexer, var_str ("cexpr"))
	call lexer_final (lexer)
	end subroutine parse_tree_init_cexpr

	subroutine parse_tree_init_sexpr (parse_tree, stream, particles)
	type(parse_tree_t), intent(out) :: parse_tree
	type(stream_t), intent(inout), target :: stream
	logical, intent(in) :: particles
	type(lexer_t) :: lexer
	call lexer_init_eval_tree (lexer, particles)
	call lexer_assign_stream (lexer, stream)
	if (particles) then
	call parse_tree_init &
	(parse_tree, syntax_pexpr, lexer, var_str ("sexpr"))
	else
	call parse_tree_init &
	(parse_tree, syntax_expr, lexer, var_str ("sexpr"))
	end if
	call lexer_final (lexer)
	end subroutine parse_tree_init_sexpr

	@ %def parse_tree_init_expr
	@ %def parse_tree_init_lexpr
	@ %def parse_tree_init_pexpr
	@ %def parse_tree_init_cexpr
	@ %def parse_tree_init_sexpr
	@
	\subsection{The evaluation tree}
	The evaluation tree contains the initial variable list and the root node.
	<<Eval trees: public>>=
	public :: eval_tree_t
	<<Eval trees: types>>=
	type, extends (expr_t) :: eval_tree_t
	private
	type(parse_node_t), pointer :: pn => null ()
	type(var_list_t) :: var_list
	type(eval_node_t), pointer :: root => null ()
	contains
	<<Eval trees: eval tree: TBP>>
	end type eval_tree_t

	@ %def eval_tree_t
	@ Init from stream, using a temporary parse tree.
	<<Eval trees: eval tree: TBP>>=
	procedure :: init_stream => eval_tree_init_stream
	<<Eval trees: procedures>>=
	subroutine eval_tree_init_stream &
	(eval_tree, stream, var_list, subevt, result_type)
	class(eval_tree_t), intent(out), target :: eval_tree
	type(stream_t), intent(inout), target :: stream
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), target, optional :: subevt
	integer, intent(in), optional :: result_type
	type(parse_tree_t) :: parse_tree
	type(parse_node_t), pointer :: nd_root
	integer :: type
	type = V_REAL; if (present (result_type)) type = result_type
	select case (type)
	case (V_INT, V_REAL, V_CMPLX)
	call parse_tree_init_expr (parse_tree, stream, present (subevt))
	case (V_LOG)
	call parse_tree_init_lexpr (parse_tree, stream, present (subevt))
	case (V_SEV)
	call parse_tree_init_pexpr (parse_tree, stream)
	case (V_PDG)
	call parse_tree_init_cexpr (parse_tree, stream)
	case (V_STR)
	call parse_tree_init_sexpr (parse_tree, stream, present (subevt))
	end select
	nd_root => parse_tree%get_root_ptr ()
	if (associated (nd_root)) then
	select case (type)
	case (V_INT, V_REAL, V_CMPLX)
	call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt)
	case (V_LOG)
	call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt)
	case (V_SEV)
	call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt)
	case (V_PDG)
	call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt)
	case (V_STR)
	call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt)
	end select
	end if
	call parse_tree_final (parse_tree)
	end subroutine eval_tree_init_stream

	@ %def eval_tree_init_stream
	@ API (to be superseded by the methods below): Init from a given parse-tree
	node. If we evaluate an expression that contains particle-list references,
	the original subevent has to be supplied. The initial variable list is
	optional.
	<<Eval trees: eval tree: TBP>>=
	procedure :: init_expr => eval_tree_init_expr
	procedure :: init_lexpr => eval_tree_init_lexpr
	procedure :: init_pexpr => eval_tree_init_pexpr
	procedure :: init_cexpr => eval_tree_init_cexpr
	procedure :: init_sexpr => eval_tree_init_sexpr
	<<Eval trees: procedures>>=
	subroutine eval_tree_init_expr &
	(expr, parse_node, var_list, subevt)
	class(eval_tree_t), intent(out), target :: expr
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	call eval_tree_link_var_list (expr, var_list)
	if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
	call eval_node_compile_expr &
	(expr%root, parse_node, expr%var_list)
	end subroutine eval_tree_init_expr

	subroutine eval_tree_init_lexpr &
	(expr, parse_node, var_list, subevt)
	class(eval_tree_t), intent(out), target :: expr
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	call eval_tree_link_var_list (expr, var_list)
	if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
	call eval_node_compile_lexpr &
	(expr%root, parse_node, expr%var_list)
	end subroutine eval_tree_init_lexpr

	subroutine eval_tree_init_pexpr &
	(expr, parse_node, var_list, subevt)
	class(eval_tree_t), intent(out), target :: expr
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	call eval_tree_link_var_list (expr, var_list)
	if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
	call eval_node_compile_pexpr &
	(expr%root, parse_node, expr%var_list)
	end subroutine eval_tree_init_pexpr

	subroutine eval_tree_init_cexpr &
	(expr, parse_node, var_list, subevt)
	class(eval_tree_t), intent(out), target :: expr
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	call eval_tree_link_var_list (expr, var_list)
	if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
	call eval_node_compile_cexpr &
	(expr%root, parse_node, expr%var_list)
	end subroutine eval_tree_init_cexpr

	subroutine eval_tree_init_sexpr &
	(expr, parse_node, var_list, subevt)
	class(eval_tree_t), intent(out), target :: expr
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	call eval_tree_link_var_list (expr, var_list)
	if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
	call eval_node_compile_sexpr &
	(expr%root, parse_node, expr%var_list)
	end subroutine eval_tree_init_sexpr

	@ %def eval_tree_init_expr
	@ %def eval_tree_init_lexpr
	@ %def eval_tree_init_pexpr
	@ %def eval_tree_init_cexpr
	@ %def eval_tree_init_sexpr
	@ Alternative: set up the expression using the parse node that has already
	been stored. We assume that the [[subevt]] or any other variable that
	may be referred to has already been added to the local variable list.
	<<Eval trees: eval tree: TBP>>=
	procedure :: setup_expr => eval_tree_setup_expr
	procedure :: setup_lexpr => eval_tree_setup_lexpr
	procedure :: setup_pexpr => eval_tree_setup_pexpr
	procedure :: setup_cexpr => eval_tree_setup_cexpr
	procedure :: setup_sexpr => eval_tree_setup_sexpr
	<<Eval trees: procedures>>=
	subroutine eval_tree_setup_expr (expr, vars)
	class(eval_tree_t), intent(inout), target :: expr
	class(vars_t), intent(in), target :: vars
	call eval_tree_link_var_list (expr, vars)
	call eval_node_compile_expr (expr%root, expr%pn, expr%var_list)
	end subroutine eval_tree_setup_expr

	subroutine eval_tree_setup_lexpr (expr, vars)
	class(eval_tree_t), intent(inout), target :: expr
	class(vars_t), intent(in), target :: vars
	call eval_tree_link_var_list (expr, vars)
	call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list)
	end subroutine eval_tree_setup_lexpr

	subroutine eval_tree_setup_pexpr (expr, vars)
	class(eval_tree_t), intent(inout), target :: expr
	class(vars_t), intent(in), target :: vars
	call eval_tree_link_var_list (expr, vars)
	call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list)
	end subroutine eval_tree_setup_pexpr

	subroutine eval_tree_setup_cexpr (expr, vars)
	class(eval_tree_t), intent(inout), target :: expr
	class(vars_t), intent(in), target :: vars
	call eval_tree_link_var_list (expr, vars)
	call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list)
	end subroutine eval_tree_setup_cexpr

	subroutine eval_tree_setup_sexpr (expr, vars)
	class(eval_tree_t), intent(inout), target :: expr
	class(vars_t), intent(in), target :: vars
	call eval_tree_link_var_list (expr, vars)
	call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list)
	end subroutine eval_tree_setup_sexpr

	@ %def eval_tree_setup_expr
	@ %def eval_tree_setup_lexpr
	@ %def eval_tree_setup_pexpr
	@ %def eval_tree_setup_cexpr
	@ %def eval_tree_setup_sexpr
	@ This extra API function handles numerical constant expressions only.
	The only nontrivial part is the optional unit.
	<<Eval trees: eval tree: TBP>>=
	procedure :: init_numeric_value => eval_tree_init_numeric_value
	<<Eval trees: procedures>>=
	subroutine eval_tree_init_numeric_value (eval_tree, parse_node)
	class(eval_tree_t), intent(out), target :: eval_tree
	type(parse_node_t), intent(in), target :: parse_node
	call eval_node_compile_numeric_value (eval_tree%root, parse_node)
	end subroutine eval_tree_init_numeric_value

	@ %def eval_tree_init_numeric_value
	@ Initialize the variable list, linking it to a context variable list.
	<<Eval trees: procedures>>=
	subroutine eval_tree_link_var_list (eval_tree, vars)
	type(eval_tree_t), intent(inout), target :: eval_tree
	class(vars_t), intent(in), target :: vars
	call eval_tree%var_list%link (vars)
	end subroutine eval_tree_link_var_list

	@ %def eval_tree_link_var_list
	@ Include a subevent object in the initialization. We add a pointer
	to this as variable [[@evt]] in the local variable list.
	<<Eval trees: procedures>>=
	subroutine eval_tree_set_subevt (eval_tree, subevt)
	type(eval_tree_t), intent(inout), target :: eval_tree
	type(subevt_t), intent(in), target :: subevt
	logical, save, target :: known = .true.
	call var_list_append_subevt_ptr &
	(eval_tree%var_list, var_str ("@evt"), subevt, known, &
	intrinsic=.true.)
	end subroutine eval_tree_set_subevt

	@ %def eval_tree_set_subevt
	@ Finalizer.
	<<Eval trees: eval tree: TBP>>=
	procedure :: final => eval_tree_final
	<<Eval trees: procedures>>=
	subroutine eval_tree_final (expr)
	class(eval_tree_t), intent(inout) :: expr
	call expr%var_list%final ()
	if (associated (expr%root)) then
	call eval_node_final_rec (expr%root)
	deallocate (expr%root)
	end if
	end subroutine eval_tree_final

	@ %def eval_tree_final
	@
	<<Eval trees: eval tree: TBP>>=
	procedure :: evaluate => eval_tree_evaluate
	<<Eval trees: procedures>>=
	subroutine eval_tree_evaluate (expr)
	class(eval_tree_t), intent(inout) :: expr
	if (associated (expr%root)) then
	call eval_node_evaluate (expr%root)
	end if
	end subroutine eval_tree_evaluate

	@ %def eval_tree_evaluate
	@ Check if the eval tree is allocated.
	<<Eval trees: procedures>>=
	function eval_tree_is_defined (eval_tree) result (flag)
	logical :: flag
	type(eval_tree_t), intent(in) :: eval_tree
	flag = associated (eval_tree%root)
	end function eval_tree_is_defined

	@ %def eval_tree_is_defined
	@ Check if the eval tree result is constant.
	<<Eval trees: procedures>>=
	function eval_tree_is_constant (eval_tree) result (flag)
	logical :: flag
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	flag = eval_tree%root%type == EN_CONSTANT
	else
	flag = .false.
	end if
	end function eval_tree_is_constant

	@ %def eval_tree_is_constant
	@ Insert a conversion node at the root, if necessary (only for
	real/int conversion)
	<<Eval trees: procedures>>=
	subroutine eval_tree_convert_result (eval_tree, result_type)
	type(eval_tree_t), intent(inout) :: eval_tree
	integer, intent(in) :: result_type
	if (associated (eval_tree%root)) then
	call insert_conversion_node (eval_tree%root, result_type)
	end if
	end subroutine eval_tree_convert_result

	@ %def eval_tree_convert_result
	@ Return the value of the top node, after evaluation. If the tree is
	empty, return the type of [[V_NONE]]. When extracting the value, no
	check for existence is done. For numeric values, the functions are
	safe against real/integer mismatch.
	<<Eval trees: eval tree: TBP>>=
	procedure :: is_known => eval_tree_result_is_known
	procedure :: get_log => eval_tree_get_log
	procedure :: get_int => eval_tree_get_int
	procedure :: get_real => eval_tree_get_real
	procedure :: get_cmplx => eval_tree_get_cmplx
	procedure :: get_pdg_array => eval_tree_get_pdg_array
	procedure :: get_subevt => eval_tree_get_subevt
	procedure :: get_string => eval_tree_get_string
	<<Eval trees: procedures>>=
	function eval_tree_get_result_type (expr) result (type)
	integer :: type
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	type = expr%root%result_type
	else
	type = V_NONE
	end if
	end function eval_tree_get_result_type

	function eval_tree_result_is_known (expr) result (flag)
	logical :: flag
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	select case (expr%root%result_type)
	case (V_LOG, V_INT, V_REAL)
	flag = expr%root%value_is_known
	case default
	flag = .true.
	end select
	else
	flag = .false.
	end if
	end function eval_tree_result_is_known

	function eval_tree_result_is_known_ptr (expr) result (ptr)
	logical, pointer :: ptr
	class(eval_tree_t), intent(in) :: expr
	logical, target, save :: known = .true.
	if (associated (expr%root)) then
	select case (expr%root%result_type)
	case (V_LOG, V_INT, V_REAL)
	ptr => expr%root%value_is_known
	case default
	ptr => known
	end select
	else
	ptr => null ()
	end if
	end function eval_tree_result_is_known_ptr

	function eval_tree_get_log (expr) result (lval)
	logical :: lval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) lval = expr%root%lval
	end function eval_tree_get_log

	function eval_tree_get_int (expr) result (ival)
	integer :: ival
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	select case (expr%root%result_type)
	case (V_INT); ival = expr%root%ival
	case (V_REAL); ival = expr%root%rval
	case (V_CMPLX); ival = expr%root%cval
	end select
	end if
	end function eval_tree_get_int

	function eval_tree_get_real (expr) result (rval)
	real(default) :: rval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	select case (expr%root%result_type)
	case (V_REAL); rval = expr%root%rval
	case (V_INT); rval = expr%root%ival
	case (V_CMPLX); rval = expr%root%cval
	end select
	end if
	end function eval_tree_get_real

	function eval_tree_get_cmplx (expr) result (cval)
	complex(default) :: cval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	select case (expr%root%result_type)
	case (V_CMPLX); cval = expr%root%cval
	case (V_REAL); cval = expr%root%rval
	case (V_INT); cval = expr%root%ival
	end select
	end if
	end function eval_tree_get_cmplx

	function eval_tree_get_pdg_array (expr) result (aval)
	type(pdg_array_t) :: aval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	aval = expr%root%aval
	end if
	end function eval_tree_get_pdg_array

	function eval_tree_get_subevt (expr) result (pval)
	type(subevt_t) :: pval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	pval = expr%root%pval
	end if
	end function eval_tree_get_subevt

	function eval_tree_get_string (expr) result (sval)
	type(string_t) :: sval
	class(eval_tree_t), intent(in) :: expr
	if (associated (expr%root)) then
	sval = expr%root%sval
	end if
	end function eval_tree_get_string

	@ %def eval_tree_get_result_type
	@ %def eval_tree_result_is_known
	@ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real
	@ %def eval_tree_get_cmplx
	@ %def eval_tree_get_pdg_expr
	@ %def eval_tree_get_pdg_array
	@ %def eval_tree_get_subevt
	@ %def eval_tree_get_string
	@ Return a pointer to the value of the top node.
	<<Eval trees: procedures>>=
	function eval_tree_get_log_ptr (eval_tree) result (lval)
	logical, pointer :: lval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	lval => eval_tree%root%lval
	else
	lval => null ()
	end if
	end function eval_tree_get_log_ptr

	function eval_tree_get_int_ptr (eval_tree) result (ival)
	integer, pointer :: ival
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	ival => eval_tree%root%ival
	else
	ival => null ()
	end if
	end function eval_tree_get_int_ptr

	function eval_tree_get_real_ptr (eval_tree) result (rval)
	real(default), pointer :: rval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	rval => eval_tree%root%rval
	else
	rval => null ()
	end if
	end function eval_tree_get_real_ptr

	function eval_tree_get_cmplx_ptr (eval_tree) result (cval)
	complex(default), pointer :: cval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	cval => eval_tree%root%cval
	else
	cval => null ()
	end if
	end function eval_tree_get_cmplx_ptr

	function eval_tree_get_subevt_ptr (eval_tree) result (pval)
	type(subevt_t), pointer :: pval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	pval => eval_tree%root%pval
	else
	pval => null ()
	end if
	end function eval_tree_get_subevt_ptr

	function eval_tree_get_pdg_array_ptr (eval_tree) result (aval)
	type(pdg_array_t), pointer :: aval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	aval => eval_tree%root%aval
	else
	aval => null ()
	end if
	end function eval_tree_get_pdg_array_ptr

	function eval_tree_get_string_ptr (eval_tree) result (sval)
	type(string_t), pointer :: sval
	type(eval_tree_t), intent(in) :: eval_tree
	if (associated (eval_tree%root)) then
	sval => eval_tree%root%sval
	else
	sval => null ()
	end if
	end function eval_tree_get_string_ptr

	@ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr
	@ %def eval_tree_get_cmplx_ptr
	@ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr
	@ %def eval_tree_get_string_ptr
	<<Eval trees: eval tree: TBP>>=
	procedure :: write => eval_tree_write
	<<Eval trees: procedures>>=
	subroutine eval_tree_write (expr, unit, write_vars)
	class(eval_tree_t), intent(in) :: expr
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: write_vars
	integer :: u
	logical :: vl
	u = given_output_unit (unit); if (u < 0) return
	vl = .false.; if (present (write_vars)) vl = write_vars
	write (u, "(1x,A)") "Evaluation tree:"
	if (associated (expr%root)) then
	call eval_node_write_rec (expr%root, unit)
	else
	write (u, "(3x,A)") "[empty]"
	end if
	if (vl) call var_list_write (expr%var_list, unit)
	end subroutine eval_tree_write

	@ %def eval_tree_write
	@ Use the written representation for generating an MD5 sum:
	<<Eval trees: procedures>>=
	function eval_tree_get_md5sum (eval_tree) result (md5sum_et)
	character(32) :: md5sum_et
	type(eval_tree_t), intent(in) :: eval_tree
	integer :: u
	u = free_unit ()
	open (unit = u, status = "scratch", action = "readwrite")
	call eval_tree_write (eval_tree, unit=u)
	rewind (u)
	md5sum_et = md5sum (u)
	close (u)
	end function eval_tree_get_md5sum

	@ %def eval_tree_get_md5sum
	@
	\subsection{Direct evaluation}
	These procedures create an eval tree and evaluate it on-the-fly, returning
	only the final value. The evaluation must yield a well-defined value, unless
	the [[is_known]] flag is present, which will be set accordingly.
	<<Eval trees: public>>=
	public :: eval_log
	public :: eval_int
	public :: eval_real
	public :: eval_cmplx
	public :: eval_subevt
	public :: eval_pdg_array
	public :: eval_string
	<<Eval trees: procedures>>=
	function eval_log &
	(parse_node, var_list, subevt, is_known) result (lval)
	logical :: lval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_lexpr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	lval = eval_tree_get_log (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	lval = .false.
	end if
	call eval_tree_final (eval_tree)
	end function eval_log

	function eval_int &
	(parse_node, var_list, subevt, is_known) result (ival)
	integer :: ival
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_expr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	ival = eval_tree_get_int (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	ival = 0
	end if
	call eval_tree_final (eval_tree)
	end function eval_int

	function eval_real &
	(parse_node, var_list, subevt, is_known) result (rval)
	real(default) :: rval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_expr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	rval = eval_tree_get_real (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	rval = 0
	end if
	call eval_tree_final (eval_tree)
	end function eval_real

	function eval_cmplx &
	(parse_node, var_list, subevt, is_known) result (cval)
	complex(default) :: cval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_expr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	cval = eval_tree_get_cmplx (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	cval = 0
	end if
	call eval_tree_final (eval_tree)
	end function eval_cmplx

	function eval_subevt &
	(parse_node, var_list, subevt, is_known) result (pval)
	type(subevt_t) :: pval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_pexpr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	pval = eval_tree_get_subevt (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	end if
	call eval_tree_final (eval_tree)
	end function eval_subevt

	function eval_pdg_array &
	(parse_node, var_list, subevt, is_known) result (aval)
	type(pdg_array_t) :: aval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_cexpr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	aval = eval_tree_get_pdg_array (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	end if
	call eval_tree_final (eval_tree)
	end function eval_pdg_array

	function eval_string &
	(parse_node, var_list, subevt, is_known) result (sval)
	type(string_t) :: sval
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	logical, intent(out), optional :: is_known
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_sexpr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (is_known)) is_known = .true.
	sval = eval_tree_get_string (eval_tree)
	else if (present (is_known)) then
	is_known = .false.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	sval = ""
	end if
	call eval_tree_final (eval_tree)
	end function eval_string

	@ %def eval_log eval_int eval_real eval_cmplx
	@ %def eval_subevt eval_pdg_array eval_string
	@ %def eval_tree_unknown
	@ Here is a variant that returns numeric values of all possible kinds, the
	appropriate kind to be selected later:
	<<Eval trees: public>>=
	public :: eval_numeric
	<<Eval trees: procedures>>=
	subroutine eval_numeric &
	(parse_node, var_list, subevt, ival, rval, cval, &
	is_known, result_type)
	type(parse_node_t), intent(in), target :: parse_node
	type(var_list_t), intent(in), target :: var_list
	type(subevt_t), intent(in), optional, target :: subevt
	integer, intent(out), optional :: ival
	real(default), intent(out), optional :: rval
	complex(default), intent(out), optional :: cval
	logical, intent(out), optional :: is_known
	integer, intent(out), optional :: result_type
	type(eval_tree_t), target :: eval_tree
	call eval_tree_init_expr &
	(eval_tree, parse_node, var_list, subevt)
	call eval_tree_evaluate (eval_tree)
	if (eval_tree_result_is_known (eval_tree)) then
	if (present (ival)) ival = eval_tree_get_int (eval_tree)
	if (present (rval)) rval = eval_tree_get_real (eval_tree)
	if (present (cval)) cval = eval_tree_get_cmplx (eval_tree)
	if (present (is_known)) is_known = .true.
	else
	call eval_tree_unknown (eval_tree, parse_node)
	if (present (ival)) ival = 0
	if (present (rval)) rval = 0
	if (present (cval)) cval = 0
	if (present (is_known)) is_known = .false.
	end if
	if (present (result_type)) &
	result_type = eval_tree_get_result_type (eval_tree)
	call eval_tree_final (eval_tree)
	end subroutine eval_numeric

	@ %def eval_numeric
	@ Error message with debugging info:
	<<Eval trees: procedures>>=
	subroutine eval_tree_unknown (eval_tree, parse_node)
	type(eval_tree_t), intent(in) :: eval_tree
	type(parse_node_t), intent(in) :: parse_node
	call parse_node_write_rec (parse_node)
	call eval_tree_write (eval_tree)
	call msg_error ("Evaluation yields an undefined result, inserting default")
	end subroutine eval_tree_unknown

	@ %def eval_tree_unknown
	@
	\subsection{Factory Type}
	Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a
	matching factory type and build method.
	<<Eval trees: public>>=
	public :: eval_tree_factory_t
	<<Eval trees: types>>=
	type, extends (expr_factory_t) :: eval_tree_factory_t
	private
	type(parse_node_t), pointer :: pn => null ()
	contains
	<<Eval trees: eval tree factory: TBP>>
	end type eval_tree_factory_t

	@ %def eval_tree_factory_t
	@ Output: delegate to the output of the embedded parse node.
	<<Eval trees: eval tree factory: TBP>>=
	procedure :: write => eval_tree_factory_write
	<<Eval trees: procedures>>=
	subroutine eval_tree_factory_write (expr_factory, unit)
	class(eval_tree_factory_t), intent(in) :: expr_factory
	integer, intent(in), optional :: unit
	if (associated (expr_factory%pn)) then
	call parse_node_write_rec (expr_factory%pn, unit)
	end if
	end subroutine eval_tree_factory_write

	@ %def eval_tree_factory_write
	@ Initializer: take a parse node and hide it thus from the environment.
	<<Eval trees: eval tree factory: TBP>>=
	procedure :: init => eval_tree_factory_init
	<<Eval trees: procedures>>=
	subroutine eval_tree_factory_init (expr_factory, pn)
	class(eval_tree_factory_t), intent(out) :: expr_factory
	type(parse_node_t), intent(in), pointer :: pn
	expr_factory%pn => pn
	end subroutine eval_tree_factory_init

	@ %def eval_tree_factory_init
	@ Factory method: allocate expression with correct eval tree type. If the
	stored parse node is not associate, don't allocate.
	<<Eval trees: eval tree factory: TBP>>=
	procedure :: build => eval_tree_factory_build
	<<Eval trees: procedures>>=
	subroutine eval_tree_factory_build (expr_factory, expr)
	class(eval_tree_factory_t), intent(in) :: expr_factory
	class(expr_t), intent(out), allocatable :: expr
	if (associated (expr_factory%pn)) then
	allocate (eval_tree_t :: expr)
	select type (expr)
	type is (eval_tree_t)
	expr%pn => expr_factory%pn
	end select
	end if
	end subroutine eval_tree_factory_build

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

	module eval_trees_ut
	use unit_tests
	use eval_trees_uti

	<<Standard module head>>

	<<Eval trees: public test>>

	contains

	<<Eval trees: test driver>>

	end module eval_trees_ut
	@ %def eval_trees_ut
	@
	<<[[eval_trees_uti.f90]]>>=
	<<File header>>

	module eval_trees_uti

	<<Use kinds>>
	<<Use strings>>

	use ifiles
	use lexers
	use lorentz
	use syntax_rules, only: syntax_write
	use pdg_arrays
	use subevents
	use variables
	use observables

	use eval_trees

	<<Standard module head>>

	<<Eval trees: test declarations>>

	contains

	<<Eval trees: tests>>

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

	@ %def expressions_test
	@ Testing the routines of the expressions module. First a simple unary
	observable and the node evaluation.
	<<Eval trees: execute tests>>=
	call test (expressions_1, "expressions_1", &
	"check simple observable", &
	u, results)
	<<Eval trees: test declarations>>=
	public :: expressions_1
	<<Eval trees: tests>>=
	subroutine expressions_1 (u)
	integer, intent(in) :: u
	type(var_list_t), pointer :: var_list => null ()
	type(eval_node_t), pointer :: node => null ()
	type(prt_t), pointer :: prt => null ()
	type(string_t) :: var_name

	write (u, "(A)") "* Test output: Expressions"
	write (u, "(A)") "* Purpose: test simple observable and node evaluation"
	write (u, "(A)")

	write (u, "(A)") "* Setting a unary observable:"
	write (u, "(A)")

	allocate (var_list)
	allocate (prt)
	call var_list_set_observables_unary (var_list, prt)
	call var_list%write (u)

	write (u, "(A)") "* Evaluating the observable node:"
	write (u, "(A)")

	var_name = "PDG"

	allocate (node)
	call node%test_obs (var_list, var_name)
	call node%write (u)

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

	call node%final_rec ()
	deallocate (node)
	!!! Workaround for NAGFOR 6.2
	! call var_list%final ()
	deallocate (var_list)
	deallocate (prt)

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

	end subroutine expressions_1

	@ %def expressions_1
	@ Parse a complicated expression, transfer it to a parse tree and evaluate.
	<<Eval trees: execute tests>>=
	call test (expressions_2, "expressions_2", &
	"check expression transfer to parse tree", &
	u, results)
	<<Eval trees: test declarations>>=
	public :: expressions_2
	<<Eval trees: tests>>=
	subroutine expressions_2 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(eval_tree_t) :: eval_tree
	type(string_t) :: expr_text
	type(var_list_t), pointer :: var_list => null ()

	write (u, "(A)") "* Test output: Expressions"
	write (u, "(A)") "* Purpose: test parse routines"
	write (u, "(A)")

	call syntax_expr_init ()
	call syntax_write (syntax_expr, u)
	allocate (var_list)
	call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
	call var_list_append_real (var_list, var_str ("x"), -5._default)
	call var_list_append_int (var_list, var_str ("foo"), -27)
	call var_list_append_real (var_list, var_str ("mb"), 4._default)
	expr_text = &
	"let real twopi = 2 * pi in" // &
	" twopi * sqrt (25.d0 - mb^2)" // &
	" / (let int mb_or_0 = max (mb, 0) in" // &
	" 1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))"
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call var_list%write (u)
	call eval_tree%init_stream (stream, var_list=var_list)
	call eval_tree%evaluate ()
	call eval_tree%write (u)

	write (u, "(A)") "* Input string:"
	write (u, "(A,A)") " ", char (expr_text)
	write (u, "(A)")
	write (u, "(A)") "* Cleanup"

	call stream_final (stream)
	call ifile_final (ifile)
	call eval_tree%final ()
	call var_list%final ()
	deallocate (var_list)
	call syntax_expr_final ()

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

	end subroutine expressions_2

	@ %def expressions_2
	@ Test a subevent expression.
	<<Eval trees: execute tests>>=
	call test (expressions_3, "expressions_3", &
	"check subevent expressions", &
	u, results)
	<<Eval trees: test declarations>>=
	public :: expressions_3
	<<Eval trees: tests>>=
	subroutine expressions_3 (u)
	integer, intent(in) :: u
	type(subevt_t) :: subevt

	write (u, "(A)") "* Test output: Expressions"
	write (u, "(A)") "* Purpose: test subevent expressions"
	write (u, "(A)")

	write (u, "(A)") "* Initialize subevent:"
	write (u, "(A)")

	call subevt_init (subevt)
	- call subevt_reset (subevt, 1)
	- call subevt_set_incoming (subevt, 1, &
	- 22, vector4_moving (1.e3_default, 1.e3_default, 1), &
	- 0._default, [2])
	- call subevt_write (subevt, u)
	- call subevt_reset (subevt, 4)
	- call subevt_reset (subevt, 3)
	- call subevt_set_incoming (subevt, 1, &
	- 21, vector4_moving (1.e3_default, 1.e3_default, 3), &
	- 0._default, [1])
	+ call subevt%reset (1)
	+ call subevt%set_incoming (1, 22, &
	+ vector4_moving (1.e3_default, 1.e3_default, 1), 0._default, [2])
	+ call subevt%write (u)
	+ call subevt%reset (4)
	+ call subevt%reset (3)
	+ call subevt%set_incoming (1, 21, &
	+ vector4_moving (1.e3_default, 1.e3_default, 3), 0._default, [1])
	call subevt_polarize (subevt, 1, -1)
	- call subevt_set_outgoing (subevt, 2, &
	- 1, vector4_moving (0._default, 1.e3_default, 3), &
	+ call subevt%set_outgoing (2, 1, &
	+ vector4_moving (0._default, 1.e3_default, 3), &
	-1.e6_default, [7])
	- call subevt_set_composite (subevt, 3, &
	- vector4_moving (-1.e3_default, 0._default, 3), &
	- [2, 7])
	- call subevt_write (subevt, u)
	+ call subevt%set_composite (3, &
	+ vector4_moving (-1.e3_default, 0._default, 3), [2, 7])
	+ call subevt%write (u)

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

	end subroutine expressions_3

	@ %def expressions_3
	@ Test expressions from a PDG array.
	<<Eval trees: execute tests>>=
	call test (expressions_4, "expressions_4", &
	"check pdg array expressions", &
	u, results)
	<<Eval trees: test declarations>>=
	public :: expressions_4
	<<Eval trees: tests>>=
	subroutine expressions_4 (u)
	integer, intent(in) :: u
	type(subevt_t), target :: subevt
	type(string_t) :: expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(eval_tree_t) :: eval_tree
	type(var_list_t), pointer :: var_list => null ()
	type(pdg_array_t) :: aval

	write (u, "(A)") "* Test output: Expressions"
	write (u, "(A)") "* Purpose: test pdg array expressions"
	write (u, "(A)")

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

	call syntax_pexpr_init ()
	call syntax_write (syntax_pexpr, u)
	allocate (var_list)
	call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
	aval = 0
	call var_list_append_pdg_array (var_list, var_str ("particle"), aval)
	aval = [11,-11]
	call var_list_append_pdg_array (var_list, var_str ("lepton"), aval)
	aval = 22
	call var_list_append_pdg_array (var_list, var_str ("photon"), aval)
	aval = 1
	call var_list_append_pdg_array (var_list, var_str ("u"), aval)
	call subevt_init (subevt)
	- call subevt_reset (subevt, 6)
	- call subevt_set_incoming (subevt, 1, &
	- 1, vector4_moving (1._default, 1._default, 1), 0._default)
	- call subevt_set_incoming (subevt, 2, &
	- -1, vector4_moving (2._default, 2._default, 1), 0._default)
	- call subevt_set_outgoing (subevt, 3, &
	- 22, vector4_moving (3._default, 3._default, 1), 0._default)
	- call subevt_set_outgoing (subevt, 4, &
	- 22, vector4_moving (4._default, 4._default, 1), 0._default)
	- call subevt_set_outgoing (subevt, 5, &
	- 11, vector4_moving (5._default, 5._default, 1), 0._default)
	- call subevt_set_outgoing (subevt, 6, &
	- -11, vector4_moving (6._default, 6._default, 1), 0._default)
	+ call subevt%reset (6)
	+ call subevt%set_incoming (1, 1, &
	+ vector4_moving (1._default, 1._default, 1), 0._default)
	+ call subevt%set_incoming (2, -1, &
	+ vector4_moving (2._default, 2._default, 1), 0._default)
	+ call subevt%set_outgoing (3, 22, &
	+ vector4_moving (3._default, 3._default, 1), 0._default)
	+ call subevt%set_outgoing (4, 22, &
	+ vector4_moving (4._default, 4._default, 1), 0._default)
	+ call subevt%set_outgoing (5, 11, &
	+ vector4_moving (5._default, 5._default, 1), 0._default)
	+ call subevt%set_outgoing (6, -11, &
	+ vector4_moving (6._default, 6._default, 1), 0._default)
	write (u, "(A)")
	write (u, "(A)") "* Expression:"
	expr_text = &
	"let alias quark = pdg(1):pdg(2):pdg(3) in" // &
	" any E > 3 GeV " // &
	" [sort by - Pt " // &
	" [select if Index < 6 " // &
	" [photon:pdg(-11):pdg(3):quark " // &
	" & incoming particle]]]" // &
	" and" // &
	" eval Theta [extract index -1 [photon]] > 45 degree" // &
	" and" // &
	" count [incoming photon] * 3 > 0"
	write (u, "(A,A)") " ", char (expr_text)
	write (u, "(A)")

	write (u, "(A)")
	write (u, "(A)") "* Extract the evaluation tree:"
	write (u, "(A)")

	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call eval_tree%init_stream (stream, var_list, subevt, V_LOG)
	call eval_tree%write (u)
	call eval_tree%evaluate ()

	write (u, "(A)")
	write (u, "(A)") "* Evaluate the tree:"
	write (u, "(A)")

	call eval_tree%write (u)

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

	call stream_final (stream)
	call ifile_final (ifile)
	call eval_tree%final ()
	call var_list%final ()
	deallocate (var_list)
	call syntax_pexpr_final ()

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

	end subroutine expressions_4

	@ %def expressions_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Physics Models}

	A model object represents a physics model. It contains a table of particle
	data, a list of parameters, and a vertex table. The list of parameters is a
	variable list which includes the real parameters (which are pointers to the
	particle data table) and PDG array variables for the particles themselves.
	The vertex list is used for phase-space generation, not for calculating the
	matrix element.

	The actual numeric model data are in the base type [[model_data_t]],
	as part of the [[qft]] section. We implement the [[model_t]] as an
	extension of this, for convenient direct access to the base-type
	methods via inheritance. (Alternatively, we could delegate these calls
	explicitly.) The extension contains administrative additions, such as
	the methods for recalculating derived data and keeping the parameter
	set consistent. It thus acts as a proxy of the actual model-data
	object towards the \whizard\ package. There are further proxy
	objects, such as the [[parameter_t]] array which provides the
	interface to the actual numeric parameters.

	Model definitions are read from model files. Therefore, this module contains
	a parser for model files. The parameter definitions (derived parameters) are
	Sindarin expressions.

	The models, as read from file, are stored in a model library which is a simple
	list of model definitions. For setting up a process object we should make a
	copy (an instance) of a model, which gets the current parameter values from
	the global variable list.

	\subsection{Module}
	<<[[models.f90]]>>=
	<<File header>>

	module models

	use, intrinsic :: iso_c_binding !NODEP!

	<<Use kinds>>
	use kinds, only: c_default_float
	<<Use strings>>
	use io_units
	use diagnostics
	use md5
	use os_interface
	use physics_defs, only: UNDEFINED
	use model_data

	use ifiles
	use syntax_rules
	use lexers
	use parser
	use pdg_arrays
	use variables
	use expr_base
	use eval_trees

	use ttv_formfactors, only: init_parameters

	<<Standard module head>>

	<<Models: public>>

	<<Models: parameters>>

	<<Models: types>>

	<<Models: interfaces>>

	<<Models: variables>>

	contains

	<<Models: procedures>>

	end module models
	@ %def models
	@
	\subsection{Physics Parameters}
	A parameter has a name, a value. Derived parameters also have a
	definition in terms of other parameters, which is stored as an
	[[eval_tree]]. External parameters are set by an external program.

	This parameter object should be considered as a proxy object. The
	parameter name and value are stored in a corresponding
	[[modelpar_data_t]] object which is located in a [[model_data_t]]
	object. The latter is a component of the [[model_t]] handler.
	Methods of [[parameter_t]] can be delegated to the [[par_data_t]]
	component.

	The [[block_name]] and [[block_index]] values, if nonempty, indicate
	the possibility of reading this parameter from a SLHA-type input file.
	(Within the [[parameter_t]] object, this info is just used for I/O,
	the actual block register is located in the parent [[model_t]]
	object.)

	The [[pn]] component is a pointer to the parameter definition inside the
	model parse tree. It allows us to recreate the [[eval_tree]] when making
	copies (instances) of the parameter object.
	<<Models: parameters>>=
	integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1
	integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2
	integer, parameter :: PAR_EXTERNAL = 3

	@ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED
	<<Models: types>>=
	type :: parameter_t
	private
	integer :: type = PAR_NONE
	class(modelpar_data_t), pointer :: data => null ()
	type(string_t) :: block_name
	integer, dimension(:), allocatable :: block_index
	type(parse_node_t), pointer :: pn => null ()
	class(expr_t), allocatable :: expr
	contains
	<<Models: parameter: TBP>>
	end type parameter_t

	@ %def parameter_t
	@ Initialization depends on parameter type. Independent parameters
	are initialized by a constant value or a constant numerical expression
	(which may contain a unit). Derived parameters are initialized by an
	arbitrary numerical expression, which makes use of the current
	variable list. The expression is evaluated by the function
	[[parameter_reset]].

	This implementation supports only real parameters and real values.
	<<Models: parameter: TBP>>=
	procedure :: init_independent_value => parameter_init_independent_value
	procedure :: init_independent => parameter_init_independent
	procedure :: init_derived => parameter_init_derived
	procedure :: init_external => parameter_init_external
	procedure :: init_unused => parameter_init_unused
	<<Models: procedures>>=
	subroutine parameter_init_independent_value (par, par_data, name, value)
	class(parameter_t), intent(out) :: par
	class(modelpar_data_t), intent(in), target :: par_data
	type(string_t), intent(in) :: name
	real(default), intent(in) :: value
	par%type = PAR_INDEPENDENT
	par%data => par_data
	call par%data%init (name, value)
	end subroutine parameter_init_independent_value

	subroutine parameter_init_independent (par, par_data, name, pn)
	class(parameter_t), intent(out) :: par
	class(modelpar_data_t), intent(in), target :: par_data
	type(string_t), intent(in) :: name
	type(parse_node_t), intent(in), target :: pn
	par%type = PAR_INDEPENDENT
	par%pn => pn
	allocate (eval_tree_t :: par%expr)
	select type (expr => par%expr)
	type is (eval_tree_t)
	call expr%init_numeric_value (pn)
	end select
	par%data => par_data
	call par%data%init (name, par%expr%get_real ())
	end subroutine parameter_init_independent

	subroutine parameter_init_derived (par, par_data, name, pn, var_list)
	class(parameter_t), intent(out) :: par
	class(modelpar_data_t), intent(in), target :: par_data
	type(string_t), intent(in) :: name
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	par%type = PAR_DERIVED
	par%pn => pn
	allocate (eval_tree_t :: par%expr)
	select type (expr => par%expr)
	type is (eval_tree_t)
	call expr%init_expr (pn, var_list=var_list)
	end select
	par%data => par_data
	! call par%expr%evaluate ()
	call par%data%init (name, 0._default)
	end subroutine parameter_init_derived

	subroutine parameter_init_external (par, par_data, name)
	class(parameter_t), intent(out) :: par
	class(modelpar_data_t), intent(in), target :: par_data
	type(string_t), intent(in) :: name
	par%type = PAR_EXTERNAL
	par%data => par_data
	call par%data%init (name, 0._default)
	end subroutine parameter_init_external

	subroutine parameter_init_unused (par, par_data, name)
	class(parameter_t), intent(out) :: par
	class(modelpar_data_t), intent(in), target :: par_data
	type(string_t), intent(in) :: name
	par%type = PAR_UNUSED
	par%data => par_data
	call par%data%init (name, 0._default)
	end subroutine parameter_init_unused

	@ %def parameter_init_independent_value
	@ %def parameter_init_independent
	@ %def parameter_init_derived
	@ %def parameter_init_external
	@ %def parameter_init_unused
	@ The finalizer is needed for the evaluation tree in the definition.
	<<Models: parameter: TBP>>=
	procedure :: final => parameter_final
	<<Models: procedures>>=
	subroutine parameter_final (par)
	class(parameter_t), intent(inout) :: par
	if (allocated (par%expr)) then
	call par%expr%final ()
	end if
	end subroutine parameter_final

	@ %def parameter_final
	@ All derived parameters should be recalculated if some independent
	parameters have changed:
	<<Models: parameter: TBP>>=
	procedure :: reset_derived => parameter_reset_derived
	<<Models: procedures>>=
	subroutine parameter_reset_derived (par)
	class(parameter_t), intent(inout) :: par
	select case (par%type)
	case (PAR_DERIVED)
	call par%expr%evaluate ()
	par%data = par%expr%get_real ()
	end select
	end subroutine parameter_reset_derived

	@ %def parameter_reset_derived parameter_reset_external
	@ Output. [We should have a formula format for the eval tree,
	suitable for input and output!]
	<<Models: parameter: TBP>>=
	procedure :: write => parameter_write
	<<Models: procedures>>=
	subroutine parameter_write (par, unit, write_defs)
	class(parameter_t), intent(in) :: par
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: write_defs
	logical :: defs
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	defs = .false.; if (present (write_defs)) defs = write_defs
	select case (par%type)
	case (PAR_INDEPENDENT)
	write (u, "(3x,A)", advance="no") "parameter"
	call par%data%write (u)
	case (PAR_DERIVED)
	write (u, "(3x,A)", advance="no") "derived"
	call par%data%write (u)
	case (PAR_EXTERNAL)
	write (u, "(3x,A)", advance="no") "external"
	call par%data%write (u)
	case (PAR_UNUSED)
	write (u, "(3x,A)", advance="no") "unused"
	write (u, "(1x,A)", advance="no") char (par%data%get_name ())
	end select
	select case (par%type)
	case (PAR_INDEPENDENT)
	if (allocated (par%block_index)) then
	write (u, "(1x,A,1x,A,*(1x,I0))") &
	"slha_entry", char (par%block_name), par%block_index
	else
	write (u, "(A)")
	end if
	case (PAR_DERIVED)
	if (defs) then
	call par%expr%write (unit)
	else
	write (u, "(A)")
	end if
	case default
	write (u, "(A)")
	end select
	end subroutine parameter_write

	@ %def parameter_write
	@ Screen output variant. Restrict output to the given parameter type.
	<<Models: parameter: TBP>>=
	procedure :: show => parameter_show
	<<Models: procedures>>=
	subroutine parameter_show (par, l, u, partype)
	class(parameter_t), intent(in) :: par
	integer, intent(in) :: l, u
	integer, intent(in) :: partype
	if (par%type == partype) then
	call par%data%show (l, u)
	end if
	end subroutine parameter_show

	@ %def parameter_show
	@
	\subsection{SLHA block register}
	For the optional SLHA interface, the model record contains a register
	of SLHA-type block names together with index values, which point to a
	particular parameter. These are private types:
	<<Models: types>>=
	type :: slha_entry_t
	integer, dimension(:), allocatable :: block_index
	integer :: i_par = 0
	end type slha_entry_t

	@ %def slha_entry_t
	<<Models: types>>=
	type :: slha_block_t
	type(string_t) :: name
	integer :: n_entry = 0
	type(slha_entry_t), dimension(:), allocatable :: entry
	end type slha_block_t

	@ %def slha_block_t
	@
	\subsection{Model Object}
	A model object holds all information about parameters, particles,
	and vertices. For models that require an external program for
	parameter calculation, there is the pointer to a function that does
	this calculation, given the set of independent and derived parameters.

	As explained above, the type inherits from [[model_data_t]], which is
	the actual storage for the model data.

	When reading a model, we create a parse tree. Parameter definitions are
	available via parse nodes. Since we may need those later when making model
	instances, we keep the whole parse tree in the model definition (but not in
	the instances).
	<<Models: public>>=
	public :: model_t
	<<Models: types>>=
	type, extends (model_data_t) :: model_t
	private
	character(32) :: md5sum = ""
	logical :: ufo_model = .false.
	type(string_t) :: ufo_path
	type(string_t), dimension(:), allocatable :: schemes
	type(string_t), allocatable :: selected_scheme
	type(parameter_t), dimension(:), allocatable :: par
	integer :: n_slha_block = 0
	type(slha_block_t), dimension(:), allocatable :: slha_block
	integer :: max_par_name_length = 0
	integer :: max_field_name_length = 0
	type(var_list_t) :: var_list
	type(string_t) :: dlname
	procedure(model_init_external_parameters), nopass, pointer :: &
	init_external_parameters => null ()
	type(dlaccess_t) :: dlaccess
	type(parse_tree_t) :: parse_tree
	contains
	<<Models: model: TBP>>
	end type model_t

	@ %def model_t
	@ This is the interface for a procedure that initializes the
	calculation of external parameters, given the array of all
	parameters.
	<<Models: interfaces>>=
	abstract interface
	subroutine model_init_external_parameters (par) bind (C)
	import
	real(c_default_float), dimension(*), intent(inout) :: par
	end subroutine model_init_external_parameters
	end interface

	@ %def model_init_external_parameters
	@ Initialization: Specify the number of parameters, particles,
	vertices and allocate memory. If an associated DL library is
	specified, load this library.

	The model may already carry scheme information, so we have to save and
	restore the scheme number when actually initializing the [[model_data_t]]
	base.
	<<Models: model: TBP>>=
	generic :: init => model_init
	procedure, private :: model_init
	<<Models: procedures>>=
	subroutine model_init &
	(model, name, libname, os_data, n_par, n_prt, n_vtx, ufo)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in) :: name, libname
	type(os_data_t), intent(in) :: os_data
	integer, intent(in) :: n_par, n_prt, n_vtx
	logical, intent(in), optional :: ufo
	type(c_funptr) :: c_fptr
	type(string_t) :: libpath
	integer :: scheme_num
	scheme_num = model%get_scheme_num ()
	call model%basic_init (name, n_par, n_prt, n_vtx)
	if (present (ufo)) model%ufo_model = ufo
	call model%set_scheme_num (scheme_num)
	if (libname /= "") then
	if (.not. os_data%use_testfiles) then
	libpath = os_data%whizard_models_libpath_local
	model%dlname = os_get_dlname ( &
	libpath // "/" // libname, os_data, ignore=.true.)
	end if
	if (model%dlname == "") then
	libpath = os_data%whizard_models_libpath
	model%dlname = os_get_dlname (libpath // "/" // libname, os_data)
	end if
	else
	model%dlname = ""
	end if
	if (model%dlname /= "") then
	if (.not. dlaccess_is_open (model%dlaccess)) then
	if (logging) &
	call msg_message ("Loading model auxiliary library '" &
	// char (libpath) // "/" // char (model%dlname) // "'")
	call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, &
	model%dlname, os_data)
	if (dlaccess_has_error (model%dlaccess)) then
	call msg_message (char (dlaccess_get_error (model%dlaccess)))
	call msg_fatal ("Loading model auxiliary library '" &
	// char (model%dlname) // "' failed")
	return
	end if
	c_fptr = dlaccess_get_c_funptr (model%dlaccess, &
	var_str ("init_external_parameters"))
	if (dlaccess_has_error (model%dlaccess)) then
	call msg_message (char (dlaccess_get_error (model%dlaccess)))
	call msg_fatal ("Loading function from auxiliary library '" &
	// char (model%dlname) // "' failed")
	return
	end if
	call c_f_procpointer (c_fptr, model% init_external_parameters)
	end if
	end if
	end subroutine model_init

	@ %def model_init
	@ For a model instance, we do not attempt to load a DL library. This is the
	core of the full initializer above.
	<<Models: model: TBP>>=
	procedure, private :: basic_init => model_basic_init
	<<Models: procedures>>=
	subroutine model_basic_init (model, name, n_par, n_prt, n_vtx)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in) :: name
	integer, intent(in) :: n_par, n_prt, n_vtx
	allocate (model%par (n_par))
	call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx)
	end subroutine model_basic_init

	@ %def model_basic_init
	@ Finalization: The variable list contains allocated pointers, also the parse
	tree. We also close the DL access object, if any, that enables external
	parameter calculation.
	<<Models: model: TBP>>=
	procedure :: final => model_final
	<<Models: procedures>>=
	subroutine model_final (model)
	class(model_t), intent(inout) :: model
	integer :: i
	if (allocated (model%par)) then
	do i = 1, size (model%par)
	call model%par(i)%final ()
	end do
	end if
	call model%var_list%final (follow_link=.false.)
	if (model%dlname /= "") call dlaccess_final (model%dlaccess)
	call parse_tree_final (model%parse_tree)
	call model%model_data_t%final ()
	end subroutine model_final

	@ %def model_final
	@ Output. By default, the output is in the form of an input file. If
	[[verbose]] is true, for each derived parameter the definition (eval
	tree) is displayed, and the vertex hash table is shown.
	<<Models: model: TBP>>=
	procedure :: write => model_write
	<<Models: procedures>>=
	subroutine model_write (model, unit, verbose, &
	show_md5sum, show_variables, show_parameters, &
	show_particles, show_vertices, show_scheme)
	class(model_t), intent(in) :: model
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	logical, intent(in), optional :: show_md5sum
	logical, intent(in), optional :: show_variables
	logical, intent(in), optional :: show_parameters
	logical, intent(in), optional :: show_particles
	logical, intent(in), optional :: show_vertices
	logical, intent(in), optional :: show_scheme
	logical :: verb, show_md5, show_par, show_var
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	verb = .false.; if (present (verbose)) verb = verbose
	show_md5 = .true.; if (present (show_md5sum)) &
	show_md5 = show_md5sum
	show_par = .true.; if (present (show_parameters)) &
	show_par = show_parameters
	show_var = verb; if (present (show_variables)) &
	show_var = show_variables
	write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"'
	if (show_md5 .and. model%md5sum /= "") &
	write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'"
	if (model%is_ufo_model ()) then
	write (u, "(1x,A)") "! model derived from UFO source"
	else if (model%has_schemes ()) then
	write (u, "(1x,A)", advance="no") "! schemes ="
	do i = 1, size (model%schemes)
	if (i > 1) write (u, "(',')", advance="no")
	write (u, "(1x,A,A,A)", advance="no") &
	"'", char (model%schemes(i)), "'"
	end do
	write (u, *)
	if (allocated (model%selected_scheme)) then
	write (u, "(1x,A,A,A,I0,A)") &
	"! selected scheme = '", char (model%get_scheme ()), &
	"' (", model%get_scheme_num (), ")"
	end if
	end if
	if (show_par) then
	write (u, "(A)")
	do i = 1, size (model%par)
	call model%par(i)%write (u, write_defs=verbose)
	end do
	end if
	call model%model_data_t%write (unit, verbose, &
	show_md5sum, show_variables, &
	show_parameters=.false., &
	show_particles=show_particles, &
	show_vertices=show_vertices, &
	show_scheme=show_scheme)
	if (show_var) then
	write (u, "(A)")
	call var_list_write (model%var_list, unit, follow_link=.false.)
	end if
	end subroutine model_write

	@ %def model_write
	@ Screen output, condensed form.
	<<Models: model: TBP>>=
	procedure :: show => model_show
	<<Models: procedures>>=
	subroutine model_show (model, unit)
	class(model_t), intent(in) :: model
	integer, intent(in), optional :: unit
	integer :: i, u, l
	u = given_output_unit (unit)
	write (u, "(A,1x,A)") "Model:", char (model%get_name ())
	if (model%has_schemes ()) then
	write (u, "(2x,A,A,A,I0,A)") "Scheme: '", &
	char (model%get_scheme ()), "' (", model%get_scheme_num (), ")"
	end if
	l = model%max_field_name_length
	call model%show_fields (l, u)
	l = model%max_par_name_length
	if (any (model%par%type == PAR_INDEPENDENT)) then
	write (u, "(2x,A)") "Independent parameters:"
	do i = 1, size (model%par)
	call model%par(i)%show (l, u, PAR_INDEPENDENT)
	end do
	end if
	if (any (model%par%type == PAR_DERIVED)) then
	write (u, "(2x,A)") "Derived parameters:"
	do i = 1, size (model%par)
	call model%par(i)%show (l, u, PAR_DERIVED)
	end do
	end if
	if (any (model%par%type == PAR_EXTERNAL)) then
	write (u, "(2x,A)") "External parameters:"
	do i = 1, size (model%par)
	call model%par(i)%show (l, u, PAR_EXTERNAL)
	end do
	end if
	if (any (model%par%type == PAR_UNUSED)) then
	write (u, "(2x,A)") "Unused parameters:"
	do i = 1, size (model%par)
	call model%par(i)%show (l, u, PAR_UNUSED)
	end do
	end if
	end subroutine model_show

	@ %def model_show
	@ Show all fields/particles.
	<<Models: model: TBP>>=
	procedure :: show_fields => model_show_fields
	<<Models: procedures>>=
	subroutine model_show_fields (model, l, unit)
	class(model_t), intent(in), target :: model
	integer, intent(in) :: l
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: field
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(2x,A)") "Particles:"
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	call field%show (l, u)
	end do
	end subroutine model_show_fields

	@ %def model_data_show_fields
	@ Show the list of stable, unstable, polarized, or unpolarized
	particles, respectively.
	<<Models: model: TBP>>=
	procedure :: show_stable => model_show_stable
	procedure :: show_unstable => model_show_unstable
	procedure :: show_polarized => model_show_polarized
	procedure :: show_unpolarized => model_show_unpolarized
	<<Models: procedures>>=
	subroutine model_show_stable (model, unit)
	class(model_t), intent(in), target :: model
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: field
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(A,1x)", advance="no") "Stable particles:"
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	if (field%is_stable (.false.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
	end if
	if (field%has_antiparticle ()) then
	if (field%is_stable (.true.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
	end if
	end if
	end do
	write (u, *)
	end subroutine model_show_stable

	subroutine model_show_unstable (model, unit)
	class(model_t), intent(in), target :: model
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: field
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(A,1x)", advance="no") "Unstable particles:"
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	if (.not. field%is_stable (.false.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
	end if
	if (field%has_antiparticle ()) then
	if (.not. field%is_stable (.true.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
	end if
	end if
	end do
	write (u, *)
	end subroutine model_show_unstable

	subroutine model_show_polarized (model, unit)
	class(model_t), intent(in), target :: model
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: field
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(A,1x)", advance="no") "Polarized particles:"
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	if (field%is_polarized (.false.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
	end if
	if (field%has_antiparticle ()) then
	if (field%is_polarized (.true.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
	end if
	end if
	end do
	write (u, *)
	end subroutine model_show_polarized

	subroutine model_show_unpolarized (model, unit)
	class(model_t), intent(in), target :: model
	integer, intent(in), optional :: unit
	type(field_data_t), pointer :: field
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(A,1x)", advance="no") "Unpolarized particles:"
	do i = 1, model%get_n_field ()
	field => model%get_field_ptr_by_index (i)
	if (.not. field%is_polarized (.false.)) then
	write (u, "(1x,A)", advance="no") &
	char (field%get_name (.false.))
	end if
	if (field%has_antiparticle ()) then
	if (.not. field%is_polarized (.true.)) then
	write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
	end if
	end if
	end do
	write (u, *)
	end subroutine model_show_unpolarized

	@ %def model_show_stable
	@ %def model_show_unstable
	@ %def model_show_polarized
	@ %def model_show_unpolarized
	@ Retrieve the MD5 sum of a model (actually, of the model file).
	<<Models: model: TBP>>=
	procedure :: get_md5sum => model_get_md5sum
	<<Models: procedures>>=
	function model_get_md5sum (model) result (md5sum)
	character(32) :: md5sum
	class(model_t), intent(in) :: model
	md5sum = model%md5sum
	end function model_get_md5sum

	@ %def model_get_md5sum
	@ Parameters are defined by an expression which may be constant or
	arbitrary.
	<<Models: model: TBP>>=
	procedure :: &
	set_parameter_constant => model_set_parameter_constant
	procedure, private :: &
	set_parameter_parse_node => model_set_parameter_parse_node
	procedure :: &
	set_parameter_external => model_set_parameter_external
	procedure :: &
	set_parameter_unused => model_set_parameter_unused
	<<Models: procedures>>=
	subroutine model_set_parameter_constant (model, i, name, value)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	real(default), intent(in) :: value
	logical, save, target :: known = .true.
	class(modelpar_data_t), pointer :: par_data
	real(default), pointer :: value_ptr
	par_data => model%get_par_real_ptr (i)
	call model%par(i)%init_independent_value (par_data, name, value)
	value_ptr => par_data%get_real_ptr ()
	call var_list_append_real_ptr (model%var_list, &
	name, value_ptr, &
	is_known=known, intrinsic=.true.)
	model%max_par_name_length = max (model%max_par_name_length, len (name))
	end subroutine model_set_parameter_constant

	subroutine model_set_parameter_parse_node (model, i, name, pn, constant)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	type(parse_node_t), intent(in), target :: pn
	logical, intent(in) :: constant
	logical, save, target :: known = .true.
	class(modelpar_data_t), pointer :: par_data
	real(default), pointer :: value_ptr
	par_data => model%get_par_real_ptr (i)
	if (constant) then
	call model%par(i)%init_independent (par_data, name, pn)
	else
	call model%par(i)%init_derived (par_data, name, pn, model%var_list)
	end if
	value_ptr => par_data%get_real_ptr ()
	call var_list_append_real_ptr (model%var_list, &
	name, value_ptr, &
	is_known=known, locked=.not.constant, intrinsic=.true.)
	model%max_par_name_length = max (model%max_par_name_length, len (name))
	end subroutine model_set_parameter_parse_node

	subroutine model_set_parameter_external (model, i, name)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	logical, save, target :: known = .true.
	class(modelpar_data_t), pointer :: par_data
	real(default), pointer :: value_ptr
	par_data => model%get_par_real_ptr (i)
	call model%par(i)%init_external (par_data, name)
	value_ptr => par_data%get_real_ptr ()
	call var_list_append_real_ptr (model%var_list, &
	name, value_ptr, &
	is_known=known, locked=.true., intrinsic=.true.)
	model%max_par_name_length = max (model%max_par_name_length, len (name))
	end subroutine model_set_parameter_external

	subroutine model_set_parameter_unused (model, i, name)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name
	class(modelpar_data_t), pointer :: par_data
	par_data => model%get_par_real_ptr (i)
	call model%par(i)%init_unused (par_data, name)
	call var_list_append_real (model%var_list, &
	name, locked=.true., intrinsic=.true.)
	model%max_par_name_length = max (model%max_par_name_length, len (name))
	end subroutine model_set_parameter_unused

	@ %def model_set_parameter
	@ Make a copy of a parameter. We assume that the [[model_data_t]]
	parameter arrays have already been copied, so names and values are
	available in the current model, and can be used as targets. The eval
	tree should not be copied, since it should refer to the new variable
	list. The safe solution is to make use of the above initializers,
	which also take care of the building a new variable list.
	<<Models: model: TBP>>=
	procedure, private :: copy_parameter => model_copy_parameter
	<<Models: procedures>>=
	subroutine model_copy_parameter (model, i, par)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parameter_t), intent(in) :: par
	type(string_t) :: name
	real(default) :: value
	name = par%data%get_name ()
	select case (par%type)
	case (PAR_INDEPENDENT)
	if (associated (par%pn)) then
	call model%set_parameter_parse_node (i, name, par%pn, &
	constant = .true.)
	else
	value = par%data%get_real ()
	call model%set_parameter_constant (i, name, value)
	end if
	if (allocated (par%block_index)) then
	model%par(i)%block_name = par%block_name
	model%par(i)%block_index = par%block_index
	end if
	case (PAR_DERIVED)
	call model%set_parameter_parse_node (i, name, par%pn, &
	constant = .false.)
	case (PAR_EXTERNAL)
	call model%set_parameter_external (i, name)
	case (PAR_UNUSED)
	call model%set_parameter_unused (i, name)
	end select
	end subroutine model_copy_parameter

	@ %def model_copy_parameter
	@ Recalculate all derived parameters.
	<<Models: model: TBP>>=
	procedure :: update_parameters => model_parameters_update
	<<Models: procedures>>=
	subroutine model_parameters_update (model)
	class(model_t), intent(inout) :: model
	integer :: i
	real(default), dimension(:), allocatable :: par
	do i = 1, size (model%par)
	call model%par(i)%reset_derived ()
	end do
	if (associated (model%init_external_parameters)) then
	allocate (par (model%get_n_real ()))
	call model%real_parameters_to_c_array (par)
	call model%init_external_parameters (par)
	call model%real_parameters_from_c_array (par)
	if (model%get_name() == var_str ("SM_tt_threshold")) &
	call set_threshold_parameters ()
	end if
	contains
	subroutine set_threshold_parameters ()
	real(default) :: mpole, wtop
	!!! !!! !!! Workaround for OS-X and BSD which do not load
	!!! !!! !!! the global values created previously. Therefore
	!!! !!! !!! a second initialization for the threshold model,
	!!! !!! !!! where M1S is required to compute the top mass.
	call init_parameters (mpole, wtop, &
	par(20), par(21), par(22), &
	par(19), par(39), par(4), par(1), &
	par(2), par(10), par(24), par(25), &
	par(23), par(26), par(27), par(29), &
	par(30), par(31), par(32), par(33), &
	par(36) > 0._default, par(28))
	end subroutine set_threshold_parameters
	end subroutine model_parameters_update

	@ %def model_parameters_update
	@ Initialize field data with PDG long name and PDG code.
	<<Models: model: TBP>>=
	procedure, private :: init_field => model_init_field
	<<Models: procedures>>=
	subroutine model_init_field (model, i, longname, pdg)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: longname
	integer, intent(in) :: pdg
	type(field_data_t), pointer :: field
	field => model%get_field_ptr_by_index (i)
	call field%init (longname, pdg)
	end subroutine model_init_field

	@ %def model_init_field
	@ Copy field data for index [[i]] from another particle which serves
	as a template. The name should be the unique long name.
	<<Models: model: TBP>>=
	procedure, private :: copy_field => model_copy_field
	<<Models: procedures>>=
	subroutine model_copy_field (model, i, name_src)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(string_t), intent(in) :: name_src
	type(field_data_t), pointer :: field_src, field
	field_src => model%get_field_ptr (name_src)
	field => model%get_field_ptr_by_index (i)
	call field%copy_from (field_src)
	end subroutine model_copy_field

	@ %def model_copy_field
	@
	\subsection{Model Access via Variables}
	Write the model variable list.
	<<Models: model: TBP>>=
	procedure :: write_var_list => model_write_var_list
	<<Models: procedures>>=
	subroutine model_write_var_list (model, unit, follow_link)
	class(model_t), intent(in) :: model
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: follow_link
	call var_list_write (model%var_list, unit, follow_link)
	end subroutine model_write_var_list

	@ %def model_write_var_list
	@ Link a variable list to the model variables.
	<<Models: model: TBP>>=
	procedure :: link_var_list => model_link_var_list
	<<Models: procedures>>=
	subroutine model_link_var_list (model, var_list)
	class(model_t), intent(inout) :: model
	type(var_list_t), intent(in), target :: var_list
	call model%var_list%link (var_list)
	end subroutine model_link_var_list

	@ %def model_link_var_list
	@
	Check if the model contains a named variable.
	<<Models: model: TBP>>=
	procedure :: var_exists => model_var_exists
	<<Models: procedures>>=
	function model_var_exists (model, name) result (flag)
	class(model_t), intent(in) :: model
	type(string_t), intent(in) :: name
	logical :: flag
	flag = model%var_list%contains (name, follow_link=.false.)
	end function model_var_exists

	@ %def model_var_exists
	@ Check if the model variable is a derived parameter, i.e., locked.
	<<Models: model: TBP>>=
	procedure :: var_is_locked => model_var_is_locked
	<<Models: procedures>>=
	function model_var_is_locked (model, name) result (flag)
	class(model_t), intent(in) :: model
	type(string_t), intent(in) :: name
	logical :: flag
	flag = model%var_list%is_locked (name, follow_link=.false.)
	end function model_var_is_locked

	@ %def model_var_is_locked
	@ Set a model parameter via the named variable. We assume that the
	variable exists and is writable, i.e., non-locked. We update the
	model and variable list, so independent and derived parameters are
	always synchronized.
	<<Models: model: TBP>>=
	procedure :: set_real => model_var_set_real
	<<Models: procedures>>=
	subroutine model_var_set_real (model, name, rval, verbose, pacified)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in) :: name
	real(default), intent(in) :: rval
	logical, intent(in), optional :: verbose, pacified
	call model%var_list%set_real (name, rval, &
	is_known=.true., ignore=.false., &
	verbose=verbose, model_name=model%get_name (), pacified=pacified)
	call model%update_parameters ()
	end subroutine model_var_set_real

	@ %def model_var_set_real
	@ Retrieve a model parameter value.
	<<Models: model: TBP>>=
	procedure :: get_rval => model_var_get_rval
	<<Models: procedures>>=
	function model_var_get_rval (model, name) result (rval)
	class(model_t), intent(in) :: model
	type(string_t), intent(in) :: name
	real(default) :: rval
	rval = model%var_list%get_rval (name, follow_link=.false.)
	end function model_var_get_rval

	@ %def model_var_get_rval
	@
	[To be deleted] Return a pointer to the variable list.
	<<Models: model: TBP>>=
	procedure :: get_var_list_ptr => model_get_var_list_ptr
	<<Models: procedures>>=
	function model_get_var_list_ptr (model) result (var_list)
	type(var_list_t), pointer :: var_list
	class(model_t), intent(in), target :: model
	var_list => model%var_list
	end function model_get_var_list_ptr

	@ %def model_get_var_list_ptr
	@
	\subsection{UFO models}
	A single flag identifies a model as a UFO model. There is no other
	distinction, but the flag allows us to handle built-in and UFO models
	with the same name in parallel.
	<<Models: model: TBP>>=
	procedure :: is_ufo_model => model_is_ufo_model
	<<Models: procedures>>=
	function model_is_ufo_model (model) result (flag)
	class(model_t), intent(in) :: model
	logical :: flag
	flag = model%ufo_model
	end function model_is_ufo_model

	@ %def model_is_ufo_model
	@ Return the UFO path used for fetching the UFO source.
	<<Models: model: TBP>>=
	procedure :: get_ufo_path => model_get_ufo_path
	<<Models: procedures>>=
	function model_get_ufo_path (model) result (path)
	class(model_t), intent(in) :: model
	type(string_t) :: path
	if (model%ufo_model) then
	path = model%ufo_path
	else
	path = ""
	end if
	end function model_get_ufo_path

	@ %def model_get_ufo_path
	@
	Call OMega and generate a model file from an UFO source file. We
	start with a file name; the model name is expected to be the base
	name, stripping extensions.

	The path search either takes [[ufo_path_requested]], or searches first
	in the working directory, then in a hard-coded UFO model directory.
	<<Models: procedures>>=
	subroutine model_generate_ufo (filename, os_data, ufo_path, &
	ufo_path_requested)
	type(string_t), intent(in) :: filename
	type(os_data_t), intent(in) :: os_data
	type(string_t), intent(out) :: ufo_path
	type(string_t), intent(in), optional :: ufo_path_requested
	type(string_t) :: model_name, omega_path, ufo_dir, ufo_init
	logical :: exist
	call get_model_name (filename, model_name)
	call msg_message ("Model: Generating model '" // char (model_name) &
	// "' from UFO sources")
	if (present (ufo_path_requested)) then
	call msg_message ("Model: Searching for UFO sources in '" &
	// char (ufo_path_requested) // "'")
	ufo_path = ufo_path_requested
	ufo_dir = ufo_path_requested // "/" // model_name
	ufo_init = ufo_dir // "/" // "__init__.py"
	inquire (file = char (ufo_init), exist = exist)
	else
	call msg_message ("Model: Searching for UFO sources in &
	&working directory")
	ufo_path = "."
	ufo_dir = ufo_path // "/" // model_name
	ufo_init = ufo_dir // "/" // "__init__.py"
	inquire (file = char (ufo_init), exist = exist)
	if (.not. exist) then
	ufo_path = char (os_data%whizard_modelpath_ufo)
	ufo_dir = ufo_path // "/" // model_name
	ufo_init = ufo_dir // "/" // "__init__.py"
	call msg_message ("Model: Searching for UFO sources in '" &
	// char (os_data%whizard_modelpath_ufo) // "'")
	inquire (file = char (ufo_init), exist = exist)
	end if
	end if
	if (exist) then
	call msg_message ("Model: Found UFO sources for model '" &
	// char (model_name) // "'")
	else
	call msg_fatal ("Model: UFO sources for model '" &
	// char (model_name) // "' not found")
	end if
	omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt"
	call os_system_call (omega_path &
	// " -model:UFO_dir " // ufo_dir &
	// " -model:exec" &
	// " -model:write_WHIZARD" &
	// " > " // filename)
	inquire (file = char (filename), exist = exist)
	if (exist) then
	call msg_message ("Model: Model file '" // char (filename) //&
	"' generated")
	else
	call msg_fatal ("Model: Model file '" // char (filename) &
	// "' could not be generated")
	end if
	contains
	subroutine get_model_name (filename, model_name)
	type(string_t), intent(in) :: filename
	type(string_t), intent(out) :: model_name
	type(string_t) :: string
	string = filename
	call split (string, model_name, ".")
	end subroutine get_model_name
	end subroutine model_generate_ufo

	@ %def model_generate_ufo
	@
	\subsection{Scheme handling}
	A model can specify a set of allowed schemes that steer the setup of
	model variables. The model file can contain scheme-specific
	declarations that are selected by a [[select scheme]] clause. Scheme
	support is optional.

	If enabled, the model object contains a list of allowed schemes, and
	the model reader takes the active scheme as an argument. After the
	model has been read, the scheme is fixed and can no longer be
	modified.

	The model supports schemes if the scheme array is allocated.
	<<Models: model: TBP>>=
	procedure :: has_schemes => model_has_schemes
	<<Models: procedures>>=
	function model_has_schemes (model) result (flag)
	logical :: flag
	class(model_t), intent(in) :: model
	flag = allocated (model%schemes)
	end function model_has_schemes

	@ %def model_has_schemes
	@
	Enable schemes: fix the list of allowed schemes.
	<<Models: model: TBP>>=
	procedure :: enable_schemes => model_enable_schemes
	<<Models: procedures>>=
	subroutine model_enable_schemes (model, scheme)
	class(model_t), intent(inout) :: model
	type(string_t), dimension(:), intent(in) :: scheme
	allocate (model%schemes (size (scheme)), source = scheme)
	end subroutine model_enable_schemes

	@ %def model_enable_schemes
	@
	Find the scheme. Check if the scheme is allowed. The numeric index of the
	selected scheme is stored in the [[model_data_t]] base object.

	If no argument is given,
	select the first scheme. The numeric scheme ID will then be $1$, while a
	model without schemes retains $0$.
	<<Models: model: TBP>>=
	procedure :: set_scheme => model_set_scheme
	<<Models: procedures>>=
	subroutine model_set_scheme (model, scheme)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in), optional :: scheme
	logical :: ok
	integer :: i
	if (model%has_schemes ()) then
	if (present (scheme)) then
	ok = .false.
	CHECK_SCHEME: do i = 1, size (model%schemes)
	if (scheme == model%schemes(i)) then
	allocate (model%selected_scheme, source = scheme)
	call model%set_scheme_num (i)
	ok = .true.
	exit CHECK_SCHEME
	end if
	end do CHECK_SCHEME
	if (.not. ok) then
	call msg_fatal &
	("Model '" // char (model%get_name ()) &
	// "': scheme '" // char (scheme) // "' not supported")
	end if
	else
	allocate (model%selected_scheme, source = model%schemes(1))
	call model%set_scheme_num (1)
	end if
	else
	if (present (scheme)) then
	call msg_error &
	("Model '" // char (model%get_name ()) &
	// "' does not support schemes")
	end if
	end if
	end subroutine model_set_scheme

	@ %def model_set_scheme
	@
	Get the scheme. Note that the base [[model_data_t]] provides a
	[[get_scheme_num]] getter function.
	<<Models: model: TBP>>=
	procedure :: get_scheme => model_get_scheme
	<<Models: procedures>>=
	function model_get_scheme (model) result (scheme)
	class(model_t), intent(in) :: model
	type(string_t) :: scheme
	if (allocated (model%selected_scheme)) then
	scheme = model%selected_scheme
	else
	scheme = ""
	end if
	end function model_get_scheme

	@ %def model_get_scheme
	@
	Check if a model has been set up with a specific name and (if
	applicable) scheme. This helps in determining whether we need a new
	model object.

	A UFO model is considered to be distinct from a non-UFO model. We assume that
	if [[ufo]] is asked for, there is no scheme argument. Furthermore,
	if there is an [[ufo_path]] requested, it must coincide with the
	[[ufo_path]] of the model. If not, the model [[ufo_path]] is not checked.
	<<Models: model: TBP>>=
	procedure :: matches => model_matches
	<<Models: procedures>>=
	function model_matches (model, name, scheme, ufo, ufo_path) result (flag)
	logical :: flag
	class(model_t), intent(in) :: model
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path
	logical :: ufo_model
	ufo_model = .false.; if (present (ufo)) ufo_model = ufo
	if (name /= model%get_name ()) then
	flag = .false.
	else if (ufo_model .neqv. model%is_ufo_model ()) then
	flag = .false.
	else if (ufo_model) then
	if (present (ufo_path)) then
	flag = model%get_ufo_path () == ufo_path
	else
	flag = .true.
	end if
	else if (model%has_schemes ()) then
	if (present (scheme)) then
	flag = model%get_scheme () == scheme
	else
	flag = model%get_scheme_num () == 1
	end if
	else if (present (scheme)) then
	flag = .false.
	else
	flag = .true.
	end if
	end function model_matches

	@ %def model_matches
	@
	\subsection{SLHA-type interface}
	Abusing the original strict SUSY Les Houches Accord (SLHA), we support
	reading parameter data from some custom SLHA-type input file. To this
	end, the [[model]] object stores a list of model-specific block names
	together with information how to find a parameter in the model record,
	given a block name and index vector.

	Check if the model supports custom SLHA block info. This is the case
	if [[n_slha_block]] is nonzero, i.e., after SLHA block names have been
	parsed and registered.
	<<Models: model: TBP>>=
	procedure :: supports_custom_slha => model_supports_custom_slha
	<<Models: procedures>>=
	function model_supports_custom_slha (model) result (flag)
	class(model_t), intent(in) :: model
	logical :: flag

	flag = model%n_slha_block > 0

	end function model_supports_custom_slha

	@ %def model_supports_custom_slha
	@ Return the block names for all SLHA block references.
	<<Models: model: TBP>>=
	procedure :: get_custom_slha_blocks => model_get_custom_slha_blocks
	<<Models: procedures>>=
	subroutine model_get_custom_slha_blocks (model, block_name)
	class(model_t), intent(in) :: model
	type(string_t), dimension(:), allocatable :: block_name

	integer :: i

	allocate (block_name (model%n_slha_block))
	do i = 1, size (block_name)
	block_name(i) = model%slha_block(i)%name
	end do

	end subroutine model_get_custom_slha_blocks

	@ %def model_get_custom_slha_blocks
	@
	This routine registers a SLHA block reference. We have the index of a
	(new) parameter entry and a parse node from the model file which
	specifies a block name and an index array.
	<<Models: procedures>>=
	subroutine model_record_slha_block_entry (model, i_par, node)
	class(model_t), intent(inout) :: model
	integer, intent(in) :: i_par
	type(parse_node_t), intent(in), target :: node

	type(parse_node_t), pointer :: node_block_name, node_index
	type(string_t) :: block_name
	integer :: n_index, i, i_block
	integer, dimension(:), allocatable :: block_index

	node_block_name => node%get_sub_ptr (2)
	select case (char (node_block_name%get_rule_key ()))
	case ("block_name")
	block_name = node_block_name%get_string ()
	case ("QNUMBERS")
	block_name = "QNUMBERS"
	case default
	block_name = node_block_name%get_string ()
	end select
	n_index = node%get_n_sub () - 2
	allocate (block_index (n_index))
	node_index => node_block_name%get_next_ptr ()
	do i = 1, n_index
	block_index(i) = node_index%get_integer ()
	node_index => node_index%get_next_ptr ()
	end do
	i_block = 0
	FIND_BLOCK: do i = 1, model%n_slha_block
	if (model%slha_block(i)%name == block_name) then
	i_block = i
	exit FIND_BLOCK
	end if
	end do FIND_BLOCK
	if (i_block == 0) then
	call model_add_slha_block (model, block_name)
	i_block = model%n_slha_block
	end if
	associate (b => model%slha_block(i_block))
	call add_slha_block_entry (b, block_index, i_par)
	end associate
	model%par(i_par)%block_name = block_name
	model%par(i_par)%block_index = block_index
	end subroutine model_record_slha_block_entry

	@ %def model_record_slha_block_entry
	@ Add a new entry to the SLHA block register, increasing the array
	size if necessary
	<<Models: procedures>>=
	subroutine model_add_slha_block (model, block_name)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in) :: block_name

	if (.not. allocated (model%slha_block)) allocate (model%slha_block (1))
	if (model%n_slha_block == size (model%slha_block)) call grow
	model%n_slha_block = model%n_slha_block + 1
	associate (b => model%slha_block(model%n_slha_block))
	b%name = block_name
	allocate (b%entry (1))
	end associate

	contains

	subroutine grow
	type(slha_block_t), dimension(:), allocatable :: b_tmp
	call move_alloc (model%slha_block, b_tmp)
	allocate (model%slha_block (2 * size (b_tmp)))
	model%slha_block(:size (b_tmp)) = b_tmp(:)
	end subroutine grow

	end subroutine model_add_slha_block

	@ %def model_add_slha_block
	@ Add a new entry to a block-register record. The entry establishes a
	pointer-target relation between an index array within the SLHA block and a
	parameter-data record. We increase the entry array as needed.
	<<Models: procedures>>=
	subroutine add_slha_block_entry (b, block_index, i_par)
	type(slha_block_t), intent(inout) :: b
	integer, dimension(:), intent(in) :: block_index
	integer, intent(in) :: i_par

	if (b%n_entry == size (b%entry)) call grow
	b%n_entry = b%n_entry + 1
	associate (entry => b%entry(b%n_entry))
	entry%block_index = block_index
	entry%i_par = i_par
	end associate

	contains

	subroutine grow
	type(slha_entry_t), dimension(:), allocatable :: entry_tmp
	call move_alloc (b%entry, entry_tmp)
	allocate (b%entry (2 * size (entry_tmp)))
	b%entry(:size (entry_tmp)) = entry_tmp(:)
	end subroutine grow

	end subroutine add_slha_block_entry

	@ %def add_slha_block_entry
	@
	The lookup routine returns a pointer to the appropriate [[par_data]]
	record, if [[block_name]] and [[block_index]] are valid. The latter
	point to the [[slha_block_t]] register within the [[model_t]] object,
	if it is allocated.

	This should only be needed during I/O (i.e., while reading the SLHA
	file), so a simple linear search for each parameter should not be a
	performance problem.
	<<Models: model: TBP>>=
	procedure :: slha_lookup => model_slha_lookup
	<<Models: procedures>>=
	subroutine model_slha_lookup (model, block_name, block_index, par_data)
	class(model_t), intent(in) :: model
	type(string_t), intent(in) :: block_name
	integer, dimension(:), intent(in) :: block_index
	class(modelpar_data_t), pointer, intent(out) :: par_data

	integer :: i, j

	par_data => null ()
	if (allocated (model%slha_block)) then
	do i = 1, model%n_slha_block
	associate (block => model%slha_block(i))
	if (block%name == block_name) then
	do j = 1, block%n_entry
	associate (entry => block%entry(j))
	if (size (entry%block_index) == size (block_index)) then
	if (all (entry%block_index == block_index)) then
	par_data => model%par(entry%i_par)%data
	return
	end if
	end if
	end associate
	end do
	end if
	end associate
	end do
	end if

	end subroutine model_slha_lookup

	@ %def model_slha_lookup
	@ Modify the value of a parameter, identified by block name and index array.
	<<Models: model: TBP>>=
	procedure :: slha_set_par => model_slha_set_par
	<<Models: procedures>>=
	subroutine model_slha_set_par (model, block_name, block_index, value)
	class(model_t), intent(inout) :: model
	type(string_t), intent(in) :: block_name
	integer, dimension(:), intent(in) :: block_index
	real(default), intent(in) :: value

	class(modelpar_data_t), pointer :: par_data

	call model%slha_lookup (block_name, block_index, par_data)
	if (associated (par_data)) then
	par_data = value
	end if

	end subroutine model_slha_set_par

	@ %def model_slha_set_par
	@
	\subsection{Reading models from file}
	This procedure defines the model-file syntax for the parser, returning
	an internal file (ifile).

	Note that arithmetic operators are defined as keywords in the
	expression syntax, so we exclude them here.
	<<Models: procedures>>=
	subroutine define_model_file_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ model_def = model_name_def " // &
	"scheme_header parameters external_pars particles vertices")
	call ifile_append (ifile, "SEQ model_name_def = model model_name")
	call ifile_append (ifile, "KEY model")
	call ifile_append (ifile, "QUO model_name = '""'...'""'")
	call ifile_append (ifile, "SEQ scheme_header = scheme_decl?")
	call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list")
	call ifile_append (ifile, "KEY schemes")
	call ifile_append (ifile, "LIS scheme_list = scheme_name+")
	call ifile_append (ifile, "QUO scheme_name = '""'...'""'")
	call ifile_append (ifile, "SEQ parameters = generic_par_def*")
	call ifile_append (ifile, "ALT generic_par_def = &
	&parameter_def \| derived_def \| unused_def \| scheme_block")
	call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // &
	"'=' any_real_value slha_annotation?")
	call ifile_append (ifile, "ALT any_real_value = " &
	// "neg_real_value \| pos_real_value \| real_value")
	call ifile_append (ifile, "SEQ neg_real_value = '-' real_value")
	call ifile_append (ifile, "SEQ pos_real_value = '+' real_value")
	call ifile_append (ifile, "KEY parameter")
	call ifile_append (ifile, "IDE par_name")
	! call ifile_append (ifile, "KEY '='") !!! Key already exists
	call ifile_append (ifile, "SEQ slha_annotation = " // &
	"slha_entry slha_block_name slha_entry_index*")
	call ifile_append (ifile, "KEY slha_entry")
	call ifile_append (ifile, "IDE slha_block_name")
	call ifile_append (ifile, "INT slha_entry_index")
	call ifile_append (ifile, "SEQ derived_def = derived par_name " // &
	"'=' expr")
	call ifile_append (ifile, "KEY derived")
	call ifile_append (ifile, "SEQ unused_def = unused par_name")
	call ifile_append (ifile, "KEY unused")
	call ifile_append (ifile, "SEQ external_pars = external_def*")
	call ifile_append (ifile, "SEQ external_def = external par_name")
	call ifile_append (ifile, "KEY external")
	call ifile_append (ifile, "SEQ scheme_block = &
	&scheme_block_beg scheme_block_body scheme_block_end")
	call ifile_append (ifile, "SEQ scheme_block_beg = select scheme")
	call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*")
	call ifile_append (ifile, "SEQ scheme_block_case = &
	&scheme scheme_id parameters")
	call ifile_append (ifile, "ALT scheme_id = scheme_list \| other")
	call ifile_append (ifile, "SEQ scheme_block_end = end select")
	call ifile_append (ifile, "KEY select")
	call ifile_append (ifile, "KEY scheme")
	call ifile_append (ifile, "KEY other")
	call ifile_append (ifile, "KEY end")
	call ifile_append (ifile, "SEQ particles = particle_def*")
	call ifile_append (ifile, "SEQ particle_def = particle name_def " // &
	"prt_pdg prt_details")
	call ifile_append (ifile, "KEY particle")
	call ifile_append (ifile, "SEQ prt_pdg = signed_int")
	call ifile_append (ifile, "ALT prt_details = prt_src \| prt_properties")
	call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties")
	call ifile_append (ifile, "KEY like")
	call ifile_append (ifile, "SEQ prt_properties = prt_property*")
	call ifile_append (ifile, "ALT prt_property = " // &
	"parton \| invisible \| gauge \| left \| right \| " // &
	"prt_name \| prt_anti \| prt_tex_name \| prt_tex_anti \| " // &
	"prt_spin \| prt_isospin \| prt_charge \| " // &
	"prt_color \| prt_mass \| prt_width")
	call ifile_append (ifile, "KEY parton")
	call ifile_append (ifile, "KEY invisible")
	call ifile_append (ifile, "KEY gauge")
	call ifile_append (ifile, "KEY left")
	call ifile_append (ifile, "KEY right")
	call ifile_append (ifile, "SEQ prt_name = name name_def+")
	call ifile_append (ifile, "SEQ prt_anti = anti name_def+")
	call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def")
	call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def")
	call ifile_append (ifile, "KEY name")
	call ifile_append (ifile, "KEY anti")
	call ifile_append (ifile, "KEY tex_name")
	call ifile_append (ifile, "KEY tex_anti")
	call ifile_append (ifile, "ALT name_def = name_string \| name_id")
	call ifile_append (ifile, "QUO name_string = '""'...'""'")
	call ifile_append (ifile, "IDE name_id")
	call ifile_append (ifile, "SEQ prt_spin = spin frac")
	call ifile_append (ifile, "KEY spin")
	call ifile_append (ifile, "SEQ prt_isospin = isospin frac")
	call ifile_append (ifile, "KEY isospin")
	call ifile_append (ifile, "SEQ prt_charge = charge frac")
	call ifile_append (ifile, "KEY charge")
	call ifile_append (ifile, "SEQ prt_color = color integer_literal")
	call ifile_append (ifile, "KEY color")
	call ifile_append (ifile, "SEQ prt_mass = mass par_name")
	call ifile_append (ifile, "KEY mass")
	call ifile_append (ifile, "SEQ prt_width = width par_name")
	call ifile_append (ifile, "KEY width")
	call ifile_append (ifile, "SEQ vertices = vertex_def*")
	call ifile_append (ifile, "SEQ vertex_def = vertex name_def+")
	call ifile_append (ifile, "KEY vertex")
	call define_expr_syntax (ifile, particles=.false., analysis=.false.)
	end subroutine define_model_file_syntax

	@ %def define_model_file_syntax
	@ The model-file syntax and lexer are fixed, therefore stored as
	module variables:
	<<Models: variables>>=
	type(syntax_t), target, save :: syntax_model_file

	@ %def syntax_model_file
	<<Models: public>>=
	public :: syntax_model_file_init
	<<Models: procedures>>=
	subroutine syntax_model_file_init ()
	type(ifile_t) :: ifile
	call define_model_file_syntax (ifile)
	call syntax_init (syntax_model_file, ifile)
	call ifile_final (ifile)
	end subroutine syntax_model_file_init

	@ %def syntax_model_file_init
	<<Models: procedures>>=
	subroutine lexer_init_model_file (lexer)
	type(lexer_t), intent(out) :: lexer
	call lexer_init (lexer, &
	comment_chars = "#!", &
	quote_chars = '"{', &
	quote_match = '"}', &
	single_chars = ":(),", &
	special_class = [ "+-*/^", "<>= " ] , &
	keyword_list = syntax_get_keyword_list_ptr (syntax_model_file))
	end subroutine lexer_init_model_file

	@ %def lexer_init_model_file
	<<Models: public>>=
	public :: syntax_model_file_final
	<<Models: procedures>>=
	subroutine syntax_model_file_final ()
	call syntax_final (syntax_model_file)
	end subroutine syntax_model_file_final

	@ %def syntax_model_file_final
	<<Models: public>>=
	public :: syntax_model_file_write
	<<Models: procedures>>=
	subroutine syntax_model_file_write (unit)
	integer, intent(in), optional :: unit
	call syntax_write (syntax_model_file, unit)
	end subroutine syntax_model_file_write

	@ %def syntax_model_file_write
	@
	Read a model from file. Handle all syntax and respect the provided scheme.

	The [[ufo]] flag just says that the model object should be tagged as
	being derived from an UFO model. The UFO model path may be requested
	by the caller. If not, we use a standard path search for UFO models.
	There is no difference in the
	contents of the file or the generated model object.
	<<Models: model: TBP>>=
	procedure :: read => model_read
	<<Models: procedures>>=
	subroutine model_read (model, filename, os_data, exist, &
	scheme, ufo, ufo_path_requested, rebuild_mdl)
	class(model_t), intent(out), target :: model
	type(string_t), intent(in) :: filename
	type(os_data_t), intent(in) :: os_data
	logical, intent(out), optional :: exist
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path_requested
	logical, intent(in), optional :: rebuild_mdl
	type(string_t) :: file
	type(stream_t), target :: stream
	type(lexer_t) :: lexer
	integer :: unit
	character(32) :: model_md5sum
	type(parse_node_t), pointer :: nd_model_def, nd_model_name_def
	type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl
	type(parse_node_t), pointer :: nd_parameters
	type(parse_node_t), pointer :: nd_external_pars
	type(parse_node_t), pointer :: nd_particles, nd_vertices
	type(string_t) :: model_name, lib_name
	integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx
	type(parse_node_t), pointer :: nd_par_def
	type(parse_node_t), pointer :: nd_ext_def
	type(parse_node_t), pointer :: nd_prt
	type(parse_node_t), pointer :: nd_vtx
	logical :: ufo_model, model_exist, rebuild
	ufo_model = .false.; if (present (ufo)) ufo_model = ufo
	rebuild = .true.; if (present (rebuild_mdl)) rebuild = rebuild_mdl
	file = filename
	inquire (file=char(file), exist=model_exist)
	if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then
	file = os_data%whizard_modelpath_local // "/" // filename
	inquire (file = char (file), exist = model_exist)
	end if
	if (.not. model_exist) then
	file = os_data%whizard_modelpath // "/" // filename
	inquire (file = char (file), exist = model_exist)
	end if
	if (ufo_model .and. rebuild) then
	file = filename
	call model_generate_ufo (filename, os_data, model%ufo_path, &
	ufo_path_requested=ufo_path_requested)
	inquire (file = char (file), exist = model_exist)
	end if
	if (.not. model_exist) then
	call msg_fatal ("Model file '" // char (filename) // "' not found")
	if (present (exist)) exist = .false.
	return
	end if
	if (present (exist)) exist = .true.

	if (logging) call msg_message ("Reading model file '" // char (file) // "'")

	unit = free_unit ()
	open (file=char(file), unit=unit, action="read", status="old")
	model_md5sum = md5sum (unit)
	close (unit)

	call lexer_init_model_file (lexer)
	call stream_init (stream, char (file))
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init (model%parse_tree, syntax_model_file, lexer)
	call stream_final (stream)
	call lexer_final (lexer)

	nd_model_def => model%parse_tree%get_root_ptr ()
	nd_model_name_def => parse_node_get_sub_ptr (nd_model_def)
	model_name = parse_node_get_string &
	(parse_node_get_sub_ptr (nd_model_name_def, 2))
	nd_schemes => nd_model_name_def%get_next_ptr ()

	call find_block &
	("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters)
	call find_block &
	("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars)
	call find_block &
	("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles)
	call find_block &
	("particles", nd_particles, nd_prt, n_prt, nd_vertices)
	call find_block &
	("vertices", nd_vertices, nd_vtx, n_vtx)

	if (associated (nd_external_pars)) then
	lib_name = "external." // model_name
	else
	lib_name = ""
	end if

	if (associated (nd_scheme_decl)) then
	call handle_schemes (nd_scheme_decl, scheme)
	end if

	n_par = 0
	call count_parameters (nd_par_def, n_parblock, n_par)

	call model%init &
	(model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo)
	model%md5sum = model_md5sum

	if (associated (nd_par_def)) then
	i_par = 0
	call handle_parameters (nd_par_def, n_parblock, i_par)
	end if
	if (associated (nd_ext_def)) then
	call handle_external (nd_ext_def, n_par, n_ext)
	end if
	call model%update_parameters ()
	if (associated (nd_prt)) then
	call handle_fields (nd_prt, n_prt)
	end if
	if (associated (nd_vtx)) then
	call handle_vertices (nd_vtx, n_vtx)
	end if

	call model%freeze_vertices ()
	call model%append_field_vars ()

	contains

	subroutine find_block (key, nd, nd_item, n_item, nd_next)
	character(*), intent(in) :: key
	type(parse_node_t), pointer, intent(inout) :: nd
	type(parse_node_t), pointer, intent(out) :: nd_item
	integer, intent(out), optional :: n_item
	type(parse_node_t), pointer, intent(out), optional :: nd_next
	if (associated (nd)) then
	if (nd%get_rule_key () == key) then
	nd_item => nd%get_sub_ptr ()
	if (present (n_item)) n_item = nd%get_n_sub ()
	if (present (nd_next)) nd_next => nd%get_next_ptr ()
	else
	nd_item => null ()
	if (present (n_item)) n_item = 0
	if (present (nd_next)) nd_next => nd
	nd => null ()
	end if
	else
	nd_item => null ()
	if (present (n_item)) n_item = 0
	if (present (nd_next)) nd_next => null ()
	end if
	end subroutine find_block

	subroutine handle_schemes (nd_scheme_decl, scheme)
	type(parse_node_t), pointer, intent(in) :: nd_scheme_decl
	type(string_t), intent(in), optional :: scheme
	type(parse_node_t), pointer :: nd_list, nd_entry
	type(string_t), dimension(:), allocatable :: schemes
	integer :: i, n_schemes
	nd_list => nd_scheme_decl%get_sub_ptr (3)
	nd_entry => nd_list%get_sub_ptr ()
	n_schemes = nd_list%get_n_sub ()
	allocate (schemes (n_schemes))
	do i = 1, n_schemes
	schemes(i) = nd_entry%get_string ()
	nd_entry => nd_entry%get_next_ptr ()
	end do
	if (present (scheme)) then
	do i = 1, n_schemes
	if (schemes(i) == scheme) goto 10 ! block exit
	end do
	call msg_fatal ("Scheme '" // char (scheme) &
	// "' is not supported by model '" // char (model_name) // "'")
	end if
	10 continue
	call model%enable_schemes (schemes)
	call model%set_scheme (scheme)
	end subroutine handle_schemes

	subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def)
	type(parse_node_t), pointer, intent(in) :: nd_scheme_block
	integer, intent(out) :: n_parblock_sub
	type(parse_node_t), pointer, intent(out) :: nd_par_def
	type(parse_node_t), pointer :: nd_scheme_body
	type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme
	type(string_t) :: scheme
	integer :: n_cases, i
	scheme = model%get_scheme ()
	nd_scheme_body => nd_scheme_block%get_sub_ptr (2)
	nd_parameters => null ()
	select case (char (nd_scheme_body%get_rule_key ()))
	case ("scheme_block_body")
	n_cases = nd_scheme_body%get_n_sub ()
	FIND_SCHEME: do i = 1, n_cases
	nd_scheme_case => nd_scheme_body%get_sub_ptr (i)
	nd_scheme_id => nd_scheme_case%get_sub_ptr (2)
	select case (char (nd_scheme_id%get_rule_key ()))
	case ("scheme_list")
	nd_scheme => nd_scheme_id%get_sub_ptr ()
	do while (associated (nd_scheme))
	if (scheme == nd_scheme%get_string ()) then
	nd_parameters => nd_scheme_id%get_next_ptr ()
	exit FIND_SCHEME
	end if
	nd_scheme => nd_scheme%get_next_ptr ()
	end do
	case ("other")
	nd_parameters => nd_scheme_id%get_next_ptr ()
	exit FIND_SCHEME
	case default
	print *, "'", char (nd_scheme_id%get_rule_key ()), "'"
	call msg_bug ("Model read: impossible scheme rule")
	end select
	end do FIND_SCHEME
	end select
	if (associated (nd_parameters)) then
	select case (char (nd_parameters%get_rule_key ()))
	case ("parameters")
	n_parblock_sub = nd_parameters%get_n_sub ()
	if (n_parblock_sub > 0) then
	nd_par_def => nd_parameters%get_sub_ptr ()
	else
	nd_par_def => null ()
	end if
	case default
	n_parblock_sub = 0
	nd_par_def => null ()
	end select
	else
	n_parblock_sub = 0
	nd_par_def => null ()
	end if
	end subroutine select_scheme

	recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par)
	type(parse_node_t), pointer, intent(in) :: nd_par_def_in
	integer, intent(in) :: n_parblock
	integer, intent(inout) :: n_par
	type(parse_node_t), pointer :: nd_par_def, nd_par_key
	type(parse_node_t), pointer :: nd_par_def_sub
	integer :: n_parblock_sub
	integer :: i
	nd_par_def => nd_par_def_in
	do i = 1, n_parblock
	nd_par_key => nd_par_def%get_sub_ptr ()
	select case (char (nd_par_key%get_rule_key ()))
	case ("parameter", "derived", "unused")
	n_par = n_par + 1
	case ("scheme_block_beg")
	call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
	if (n_parblock_sub > 0) then
	call count_parameters (nd_par_def_sub, n_parblock_sub, n_par)
	end if
	case default
	print *, "'", char (nd_par_key%get_rule_key ()), "'"
	call msg_bug ("Model read: impossible parameter rule")
	end select
	nd_par_def => parse_node_get_next_ptr (nd_par_def)
	end do
	end subroutine count_parameters

	recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par)
	type(parse_node_t), pointer, intent(in) :: nd_par_def_in
	integer, intent(in) :: n_parblock
	integer, intent(inout) :: i_par
	type(parse_node_t), pointer :: nd_par_def, nd_par_key
	type(parse_node_t), pointer :: nd_par_def_sub
	integer :: n_parblock_sub
	integer :: i
	nd_par_def => nd_par_def_in
	do i = 1, n_parblock
	nd_par_key => nd_par_def%get_sub_ptr ()
	select case (char (nd_par_key%get_rule_key ()))
	case ("parameter")
	i_par = i_par + 1
	call model%read_parameter (i_par, nd_par_def)
	case ("derived")
	i_par = i_par + 1
	call model%read_derived (i_par, nd_par_def)
	case ("unused")
	i_par = i_par + 1
	call model%read_unused (i_par, nd_par_def)
	case ("scheme_block_beg")
	call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
	if (n_parblock_sub > 0) then
	call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par)
	end if
	end select
	nd_par_def => parse_node_get_next_ptr (nd_par_def)
	end do
	end subroutine handle_parameters

	subroutine handle_external (nd_ext_def, n_par, n_ext)
	type(parse_node_t), pointer, intent(inout) :: nd_ext_def
	integer, intent(in) :: n_par, n_ext
	integer :: i
	do i = n_par + 1, n_par + n_ext
	call model%read_external (i, nd_ext_def)
	nd_ext_def => parse_node_get_next_ptr (nd_ext_def)
	end do
	! real(c_default_float), dimension(:), allocatable :: par
	! if (associated (model%init_external_parameters)) then
	! allocate (par (model%get_n_real ()))
	! call model%real_parameters_to_c_array (par)
	! call model%init_external_parameters (par)
	! call model%real_parameters_from_c_array (par)
	! end if
	end subroutine handle_external

	subroutine handle_fields (nd_prt, n_prt)
	type(parse_node_t), pointer, intent(inout) :: nd_prt
	integer, intent(in) :: n_prt
	integer :: i
	do i = 1, n_prt
	call model%read_field (i, nd_prt)
	nd_prt => parse_node_get_next_ptr (nd_prt)
	end do
	end subroutine handle_fields

	subroutine handle_vertices (nd_vtx, n_vtx)
	type(parse_node_t), pointer, intent(inout) :: nd_vtx
	integer, intent(in) :: n_vtx
	integer :: i
	do i = 1, n_vtx
	call model%read_vertex (i, nd_vtx)
	nd_vtx => parse_node_get_next_ptr (nd_vtx)
	end do
	end subroutine handle_vertices

	end subroutine model_read

	@ %def model_read
	@ Parameters are real values (literal) with an optional unit.
	<<Models: model: TBP>>=
	procedure, private :: read_parameter => model_read_parameter
	<<Models: procedures>>=
	subroutine model_read_parameter (model, i, node)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in), target :: node
	type(parse_node_t), pointer :: node_name, node_val, node_slha_entry
	type(string_t) :: name
	node_name => parse_node_get_sub_ptr (node, 2)
	name = parse_node_get_string (node_name)
	node_val => parse_node_get_next_ptr (node_name, 2)
	call model%set_parameter_parse_node (i, name, node_val, constant=.true.)
	node_slha_entry => parse_node_get_next_ptr (node_val)
	if (associated (node_slha_entry)) then
	call model_record_slha_block_entry (model, i, node_slha_entry)
	end if
	end subroutine model_read_parameter

	@ %def model_read_parameter
	@ Derived parameters have any numeric expression as their definition.
	Don't evaluate the expression, yet.
	<<Models: model: TBP>>=
	procedure, private :: read_derived => model_read_derived
	<<Models: procedures>>=
	subroutine model_read_derived (model, i, node)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in), target :: node
	type(string_t) :: name
	type(parse_node_t), pointer :: pn_expr
	name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
	pn_expr => parse_node_get_sub_ptr (node, 4)
	call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.)
	end subroutine model_read_derived

	@ %def model_read_derived
	@ External parameters have no definition; they are handled by an
	external library.
	<<Models: model: TBP>>=
	procedure, private :: read_external => model_read_external
	<<Models: procedures>>=
	subroutine model_read_external (model, i, node)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in), target :: node
	type(string_t) :: name
	name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
	call model%set_parameter_external (i, name)
	end subroutine model_read_external

	@ %def model_read_external
	@ Ditto for unused parameters, they are there just for reserving the name.
	<<Models: model: TBP>>=
	procedure, private :: read_unused => model_read_unused
	<<Models: procedures>>=
	subroutine model_read_unused (model, i, node)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in), target :: node
	type(string_t) :: name
	name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
	call model%set_parameter_unused (i, name)
	end subroutine model_read_unused

	@ %def model_read_unused
	<<Models: model: TBP>>=
	procedure, private :: read_field => model_read_field
	<<Models: procedures>>=
	subroutine model_read_field (model, i, node)
	class(model_t), intent(inout), target :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in) :: node
	type(parse_node_t), pointer :: nd_src, nd_props, nd_prop
	type(string_t) :: longname
	integer :: pdg
	type(string_t) :: name_src
	type(string_t), dimension(:), allocatable :: name
	type(field_data_t), pointer :: field, field_src
	longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
	pdg = read_frac (parse_node_get_sub_ptr (node, 3))
	field => model%get_field_ptr_by_index (i)
	call field%init (longname, pdg)
	nd_src => parse_node_get_sub_ptr (node, 4)
	if (associated (nd_src)) then
	if (parse_node_get_rule_key (nd_src) == "prt_src") then
	name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2))
	field_src => model%get_field_ptr (name_src, check=.true.)
	call field%copy_from (field_src)
	nd_props => parse_node_get_sub_ptr (nd_src, 3)
	else
	nd_props => nd_src
	end if
	nd_prop => parse_node_get_sub_ptr (nd_props)
	do while (associated (nd_prop))
	select case (char (parse_node_get_rule_key (nd_prop)))
	case ("invisible")
	call field%set (is_visible=.false.)
	case ("parton")
	call field%set (is_parton=.true.)
	case ("gauge")
	call field%set (is_gauge=.true.)
	case ("left")
	call field%set (is_left_handed=.true.)
	case ("right")
	call field%set (is_right_handed=.true.)
	case ("prt_name")
	call read_names (nd_prop, name)
	call field%set (name=name)
	case ("prt_anti")
	call read_names (nd_prop, name)
	call field%set (anti=name)
	case ("prt_tex_name")
	call field%set ( &
	tex_name = parse_node_get_string &
	(parse_node_get_sub_ptr (nd_prop, 2)))
	case ("prt_tex_anti")
	call field%set ( &
	tex_anti = parse_node_get_string &
	(parse_node_get_sub_ptr (nd_prop, 2)))
	case ("prt_spin")
	call field%set ( &
	spin_type = read_frac &
	(parse_node_get_sub_ptr (nd_prop, 2), 2))
	case ("prt_isospin")
	call field%set ( &
	isospin_type = read_frac &
	(parse_node_get_sub_ptr (nd_prop, 2), 2))
	case ("prt_charge")
	call field%set ( &
	charge_type = read_frac &
	(parse_node_get_sub_ptr (nd_prop, 2), 3))
	case ("prt_color")
	call field%set ( &
	color_type = parse_node_get_integer &
	(parse_node_get_sub_ptr (nd_prop, 2)))
	case ("prt_mass")
	call field%set ( &
	mass_data = model%get_par_data_ptr &
	(parse_node_get_string &
	(parse_node_get_sub_ptr (nd_prop, 2))))
	case ("prt_width")
	call field%set ( &
	width_data = model%get_par_data_ptr &
	(parse_node_get_string &
	(parse_node_get_sub_ptr (nd_prop, 2))))
	case default
	call msg_bug (" Unknown particle property '" &
	// char (parse_node_get_rule_key (nd_prop)) // "'")
	end select
	if (allocated (name)) deallocate (name)
	nd_prop => parse_node_get_next_ptr (nd_prop)
	end do
	end if
	call field%freeze ()
	end subroutine model_read_field

	@ %def model_read_field
	<<Models: model: TBP>>=
	procedure, private :: read_vertex => model_read_vertex
	<<Models: procedures>>=
	subroutine model_read_vertex (model, i, node)
	class(model_t), intent(inout) :: model
	integer, intent(in) :: i
	type(parse_node_t), intent(in) :: node
	type(string_t), dimension(:), allocatable :: name
	call read_names (node, name)
	call model%set_vertex (i, name)
	end subroutine model_read_vertex

	@ %def model_read_vertex
	<<Models: procedures>>=
	subroutine read_names (node, name)
	type(parse_node_t), intent(in) :: node
	type(string_t), dimension(:), allocatable, intent(inout) :: name
	type(parse_node_t), pointer :: nd_name
	integer :: n_names, i
	n_names = parse_node_get_n_sub (node) - 1
	allocate (name (n_names))
	nd_name => parse_node_get_sub_ptr (node, 2)
	do i = 1, n_names
	name(i) = parse_node_get_string (nd_name)
	nd_name => parse_node_get_next_ptr (nd_name)
	end do
	end subroutine read_names

	@ %def read_names
	@ There is an optional argument for the base.
	<<Models: procedures>>=
	function read_frac (nd_frac, base) result (qn_type)
	integer :: qn_type
	type(parse_node_t), intent(in) :: nd_frac
	integer, intent(in), optional :: base
	type(parse_node_t), pointer :: nd_num, nd_den
	integer :: num, den
	nd_num => parse_node_get_sub_ptr (nd_frac)
	nd_den => parse_node_get_next_ptr (nd_num)
	select case (char (parse_node_get_rule_key (nd_num)))
	case ("integer_literal")
	num = parse_node_get_integer (nd_num)
	case ("neg_int")
	num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
	case ("pos_int")
	num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
	case default
	call parse_tree_bug (nd_num, "int\|neg_int\|pos_int")
	end select
	if (associated (nd_den)) then
	den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2))
	else
	den = 1
	end if
	if (present (base)) then
	if (den == 1) then
	qn_type = sign (1 + abs (num) * base, num)
	else if (den == base) then
	qn_type = sign (abs (num) + 1, num)
	else
	call parse_node_write_rec (nd_frac)
	call msg_fatal (" Fractional quantum number: wrong denominator")
	end if
	else
	if (den == 1) then
	qn_type = num
	else
	call parse_node_write_rec (nd_frac)
	call msg_fatal (" Wrong type: no fraction expected")
	end if
	end if
	end function read_frac

	@ %def read_frac
	@ Append field (PDG-array) variables to the variable list, based on
	the field content.
	<<Models: model: TBP>>=
	procedure, private :: append_field_vars => model_append_field_vars
	<<Models: procedures>>=
	subroutine model_append_field_vars (model)
	class(model_t), intent(inout) :: model
	type(pdg_array_t) :: aval
	type(field_data_t), dimension(:), pointer :: field_array
	type(field_data_t), pointer :: field
	type(string_t) :: name
	type(string_t), dimension(:), allocatable :: name_array
	integer, dimension(:), allocatable :: pdg
	logical, dimension(:), allocatable :: mask
	integer :: i, j
	field_array => model%get_field_array_ptr ()
	aval = UNDEFINED
	call var_list_append_pdg_array &
	(model%var_list, var_str ("particle"), &
	aval, locked = .true., intrinsic=.true.)
	do i = 1, size (field_array)
	aval = field_array(i)%get_pdg ()
	name = field_array(i)%get_longname ()
	call var_list_append_pdg_array &
	(model%var_list, name, aval, locked=.true., intrinsic=.true.)
	call field_array(i)%get_name_array (.false., name_array)
	do j = 1, size (name_array)
	call var_list_append_pdg_array &
	(model%var_list, name_array(j), &
	aval, locked=.true., intrinsic=.true.)
	end do
	model%max_field_name_length = &
	max (model%max_field_name_length, len (name_array(1)))
	aval = - field_array(i)%get_pdg ()
	call field_array(i)%get_name_array (.true., name_array)
	do j = 1, size (name_array)
	call var_list_append_pdg_array &
	(model%var_list, name_array(j), &
	aval, locked=.true., intrinsic=.true.)
	end do
	if (size (name_array) > 0) then
	model%max_field_name_length = &
	max (model%max_field_name_length, len (name_array(1)))
	end if
	end do
	call model%get_all_pdg (pdg)
	allocate (mask (size (pdg)))
	do i = 1, size (pdg)
	field => model%get_field_ptr (pdg(i))
	mask(i) = field%get_charge_type () /= 1
	end do
	aval = pack (pdg, mask)
	call var_list_append_pdg_array &
	(model%var_list, var_str ("charged"), &
	aval, locked = .true., intrinsic=.true.)
	do i = 1, size (pdg)
	field => model%get_field_ptr (pdg(i))
	mask(i) = field%get_charge_type () == 1
	end do
	aval = pack (pdg, mask)
	call var_list_append_pdg_array &
	(model%var_list, var_str ("neutral"), &
	aval, locked = .true., intrinsic=.true.)
	do i = 1, size (pdg)
	field => model%get_field_ptr (pdg(i))
	mask(i) = field%get_color_type () /= 1
	end do
	aval = pack (pdg, mask)
	call var_list_append_pdg_array &
	(model%var_list, var_str ("colored"), &
	aval, locked = .true., intrinsic=.true.)
	end subroutine model_append_field_vars

	@ %def model_append_field_vars
	@
	\subsection{Test models}
	<<Models: public>>=
	public :: create_test_model
	<<Models: procedures>>=
	subroutine create_test_model (model_name, test_model)
	type(string_t), intent(in) :: model_name
	type(model_t), intent(out), pointer :: test_model
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	call syntax_model_file_init ()
	call os_data%init ()
	call model_list%read_model &
	(model_name, model_name // var_str (".mdl"), os_data, test_model)
	end subroutine create_test_model

	@ %def create_test_model
	@
	\subsection{Model list}
	List of currently active models
	<<Models: types>>=
	type, extends (model_t) :: model_entry_t
	type(model_entry_t), pointer :: next => null ()
	end type model_entry_t

	@ %def model_entry_t
	<<Models: public>>=
	public :: model_list_t
	<<Models: types>>=
	type :: model_list_t
	type(model_entry_t), pointer :: first => null ()
	type(model_entry_t), pointer :: last => null ()
	type(model_list_t), pointer :: context => null ()
	contains
	<<Models: model list: TBP>>
	end type model_list_t

	@ %def model_list_t
	@ Write an account of the model list. We write linked lists first, starting
	from the global context.
	<<Models: model list: TBP>>=
	procedure :: write => model_list_write
	<<Models: procedures>>=
	recursive subroutine model_list_write (object, unit, verbose, follow_link)
	class(model_list_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	logical, intent(in), optional :: follow_link
	type(model_entry_t), pointer :: current
	logical :: rec
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	rec = .true.; if (present (follow_link)) rec = follow_link
	if (rec .and. associated (object%context)) then
	call object%context%write (unit, verbose, follow_link)
	end if
	current => object%first
	if (associated (current)) then
	do while (associated (current))
	call current%write (unit, verbose)
	current => current%next
	if (associated (current)) write (u, *)
	end do
	end if
	end subroutine model_list_write

	@ %def model_list_write
	@ Link this list to another one.
	<<Models: model list: TBP>>=
	procedure :: link => model_list_link
	<<Models: procedures>>=
	subroutine model_list_link (model_list, context)
	class(model_list_t), intent(inout) :: model_list
	type(model_list_t), intent(in), target :: context
	model_list%context => context
	end subroutine model_list_link

	@ %def model_list_link
	@ (Private, used below:)
	Append an existing model, for which we have allocated a pointer entry, to
	the model list. The original pointer becomes disassociated, and the model
	should now be considered as part of the list. We assume that this model is
	not yet part of the list.

	If we provide a [[model]] argument, this returns a pointer to the new entry.
	<<Models: model list: TBP>>=
	procedure, private :: import => model_list_import
	<<Models: procedures>>=
	subroutine model_list_import (model_list, current, model)
	class(model_list_t), intent(inout) :: model_list
	type(model_entry_t), pointer, intent(inout) :: current
	type(model_t), optional, pointer, intent(out) :: model
	if (associated (current)) then
	if (associated (model_list%first)) then
	model_list%last%next => current
	else
	model_list%first => current
	end if
	model_list%last => current
	if (present (model)) model => current%model_t
	current => null ()
	end if
	end subroutine model_list_import

	@ %def model_list_import
	@ Currently test only:

	Add a new model with given [[name]] to the list, if it does not yet
	exist. If successful, return a pointer to the new model.
	<<Models: model list: TBP>>=
	procedure :: add => model_list_add
	<<Models: procedures>>=
	subroutine model_list_add (model_list, &
	name, os_data, n_par, n_prt, n_vtx, model)
	class(model_list_t), intent(inout) :: model_list
	type(string_t), intent(in) :: name
	type(os_data_t), intent(in) :: os_data
	integer, intent(in) :: n_par, n_prt, n_vtx
	type(model_t), pointer :: model
	type(model_entry_t), pointer :: current
	if (model_list%model_exists (name, follow_link=.false.)) then
	model => null ()
	else
	allocate (current)
	call current%init (name, var_str (""), os_data, &
	n_par, n_prt, n_vtx)
	call model_list%import (current, model)
	end if
	end subroutine model_list_add

	@ %def model_list_add
	@ Read a new model from file and add to the list, if it does not yet
	exist. Finalize the model by allocating the vertex table. Return a
	pointer to the new model. If unsuccessful, return the original
	pointer.

	The model is always inserted in the last link of a chain of model lists. This
	way, we avoid loading models twice from different contexts. When a model is
	modified, we should first allocate a local copy.
	<<Models: model list: TBP>>=
	procedure :: read_model => model_list_read_model
	<<Models: procedures>>=
	subroutine model_list_read_model &
	(model_list, name, filename, os_data, model, &
	scheme, ufo, ufo_path, rebuild_mdl)
	class(model_list_t), intent(inout), target :: model_list
	type(string_t), intent(in) :: name, filename
	type(os_data_t), intent(in) :: os_data
	type(model_t), pointer, intent(inout) :: model
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path
	logical, intent(in), optional :: rebuild_mdl
	class(model_list_t), pointer :: global_model_list
	type(model_entry_t), pointer :: current
	logical :: exist
	if (.not. model_list%model_exists (name, &
	scheme, ufo, ufo_path, follow_link=.true.)) then
	allocate (current)
	call current%read (filename, os_data, exist, &
	scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, &
	rebuild_mdl=rebuild_mdl)
	if (.not. exist) return
	if (current%get_name () /= name) then
	call msg_fatal ("Model file '" // char (filename) // &
	"' contains model '" // char (current%get_name ()) // &
	"' instead of '" // char (name) // "'")
	call current%final (); deallocate (current)
	return
	end if
	global_model_list => model_list
	do while (associated (global_model_list%context))
	global_model_list => global_model_list%context
	end do
	call global_model_list%import (current, model)
	else
	model => model_list%get_model_ptr (name, scheme, ufo, ufo_path)
	end if
	end subroutine model_list_read_model

	@ %def model_list_read_model
	@ Append a copy of an existing model to a model list. Optionally, return
	pointer to the new entry.
	<<Models: model list: TBP>>=
	procedure :: append_copy => model_list_append_copy
	<<Models: procedures>>=
	subroutine model_list_append_copy (model_list, orig, model)
	class(model_list_t), intent(inout) :: model_list
	type(model_t), intent(in), target :: orig
	type(model_t), intent(out), pointer, optional :: model
	type(model_entry_t), pointer :: copy
	allocate (copy)
	call copy%init_instance (orig)
	call model_list%import (copy, model)
	end subroutine model_list_append_copy

	@ %def model_list_append_copy
	@ Check if a model exists by examining the list. Check recursively unless
	told otherwise.
	<<Models: model list: TBP>>=
	procedure :: model_exists => model_list_model_exists
	<<Models: procedures>>=
	recursive function model_list_model_exists &
	(model_list, name, scheme, ufo, ufo_path, follow_link) result (exists)
	class(model_list_t), intent(in) :: model_list
	logical :: exists
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path
	logical, intent(in), optional :: follow_link
	type(model_entry_t), pointer :: current
	logical :: rec
	rec = .true.; if (present (follow_link)) rec = follow_link
	current => model_list%first
	do while (associated (current))
	if (current%matches (name, scheme, ufo, ufo_path)) then
	exists = .true.
	return
	end if
	current => current%next
	end do
	if (rec .and. associated (model_list%context)) then
	exists = model_list%context%model_exists (name, &
	scheme, ufo, ufo_path, follow_link)
	else
	exists = .false.
	end if
	end function model_list_model_exists

	@ %def model_list_model_exists
	@ Return a pointer to a named model. Search recursively unless told otherwise.
	<<Models: model list: TBP>>=
	procedure :: get_model_ptr => model_list_get_model_ptr
	<<Models: procedures>>=
	recursive function model_list_get_model_ptr &
	(model_list, name, scheme, ufo, ufo_path, follow_link) result (model)
	class(model_list_t), intent(in) :: model_list
	type(model_t), pointer :: model
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path
	logical, intent(in), optional :: follow_link
	type(model_entry_t), pointer :: current
	logical :: rec
	rec = .true.; if (present (follow_link)) rec = follow_link
	current => model_list%first
	do while (associated (current))
	if (current%matches (name, scheme, ufo, ufo_path)) then
	model => current%model_t
	return
	end if
	current => current%next
	end do
	if (rec .and. associated (model_list%context)) then
	model => model_list%context%get_model_ptr (name, &
	scheme, ufo, ufo_path, follow_link)
	else
	model => null ()
	end if
	end function model_list_get_model_ptr

	@ %def model_list_get_model_ptr
	@ Delete the list of models. No recursion.
	<<Models: model list: TBP>>=
	procedure :: final => model_list_final
	<<Models: procedures>>=
	subroutine model_list_final (model_list)
	class(model_list_t), intent(inout) :: model_list
	type(model_entry_t), pointer :: current
	model_list%last => null ()
	do while (associated (model_list%first))
	current => model_list%first
	model_list%first => model_list%first%next
	call current%final ()
	deallocate (current)
	end do
	end subroutine model_list_final

	@ %def model_list_final
	@
	\subsection{Model instances}
	A model instance is a copy of a model object. The parameters are true
	copies. The particle data and the variable list pointers should point to the
	copy, so modifying the parameters has only a local effect. Hence, we build
	them up explicitly. The vertex array is also rebuilt, it contains particle
	pointers. Finally, the vertex hash table can be copied directly since it
	contains no pointers.

	The [[multiplicity]] entry depends on the association of the [[mass_data]]
	entry and therefore has to be set at the end.

	The instance must carry the [[target]] attribute.

	Parameters: the [[copy_parameter]] method essentially copies the parameter
	decorations (parse node, expression etc.). The current parameter values are
	part of the [[model_data_t]] base type and are copied afterwards via its
	[[copy_from]] method.

	Note: the parameter set is initialized for real parameters only.

	In order for the local model to be able to use the correct UFO model
	setup, UFO model information has to be transferred.
	<<Models: model: TBP>>=
	procedure :: init_instance => model_copy
	<<Models: procedures>>=
	subroutine model_copy (model, orig)
	class(model_t), intent(out), target :: model
	type(model_t), intent(in) :: orig
	integer :: n_par, n_prt, n_vtx
	integer :: i
	n_par = orig%get_n_real ()
	n_prt = orig%get_n_field ()
	n_vtx = orig%get_n_vtx ()
	call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx)
	if (allocated (orig%schemes)) then
	model%schemes = orig%schemes
	if (allocated (orig%selected_scheme)) then
	model%selected_scheme = orig%selected_scheme
	call model%set_scheme_num (orig%get_scheme_num ())
	end if
	end if
	if (allocated (orig%slha_block)) then
	model%slha_block = orig%slha_block
	end if
	model%md5sum = orig%md5sum
	model%ufo_model = orig%ufo_model
	model%ufo_path = orig%ufo_path
	if (allocated (orig%par)) then
	do i = 1, n_par
	call model%copy_parameter (i, orig%par(i))
	end do
	end if
	model%init_external_parameters => orig%init_external_parameters
	call model%model_data_t%copy_from (orig)
	model%max_par_name_length = orig%max_par_name_length
	call model%append_field_vars ()
	end subroutine model_copy

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

	module models_ut
	use unit_tests
	use models_uti

	<<Standard module head>>

	<<Models: public test>>

	contains

	<<Models: test driver>>

	end module models_ut
	@ %def models_ut
	@
	<<[[models_uti.f90]]>>=
	<<File header>>

	module models_uti

	<<Use kinds>>
	<<Use strings>>
	use file_utils, only: delete_file
	use physics_defs, only: SCALAR, SPINOR
	use os_interface
	use model_data
	use variables

	use models

	<<Standard module head>>

	<<Models: test declarations>>

	contains

	<<Models: tests>>

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

	@ %def models_tests
	@
	\subsubsection{Construct a Model}
	Here, we construct a toy model explicitly without referring to a file.
	<<Models: execute tests>>=
	call test (models_1, "models_1", &
	"construct model", &
	u, results)
	<<Models: test declarations>>=
	public :: models_1
	<<Models: tests>>=
	subroutine models_1 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model
	type(string_t) :: model_name
	type(string_t) :: x_longname
	type(string_t), dimension(2) :: parname
	type(string_t), dimension(2) :: x_name
	type(string_t), dimension(1) :: x_anti
	type(string_t) :: x_tex_name, x_tex_anti
	type(string_t) :: y_longname
	type(string_t), dimension(2) :: y_name
	type(string_t) :: y_tex_name
	type(field_data_t), pointer :: field

	write (u, "(A)") "* Test output: models_1"
	write (u, "(A)") "* Purpose: create a model"
	write (u, *)

	model_name = "Test model"
	call model_list%add (model_name, os_data, 2, 2, 3, model)
	parname(1) = "mx"
	parname(2) = "coup"
	call model%set_parameter_constant (1, parname(1), 10._default)
	call model%set_parameter_constant (2, parname(2), 1.3_default)
	x_longname = "X_LEPTON"
	x_name(1) = "X"
	x_name(2) = "x"
	x_anti(1) = "Xbar"
	x_tex_name = "X^+"
	x_tex_anti = "X^-"
	field => model%get_field_ptr_by_index (1)
	call field%init (x_longname, 99)
	call field%set ( &
	.true., .false., .false., .false., .false., &
	name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, &
	spin_type=SPINOR, isospin_type=-3, charge_type=2, &
	mass_data=model%get_par_data_ptr (parname(1)))
	y_longname = "Y_COLORON"
	y_name(1) = "Y"
	y_name(2) = "yc"
	y_tex_name = "Y^0"
	field => model%get_field_ptr_by_index (2)
	call field%init (y_longname, 97)
	call field%set ( &
	.false., .false., .true., .false., .false., &
	name=y_name, tex_name=y_tex_name, &
	spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8)
	call model%set_vertex (1, [99, 99, 99])
	call model%set_vertex (2, [99, 99, 99, 99])
	call model%set_vertex (3, [99, 97, 99])
	call model_list%write (u)

	call model_list%final ()

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

	end subroutine models_1

	@ %def models_1
	@
	\subsubsection{Read a Model}
	Read a predefined model from file.
	<<Models: execute tests>>=
	call test (models_2, "models_2", &
	"read model", &
	u, results)
	<<Models: test declarations>>=
	public :: models_2
	<<Models: tests>>=
	subroutine models_2 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(var_list_t), pointer :: var_list
	type(model_t), pointer :: model

	write (u, "(A)") "* Test output: models_2"
	write (u, "(A)") "* Purpose: read a model from file"
	write (u, *)

	call syntax_model_file_init ()
	call os_data%init ()

	call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
	os_data, model)
	call model_list%write (u)

	write (u, *)
	write (u, "(A)") "* Variable list"
	write (u, *)

	var_list => model%get_var_list_ptr ()
	call var_list%write (u)

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_2

	@ %def models_2
	@
	\subsubsection{Model Instance}
	Read a predefined model from file and create an instance.
	<<Models: execute tests>>=
	call test (models_3, "models_3", &
	"model instance", &
	u, results)
	<<Models: test declarations>>=
	public :: models_3
	<<Models: tests>>=
	subroutine models_3 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model
	type(var_list_t), pointer :: var_list
	type(model_t), pointer :: instance

	write (u, "(A)") "* Test output: models_3"
	write (u, "(A)") "* Purpose: create a model instance"
	write (u, *)

	call syntax_model_file_init ()
	call os_data%init ()

	call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
	os_data, model)
	allocate (instance)
	call instance%init_instance (model)

	call model%write (u)

	write (u, *)
	write (u, "(A)") "* Variable list"
	write (u, *)

	var_list => instance%get_var_list_ptr ()
	call var_list%write (u)

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

	call instance%final ()
	deallocate (instance)

	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_3

	@ %def models_test
	@
	\subsubsection{Unstable and Polarized Particles}
	Read a predefined model from file and define decays and polarization.
	<<Models: execute tests>>=
	call test (models_4, "models_4", &
	"handle decays and polarization", &
	u, results)
	<<Models: test declarations>>=
	public :: models_4
	<<Models: tests>>=
	subroutine models_4 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model, model_instance
	character(32) :: md5sum

	write (u, "(A)") "* Test output: models_4"
	write (u, "(A)") "* Purpose: set and unset decays and polarization"
	write (u, *)

	call syntax_model_file_init ()
	call os_data%init ()

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

	call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
	os_data, model)

	md5sum = model%get_parameters_md5sum ()
	write (u, *)
	write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"

	write (u, *)
	write (u, "(A)") "* Set particle decays and polarization"
	write (u, *)

	call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")])
	call model%set_polarized (6)
	call model%set_unstable (-6, [var_str ("fdec")])

	call model%write (u)

	md5sum = model%get_parameters_md5sum ()
	write (u, *)
	write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"

	write (u, *)
	write (u, "(A)") "* Create a model instance"

	allocate (model_instance)
	call model_instance%init_instance (model)

	write (u, *)
	write (u, "(A)") "* Revert particle decays and polarization"
	write (u, *)

	call model%set_stable (25)
	call model%set_unpolarized (6)
	call model%set_stable (-6)

	call model%write (u)

	md5sum = model%get_parameters_md5sum ()
	write (u, *)
	write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"

	write (u, *)
	write (u, "(A)") "* Show the model instance"
	write (u, *)

	call model_instance%write (u)

	md5sum = model_instance%get_parameters_md5sum ()
	write (u, *)
	write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"

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

	call model_instance%final ()
	deallocate (model_instance)
	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_4

	@ %def models_4
	@
	\subsubsection{Model Variables}
	Read a predefined model from file and modify some parameters.

	Note that the MD5 sum is not modified by this.
	<<Models: execute tests>>=
	call test (models_5, "models_5", &
	"handle parameters", &
	u, results)
	<<Models: test declarations>>=
	public :: models_5
	<<Models: tests>>=
	subroutine models_5 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model, model_instance
	character(32) :: md5sum

	write (u, "(A)") "* Test output: models_5"
	write (u, "(A)") "* Purpose: access and modify model variables"
	write (u, *)

	call syntax_model_file_init ()
	call os_data%init ()

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

	call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
	os_data, model)

	write (u, *)

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

	write (u, *)
	write (u, "(A)") "* Check parameter status"
	write (u, *)

	write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx"))
	write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff"))
	write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf"))
	write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff"))
	write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf"))

	write (u, *)
	write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff"))
	write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf"))

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

	call model%set_real (var_str ("ff"), 1._default)

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

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_5

	@ %def models_5
	@
	\subsubsection{Read model with disordered parameters}
	Read a model from file where the ordering of independent and derived
	parameters is non-canonical.
	<<Models: execute tests>>=
	call test (models_6, "models_6", &
	"read model parameters", &
	u, results)
	<<Models: test declarations>>=
	public :: models_6
	<<Models: tests>>=
	subroutine models_6 (u)
	integer, intent(in) :: u
	integer :: um
	character(80) :: buffer
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(var_list_t), pointer :: var_list
	type(model_t), pointer :: model

	write (u, "(A)") "* Test output: models_6"
	write (u, "(A)") "* Purpose: read a model from file &
	&with non-canonical parameter ordering"
	write (u, *)

	open (newunit=um, file="Test6.mdl", status="replace", action="readwrite")
	write (um, "(A)") 'model "Test6"'
	write (um, "(A)") ' parameter a = 1.000000000000E+00'
	write (um, "(A)") ' derived b = 2 * a'
	write (um, "(A)") ' parameter c = 3.000000000000E+00'
	write (um, "(A)") ' unused d'

	rewind (um)
	do
	read (um, "(A)", end=1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 continue
	close (um)

	call syntax_model_file_init ()
	call os_data%init ()

	call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), &
	os_data, model)

	write (u, *)
	write (u, "(A)") "* Variable list"
	write (u, *)

	var_list => model%get_var_list_ptr ()
	call var_list%write (u)

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_6

	@ %def models_6
	@
	\subsubsection{Read model with schemes}
	Read a model from file which supports scheme selection in the
	parameter list.
	<<Models: execute tests>>=
	call test (models_7, "models_7", &
	"handle schemes", &
	u, results)
	<<Models: test declarations>>=
	public :: models_7
	<<Models: tests>>=
	subroutine models_7 (u)
	integer, intent(in) :: u
	integer :: um
	character(80) :: buffer
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(var_list_t), pointer :: var_list
	type(model_t), pointer :: model

	write (u, "(A)") "* Test output: models_7"
	write (u, "(A)") "* Purpose: read a model from file &
	&with scheme selection"
	write (u, *)

	open (newunit=um, file="Test7.mdl", status="replace", action="readwrite")
	write (um, "(A)") 'model "Test7"'
	write (um, "(A)") ' schemes = "foo", "bar", "gee"'
	write (um, "(A)") ''
	write (um, "(A)") ' select scheme'
	write (um, "(A)") ' scheme "foo"'
	write (um, "(A)") ' parameter a = 1'
	write (um, "(A)") ' derived b = 2 * a'
	write (um, "(A)") ' scheme other'
	write (um, "(A)") ' parameter b = 4'
	write (um, "(A)") ' derived a = b / 2'
	write (um, "(A)") ' end select'
	write (um, "(A)") ''
	write (um, "(A)") ' parameter c = 3'
	write (um, "(A)") ''
	write (um, "(A)") ' select scheme'
	write (um, "(A)") ' scheme "foo", "gee"'
	write (um, "(A)") ' derived d = b + c'
	write (um, "(A)") ' scheme other'
	write (um, "(A)") ' unused d'
	write (um, "(A)") ' end select'

	rewind (um)
	do
	read (um, "(A)", end=1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 continue
	close (um)

	call syntax_model_file_init ()
	call os_data%init ()

	write (u, *)
	write (u, "(A)") "* Model output, default scheme (= foo)"
	write (u, *)

	call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
	os_data, model)
	call model%write (u, show_md5sum=.false.)
	call show_var_list ()
	call show_par_array ()

	call model_list%final ()

	write (u, *)
	write (u, "(A)") "* Model output, scheme foo"
	write (u, *)

	call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
	os_data, model, scheme = var_str ("foo"))
	call model%write (u, show_md5sum=.false.)
	call show_var_list ()
	call show_par_array ()

	call model_list%final ()

	write (u, *)
	write (u, "(A)") "* Model output, scheme bar"
	write (u, *)

	call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
	os_data, model, scheme = var_str ("bar"))
	call model%write (u, show_md5sum=.false.)
	call show_var_list ()
	call show_par_array ()

	call model_list%final ()

	write (u, *)
	write (u, "(A)") "* Model output, scheme gee"
	write (u, *)

	call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
	os_data, model, scheme = var_str ("gee"))
	call model%write (u, show_md5sum=.false.)
	call show_var_list ()
	call show_par_array ()

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	contains

	subroutine show_var_list ()
	write (u, *)
	write (u, "(A)") "* Variable list"
	write (u, *)
	var_list => model%get_var_list_ptr ()
	call var_list%write (u)
	end subroutine show_var_list

	subroutine show_par_array ()
	real(default), dimension(:), allocatable :: par
	integer :: n
	write (u, *)
	write (u, "(A)") "* Parameter array"
	write (u, *)
	n = model%get_n_real ()
	allocate (par (n))
	call model%real_parameters_to_array (par)
	write (u, 1) par
	1 format (1X,F6.3)
	end subroutine show_par_array

	end subroutine models_7

	@ %def models_7
	@
	\subsubsection{Read and handle UFO model}
	Read a model from file which is considered as an UFO model. In fact,
	it is a mock model file which just follows our naming convention for
	UFO models. Compare this to an equivalent non-UFO model.
	<<Models: execute tests>>=
	call test (models_8, "models_8", &
	"handle UFO-derived models", &
	u, results)
	<<Models: test declarations>>=
	public :: models_8
	<<Models: tests>>=
	subroutine models_8 (u)
	integer, intent(in) :: u
	integer :: um
	character(80) :: buffer
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(string_t) :: model_name
	type(model_t), pointer :: model

	write (u, "(A)") "* Test output: models_8"
	write (u, "(A)") "* Purpose: distinguish models marked as UFO-derived"
	write (u, *)

	call os_data%init ()

	call show_model_list_status ()
	model_name = "models_8_M"

	write (u, *)
	write (u, "(A)") "* Write WHIZARD model"
	write (u, *)

	open (newunit=um, file=char (model_name // ".mdl"), &
	status="replace", action="readwrite")
	write (um, "(A)") 'model "models_8_M"'
	write (um, "(A)") ' parameter a = 1'

	rewind (um)
	do
	read (um, "(A)", end=1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 continue
	close (um)

	write (u, *)
	write (u, "(A)") "* Write UFO model"
	write (u, *)

	open (newunit=um, file=char (model_name // ".ufo.mdl"), &
	status="replace", action="readwrite")
	write (um, "(A)") 'model "models_8_M"'
	write (um, "(A)") ' parameter a = 2'

	rewind (um)
	do
	read (um, "(A)", end=2) buffer
	write (u, "(A)") trim (buffer)
	end do
	2 continue
	close (um)

	call syntax_model_file_init ()
	call os_data%init ()

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

	call model_list%read_model (model_name, model_name // ".mdl", &
	os_data, model)
	call model%write (u, show_md5sum=.false.)

	call show_model_list_status ()

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

	call model_list%read_model (model_name, model_name // ".ufo.mdl", &
	os_data, model, ufo=.true., rebuild_mdl = .false.)
	call model%write (u, show_md5sum=.false.)

	call show_model_list_status ()

	write (u, *)
	write (u, "(A)") "* Reload WHIZARD model"
	write (u, *)

	call model_list%read_model (model_name, model_name // ".mdl", &
	os_data, model)
	call model%write (u, show_md5sum=.false.)

	call show_model_list_status ()

	write (u, *)
	write (u, "(A)") "* Reload UFO model"
	write (u, *)

	call model_list%read_model (model_name, model_name // ".ufo.mdl", &
	os_data, model, ufo=.true., rebuild_mdl = .false.)
	call model%write (u, show_md5sum=.false.)

	call show_model_list_status ()

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	contains

	subroutine show_model_list_status ()
	write (u, "(A)") "* Model list status"
	write (u, *)
	write (u, "(A,1x,L1)") "WHIZARD model exists =", &
	model_list%model_exists (model_name)
	write (u, "(A,1x,L1)") "UFO model exists =", &
	model_list%model_exists (model_name, ufo=.true.)
	end subroutine show_model_list_status

	end subroutine models_8

	@ %def models_8
	@
	\subsubsection{Generate UFO model file}
	Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model.

	Note: There must not be another unit test which works with the same
	UFO model. The model file is deleted explicitly at the end of this test.
	<<Models: execute tests>>=
	call test (models_9, "models_9", &
	"generate UFO-derived model file", &
	u, results)
	<<Models: test declarations>>=
	public :: models_9
	<<Models: tests>>=
	subroutine models_9 (u)
	integer, intent(in) :: u
	integer :: um
	character(80) :: buffer
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(string_t) :: model_name, model_file_name
	type(model_t), pointer :: model

	write (u, "(A)") "* Test output: models_9"
	write (u, "(A)") "* Purpose: enable the UFO Standard Model (test version)"
	write (u, *)

	call os_data%init ()
	call syntax_model_file_init ()

	os_data%whizard_modelpath_ufo = "../models/UFO"

	model_name = "SM"
	model_file_name = model_name // ".models_9" // ".ufo.mdl"

	write (u, "(A)") "* Generate and read UFO model"
	write (u, *)

	call delete_file (char (model_file_name))

	call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.)
	call model%write (u, show_md5sum=.false.)

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	end subroutine models_9

	@ %def models_9
	@
	\subsubsection{Read model with schemes}
	Read a model from file which contains [[slha_entry]] qualifiers for parameters.
	<<Models: execute tests>>=
	call test (models_10, "models_10", &
	"handle slha_entry option", &
	u, results)
	<<Models: test declarations>>=
	public :: models_10
	<<Models: tests>>=
	subroutine models_10 (u)
	integer, intent(in) :: u
	integer :: um
	character(80) :: buffer
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(var_list_t), pointer :: var_list
	type(model_t), pointer :: model
	type(string_t), dimension(:), allocatable :: slha_block_name
	integer :: i

	write (u, "(A)") "* Test output: models_10"
	write (u, "(A)") "* Purpose: read a model from file &
	&with slha_entry options"
	write (u, *)

	open (newunit=um, file="Test10.mdl", status="replace", action="readwrite")
	write (um, "(A)") 'model "Test10"'
	write (um, "(A)") ' parameter a = 1 slha_entry FOO 1'
	write (um, "(A)") ' parameter b = 4 slha_entry BAR 2 1'

	rewind (um)
	do
	read (um, "(A)", end=1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 continue
	close (um)

	call syntax_model_file_init ()
	call os_data%init ()

	write (u, *)
	write (u, "(A)") "* Model output, default scheme (= foo)"
	write (u, *)

	call model_list%read_model (var_str ("Test10"), var_str ("Test10.mdl"), &
	os_data, model)
	call model%write (u, show_md5sum=.false.)

	write (u, *)
	write (u, "(A)") "* Check that model contains slha_entry options"
	write (u, *)

	write (u, "(A,1x,L1)") &
	"supports_custom_slha =", model%supports_custom_slha ()

	write (u, *)
	write (u, "(A)") "custom_slha_blocks ="
	call model%get_custom_slha_blocks (slha_block_name)
	do i = 1, size (slha_block_name)
	write (u, "(1x,A)", advance="no") char (slha_block_name(i))
	end do
	write (u, *)

	write (u, *)
	write (u, "(A)") "* Parameter lookup"
	write (u, *)

	call show_slha ("FOO", [1])
	call show_slha ("FOO", [2])
	call show_slha ("BAR", [2, 1])
	call show_slha ("GEE", [3])

	write (u, *)
	write (u, "(A)") "* Modify parameter via SLHA block interface"
	write (u, *)

	call model%slha_set_par (var_str ("FOO"), [1], 7._default)
	call show_slha ("FOO", [1])

	write (u, *)
	write (u, "(A)") "* Show var list with modified parameter"
	write (u, *)

	call show_var_list ()

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

	call model_list%final ()
	call syntax_model_file_final ()

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

	contains

	subroutine show_slha (block_name, block_index)
	character(*), intent(in) :: block_name
	integer, dimension(:), intent(in) :: block_index
	class(modelpar_data_t), pointer :: par_data
	write (u, "(A,*(1x,I0))", advance="no") block_name, block_index
	write (u, "(' => ')", advance="no")
	call model%slha_lookup (var_str (block_name), block_index, par_data)
	if (associated (par_data)) then
	call par_data%write (u)
	write (u, *)
	else
	write (u, "('-')")
	end if

	end subroutine show_slha

	subroutine show_var_list ()
	var_list => model%get_var_list_ptr ()
	call var_list%write (u)
	end subroutine show_var_list

	end subroutine models_10

	@ %def models_10
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{The SUSY Les Houches Accord}

	The SUSY Les Houches Accord defines a standard interfaces for storing
	the physics data of SUSY models. Here, we provide the means
	for reading, storing, and writing such data.
	<<[[slha_interface.f90]]>>=
	<<File header>>

	module slha_interface

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use constants
	use string_utils, only: upper_case
	use system_defs, only: VERSION_STRING
	use system_defs, only: EOF
	use diagnostics
	use os_interface
	use ifiles
	use lexers
	use syntax_rules
	use parser
	use variables
	use models

	<<Standard module head>>

	<<SLHA: public>>

	<<SLHA: parameters>>

	<<SLHA: variables>>

	save

	contains

	<<SLHA: procedures>>

	<<SLHA: tests>>

	end module slha_interface
	@ %def slha_interface
	@
	\subsection{Preprocessor}
	SLHA is a mixed-format standard. It should be read in assuming free
	format (but line-oriented), but it has some fixed-format elements.

	To overcome this difficulty, we implement a preprocessing step which
	transforms the SLHA into a format that can be swallowed by our generic
	free-format lexer and parser. Each line with a blank first character
	is assumed to be a data line. We prepend a 'DATA' keyword to these lines.
	Furthermore, to enforce line-orientation, each line is appended a '\$'
	key which is recognized by the parser. To do this properly, we first
	remove trailing comments, and skip lines consisting only of comments.

	The preprocessor reads from a stream and puts out an [[ifile]].
	Blocks that are not recognized are skipped. For some blocks, data
	items are quoted, so they can be read as strings if necessary.

	A name clash occurse if the block name is identical to a keyword.
	This can happen for custom SLHA models and files. In that case, we
	prepend an underscore, which will be silently suppressed where needed.
	<<SLHA: parameters>>=
	integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2

	@ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2
	<<SLHA: procedures>>=
	subroutine slha_preprocess (stream, custom_block_name, ifile)
	type(stream_t), intent(inout), target :: stream
	type(string_t), dimension(:), intent(in) :: custom_block_name
	type(ifile_t), intent(out) :: ifile
	type(string_t) :: buffer, line, item
	integer :: iostat
	integer :: mode
	mode = MODE
	SCAN_FILE: do
	call stream_get_record (stream, buffer, iostat)
	select case (iostat)
	case (0)
	call split (buffer, line, "#")
	if (len_trim (line) == 0) cycle SCAN_FILE
	select case (char (extract (line, 1, 1)))
	case ("B", "b")
	call check_block_handling (line, custom_block_name, mode)
	call ifile_append (ifile, line // "$")
	case ("D", "d")
	mode = MODE_DATA
	call ifile_append (ifile, line // "$")
	case (" ")
	select case (mode)
	case (MODE_DATA)
	call ifile_append (ifile, "DATA" // line // "$")
	case (MODE_INFO)
	line = adjustl (line)
	call split (line, item, " ")
	call ifile_append (ifile, "INFO" // " " // item // " " &
	// '"' // trim (adjustl (line)) // '" $')
	end select
	case default
	call msg_message (char (line))
	call msg_fatal ("SLHA: Incomprehensible line")
	end select
	case (EOF)
	exit SCAN_FILE
	case default
	call msg_fatal ("SLHA: I/O error occured while reading SLHA input")
	end select
	end do SCAN_FILE
	end subroutine slha_preprocess

	@ %def slha_preprocess
	@ Return the mode that we should treat this block with. We add the
	[[custom_block_name]] array to the set of supported blocks, which
	otherwise includes only hard-coded block names. Those custom blocks
	are data blocks.

	Unknown blocks will be skipped altogether. The standard does not
	specify their internal format at all, so we must not parse their
	content.

	If the name of a (custom) block clashes with a keyword of the SLHA
	syntax, we append an underscore to the block name, modifying the
	current line string. This should be silently suppressed when actually
	parsing block names.
	<<SLHA: procedures>>=
	subroutine check_block_handling (line, custom_block_name, mode)
	type(string_t), intent(inout) :: line
	type(string_t), dimension(:), intent(in) :: custom_block_name
	integer, intent(out) :: mode
	type(string_t) :: buffer, key, block_name
	integer :: i
	buffer = trim (line)
	call split (buffer, key, " ")
	buffer = adjustl (buffer)
	call split (buffer, block_name, " ")
	buffer = adjustl (buffer)
	block_name = trim (adjustl (upper_case (block_name)))
	select case (char (block_name))
	case ("MODSEL", "MINPAR", "SMINPUTS")
	mode = MODE_DATA
	case ("MASS")
	mode = MODE_DATA
	case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX")
	mode = MODE_DATA
	case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN")
	mode = MODE_DATA
	case ("ALPHA", "HMIX")
	mode = MODE_DATA
	case ("AU", "AD", "AE")
	mode = MODE_DATA
	case ("SPINFO", "DCINFO")
	mode = MODE_INFO
	case default
	mode = MODE_SKIP
	CHECK_CUSTOM_NAMES: do i = 1, size (custom_block_name)
	if (block_name == custom_block_name(i)) then
	mode = MODE_DATA
	call mangle_keywords (block_name)
	line = key // " " // block_name // " " // trim (buffer)
	exit CHECK_CUSTOM_NAMES
	end if
	end do CHECK_CUSTOM_NAMES
	end select
	end subroutine check_block_handling

	@ %def check_block_handling
	@ Append an underscore to specific block names:
	<<SLHA: procedures>>=
	subroutine mangle_keywords (name)
	type(string_t), intent(inout) :: name
	select case (char (name))
	case ("BLOCK", "DATA", "INFO", "DECAY")
	name = name // "_"
	end select
	end subroutine mangle_keywords

	@ %def mangle_keywords
	@ Remove the underscore again:
	<<SLHA: procedures>>=
	subroutine demangle_keywords (name)
	type(string_t), intent(inout) :: name
	select case (char (name))
	case ("BLOCK_", "DATA_", "INFO_", "DECAY_")
	name = extract (name, 1, len(name)-1)
	end select
	end subroutine demangle_keywords

	@ %def demangle_keywords

	@
	\subsection{Lexer and syntax}
	<<SLHA: variables>>=
	type(syntax_t), target :: syntax_slha

	@ %def syntax_slha
	<<SLHA: public>>=
	public :: syntax_slha_init
	<<SLHA: procedures>>=
	subroutine syntax_slha_init ()
	type(ifile_t) :: ifile
	call define_slha_syntax (ifile)
	call syntax_init (syntax_slha, ifile)
	call ifile_final (ifile)
	end subroutine syntax_slha_init

	@ %def syntax_slha_init
	<<SLHA: public>>=
	public :: syntax_slha_final
	<<SLHA: procedures>>=
	subroutine syntax_slha_final ()
	call syntax_final (syntax_slha)
	end subroutine syntax_slha_final

	@ %def syntax_slha_final
	<<SLHA: public>>=
	public :: syntax_slha_write
	<<SLHA: procedures>>=
	subroutine syntax_slha_write (unit)
	integer, intent(in), optional :: unit
	call syntax_write (syntax_slha, unit)
	end subroutine syntax_slha_write

	@ %def syntax_slha_write
	<<SLHA: procedures>>=
	subroutine define_slha_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ slha = chunk*")
	call ifile_append (ifile, "ALT chunk = block_def \| decay_def")
	call ifile_append (ifile, "SEQ block_def = " &
	// "BLOCK blockgen '$' block_line*")
	call ifile_append (ifile, "ALT blockgen = block_spec \| q_spec")
	call ifile_append (ifile, "KEY BLOCK")
	call ifile_append (ifile, "SEQ q_spec = QNUMBERS pdg_code")
	call ifile_append (ifile, "KEY QNUMBERS")
	call ifile_append (ifile, "SEQ block_spec = block_name qvalue?")
	call ifile_append (ifile, "IDE block_name")
	call ifile_append (ifile, "SEQ qvalue = qname '=' real")
	call ifile_append (ifile, "IDE qname")
	call ifile_append (ifile, "KEY '='")
	call ifile_append (ifile, "REA real")
	call ifile_append (ifile, "KEY '$'")
	call ifile_append (ifile, "ALT block_line = block_data \| block_info")
	call ifile_append (ifile, "SEQ block_data = DATA data_line '$'")
	call ifile_append (ifile, "KEY DATA")
	call ifile_append (ifile, "SEQ data_line = data_item+")
	call ifile_append (ifile, "ALT data_item = signed_number \| number")
	call ifile_append (ifile, "SEQ signed_number = sign number")
	call ifile_append (ifile, "ALT sign = '+' \| '-'")
	call ifile_append (ifile, "ALT number = integer \| real")
	call ifile_append (ifile, "INT integer")
	call ifile_append (ifile, "KEY '-'")
	call ifile_append (ifile, "KEY '+'")
	call ifile_append (ifile, "SEQ block_info = INFO info_line '$'")
	call ifile_append (ifile, "KEY INFO")
	call ifile_append (ifile, "SEQ info_line = integer string_literal")
	call ifile_append (ifile, "QUO string_literal = '""'...'""'")
	call ifile_append (ifile, "SEQ decay_def = " &
	// "DECAY decay_spec '$' decay_data*")
	call ifile_append (ifile, "KEY DECAY")
	call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item")
	call ifile_append (ifile, "ALT pdg_code = signed_integer \| integer")
	call ifile_append (ifile, "SEQ signed_integer = sign integer")
	call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'")
	call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+")
	end subroutine define_slha_syntax

	@ %def define_slha_syntax
	@ The SLHA specification allows for string data items in certain
	places. Currently, we do not interpret them, but the strings, which
	are not quoted, must be parsed somehow. The hack for this problem is
	to allow essentially all characters as special characters, so the
	string can be read before it is discarded.
	<<SLHA: public>>=
	public :: lexer_init_slha
	<<SLHA: procedures>>=
	subroutine lexer_init_slha (lexer)
	type(lexer_t), intent(out) :: lexer
	call lexer_init (lexer, &
	comment_chars = "#", &
	quote_chars = '"', &
	quote_match = '"', &
	single_chars = "+-=$", &
	special_class = [ "" ], &
	keyword_list = syntax_get_keyword_list_ptr (syntax_slha), &
	upper_case_keywords = .true.) ! $
	end subroutine lexer_init_slha

	@ %def lexer_init_slha
	@
	\subsection{Interpreter}
	\subsubsection{Find blocks}
	From the parse tree, find the node that represents a particular
	block. If [[required]] is true, issue an error if not found.
	Since [[block_name]] is always invoked with capital letters, we
	have to capitalize [[pn_block_name]].
	<<SLHA: procedures>>=
	function slha_get_block_ptr &
	(parse_tree, block_name, required) result (pn_block)
	type(parse_node_t), pointer :: pn_block
	type(parse_tree_t), intent(in) :: parse_tree
	type(string_t), intent(in) :: block_name
	type(string_t) :: block_def
	logical, intent(in) :: required
	type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name
	pn_root => parse_tree%get_root_ptr ()
	pn_block => parse_node_get_sub_ptr (pn_root)
	do while (associated (pn_block))
	select case (char (parse_node_get_rule_key (pn_block)))
	case ("block_def")
	pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
	pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
	select case (char (pn_block_name%get_rule_key ()))
	case ("block_name")
	block_def = trim (adjustl (upper_case &
	(pn_block_name%get_string ())))
	case ("QNUMBERS")
	block_def = "QNUMBERS"
	end select
	if (block_def == block_name) then
	return
	end if
	end select
	pn_block => parse_node_get_next_ptr (pn_block)
	end do
	if (required) then
	call msg_fatal ("SLHA: block '" // char (block_name) // "' not found")
	end if
	end function slha_get_block_ptr

	@ %def slha_get_blck_ptr
	@ Scan the file for the first/next DECAY block.
	<<SLHA: procedures>>=
	function slha_get_first_decay_ptr (parse_tree) result (pn_decay)
	type(parse_node_t), pointer :: pn_decay
	type(parse_tree_t), intent(in) :: parse_tree
	type(parse_node_t), pointer :: pn_root
	pn_root => parse_tree%get_root_ptr ()
	pn_decay => parse_node_get_sub_ptr (pn_root)
	do while (associated (pn_decay))
	select case (char (parse_node_get_rule_key (pn_decay)))
	case ("decay_def")
	return
	end select
	pn_decay => parse_node_get_next_ptr (pn_decay)
	end do
	end function slha_get_first_decay_ptr

	function slha_get_next_decay_ptr (pn_block) result (pn_decay)
	type(parse_node_t), pointer :: pn_decay
	type(parse_node_t), intent(in), target :: pn_block
	pn_decay => parse_node_get_next_ptr (pn_block)
	do while (associated (pn_decay))
	select case (char (parse_node_get_rule_key (pn_decay)))
	case ("decay_def")
	return
	end select
	pn_decay => parse_node_get_next_ptr (pn_decay)
	end do
	end function slha_get_next_decay_ptr

	@ %def slha_get_next_decay_ptr
	@
	\subsubsection{Extract and transfer data from blocks}
	Given the parse node of a block, find the parse node of a particular
	switch or data line. Return this node and the node of the data item
	following the integer code.
	<<SLHA: procedures>>=
	subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code)
	type(parse_node_t), intent(in), target :: pn_block
	type(parse_node_t), intent(out), pointer :: pn_data
	type(parse_node_t), intent(out), pointer :: pn_item
	integer, intent(in) :: code
	pn_data => parse_node_get_sub_ptr (pn_block, 4)
	call slha_next_index_ptr (pn_data, pn_item, code)
	end subroutine slha_find_index_ptr

	subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
	type(parse_node_t), intent(in), target :: pn_block
	type(parse_node_t), intent(out), pointer :: pn_data
	type(parse_node_t), intent(out), pointer :: pn_item
	integer, intent(in) :: code1, code2
	pn_data => parse_node_get_sub_ptr (pn_block, 4)
	call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
	end subroutine slha_find_index_pair_ptr

	@ %def slha_find_index_ptr slha_find_index_pair_ptr
	@ Starting from the pointer to a data line, find a data line with the
	given integer code.
	<<SLHA: procedures>>=
	subroutine slha_next_index_ptr (pn_data, pn_item, code)
	type(parse_node_t), intent(inout), pointer :: pn_data
	integer, intent(in) :: code
	type(parse_node_t), intent(out), pointer :: pn_item
	type(parse_node_t), pointer :: pn_line, pn_code
	do while (associated (pn_data))
	pn_line => parse_node_get_sub_ptr (pn_data, 2)
	pn_code => parse_node_get_sub_ptr (pn_line)
	select case (char (parse_node_get_rule_key (pn_code)))
	case ("integer")
	if (parse_node_get_integer (pn_code) == code) then
	pn_item => parse_node_get_next_ptr (pn_code)
	return
	end if
	end select
	pn_data => parse_node_get_next_ptr (pn_data)
	end do
	pn_item => null ()
	end subroutine slha_next_index_ptr

	@ %def slha_next_index_ptr
	@ Starting from the pointer to a data line, find a data line with the
	given integer code pair.
	<<SLHA: procedures>>=
	subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
	type(parse_node_t), intent(inout), pointer :: pn_data
	integer, intent(in) :: code1, code2
	type(parse_node_t), intent(out), pointer :: pn_item
	type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2
	do while (associated (pn_data))
	pn_line => parse_node_get_sub_ptr (pn_data, 2)
	pn_code1 => parse_node_get_sub_ptr (pn_line)
	select case (char (parse_node_get_rule_key (pn_code1)))
	case ("integer")
	if (parse_node_get_integer (pn_code1) == code1) then
	pn_code2 => parse_node_get_next_ptr (pn_code1)
	if (associated (pn_code2)) then
	select case (char (parse_node_get_rule_key (pn_code2)))
	case ("integer")
	if (parse_node_get_integer (pn_code2) == code2) then
	pn_item => parse_node_get_next_ptr (pn_code2)
	return
	end if
	end select
	end if
	end if
	end select
	pn_data => parse_node_get_next_ptr (pn_data)
	end do
	pn_item => null ()
	end subroutine slha_next_index_pair_ptr

	@ %def slha_next_index_pair_ptr
	@
	\subsubsection{Handle info data}
	Return all strings with index [[i]]. The result is an allocated
	string array. Since we do not know the number of matching entries in
	advance, we build an intermediate list which is transferred to the
	final array and deleted before exiting.
	<<SLHA: procedures>>=
	subroutine retrieve_strings_in_block (pn_block, code, str_array)
	type(parse_node_t), intent(in), target :: pn_block
	integer, intent(in) :: code
	type(string_t), dimension(:), allocatable, intent(out) :: str_array
	type(parse_node_t), pointer :: pn_data, pn_item
	type :: str_entry_t
	type(string_t) :: str
	type(str_entry_t), pointer :: next => null ()
	end type str_entry_t
	type(str_entry_t), pointer :: first => null ()
	type(str_entry_t), pointer :: current => null ()
	integer :: n
	n = 0
	call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
	if (associated (pn_item)) then
	n = n + 1
	allocate (first)
	first%str = parse_node_get_string (pn_item)
	current => first
	do while (associated (pn_data))
	pn_data => parse_node_get_next_ptr (pn_data)
	call slha_next_index_ptr (pn_data, pn_item, code)
	if (associated (pn_item)) then
	n = n + 1
	allocate (current%next)
	current => current%next
	current%str = parse_node_get_string (pn_item)
	end if
	end do
	allocate (str_array (n))
	n = 0
	do while (associated (first))
	n = n + 1
	current => first
	str_array(n) = current%str
	first => first%next
	deallocate (current)
	end do
	else
	allocate (str_array (0))
	end if
	end subroutine retrieve_strings_in_block

	@ %def retrieve_strings_in_block
	@
	\subsubsection{Transfer data from SLHA to variables}
	Extract real parameter with index [[i]]. If it does not
	exist, retrieve it from the variable list, using the given name.
	<<SLHA: procedures>>=
	function get_parameter_in_block (pn_block, code, name, var_list) result (var)
	real(default) :: var
	type(parse_node_t), intent(in), target :: pn_block
	integer, intent(in) :: code
	type(string_t), intent(in) :: name
	type(var_list_t), intent(in), target :: var_list
	type(parse_node_t), pointer :: pn_data, pn_item
	call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
	if (associated (pn_item)) then
	var = get_real_parameter (pn_item)
	else
	var = var_list%get_rval (name)
	end if
	end function get_parameter_in_block

	@ %def get_parameter_in_block
	@ Extract a real data item with index [[i]]. If it
	does exist, set it in the variable list, using the given name. If
	the variable is not present in the variable list, ignore it.
	<<SLHA: procedures>>=
	subroutine set_data_item (pn_block, code, name, var_list)
	type(parse_node_t), intent(in), target :: pn_block
	integer, intent(in) :: code
	type(string_t), intent(in) :: name
	type(var_list_t), intent(inout), target :: var_list
	type(parse_node_t), pointer :: pn_data, pn_item
	call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
	if (associated (pn_item)) then
	call var_list%set_real (name, get_real_parameter (pn_item), &
	is_known=.true., ignore=.true.)
	end if
	end subroutine set_data_item

	@ %def set_data_item
	@ Extract a real matrix element with index [[i,j]]. If it
	does exists, set it in the variable list, using the given name. If
	the variable is not present in the variable list, ignore it.
	<<SLHA: procedures>>=
	subroutine set_matrix_element (pn_block, code1, code2, name, var_list)
	type(parse_node_t), intent(in), target :: pn_block
	integer, intent(in) :: code1, code2
	type(string_t), intent(in) :: name
	type(var_list_t), intent(inout), target :: var_list
	type(parse_node_t), pointer :: pn_data, pn_item
	call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
	if (associated (pn_item)) then
	call var_list%set_real (name, get_real_parameter (pn_item), &
	is_known=.true., ignore=.true.)
	end if
	end subroutine set_matrix_element

	@ %def set_matrix_element
	@
	\subsubsection{Transfer data from variables to SLHA}
	Get a real/integer parameter with index [[i]] from the variable list and write
	it to the current output file. In the integer case, we account for
	the fact that the variable is type real. If it does not exist, do nothing.
	<<SLHA: procedures>>=
	subroutine write_integer_data_item (u, code, name, var_list, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code
	type(string_t), intent(in) :: name
	type(var_list_t), intent(in) :: var_list
	character(*), intent(in) :: comment
	integer :: item
	if (var_list%contains (name)) then
	item = nint (var_list%get_rval (name))
	call write_integer_parameter (u, code, item, comment)
	end if
	end subroutine write_integer_data_item

	subroutine write_real_data_item (u, code, name, var_list, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code
	type(string_t), intent(in) :: name
	type(var_list_t), intent(in) :: var_list
	character(*), intent(in) :: comment
	real(default) :: item
	if (var_list%contains (name)) then
	item = var_list%get_rval (name)
	call write_real_parameter (u, code, item, comment)
	end if
	end subroutine write_real_data_item

	@ %def write_real_data_item
	@ Get a real data item with two integer indices from the variable list
	and write it to the current output file. If it does not exist, do
	nothing.
	<<SLHA: procedures>>=
	subroutine write_matrix_element (u, code1, code2, name, var_list, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code1, code2
	type(string_t), intent(in) :: name
	type(var_list_t), intent(in) :: var_list
	character(*), intent(in) :: comment
	real(default) :: item
	if (var_list%contains (name)) then
	item = var_list%get_rval (name)
	call write_real_matrix_element (u, code1, code2, item, comment)
	end if
	end subroutine write_matrix_element

	@ %def write_matrix_element
	@
	\subsection{Auxiliary function}
	Write a block header.
	<<SLHA: procedures>>=
	subroutine write_block_header (u, name, comment)
	integer, intent(in) :: u
	character(*), intent(in) :: name, comment
	write (u, "(A,1x,A,3x,'#',1x,A)") "BLOCK", name, comment
	end subroutine write_block_header

	@ %def write_block_header
	@ Extract a real parameter that may be defined real or
	integer, signed or unsigned.
	<<SLHA: procedures>>=
	function get_real_parameter (pn_item) result (var)
	real(default) :: var
	type(parse_node_t), intent(in), target :: pn_item
	type(parse_node_t), pointer :: pn_sign, pn_var
	integer :: sign
	select case (char (parse_node_get_rule_key (pn_item)))
	case ("signed_number")
	pn_sign => parse_node_get_sub_ptr (pn_item)
	pn_var => parse_node_get_next_ptr (pn_sign)
	select case (char (parse_node_get_key (pn_sign)))
	case ("+"); sign = +1
	case ("-"); sign = -1
	end select
	case default
	sign = +1
	pn_var => pn_item
	end select
	select case (char (parse_node_get_rule_key (pn_var)))
	case ("integer"); var = sign * parse_node_get_integer (pn_var)
	case ("real"); var = sign * parse_node_get_real (pn_var)
	end select
	end function get_real_parameter

	@ %def get_real_parameter
	@ Auxiliary: Extract an integer parameter that may be defined signed
	or unsigned. A real value is an error.
	<<SLHA: procedures>>=
	function get_integer_parameter (pn_item) result (var)
	integer :: var
	type(parse_node_t), intent(in), target :: pn_item
	type(parse_node_t), pointer :: pn_sign, pn_var
	integer :: sign
	select case (char (parse_node_get_rule_key (pn_item)))
	case ("signed_integer")
	pn_sign => parse_node_get_sub_ptr (pn_item)
	pn_var => parse_node_get_next_ptr (pn_sign)
	select case (char (parse_node_get_key (pn_sign)))
	case ("+"); sign = +1
	case ("-"); sign = -1
	end select
	case ("integer")
	sign = +1
	pn_var => pn_item
	case default
	call parse_node_write (pn_var)
	call msg_error ("SLHA: Integer parameter expected")
	var = 0
	return
	end select
	var = sign * parse_node_get_integer (pn_var)
	end function get_integer_parameter

	@ %def get_real_parameter
	@ Write an integer parameter with a single index directly to file,
	using the required output format.
	<<SLHA: procedures>>=
	subroutine write_integer_parameter (u, code, item, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code
	integer, intent(in) :: item
	character(*), intent(in) :: comment
	1 format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A)
	write (u, 1) code, item, comment
	end subroutine write_integer_parameter

	@ %def write_integer_parameter
	@ Write a real parameter with two indices directly to file,
	using the required output format.
	<<SLHA: procedures>>=
	subroutine write_real_parameter (u, code, item, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code
	real(default), intent(in) :: item
	character(*), intent(in) :: comment
	1 format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
	write (u, 1) code, item, comment
	end subroutine write_real_parameter

	@ %def write_real_parameter
	@ Write a real parameter with a single index directly to file,
	using the required output format.
	<<SLHA: procedures>>=
	subroutine write_real_matrix_element (u, code1, code2, item, comment)
	integer, intent(in) :: u
	integer, intent(in) :: code1, code2
	real(default), intent(in) :: item
	character(*), intent(in) :: comment
	1 format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
	write (u, 1) code1, code2, item, comment
	end subroutine write_real_matrix_element

	@ %def write_real_matrix_element
	@
	\subsubsection{The concrete SLHA interpreter}
	SLHA codes for particular physics models
	<<SLHA: parameters>>=
	integer, parameter :: MDL_MSSM = 0
	integer, parameter :: MDL_NMSSM = 1
	@ %def MDL_MSSM MDL_NMSSM
	@ Take the parse tree and extract relevant data. Select the correct
	model and store all data that is present in the appropriate variable
	list. Finally, update the variable record.

	We assume that if the model contains custom SLHA block names, we just
	have to scan those to get complete information. Block names could
	coincide with the SLHA standard block names, but we do not have to
	assume this. This will be the situation for an UFO-generated file.
	In particular, an UFO file should contain all expressions necessary
	for computing dependent parameters, so we can forget about the strict
	SLHA standard and its hard-coded conventions.

	If there are no custom SLHA block names, we should assume that the
	model is a standard SUSY model, and the parameters and hard-coded
	blocks can be read as specified by the original SLHA standard. There
	are hard-coded block names and parameter calculations.

	Public for use in unit test.
	<<SLHA: public>>=
	public :: slha_interpret_parse_tree
	<<SLHA: procedures>>=
	subroutine slha_interpret_parse_tree &
	(parse_tree, model, input, spectrum, decays)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	logical, intent(in) :: input, spectrum, decays
	logical :: errors
	integer :: mssm_type
	if (model%supports_custom_slha ()) then
	call slha_handle_custom_file (parse_tree, model)
	else
	call slha_handle_MODSEL (parse_tree, model, mssm_type)
	if (input) then
	call slha_handle_SMINPUTS (parse_tree, model)
	call slha_handle_MINPAR (parse_tree, model, mssm_type)
	end if
	if (spectrum) then
	call slha_handle_info_block (parse_tree, "SPINFO", errors)
	if (errors) return
	call slha_handle_MASS (parse_tree, model)
	call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model)
	call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model)
	call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model)
	call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model)
	call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model)
	call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model)
	call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model)
	call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model)
	call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model)
	call slha_handle_ALPHA (parse_tree, model)
	call slha_handle_HMIX (parse_tree, model)
	call slha_handle_NMSSMRUN (parse_tree, model)
	call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model)
	call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model)
	call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model)
	end if
	end if
	if (decays) then
	call slha_handle_info_block (parse_tree, "DCINFO", errors)
	if (errors) return
	call slha_handle_decays (parse_tree, model)
	end if
	end subroutine slha_interpret_parse_tree

	@ %def slha_interpret_parse_tree
	@
	\subsubsection{Info blocks}
	Handle the informational blocks SPINFO and DCINFO. The first two
	items are program name and version. Items with index 3 are warnings.
	Items with index 4 are errors. We reproduce these as WHIZARD warnings
	and errors.
	<<SLHA: procedures>>=
	subroutine slha_handle_info_block (parse_tree, block_name, errors)
	type(parse_tree_t), intent(in) :: parse_tree
	character(*), intent(in) :: block_name
	logical, intent(out) :: errors
	type(parse_node_t), pointer :: pn_block
	type(string_t), dimension(:), allocatable :: msg
	integer :: i
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str (block_name), required=.true.)
	if (.not. associated (pn_block)) then
	call msg_error ("SLHA: Missing info block '" &
	// trim (block_name) // "'; ignored.")
	errors = .true.
	return
	end if
	select case (block_name)
	case ("SPINFO")
	call msg_message ("SLHA: SUSY spectrum program info:")
	case ("DCINFO")
	call msg_message ("SLHA: SUSY decay program info:")
	end select
	call retrieve_strings_in_block (pn_block, 1, msg)
	do i = 1, size (msg)
	call msg_message ("SLHA: " // char (msg(i)))
	end do
	call retrieve_strings_in_block (pn_block, 2, msg)
	do i = 1, size (msg)
	call msg_message ("SLHA: " // char (msg(i)))
	end do
	call retrieve_strings_in_block (pn_block, 3, msg)
	do i = 1, size (msg)
	call msg_warning ("SLHA: " // char (msg(i)))
	end do
	call retrieve_strings_in_block (pn_block, 4, msg)
	do i = 1, size (msg)
	call msg_error ("SLHA: " // char (msg(i)))
	end do
	errors = size (msg) > 0
	end subroutine slha_handle_info_block

	@ %def slha_handle_info_block
	@
	\subsubsection{MODSEL}
	Handle the overall model definition. Only certain models are
	recognized. The soft-breaking model templates that determine the set
	of input parameters.

	This block used to be required, but for generic UFO model support we
	should allow for its absence. In that case, [[mssm_type]] will be set
	to a negative value. If the block is present, the model must be one
	of the following, or parsing ends with an error.
	<<SLHA: parameters>>=
	integer, parameter :: MSSM_GENERIC = 0
	integer, parameter :: MSSM_SUGRA = 1
	integer, parameter :: MSSM_GMSB = 2
	integer, parameter :: MSSM_AMSB = 3

	@ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB
	<<SLHA: procedures>>=
	subroutine slha_handle_MODSEL (parse_tree, model, mssm_type)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(in), target :: model
	integer, intent(out) :: mssm_type
	type(parse_node_t), pointer :: pn_block, pn_data, pn_item
	type(string_t) :: model_name
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("MODSEL"), required=.false.)
	if (.not. associated (pn_block)) then
	mssm_type = -1
	return
	end if
	call slha_find_index_ptr (pn_block, pn_data, pn_item, 1)
	if (associated (pn_item)) then
	mssm_type = get_integer_parameter (pn_item)
	else
	mssm_type = MSSM_GENERIC
	end if
	call slha_find_index_ptr (pn_block, pn_data, pn_item, 3)
	if (associated (pn_item)) then
	select case (parse_node_get_integer (pn_item))
	case (MDL_MSSM); model_name = "MSSM"
	case (MDL_NMSSM); model_name = "NMSSM"
	case default
	call msg_fatal ("SLHA: unknown model code in MODSEL")
	return
	end select
	else
	model_name = "MSSM"
	end if
	call slha_find_index_ptr (pn_block, pn_data, pn_item, 4)
	if (associated (pn_item)) then
	call msg_fatal (" R-parity violation is currently not supported by WHIZARD.")
	end if
	call slha_find_index_ptr (pn_block, pn_data, pn_item, 5)
	if (associated (pn_item)) then
	call msg_fatal (" CP violation is currently not supported by WHIZARD.")
	end if
	select case (char (model_name))
	case ("MSSM")
	select case (char (model%get_name ()))
	case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg")
	model_name = model%get_name ()
	case default
	call msg_fatal ("Selected model '" &
	// char (model%get_name ()) // "' does not match model '" &
	// char (model_name) // "' in SLHA input file.")
	return
	end select
	case ("NMSSM")
	select case (char (model%get_name ()))
	case ("NMSSM","NMSSM_CKM","NMSSM_Hgg")
	model_name = model%get_name ()
	case default
	call msg_fatal ("Selected model '" &
	// char (model%get_name ()) // "' does not match model '" &
	// char (model_name) // "' in SLHA input file.")
	return
	end select
	case default
	call msg_bug ("SLHA model name '" &
	// char (model_name) // "' not recognized.")
	return
	end select
	call msg_message ("SLHA: Initializing model '" // char (model_name) // "'")
	end subroutine slha_handle_MODSEL

	@ %def slha_handle_MODSEL
	@ Write a MODSEL block, based on the contents of the current model.
	<<SLHA: procedures>>=
	subroutine slha_write_MODSEL (u, model, mssm_type)
	integer, intent(in) :: u
	type(model_t), intent(in), target :: model
	integer, intent(out) :: mssm_type
	type(var_list_t), pointer :: var_list
	integer :: model_id
	type(string_t) :: mtype_string
	var_list => model%get_var_list_ptr ()
	if (var_list%contains (var_str ("mtype"))) then
	mssm_type = nint (var_list%get_rval (var_str ("mtype")))
	else
	call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " &
	// "is unknown in current model, no SLHA output possible")
	mssm_type = -1
	return
	end if
	call write_block_header (u, "MODSEL", "SUSY model selection")
	select case (mssm_type)
	case (0); mtype_string = "Generic MSSM"
	case (1); mtype_string = "SUGRA"
	case (2); mtype_string = "GMSB"
	case (3); mtype_string = "AMSB"
	case default
	mtype_string = "unknown"
	end select
	call write_integer_parameter (u, 1, mssm_type, &
	"SUSY-breaking scheme: " // char (mtype_string))
	select case (char (model%get_name ()))
	case ("MSSM"); model_id = MDL_MSSM
	case ("NMSSM"); model_id = MDL_NMSSM
	case default
	model_id = 0
	end select
	call write_integer_parameter (u, 3, model_id, &
	"SUSY model type: " // char (model%get_name ()))
	end subroutine slha_write_MODSEL

	@ %def slha_write_MODSEL
	@
	\subsubsection{SMINPUTS}
	Read SM parameters and update the variable list accordingly. If a
	parameter is not defined in the block, we use the previous value from
	the model variable list. For the basic parameters we have to do a
	small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme,
	while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$.
	<<SLHA: procedures>>=
	subroutine slha_handle_SMINPUTS (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block
	real(default) :: alpha_em_i, GF, alphas, mZ
	real(default) :: ee, vv, cw_sw, cw2, mW
	real(default) :: mb, mtop, mtau
	type(var_list_t), pointer :: var_list
	var_list => model%get_var_list_ptr ()
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("SMINPUTS"), required=.true.)
	if (.not. (associated (pn_block))) return
	alpha_em_i = &
	get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list)
	GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list)
	alphas = &
	get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list)
	mZ = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list)
	mb = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list)
	mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list)
	mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list)
	ee = sqrt (4 * pi / alpha_em_i)
	vv = 1 / sqrt (sqrt (2._default) * GF)
	cw_sw = ee * vv / (2 * mZ)
	if (2*cw_sw <= 1) then
	cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2
	mW = mZ * sqrt (cw2)
	call var_list%set_real (var_str ("GF"), GF, .true.)
	call var_list%set_real (var_str ("mZ"), mZ, .true.)
	call var_list%set_real (var_str ("mW"), mW, .true.)
	call var_list%set_real (var_str ("mtau"), mtau, .true.)
	call var_list%set_real (var_str ("mb"), mb, .true.)
	call var_list%set_real (var_str ("mtop"), mtop, .true.)
	call var_list%set_real (var_str ("alphas"), alphas, .true.)
	else
	call msg_fatal ("SLHA: Unphysical SM parameter values")
	return
	end if
	end subroutine slha_handle_SMINPUTS

	@ %def slha_handle_SMINPUTS
	@ Write a SMINPUTS block.
	<<SLHA: procedures>>=
	subroutine slha_write_SMINPUTS (u, model)
	integer, intent(in) :: u
	type(model_t), intent(in), target :: model
	type(var_list_t), pointer :: var_list
	var_list => model%get_var_list_ptr ()
	call write_block_header (u, "SMINPUTS", "SM input parameters")
	call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, &
	"Inverse electromagnetic coupling alpha (Z pole)")
	call write_real_data_item (u, 2, var_str ("GF"), var_list, &
	"Fermi constant")
	call write_real_data_item (u, 3, var_str ("alphas"), var_list, &
	"Strong coupling alpha_s (Z pole)")
	call write_real_data_item (u, 4, var_str ("mZ"), var_list, &
	"Z mass")
	call write_real_data_item (u, 5, var_str ("mb"), var_list, &
	"b running mass (at mb)")
	call write_real_data_item (u, 6, var_str ("mtop"), var_list, &
	"top mass")
	call write_real_data_item (u, 7, var_str ("mtau"), var_list, &
	"tau mass")
	end subroutine slha_write_SMINPUTS

	@ %def slha_write_SMINPUTS
	@
	\subsubsection{MINPAR}
	The block of SUSY input parameters. They are accessible to WHIZARD,
	but they only get used when an external spectrum generator is
	invoked. The precise set of parameters depends on the type of SUSY
	breaking, which by itself is one of the parameters.
	<<SLHA: procedures>>=
	subroutine slha_handle_MINPAR (parse_tree, model, mssm_type)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	integer, intent(in) :: mssm_type
	type(var_list_t), pointer :: var_list
	type(parse_node_t), pointer :: pn_block
	var_list => model%get_var_list_ptr ()
	call var_list%set_real &
	(var_str ("mtype"), real(mssm_type, default), is_known=.true.)
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("MINPAR"), required=.true.)
	select case (mssm_type)
	case (MSSM_SUGRA)
	call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
	call set_data_item (pn_block, 2, var_str ("m_half"), var_list)
	call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
	call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
	call set_data_item (pn_block, 5, var_str ("A0"), var_list)
	case (MSSM_GMSB)
	call set_data_item (pn_block, 1, var_str ("Lambda"), var_list)
	call set_data_item (pn_block, 2, var_str ("M_mes"), var_list)
	call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
	call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
	call set_data_item (pn_block, 5, var_str ("N_5"), var_list)
	call set_data_item (pn_block, 6, var_str ("c_grav"), var_list)
	case (MSSM_AMSB)
	call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
	call set_data_item (pn_block, 2, var_str ("m_grav"), var_list)
	call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
	call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
	case default
	call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
	end select
	end subroutine slha_handle_MINPAR

	@ %def slha_handle_MINPAR
	@ Write a MINPAR block as appropriate for the current model type.
	<<SLHA: procedures>>=
	subroutine slha_write_MINPAR (u, model, mssm_type)
	integer, intent(in) :: u
	type(model_t), intent(in), target :: model
	integer, intent(in) :: mssm_type
	type(var_list_t), pointer :: var_list
	var_list => model%get_var_list_ptr ()
	call write_block_header (u, "MINPAR", "Basic SUSY input parameters")
	select case (mssm_type)
	case (MSSM_SUGRA)
	call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
	"Common scalar mass")
	call write_real_data_item (u, 2, var_str ("m_half"), var_list, &
	"Common gaugino mass")
	call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
	"tan(beta)")
	call write_integer_data_item (u, 4, &
	var_str ("sgn_mu"), var_list, &
	"Sign of mu")
	call write_real_data_item (u, 5, var_str ("A0"), var_list, &
	"Common trilinear coupling")
	case (MSSM_GMSB)
	call write_real_data_item (u, 1, var_str ("Lambda"), var_list, &
	"Soft-breaking scale")
	call write_real_data_item (u, 2, var_str ("M_mes"), var_list, &
	"Messenger scale")
	call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
	"tan(beta)")
	call write_integer_data_item (u, 4, &
	var_str ("sgn_mu"), var_list, &
	"Sign of mu")
	call write_integer_data_item (u, 5, var_str ("N_5"), var_list, &
	"Messenger index")
	call write_real_data_item (u, 6, var_str ("c_grav"), var_list, &
	"Gravitino mass factor")
	case (MSSM_AMSB)
	call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
	"Common scalar mass")
	call write_real_data_item (u, 2, var_str ("m_grav"), var_list, &
	"Gravitino mass")
	call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
	"tan(beta)")
	call write_integer_data_item (u, 4, &
	var_str ("sgn_mu"), var_list, &
	"Sign of mu")
	case default
	call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
	"tan(beta)")
	end select
	end subroutine slha_write_MINPAR

	@ %def slha_write_MINPAR
	@
	\subsubsection{Mass spectrum}
	Set masses. Since the particles are identified by PDG code, read
	the line and try to set the appropriate particle mass in the current
	model. At the end, update parameters, just in case the $W$ or $Z$
	mass was included.
	<<SLHA: procedures>>=
	subroutine slha_handle_MASS (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code
	type(parse_node_t), pointer :: pn_mass
	integer :: pdg
	real(default) :: mass
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("MASS"), required=.true.)
	if (.not. (associated (pn_block))) return
	pn_data => parse_node_get_sub_ptr (pn_block, 4)
	do while (associated (pn_data))
	pn_line => parse_node_get_sub_ptr (pn_data, 2)
	pn_code => parse_node_get_sub_ptr (pn_line)
	if (associated (pn_code)) then
	pdg = get_integer_parameter (pn_code)
	pn_mass => parse_node_get_next_ptr (pn_code)
	if (associated (pn_mass)) then
	mass = get_real_parameter (pn_mass)
	call model%set_field_mass (pdg, mass)
	else
	call msg_error ("SLHA: Block MASS: Missing mass value")
	end if
	else
	call msg_error ("SLHA: Block MASS: Missing PDG code")
	end if
	pn_data => parse_node_get_next_ptr (pn_data)
	end do
	end subroutine slha_handle_MASS

	@ %def slha_handle_MASS
	@
	\subsubsection{Widths}
	Set widths. For each DECAY block, extract the header, read the PDG
	code and width, and try to set the appropriate particle width in the
	current model.
	<<SLHA: procedures>>=
	subroutine slha_handle_decays (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width
	integer :: pdg
	real(default) :: width
	pn_decay => slha_get_first_decay_ptr (parse_tree)
	do while (associated (pn_decay))
	pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2)
	pn_code => parse_node_get_sub_ptr (pn_decay_spec)
	pdg = get_integer_parameter (pn_code)
	pn_width => parse_node_get_next_ptr (pn_code)
	width = get_real_parameter (pn_width)
	call model%set_field_width (pdg, width)
	pn_decay => slha_get_next_decay_ptr (pn_decay)
	end do
	end subroutine slha_handle_decays

	@ %def slha_handle_decays
	@
	\subsubsection{Mixing matrices}
	Read mixing matrices. We can treat all matrices by a single
	procedure if we just know the block name, variable prefix, and matrix
	dimension. The matrix dimension must be less than 10.
	For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal
	matrices, so we generalize the definition.
	<<SLHA: procedures>>=
	subroutine slha_handle_matrix_block &
	(parse_tree, block_name, var_prefix, dim1, dim2, model)
	type(parse_tree_t), intent(in) :: parse_tree
	character(*), intent(in) :: block_name, var_prefix
	integer, intent(in) :: dim1, dim2
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block
	type(var_list_t), pointer :: var_list
	integer :: i, j
	character(len=len(var_prefix)+2) :: var_name
	var_list => model%get_var_list_ptr ()
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str (block_name), required=.false.)
	if (.not. (associated (pn_block))) return
	do i = 1, dim1
	do j = 1, dim2
	write (var_name, "(A,I1,I1)") var_prefix, i, j
	call set_matrix_element (pn_block, i, j, var_str (var_name), var_list)
	end do
	end do
	end subroutine slha_handle_matrix_block

	@ %def slha_handle_matrix_block
	@
	\subsubsection{Higgs data}
	Read the block ALPHA which holds just the Higgs mixing angle.
	<<SLHA: procedures>>=
	subroutine slha_handle_ALPHA (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item
	type(var_list_t), pointer :: var_list
	real(default) :: al_h
	var_list => model%get_var_list_ptr ()
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("ALPHA"), required=.false.)
	if (.not. (associated (pn_block))) return
	pn_data => parse_node_get_sub_ptr (pn_block, 4)
	pn_line => parse_node_get_sub_ptr (pn_data, 2)
	pn_item => parse_node_get_sub_ptr (pn_line)
	if (associated (pn_item)) then
	al_h = get_real_parameter (pn_item)
	call var_list%set_real (var_str ("al_h"), al_h, &
	is_known=.true., ignore=.true.)
	end if
	end subroutine slha_handle_ALPHA

	@ %def slha_handle_matrix_block
	@ Read the block HMIX for the Higgs mixing parameters
	<<SLHA: procedures>>=
	subroutine slha_handle_HMIX (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block
	type(var_list_t), pointer :: var_list
	var_list => model%get_var_list_ptr ()
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("HMIX"), required=.false.)
	if (.not. (associated (pn_block))) return
	call set_data_item (pn_block, 1, var_str ("mu_h"), var_list)
	call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list)
	end subroutine slha_handle_HMIX

	@ %def slha_handle_HMIX
	@ Read the block NMSSMRUN for the specific NMSSM parameters
	<<SLHA: procedures>>=
	subroutine slha_handle_NMSSMRUN (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model
	type(parse_node_t), pointer :: pn_block
	type(var_list_t), pointer :: var_list
	var_list => model%get_var_list_ptr ()
	pn_block => slha_get_block_ptr &
	(parse_tree, var_str ("NMSSMRUN"), required=.false.)
	if (.not. (associated (pn_block))) return
	call set_data_item (pn_block, 1, var_str ("ls"), var_list)
	call set_data_item (pn_block, 2, var_str ("ks"), var_list)
	call set_data_item (pn_block, 3, var_str ("a_ls"), var_list)
	call set_data_item (pn_block, 4, var_str ("a_ks"), var_list)
	call set_data_item (pn_block, 5, var_str ("nmu"), var_list)
	end subroutine slha_handle_NMSSMRUN

	@ %def slha_handle_NMSSMRUN
	@
	\subsection{Parsing custom SLHA files}
	With the introduction of UFO models, we support custom files in
	generic SLHA format that reset model parameters. In contrast to
	strict SLHA files, the order and naming of blocks is arbitrary.

	We scan the complete file (i.e., preprocessed parse tree), parsing all
	blocks that contain data lines. For each data line, we identify index
	array and associated value. Then we set the model parameter
	that is associated with that block name and index array, if it exists.
	<<SLHA: procedures>>=
	subroutine slha_handle_custom_file (parse_tree, model)
	type(parse_tree_t), intent(in) :: parse_tree
	type(model_t), intent(inout), target :: model

	type(parse_node_t), pointer :: pn_root, pn_block
	type(parse_node_t), pointer :: pn_block_spec, pn_block_name
	type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
	type(string_t) :: block_name
	integer, dimension(:), allocatable :: block_index
	integer :: n_index, i
	real(default) :: value

	pn_root => parse_tree%get_root_ptr ()
	pn_block => pn_root%get_sub_ptr ()
	HANDLE_BLOCKS: do while (associated (pn_block))
	select case (char (pn_block%get_rule_key ()))
	case ("block_def")
	call slha_handle_custom_block (pn_block, model)
	end select
	pn_block => pn_block%get_next_ptr ()
	end do HANDLE_BLOCKS

	end subroutine slha_handle_custom_file

	@ %def slha_handle_custom_file
	@
	<<SLHA: procedures>>=
	subroutine slha_handle_custom_block (pn_block, model)
	type(parse_node_t), intent(in), target :: pn_block
	type(model_t), intent(inout), target :: model

	type(parse_node_t), pointer :: pn_block_spec, pn_block_name
	type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
	type(string_t) :: block_name
	integer, dimension(:), allocatable :: block_index
	integer :: n_index, i
	real(default) :: value

	pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
	pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
	select case (char (parse_node_get_rule_key (pn_block_name)))
	case ("block_name")
	block_name = trim (adjustl (upper_case (pn_block_name%get_string ())))
	case ("QNUMBERS")
	block_name = "QNUMBERS"
	end select
	call demangle_keywords (block_name)
	pn_data => pn_block%get_sub_ptr (4)
	HANDLE_LINES: do while (associated (pn_data))
	select case (char (pn_data%get_rule_key ()))
	case ("block_data")
	pn_line => pn_data%get_sub_ptr (2)
	n_index = pn_line%get_n_sub () - 1
	allocate (block_index (n_index))
	pn_code => pn_line%get_sub_ptr ()
	READ_LINE: do i = 1, n_index
	select case (char (pn_code%get_rule_key ()))
	case ("integer"); block_index(i) = pn_code%get_integer ()
	case default
	pn_code => null ()
	exit READ_LINE
	end select
	pn_code => pn_code%get_next_ptr ()
	end do READ_LINE
	if (associated (pn_code)) then
	value = get_real_parameter (pn_code)
	call model%slha_set_par (block_name, block_index, value)
	end if
	deallocate (block_index)
	end select
	pn_data => pn_data%get_next_ptr ()
	end do HANDLE_LINES

	end subroutine slha_handle_custom_block

	@ %def slha_handle_custom_block
	@
	\subsection{Parser}
	Read a SLHA file from stream, including preprocessing, and make up a
	parse tree.
	<<SLHA: procedures>>=
	subroutine slha_parse_stream (stream, custom_block_name, parse_tree)
	type(stream_t), intent(inout), target :: stream
	type(string_t), dimension(:), intent(in) :: custom_block_name
	type(parse_tree_t), intent(out) :: parse_tree
	type(ifile_t) :: ifile
	type(lexer_t) :: lexer
	type(stream_t), target :: stream_tmp
	call slha_preprocess (stream, custom_block_name, ifile)
	call stream_init (stream_tmp, ifile)
	call lexer_init_slha (lexer)
	call lexer_assign_stream (lexer, stream_tmp)
	call parse_tree_init (parse_tree, syntax_slha, lexer)
	call lexer_final (lexer)
	call stream_final (stream_tmp)
	call ifile_final (ifile)
	end subroutine slha_parse_stream

	@ %def slha_parse_stream
	@ Read a SLHA file chosen by name. Check first the current directory,
	then the directory where SUSY input files should be located.

	The [[default_mode]] applies to unknown blocks in the SLHA file: this
	is either [[MODE_SKIP]] or [[MODE_DATA]], corresponding to genuine
	SUSY and custom file content, respectively.
	<<SLHA: public>>=
	public :: slha_parse_file
	<<SLHA: procedures>>=
	subroutine slha_parse_file (file, custom_block_name, os_data, parse_tree)
	type(string_t), intent(in) :: file
	type(string_t), dimension(:), intent(in) :: custom_block_name
	type(os_data_t), intent(in) :: os_data
	type(parse_tree_t), intent(out) :: parse_tree
	logical :: exist
	type(string_t) :: filename
	type(stream_t), target :: stream
	call msg_message ("Reading SLHA input file '" // char (file) // "'")
	filename = file
	inquire (file=char(filename), exist=exist)
	if (.not. exist) then
	filename = os_data%whizard_susypath // "/" // file
	inquire (file=char(filename), exist=exist)
	if (.not. exist) then
	call msg_fatal ("SLHA input file '" // char (file) // "' not found")
	return
	end if
	end if
	call stream_init (stream, char (filename))
	call slha_parse_stream (stream, custom_block_name, parse_tree)
	call stream_final (stream)
	end subroutine slha_parse_file

	@ %def slha_parse_file
	@
	\subsection{API}
	Read the SLHA file, parse it, and interpret the parse tree. The model
	parameters retrieved from the file will be inserted into the
	appropriate model, which is loaded and modified in the background.
	The pointer to this model is returned as the last argument.
	<<SLHA: public>>=
	public :: slha_read_file
	<<SLHA: procedures>>=
	subroutine slha_read_file &
	(file, os_data, model, input, spectrum, decays)
	type(string_t), intent(in) :: file
	type(os_data_t), intent(in) :: os_data
	type(model_t), intent(inout), target :: model
	logical, intent(in) :: input, spectrum, decays
	type(string_t), dimension(:), allocatable :: custom_block_name
	type(parse_tree_t) :: parse_tree
	call model%get_custom_slha_blocks (custom_block_name)
	call slha_parse_file (file, custom_block_name, os_data, parse_tree)
	if (associated (parse_tree%get_root_ptr ())) then
	call slha_interpret_parse_tree &
	(parse_tree, model, input, spectrum, decays)
	call parse_tree_final (parse_tree)
	call model%update_parameters ()
	end if
	end subroutine slha_read_file

	@ %def slha_read_file
	@ Write the SLHA contents, as far as possible, to external file.
	<<SLHA: public>>=
	public :: slha_write_file
	<<SLHA: procedures>>=
	subroutine slha_write_file (file, model, input, spectrum, decays)
	type(string_t), intent(in) :: file
	type(model_t), target, intent(in) :: model
	logical, intent(in) :: input, spectrum, decays
	integer :: mssm_type
	integer :: u
	u = free_unit ()
	call msg_message ("Writing SLHA output file '" // char (file) // "'")
	open (unit=u, file=char(file), action="write", status="replace")
	write (u, "(A)") "# SUSY Les Houches Accord"
	write (u, "(A)") "# Output generated by " // trim (VERSION_STRING)
	call slha_write_MODSEL (u, model, mssm_type)
	if (input) then
	call slha_write_SMINPUTS (u, model)
	call slha_write_MINPAR (u, model, mssm_type)
	end if
	if (spectrum) then
	call msg_bug ("SLHA: spectrum output not supported yet")
	end if
	if (decays) then
	call msg_bug ("SLHA: decays output not supported yet")
	end if
	close (u)
	end subroutine slha_write_file

	@ %def slha_write_file
	@
	\subsection{Dispatch}
	<<SLHA: public>>=
	public :: dispatch_slha
	<<SLHA: procedures>>=
	subroutine dispatch_slha (var_list, input, spectrum, decays)
	type(var_list_t), intent(inout), target :: var_list
	logical, intent(out) :: input, spectrum, decays
	input = var_list%get_lval (var_str ("?slha_read_input"))
	spectrum = var_list%get_lval (var_str ("?slha_read_spectrum"))
	decays = var_list%get_lval (var_str ("?slha_read_decays"))
	end subroutine dispatch_slha

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

	module slha_interface_ut
	use unit_tests
	use slha_interface_uti

	<<Standard module head>>

	<<SLHA: public test>>

	contains

	<<SLHA: test driver>>

	end module slha_interface_ut
	@ %def slha_interface_ut
	@
	<<[[slha_interface_uti.f90]]>>=
	<<File header>>

	module slha_interface_uti

	<<Use strings>>
	use io_units
	use os_interface
	use parser
	use model_data
	use variables
	use models

	use slha_interface

	<<Standard module head>>

	<<SLHA: test declarations>>

	contains

	<<SLHA: tests>>

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

	@ %def slha_test
	@ Checking the basics of the SLHA interface.
	<<SLHA: execute tests>>=
	call test (slha_1, "slha_1", &
	"check SLHA interface", &
	u, results)
	<<SLHA: test declarations>>=
	public :: slha_1
	<<SLHA: tests>>=
	subroutine slha_1 (u)
	integer, intent(in) :: u
	type(os_data_t), pointer :: os_data => null ()
	type(parse_tree_t), pointer :: parse_tree => null ()
	integer :: u_file, iostat
	character(80) :: buffer
	character(*), parameter :: file_slha = "slha_test.dat"
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()
	type(string_t), dimension(0) :: empty_string_array

	write (u, "(A)") "* Test output: SLHA Interface"
	write (u, "(A)") "* Purpose: test SLHA file reading and writing"
	write (u, "(A)")

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

	allocate (os_data)
	allocate (parse_tree)
	call os_data%init ()
	call syntax_model_file_init ()
	call model_list%read_model &
	(var_str("MSSM"), var_str("MSSM.mdl"), os_data, model)
	call syntax_slha_init ()

	write (u, "(A)") "* Reading SLHA file sps1ap_decays.slha"
	write (u, "(A)")

	call slha_parse_file (var_str ("sps1ap_decays.slha"), &
	empty_string_array, os_data, parse_tree)

	write (u, "(A)") "* Writing the parse tree:"
	write (u, "(A)")

	call parse_tree_write (parse_tree, u)

	write (u, "(A)") "* Interpreting the parse tree"
	write (u, "(A)")

	call slha_interpret_parse_tree (parse_tree, model, &
	input=.true., spectrum=.true., decays=.true.)
	call parse_tree_final (parse_tree)

	write (u, "(A)") "* Writing out the list of variables (reals only):"
	write (u, "(A)")

	call var_list_write (model%get_var_list_ptr (), &
	only_type = V_REAL, unit = u)

	write (u, "(A)")
	write (u, "(A)") "* Writing SLHA output to '" // file_slha // "'"
	write (u, "(A)")

	call slha_write_file (var_str (file_slha), model, input=.true., &
	spectrum=.false., decays=.false.)
	u_file = free_unit ()
	open (u_file, file = file_slha, action = "read", status = "old")
	do
	read (u_file, "(A)", iostat = iostat) buffer
	if (buffer(1:37) == "# Output generated by WHIZARD version") then
	buffer = "[...]"
	end if
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do
	close (u_file)

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

	call parse_tree_final (parse_tree)
	deallocate (parse_tree)
	deallocate (os_data)

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

	end subroutine slha_1

	@ %def slha_1
	@
	\subsubsection{SLHA interface}
	This rather trivial sets all input values for the SLHA interface
	to [[false]].
	<<SLHA: execute tests>>=
	call test (slha_2, "slha_2", &
	"SLHA interface", &
	u, results)
	<<SLHA: test declarations>>=
	public :: slha_2
	<<SLHA: tests>>=
	subroutine slha_2 (u)
	integer, intent(in) :: u
	type(var_list_t) :: var_list
	logical :: input, spectrum, decays

	write (u, "(A)") "* Test output: slha_2"
	write (u, "(A)") "* Purpose: SLHA interface settings"
	write (u, "(A)")

	write (u, "(A)") "* Default settings"
	write (u, "(A)")

	call var_list%init_defaults (0)
	call dispatch_slha (var_list, &
	input = input, spectrum = spectrum, decays = decays)

	write (u, "(A,1x,L1)") " slha_read_input =", input
	write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum
	write (u, "(A,1x,L1)") " slha_read_decays =", decays

	call var_list%final ()
	call var_list%init_defaults (0)

	write (u, "(A)")
	write (u, "(A)") "* Set all entries to [false]"
	write (u, "(A)")

	call var_list%set_log (var_str ("?slha_read_input"), &
	.false., is_known = .true.)
	call var_list%set_log (var_str ("?slha_read_spectrum"), &
	.false., is_known = .true.)
	call var_list%set_log (var_str ("?slha_read_decays"), &
	.false., is_known = .true.)

	call dispatch_slha (var_list, &
	input = input, spectrum = spectrum, decays = decays)

	write (u, "(A,1x,L1)") " slha_read_input =", input
	write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum
	write (u, "(A,1x,L1)") " slha_read_decays =", decays

	call var_list%final ()

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

	end subroutine slha_2

	@ %def slha_2
	Index: trunk/src/whizard-core/whizard.nw
	===================================================================
	--- trunk/src/whizard-core/whizard.nw (revision 8777)
	+++ trunk/src/whizard-core/whizard.nw (revision 8778)
	@@ -1,29223 +1,29208 @@
	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD main code as NOWEB source
	\includemodulegraph{whizard-core}
	\chapter{Integration and Simulation}
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{User-controlled File I/O}

	The SINDARIN language includes commands that write output to file (input may
	be added later). We identify files by their name, and manage the unit
	internally. We need procedures for opening, closing, and printing files.

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

	module user_files

	<<Use strings>>
	use io_units
	use diagnostics
	use ifiles
	use analysis

	<<Standard module head>>

	<<User files: public>>

	<<User files: types>>

	<<User files: interfaces>>

	contains

	<<User files: procedures>>

	end module user_files
	@ %def user_files
	@
	\subsection{The file type}
	This is a type that describes an open user file and its properties. The entry
	is part of a doubly-linked list.
	<<User files: types>>=
	type :: file_t
	private
	type(string_t) :: name
	integer :: unit = -1
	logical :: reading = .false.
	logical :: writing = .false.
	type(file_t), pointer :: prev => null ()
	type(file_t), pointer :: next => null ()
	end type file_t

	@ %def file_t
	@ The initializer opens the file.
	<<User files: procedures>>=
	subroutine file_init (file, name, action, status, position)
	type(file_t), intent(out) :: file
	type(string_t), intent(in) :: name
	character(len=*), intent(in) :: action, status, position
	file%unit = free_unit ()
	file%name = name
	open (unit = file%unit, file = char (file%name), &
	action = action, status = status, position = position)
	select case (action)
	case ("read")
	file%reading = .true.
	case ("write")
	file%writing = .true.
	case ("readwrite")
	file%reading = .true.
	file%writing = .true.
	end select
	end subroutine file_init

	@ %def file_init
	@ The finalizer closes it.
	<<User files: procedures>>=
	subroutine file_final (file)
	type(file_t), intent(inout) :: file
	close (unit = file%unit)
	file%unit = -1
	end subroutine file_final

	@ %def file_final
	@ Check if a file is open with correct status.
	<<User files: procedures>>=
	function file_is_open (file, action) result (flag)
	logical :: flag
	type(file_t), intent(in) :: file
	character(*), intent(in) :: action
	select case (action)
	case ("read")
	flag = file%reading
	case ("write")
	flag = file%writing
	case ("readwrite")
	flag = file%reading .and. file%writing
	case default
	call msg_bug ("Checking file '" // char (file%name) &
	// "': illegal action specifier")
	end select
	end function file_is_open

	@ %def file_is_open
	@ Return the unit number of a file for direct access. It should be checked
	first whether the file is open.
	<<User files: procedures>>=
	function file_get_unit (file) result (unit)
	integer :: unit
	type(file_t), intent(in) :: file
	unit = file%unit
	end function file_get_unit

	@ %def file_get_unit
	@ Write to the file. Error if in wrong mode. If there is no string, just
	write an empty record. If there is a string, respect the [[advancing]]
	option.
	<<User files: procedures>>=
	subroutine file_write_string (file, string, advancing)
	type(file_t), intent(in) :: file
	type(string_t), intent(in), optional :: string
	logical, intent(in), optional :: advancing
	if (file%writing) then
	if (present (string)) then
	if (present (advancing)) then
	if (advancing) then
	write (file%unit, "(A)") char (string)
	else
	write (file%unit, "(A)", advance="no") char (string)
	end if
	else
	write (file%unit, "(A)") char (string)
	end if
	else
	write (file%unit, *)
	end if
	else
	call msg_error ("Writing to file: File '" // char (file%name) &
	// "' is not open for writing.")
	end if
	end subroutine file_write_string

	@ %def file_write
	@ Write a whole ifile, line by line.
	<<User files: procedures>>=
	subroutine file_write_ifile (file, ifile)
	type(file_t), intent(in) :: file
	type(ifile_t), intent(in) :: ifile
	type(line_p) :: line
	call line_init (line, ifile)
	do while (line_is_associated (line))
	call file_write_string (file, line_get_string_advance (line))
	end do
	end subroutine file_write_ifile

	@ %def file_write_ifile
	@ Write an analysis object (or all objects) to an open file.
	<<User files: procedures>>=
	subroutine file_write_analysis (file, tag)
	type(file_t), intent(in) :: file
	type(string_t), intent(in), optional :: tag
	if (file%writing) then
	if (present (tag)) then
	call analysis_write (tag, unit = file%unit)
	else
	call analysis_write (unit = file%unit)
	end if
	else
	call msg_error ("Writing analysis to file: File '" // char (file%name) &
	// "' is not open for writing.")
	end if
	end subroutine file_write_analysis

	@ %def file_write_analysis
	@
	\subsection{The file list}
	We maintain a list of all open files and their attributes. The list must be
	doubly-linked because we may delete entries.
	<<User files: public>>=
	public :: file_list_t
	<<User files: types>>=
	type :: file_list_t
	type(file_t), pointer :: first => null ()
	type(file_t), pointer :: last => null ()
	end type file_list_t

	@ %def file_list_t
	@ There is no initialization routine, but a finalizer which deletes all:
	<<User files: public>>=
	public :: file_list_final
	<<User files: procedures>>=
	subroutine file_list_final (file_list)
	type(file_list_t), intent(inout) :: file_list
	type(file_t), pointer :: current
	do while (associated (file_list%first))
	current => file_list%first
	file_list%first => current%next
	call file_final (current)
	deallocate (current)
	end do
	file_list%last => null ()
	end subroutine file_list_final

	@ %def file_list_final
	@ Find an entry in the list. Return null pointer on failure.
	<<User files: procedures>>=
	function file_list_get_file_ptr (file_list, name) result (current)
	type(file_t), pointer :: current
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	current => file_list%first
	do while (associated (current))
	if (current%name == name) return
	current => current%next
	end do
	end function file_list_get_file_ptr

	@ %def file_list_get_file_ptr
	@ Check if a file is open, public version:
	<<User files: public>>=
	public :: file_list_is_open
	<<User files: procedures>>=
	function file_list_is_open (file_list, name, action) result (flag)
	logical :: flag
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	character(len=*), intent(in) :: action
	type(file_t), pointer :: current
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	flag = file_is_open (current, action)
	else
	flag = .false.
	end if
	end function file_list_is_open

	@ %def file_list_is_open
	@ Return the unit number for a file. It should be checked first whether the
	file is open.
	<<User files: public>>=
	public :: file_list_get_unit
	<<User files: procedures>>=
	function file_list_get_unit (file_list, name) result (unit)
	integer :: unit
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	type(file_t), pointer :: current
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	unit = file_get_unit (current)
	else
	unit = -1
	end if
	end function file_list_get_unit

	@ %def file_list_get_unit
	@ Append a new file entry, i.e., open this file. Error if it is
	already open.
	<<User files: public>>=
	public :: file_list_open
	<<User files: procedures>>=
	subroutine file_list_open (file_list, name, action, status, position)
	type(file_list_t), intent(inout) :: file_list
	type(string_t), intent(in) :: name
	character(len=*), intent(in) :: action, status, position
	type(file_t), pointer :: current
	if (.not. associated (file_list_get_file_ptr (file_list, name))) then
	allocate (current)
	call msg_message ("Opening file '" // char (name) // "' for output")
	call file_init (current, name, action, status, position)
	if (associated (file_list%last)) then
	file_list%last%next => current
	current%prev => file_list%last
	else
	file_list%first => current
	end if
	file_list%last => current
	else
	call msg_error ("Opening file: File '" // char (name) &
	// "' is already open.")
	end if
	end subroutine file_list_open

	@ %def file_list_open
	@ Delete a file entry, i.e., close this file. Error if it is not open.
	<<User files: public>>=
	public :: file_list_close
	<<User files: procedures>>=
	subroutine file_list_close (file_list, name)
	type(file_list_t), intent(inout) :: file_list
	type(string_t), intent(in) :: name
	type(file_t), pointer :: current
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	if (associated (current%prev)) then
	current%prev%next => current%next
	else
	file_list%first => current%next
	end if
	if (associated (current%next)) then
	current%next%prev => current%prev
	else
	file_list%last => current%prev
	end if
	call msg_message ("Closing file '" // char (name) // "' for output")
	call file_final (current)
	deallocate (current)
	else
	call msg_error ("Closing file: File '" // char (name) &
	// "' is not open.")
	end if
	end subroutine file_list_close

	@ %def file_list_close
	@ Write a string to file. Error if it is not open.
	<<User files: public>>=
	public :: file_list_write
	<<User files: interfaces>>=
	interface file_list_write
	module procedure file_list_write_string
	module procedure file_list_write_ifile
	end interface
	<<User files: procedures>>=
	subroutine file_list_write_string (file_list, name, string, advancing)
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: string
	logical, intent(in), optional :: advancing
	type(file_t), pointer :: current
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	call file_write_string (current, string, advancing)
	else
	call msg_error ("Writing to file: File '" // char (name) &
	// "'is not open.")
	end if
	end subroutine file_list_write_string

	subroutine file_list_write_ifile (file_list, name, ifile)
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	type(ifile_t), intent(in) :: ifile
	type(file_t), pointer :: current
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	call file_write_ifile (current, ifile)
	else
	call msg_error ("Writing to file: File '" // char (name) &
	// "'is not open.")
	end if
	end subroutine file_list_write_ifile

	@ %def file_list_write
	@ Write an analysis object or all objects to data file. Error if it is not
	open. If the file name is empty, write to standard output.
	<<User files: public>>=
	public :: file_list_write_analysis
	<<User files: procedures>>=
	subroutine file_list_write_analysis (file_list, name, tag)
	type(file_list_t), intent(in) :: file_list
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: tag
	type(file_t), pointer :: current
	if (name == "") then
	if (present (tag)) then
	call analysis_write (tag)
	else
	call analysis_write
	end if
	else
	current => file_list_get_file_ptr (file_list, name)
	if (associated (current)) then
	call file_write_analysis (current, tag)
	else
	call msg_error ("Writing analysis to file: File '" // char (name) &
	// "' is not open.")
	end if
	end if
	end subroutine file_list_write_analysis

	@ %def file_list_write_analysis
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Runtime data}

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

	module rt_data

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_utils, only: write_separator
	use format_defs, only: FMT_19, FMT_12
	use system_dependencies
	use diagnostics
	use os_interface
	use lexers
	use parser
	use models
	use subevents
	use pdg_arrays
	use variables, only: var_list_t
	use process_libraries
	use prclib_stacks
	use prc_core, only: helicity_selection_t
	use beam_structures
	use event_base, only: event_callback_t
	use user_files
	use process_stacks
	use iterations

	<<Standard module head>>

	<<RT data: public>>

	<<RT data: types>>

	contains

	<<RT data: procedures>>

	end module rt_data
	@ %def rt_data
	@
	\subsection{Strategy for models and variables}
	The program manages its data via a main [[rt_data_t]] object. During program
	flow, various commands create and use local [[rt_data_t]] objects. Those
	transient blocks contain either pointers to global object or local copies
	which are deleted after use.

	Each [[rt_data_t]] object contains a variable list component. This lists
	holds (local copies of) all kinds of intrinsic or user-defined variables. The
	variable list is linked to the variable list contained in the local process
	library. This, in turn, is linked to the variable list of the [[rt_data_t]]
	context, and so on.

	A variable lookup will thus be recursively delegated to the linked variable
	lists, until a match is found. When modifying a variable which is not yet
	local, the program creates a local copy and uses this afterwards. Thus, when
	the local [[rt_data_t]] object is deleted, the context value is recovered.

	Models are kept in a model list which is separate from the variable list.
	Otherwise, they are treated in a similar manner: the local list is linked to
	the context model list. Model lookup is thus recursively delegated. When a
	model or any part of it is modified, the model is copied to the local
	[[rt_data_t]] object, so the context model is not modified. Commands such as
	[[integrate]] will create their own copy of the current model (and of the
	current variable list) at the point where they are executed.

	When a model is encountered for the first time, it is read from file. The
	reading is automatically delegated to the global context. Thus, this master
	copy survives until the main [[rt_data_t]] object is deleted, at program
	completion.

	If there is a currently active model, its variable list is linked to the main
	variable list. Variable lookups will then start from the model variable
	list. When the current model is switched, the new active model will get this
	link instead. Consequently, a change to the current model is kept as long as
	this model has a local copy; it survives local model switches. On the other
	hand, a parameter change in the current model doesn't affect any other model,
	even if the parameter name is identical.
	@
	\subsection{Container for parse nodes}
	The runtime data set contains a bunch of parse nodes (chunks of code
	that have not been compiled into evaluation trees but saved for later
	use). We collect them here.

	This implementation has the useful effect that an assignment between two
	objects of this type will establish a pointer-target relationship for
	all components.
	<<RT data: types>>=
	type :: rt_parse_nodes_t
	type(parse_node_t), pointer :: cuts_lexpr => null ()
	type(parse_node_t), pointer :: scale_expr => null ()
	type(parse_node_t), pointer :: fac_scale_expr => null ()
	type(parse_node_t), pointer :: ren_scale_expr => null ()
	type(parse_node_t), pointer :: weight_expr => null ()
	type(parse_node_t), pointer :: selection_lexpr => null ()
	type(parse_node_t), pointer :: reweight_expr => null ()
	type(parse_node_t), pointer :: analysis_lexpr => null ()
	type(parse_node_p), dimension(:), allocatable :: alt_setup
	contains
	<<RT data: rt parse nodes: TBP>>
	end type rt_parse_nodes_t

	@ %def rt_parse_nodes_t
	@ Clear individual components. The parse nodes are nullified. No
	finalization needed since the pointer targets are part of the global
	parse tree.
	<<RT data: rt parse nodes: TBP>>=
	procedure :: clear => rt_parse_nodes_clear
	<<RT data: procedures>>=
	subroutine rt_parse_nodes_clear (rt_pn, name)
	class(rt_parse_nodes_t), intent(inout) :: rt_pn
	type(string_t), intent(in) :: name
	select case (char (name))
	case ("cuts")
	rt_pn%cuts_lexpr => null ()
	case ("scale")
	rt_pn%scale_expr => null ()
	case ("factorization_scale")
	rt_pn%fac_scale_expr => null ()
	case ("renormalization_scale")
	rt_pn%ren_scale_expr => null ()
	case ("weight")
	rt_pn%weight_expr => null ()
	case ("selection")
	rt_pn%selection_lexpr => null ()
	case ("reweight")
	rt_pn%reweight_expr => null ()
	case ("analysis")
	rt_pn%analysis_lexpr => null ()
	end select
	end subroutine rt_parse_nodes_clear

	@ %def rt_parse_nodes_clear
	@ Output for the parse nodes.
	<<RT data: rt parse nodes: TBP>>=
	procedure :: write => rt_parse_nodes_write
	<<RT data: procedures>>=
	subroutine rt_parse_nodes_write (object, unit)
	class(rt_parse_nodes_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	call wrt ("Cuts", object%cuts_lexpr)
	call write_separator (u)
	call wrt ("Scale", object%scale_expr)
	call write_separator (u)
	call wrt ("Factorization scale", object%fac_scale_expr)
	call write_separator (u)
	call wrt ("Renormalization scale", object%ren_scale_expr)
	call write_separator (u)
	call wrt ("Weight", object%weight_expr)
	call write_separator (u, 2)
	call wrt ("Event selection", object%selection_lexpr)
	call write_separator (u)
	call wrt ("Event reweighting factor", object%reweight_expr)
	call write_separator (u)
	call wrt ("Event analysis", object%analysis_lexpr)
	if (allocated (object%alt_setup)) then
	call write_separator (u, 2)
	write (u, "(1x,A,':')") "Alternative setups"
	do i = 1, size (object%alt_setup)
	call write_separator (u)
	call wrt ("Commands", object%alt_setup(i)%ptr)
	end do
	end if
	contains
	subroutine wrt (title, pn)
	character(*), intent(in) :: title
	type(parse_node_t), intent(in), pointer :: pn
	if (associated (pn)) then
	write (u, "(1x,A,':')") title
	call write_separator (u)
	call parse_node_write_rec (pn, u)
	else
	write (u, "(1x,A,':',1x,A)") title, "[undefined]"
	end if
	end subroutine wrt
	end subroutine rt_parse_nodes_write

	@ %def rt_parse_nodes_write
	@ Screen output for individual components. (This should eventually be more
	condensed, currently we print the internal representation tree.)
	<<RT data: rt parse nodes: TBP>>=
	procedure :: show => rt_parse_nodes_show
	<<RT data: procedures>>=
	subroutine rt_parse_nodes_show (rt_pn, name, unit)
	class(rt_parse_nodes_t), intent(in) :: rt_pn
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: unit
	type(parse_node_t), pointer :: pn
	integer :: u
	u = given_output_unit (unit)
	select case (char (name))
	case ("cuts")
	pn => rt_pn%cuts_lexpr
	case ("scale")
	pn => rt_pn%scale_expr
	case ("factorization_scale")
	pn => rt_pn%fac_scale_expr
	case ("renormalization_scale")
	pn => rt_pn%ren_scale_expr
	case ("weight")
	pn => rt_pn%weight_expr
	case ("selection")
	pn => rt_pn%selection_lexpr
	case ("reweight")
	pn => rt_pn%reweight_expr
	case ("analysis")
	pn => rt_pn%analysis_lexpr
	end select
	if (associated (pn)) then
	write (u, "(A,1x,A,1x,A)") "Expression:", char (name), "(parse tree):"
	call parse_node_write_rec (pn, u)
	else
	write (u, "(A,1x,A,A)") "Expression:", char (name), ": [undefined]"
	end if
	end subroutine rt_parse_nodes_show

	@ %def rt_parse_nodes_show
	@
	\subsection{The data type}
	This is a big data container which contains everything that is used and
	modified during the command flow. A local copy of this can be used to
	temporarily override defaults. The data set is transparent.
	<<RT data: public>>=
	public :: rt_data_t
	<<RT data: types>>=
	type :: rt_data_t
	type(lexer_t), pointer :: lexer => null ()
	type(rt_data_t), pointer :: context => null ()
	type(string_t), dimension(:), allocatable :: export
	type(var_list_t) :: var_list
	type(iterations_list_t) :: it_list
	type(os_data_t) :: os_data
	type(model_list_t) :: model_list
	type(model_t), pointer :: model => null ()
	logical :: model_is_copy = .false.
	type(model_t), pointer :: preload_model => null ()
	type(model_t), pointer :: fallback_model => null ()
	type(prclib_stack_t) :: prclib_stack
	type(process_library_t), pointer :: prclib => null ()
	type(beam_structure_t) :: beam_structure
	type(rt_parse_nodes_t) :: pn
	type(process_stack_t) :: process_stack
	type(string_t), dimension(:), allocatable :: sample_fmt
	class(event_callback_t), allocatable :: event_callback
	type(file_list_t), pointer :: out_files => null ()
	logical :: quit = .false.
	integer :: quit_code = 0
	type(string_t) :: logfile
	logical :: nlo_fixed_order = .false.
	logical, dimension(0:5) :: selected_nlo_parts = .false.
	integer, dimension(:), allocatable :: nlo_component
	contains
	<<RT data: rt data: TBP>>
	end type rt_data_t

	@ %def rt_data_t
	@
	\subsection{Output}
	<<RT data: rt data: TBP>>=
	procedure :: write => rt_data_write
	<<RT data: procedures>>=
	subroutine rt_data_write (object, unit, vars, pacify)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	type(string_t), dimension(:), intent(in), optional :: vars
	logical, intent(in), optional :: pacify
	integer :: u, i
	u = given_output_unit (unit)
	call write_separator (u, 2)
	write (u, "(1x,A)") "Runtime data:"
	if (object%get_n_export () > 0) then
	call write_separator (u, 2)
	write (u, "(1x,A)") "Exported objects and variables:"
	call write_separator (u)
	call object%write_exports (u)
	end if
	if (present (vars)) then
	if (size (vars) /= 0) then
	call write_separator (u, 2)
	write (u, "(1x,A)") "Selected variables:"
	call write_separator (u)
	call object%write_vars (u, vars)
	end if
	else
	call write_separator (u, 2)
	if (associated (object%model)) then
	call object%model%write_var_list (u, follow_link=.true.)
	else
	call object%var_list%write (u, follow_link=.true.)
	end if
	end if
	if (object%it_list%get_n_pass () > 0) then
	call write_separator (u, 2)
	write (u, "(1x)", advance="no")
	call object%it_list%write (u)
	end if
	if (associated (object%model)) then
	call write_separator (u, 2)
	call object%model%write (u)
	end if
	call object%prclib_stack%write (u)
	call object%beam_structure%write (u)
	call write_separator (u, 2)
	call object%pn%write (u)
	if (allocated (object%sample_fmt)) then
	call write_separator (u)
	write (u, "(1x,A)", advance="no") "Event sample formats = "
	do i = 1, size (object%sample_fmt)
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (object%sample_fmt(i))
	end do
	write (u, "(A)")
	end if
	call write_separator (u)
	write (u, "(1x,A)", advance="no") "Event callback:"
	if (allocated (object%event_callback)) then
	call object%event_callback%write (u)
	else
	write (u, "(1x,A)") "[undefined]"
	end if
	call object%process_stack%write (u, pacify)
	write (u, "(1x,A,1x,L1)") "quit :", object%quit
	write (u, "(1x,A,1x,I0)") "quit_code:", object%quit_code
	call write_separator (u, 2)
	write (u, "(1x,A,1x,A)") "Logfile :", "'" // trim (char (object%logfile)) // "'"
	call write_separator (u, 2)
	end subroutine rt_data_write

	@ %def rt_data_write
	@ Write only selected variables.
	<<RT data: rt data: TBP>>=
	procedure :: write_vars => rt_data_write_vars
	<<RT data: procedures>>=
	subroutine rt_data_write_vars (object, unit, vars)
	class(rt_data_t), intent(in), target :: object
	integer, intent(in), optional :: unit
	type(string_t), dimension(:), intent(in) :: vars
	type(var_list_t), pointer :: var_list
	integer :: u, i
	u = given_output_unit (unit)
	var_list => object%get_var_list_ptr ()
	do i = 1, size (vars)
	associate (var => vars(i))
	if (var_list%contains (var, follow_link=.true.)) then
	call var_list%write_var (var, unit = u, &
	follow_link = .true., defined=.true.)
	end if
	end associate
	end do
	end subroutine rt_data_write_vars

	@ %def rt_data_write_vars
	@ Write only the model list.
	<<RT data: rt data: TBP>>=
	procedure :: write_model_list => rt_data_write_model_list
	<<RT data: procedures>>=
	subroutine rt_data_write_model_list (object, unit)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call object%model_list%write (u)
	end subroutine rt_data_write_model_list

	@ %def rt_data_write_model_list
	@ Write only the library stack.
	<<RT data: rt data: TBP>>=
	procedure :: write_libraries => rt_data_write_libraries
	<<RT data: procedures>>=
	subroutine rt_data_write_libraries (object, unit, libpath)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: libpath
	integer :: u
	u = given_output_unit (unit)
	call object%prclib_stack%write (u, libpath)
	end subroutine rt_data_write_libraries

	@ %def rt_data_write_libraries
	@ Write only the beam data.
	<<RT data: rt data: TBP>>=
	procedure :: write_beams => rt_data_write_beams
	<<RT data: procedures>>=
	subroutine rt_data_write_beams (object, unit)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call write_separator (u, 2)
	call object%beam_structure%write (u)
	call write_separator (u, 2)
	end subroutine rt_data_write_beams

	@ %def rt_data_write_beams
	@ Write only the process and event expressions.
	<<RT data: rt data: TBP>>=
	procedure :: write_expr => rt_data_write_expr
	<<RT data: procedures>>=
	subroutine rt_data_write_expr (object, unit)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call write_separator (u, 2)
	call object%pn%write (u)
	call write_separator (u, 2)
	end subroutine rt_data_write_expr

	@ %def rt_data_write_expr
	@ Write only the process stack.
	<<RT data: rt data: TBP>>=
	procedure :: write_process_stack => rt_data_write_process_stack
	<<RT data: procedures>>=
	subroutine rt_data_write_process_stack (object, unit)
	class(rt_data_t), intent(in) :: object
	integer, intent(in), optional :: unit
	call object%process_stack%write (unit)
	end subroutine rt_data_write_process_stack

	@ %def rt_data_write_process_stack
	@
	<<RT data: rt data: TBP>>=
	procedure :: write_var_descriptions => rt_data_write_var_descriptions
	<<RT data: procedures>>=
	subroutine rt_data_write_var_descriptions (rt_data, unit, ascii_output)
	class(rt_data_t), intent(in) :: rt_data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: ascii_output
	integer :: u
	logical :: ao
	u = given_output_unit (unit)
	ao = .false.; if (present (ascii_output)) ao = ascii_output
	call rt_data%var_list%write (u, follow_link=.true., &
	descriptions=.true., ascii_output=ao)
	end subroutine rt_data_write_var_descriptions

	@ %def rt_data_write_var_descriptions
	@
	<<RT data: rt data: TBP>>=
	procedure :: show_description_of_string => rt_data_show_description_of_string
	<<RT data: procedures>>=
	subroutine rt_data_show_description_of_string (rt_data, string, &
	unit, ascii_output)
	class(rt_data_t), intent(in) :: rt_data
	type(string_t), intent(in) :: string
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: ascii_output
	integer :: u
	logical :: ao
	u = given_output_unit (unit)
	ao = .false.; if (present (ascii_output)) ao = ascii_output
	call rt_data%var_list%write_var (string, unit=u, follow_link=.true., &
	defined=.false., descriptions=.true., ascii_output=ao)
	end subroutine rt_data_show_description_of_string

	@ %def rt_data_show_description_of_string
	@
	\subsection{Clear}
	The [[clear]] command can remove the contents of various subobjects.
	The objects themselves should stay.
	<<RT data: rt data: TBP>>=
	procedure :: clear_beams => rt_data_clear_beams
	<<RT data: procedures>>=
	subroutine rt_data_clear_beams (global)
	class(rt_data_t), intent(inout) :: global
	call global%beam_structure%final_sf ()
	call global%beam_structure%final_pol ()
	call global%beam_structure%final_mom ()
	end subroutine rt_data_clear_beams

	@ %def rt_data_clear_beams
	@
	\subsection{Initialization}
	Initialize runtime data. This defines special variables such as
	[[sqrts]], and should be done only for the instance that is actually
	global. Local copies will inherit the special variables.

	We link the global variable list to the process stack variable list,
	so the latter is always available (and kept global).
	<<RT data: rt data: TBP>>=
	procedure :: global_init => rt_data_global_init
	<<RT data: procedures>>=
	subroutine rt_data_global_init (global, paths, logfile)
	class(rt_data_t), intent(out), target :: global
	type(paths_t), intent(in), optional :: paths
	type(string_t), intent(in), optional :: logfile
	integer :: seed
	call global%os_data%init (paths)
	if (present (logfile)) then
	global%logfile = logfile
	else
	global%logfile = ""
	end if
	allocate (global%out_files)
	call system_clock (seed)
	call global%var_list%init_defaults (seed, paths)
	call global%init_pointer_variables ()
	call global%process_stack%init_var_list (global%var_list)
	end subroutine rt_data_global_init

	@ %def rt_data_global_init
	@
	\subsection{Local copies}
	This is done at compile time when a local copy of runtime data is
	needed: Link the variable list and initialize all derived parameters.
	This allows for synchronizing them with local variable changes without
	affecting global data.

	Also re-initialize pointer variables, so they point to local copies of
	their targets.
	<<RT data: rt data: TBP>>=
	procedure :: local_init => rt_data_local_init
	<<RT data: procedures>>=
	subroutine rt_data_local_init (local, global, env)
	class(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(in), target :: global
	integer, intent(in), optional :: env
	local%context => global
	call local%process_stack%link (global%process_stack)
	call local%process_stack%init_var_list (local%var_list)
	call local%process_stack%link_var_list (global%var_list)
	call local%var_list%append_string (var_str ("$model_name"), &
	var_str (""), intrinsic=.true.)
	call local%init_pointer_variables ()
	local%fallback_model => global%fallback_model
	local%os_data = global%os_data
	local%logfile = global%logfile
	call local%model_list%link (global%model_list)
	local%model => global%model
	if (associated (local%model)) then
	call local%model%link_var_list (local%var_list)
	end if
	if (allocated (global%event_callback)) then
	allocate (local%event_callback, source = global%event_callback)
	end if
	end subroutine rt_data_local_init

	@ %def rt_data_local_init
	@ These variables point to objects which get local copies:
	<<RT data: rt data: TBP>>=
	procedure :: init_pointer_variables => rt_data_init_pointer_variables
	<<RT data: procedures>>=
	subroutine rt_data_init_pointer_variables (local)
	class(rt_data_t), intent(inout), target :: local
	logical, target, save :: known = .true.
	call local%var_list%append_string_ptr (var_str ("$fc"), &
	local%os_data%fc, known, intrinsic=.true., &
	description=var_str('This string variable gives the ' // &
	'\ttt{Fortran} compiler used within \whizard. It can ' // &
	'only be accessed, not set by the user. (cf. also ' // &
	'\ttt{\$fcflags}, \ttt{\$fclibs})'))
	call local%var_list%append_string_ptr (var_str ("$fcflags"), &
	local%os_data%fcflags, known, intrinsic=.true., &
	description=var_str('This string variable gives the ' // &
	'compiler flags for the \ttt{Fortran} compiler used ' // &
	'within \whizard. It can only be accessed, not set by ' // &
	'the user. (cf. also \ttt{\$fc}, \ttt{\$fclibs})'))
	call local%var_list%append_string_ptr (var_str ("$fclibs"), &
	local%os_data%fclibs, known, intrinsic=.true., &
	description=var_str('This string variable gives the ' // &
	'linked libraries for the \ttt{Fortran} compiler used ' // &
	'within \whizard. It can only be accessed, not set by ' // &
	'the user. (cf. also \ttt{\$fc}, \ttt{\$fcflags})'))
	end subroutine rt_data_init_pointer_variables

	@ %def rt_data_init_pointer_variables
	@ This is done at execution time: Copy data, transfer pointers.
	[[local]] has intent(inout) because its local variable list has
	already been prepared by the previous routine.

	To be pedantic, the local pointers to model and library should point
	to the entries in the local copies. (However, as long as these are
	just shallow copies with identical content, this is actually
	irrelevant.)

	The process library and process stacks behave as global objects. The
	copies of the process library and process stacks should be shallow
	copies, so the contents stay identical. Since objects may be pushed
	on the stack in the local environment, upon restoring the global
	environment, we should reverse the assignment. Then the added stack
	elements will end up on the global stack. (This should be
	reconsidered in a parallel environment.)
	<<RT data: rt data: TBP>>=
	procedure :: activate => rt_data_activate
	<<RT data: procedures>>=
	subroutine rt_data_activate (local)
	class(rt_data_t), intent(inout), target :: local
	class(rt_data_t), pointer :: global
	global => local%context
	if (associated (global)) then
	local%lexer => global%lexer
	call global%copy_globals (local)
	local%os_data = global%os_data
	local%logfile = global%logfile
	if (associated (global%prclib)) then
	local%prclib => &
	local%prclib_stack%get_library_ptr (global%prclib%get_name ())
	end if
	call local%import_values ()
	call local%process_stack%link (global%process_stack)
	local%it_list = global%it_list
	local%beam_structure = global%beam_structure
	local%pn = global%pn
	if (allocated (local%sample_fmt)) deallocate (local%sample_fmt)
	if (allocated (global%sample_fmt)) then
	allocate (local%sample_fmt (size (global%sample_fmt)), &
	source = global%sample_fmt)
	end if
	local%out_files => global%out_files
	local%model => global%model
	local%model_is_copy = .false.
	else if (.not. associated (local%model)) then
	local%model => local%preload_model
	local%model_is_copy = .false.
	end if
	if (associated (local%model)) then
	call local%model%link_var_list (local%var_list)
	call local%var_list%set_string (var_str ("$model_name"), &
	local%model%get_name (), is_known = .true.)
	else
	call local%var_list%set_string (var_str ("$model_name"), &
	var_str (""), is_known = .false.)
	end if
	end subroutine rt_data_activate

	@ %def rt_data_activate
	@ Restore the previous state of data, without actually finalizing the local
	environment. We also clear the local process stack. Some local modifications
	(model list and process library stack) are communicated to the global context,
	if there is any.

	If the [[keep_local]] flag is set, we want to retain current settings in
	the local environment. In particular, we create an instance of the currently
	selected model (which thus becomes separated from the model library!).
	The local variables are also kept.
	<<RT data: rt data: TBP>>=
	procedure :: deactivate => rt_data_deactivate
	<<RT data: procedures>>=
	subroutine rt_data_deactivate (local, global, keep_local)
	class(rt_data_t), intent(inout), target :: local
	class(rt_data_t), intent(inout), optional, target :: global
	logical, intent(in), optional :: keep_local
	type(string_t) :: local_model, local_scheme
	logical :: same_model, delete
	delete = .true.; if (present (keep_local)) delete = .not. keep_local
	if (present (global)) then
	if (associated (global%model) .and. associated (local%model)) then
	local_model = local%model%get_name ()
	if (global%model%has_schemes ()) then
	local_scheme = local%model%get_scheme ()
	same_model = &
	global%model%matches (local_model, local_scheme)
	else
	same_model = global%model%matches (local_model)
	end if
	else
	same_model = .false.
	end if
	if (delete) then
	call local%process_stack%clear ()
	call local%unselect_model ()
	call local%unset_values ()
	else if (associated (local%model)) then
	call local%ensure_model_copy ()
	end if
	if (.not. same_model .and. associated (global%model)) then
	if (global%model%has_schemes ()) then
	call msg_message ("Restoring model '" // &
	char (global%model%get_name ()) // "', scheme '" // &
	char (global%model%get_scheme ()) // "'")
	else
	call msg_message ("Restoring model '" // &
	char (global%model%get_name ()) // "'")
	end if
	end if
	if (associated (global%model)) then
	call global%model%link_var_list (global%var_list)
	end if
	call global%restore_globals (local)
	else
	call local%unselect_model ()
	end if
	end subroutine rt_data_deactivate

	@ %def rt_data_deactivate
	@ This imports the global objects for which local modifications
	should be kept. Currently, this is only the process library stack.
	<<RT data: rt data: TBP>>=
	procedure :: copy_globals => rt_data_copy_globals
	<<RT data: procedures>>=
	subroutine rt_data_copy_globals (global, local)
	class(rt_data_t), intent(in) :: global
	class(rt_data_t), intent(inout) :: local
	local%prclib_stack = global%prclib_stack
	end subroutine rt_data_copy_globals

	@ %def rt_data_copy_globals
	@ This restores global objects for which local modifications
	should be kept. May also modify (remove) the local objects.
	<<RT data: rt data: TBP>>=
	procedure :: restore_globals => rt_data_restore_globals
	<<RT data: procedures>>=
	subroutine rt_data_restore_globals (global, local)
	class(rt_data_t), intent(inout) :: global
	class(rt_data_t), intent(inout) :: local
	global%prclib_stack = local%prclib_stack
	call local%handle_exports (global)
	end subroutine rt_data_restore_globals

	@ %def rt_data_restore_globals
	@
	\subsection{Exported objects}
	Exported objects are transferred to the global state when a local environment
	is closed. (For the top-level global data set, there is no effect.)

	The current implementation handles only the [[results]] object, which resolves
	to the local process stack. The stack elements are appended to the global
	stack without modification, the local stack becomes empty.

	Write names of objects to be exported:
	<<RT data: rt data: TBP>>=
	procedure :: write_exports => rt_data_write_exports
	<<RT data: procedures>>=
	subroutine rt_data_write_exports (rt_data, unit)
	class(rt_data_t), intent(in) :: rt_data
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	do i = 1, rt_data%get_n_export ()
	write (u, "(A)") char (rt_data%export(i))
	end do
	end subroutine rt_data_write_exports

	@ %def rt_data_write_exports
	@ The number of entries in the export list.
	<<RT data: rt data: TBP>>=
	procedure :: get_n_export => rt_data_get_n_export
	<<RT data: procedures>>=
	function rt_data_get_n_export (rt_data) result (n)
	class(rt_data_t), intent(in) :: rt_data
	integer :: n
	if (allocated (rt_data%export)) then
	n = size (rt_data%export)
	else
	n = 0
	end if
	end function rt_data_get_n_export

	@ %def rt_data_get_n_export
	@ Return a specific export
	@ Append new names to the export list. If a duplicate occurs, do not transfer
	it.
	<<RT data: rt data: TBP>>=
	procedure :: append_exports => rt_data_append_exports
	<<RT data: procedures>>=
	subroutine rt_data_append_exports (rt_data, export)
	class(rt_data_t), intent(inout) :: rt_data
	type(string_t), dimension(:), intent(in) :: export
	logical, dimension(:), allocatable :: mask
	type(string_t), dimension(:), allocatable :: tmp
	integer :: i, j, n
	if (.not. allocated (rt_data%export)) allocate (rt_data%export (0))
	n = size (rt_data%export)
	allocate (mask (size (export)), source=.false.)
	do i = 1, size (export)
	mask(i) = all (export(i) /= rt_data%export) &
	.and. all (export(i) /= export(:i-1))
	end do
	if (count (mask) > 0) then
	allocate (tmp (n + count (mask)))
	tmp(1:n) = rt_data%export(:)
	j = n
	do i = 1, size (export)
	if (mask(i)) then
	j = j + 1
	tmp(j) = export(i)
	end if
	end do
	call move_alloc (from=tmp, to=rt_data%export)
	end if
	end subroutine rt_data_append_exports

	@ %def rt_data_append_exports
	@ Transfer export-objects from the [[local]] rt data to the [[global]] rt
	data, as far as supported.
	<<RT data: rt data: TBP>>=
	procedure :: handle_exports => rt_data_handle_exports
	<<RT data: procedures>>=
	subroutine rt_data_handle_exports (local, global)
	class(rt_data_t), intent(inout), target :: local
	class(rt_data_t), intent(inout), target :: global
	type(string_t) :: export
	integer :: i
	if (local%get_n_export () > 0) then
	do i = 1, local%get_n_export ()
	export = local%export(i)
	select case (char (export))
	case ("results")
	call msg_message ("Exporting integration results &
	&to outer environment")
	call local%transfer_process_stack (global)
	case default
	call msg_bug ("handle exports: '" &
	// char (export) // "' unsupported")
	end select
	end do
	end if
	end subroutine rt_data_handle_exports

	@ %def rt_data_handle_exports
	@ Export the process stack. One-by-one, take the last process from the local
	stack and push it on the global stack. Also handle the corresponding result
	variables: append if the process did not exist yet in the global stack,
	otherwise update.

	TODO: result variables do not work that way yet, require initialization in the
	global variable list.
	<<RT data: rt data: TBP>>=
	procedure :: transfer_process_stack => rt_data_transfer_process_stack
	<<RT data: procedures>>=
	subroutine rt_data_transfer_process_stack (local, global)
	class(rt_data_t), intent(inout), target :: local
	class(rt_data_t), intent(inout), target :: global
	type(process_entry_t), pointer :: process
	type(string_t) :: process_id
	do
	call local%process_stack%pop_last (process)
	if (.not. associated (process)) exit
	process_id = process%get_id ()
	call global%process_stack%push (process)
	call global%process_stack%fill_result_vars (process_id)
	call global%process_stack%update_result_vars &
	(process_id, global%var_list)
	end do
	end subroutine rt_data_transfer_process_stack

	@ %def rt_data_transfer_process_stack
	@
	\subsection{Finalization}
	Finalizer for the variable list and the structure-function list.
	This is done only for the global RT dataset; local copies contain
	pointers to this and do not need a finalizer.
	<<RT data: rt data: TBP>>=
	procedure :: final => rt_data_global_final
	<<RT data: procedures>>=
	subroutine rt_data_global_final (global)
	class(rt_data_t), intent(inout) :: global
	call global%process_stack%final ()
	call global%prclib_stack%final ()
	call global%model_list%final ()
	call global%var_list%final (follow_link=.false.)
	if (associated (global%out_files)) then
	call file_list_final (global%out_files)
	deallocate (global%out_files)
	end if
	end subroutine rt_data_global_final

	@ %def rt_data_global_final
	@ The local copy needs a finalizer for the variable list, which consists
	of local copies. This finalizer is called only when the local
	environment is finally discarded. (Note that the process stack should
	already have been cleared after execution, which can occur many times
	for the same local environment.)
	<<RT data: rt data: TBP>>=
	procedure :: local_final => rt_data_local_final
	<<RT data: procedures>>=
	subroutine rt_data_local_final (local)
	class(rt_data_t), intent(inout) :: local
	call local%process_stack%clear ()
	call local%model_list%final ()
	call local%var_list%final (follow_link=.false.)
	end subroutine rt_data_local_final

	@ %def rt_data_local_final
	@
	\subsection{Model Management}
	Read a model, so it becomes available for activation. No variables or model
	copies, this is just initialization.

	If this is a local environment, the model will be automatically read into the
	global context.
	<<RT data: rt data: TBP>>=
	procedure :: read_model => rt_data_read_model
	<<RT data: procedures>>=
	subroutine rt_data_read_model (global, name, model, scheme)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	type(model_t), pointer, intent(out) :: model
	type(string_t) :: filename
	filename = name // ".mdl"
	call global%model_list%read_model &
	(name, filename, global%os_data, model, scheme)
	end subroutine rt_data_read_model

	@ %def rt_data_read_model
	@ Read a UFO model. Create it on the fly if necessary.
	<<RT data: rt data: TBP>>=
	procedure :: read_ufo_model => rt_data_read_ufo_model
	<<RT data: procedures>>=
	subroutine rt_data_read_ufo_model (global, name, model, ufo_path)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	type(model_t), pointer, intent(out) :: model
	type(string_t), intent(in), optional :: ufo_path
	type(string_t) :: filename
	filename = name // ".ufo.mdl"
	call global%model_list%read_model &
	(name, filename, global%os_data, model, ufo=.true., ufo_path=ufo_path)
	end subroutine rt_data_read_ufo_model

	@ %def rt_data_read_ufo_model
	@ Initialize the fallback model. This model is used
	whenever the current model does not describe all physical particles
	(hadrons, mainly). It is not supposed to be modified, and the pointer
	should remain linked to this model.
	<<RT data: rt data: TBP>>=
	procedure :: init_fallback_model => rt_data_init_fallback_model
	<<RT data: procedures>>=
	subroutine rt_data_init_fallback_model (global, name, filename)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name, filename
	call global%model_list%read_model &
	(name, filename, global%os_data, global%fallback_model)
	end subroutine rt_data_init_fallback_model

	@ %def rt_data_init_fallback_model
	@
	Activate a model: assign the current-model pointer and set the model name in
	the variable list. If necessary, read the model from file. Link the global
	variable list to the model variable list.
	<<RT data: rt data: TBP>>=
	procedure :: select_model => rt_data_select_model
	<<RT data: procedures>>=
	subroutine rt_data_select_model (global, name, scheme, ufo, ufo_path)
	class(rt_data_t), intent(inout), target :: global
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	logical, intent(in), optional :: ufo
	type(string_t), intent(in), optional :: ufo_path
	logical :: same_model, ufo_model
	ufo_model = .false.; if (present (ufo)) ufo_model = ufo
	if (associated (global%model)) then
	same_model = global%model%matches (name, scheme, ufo)
	else
	same_model = .false.
	end if
	if (.not. same_model) then
	global%model => global%model_list%get_model_ptr (name, scheme, ufo)
	if (.not. associated (global%model)) then
	if (ufo_model) then
	call global%read_ufo_model (name, global%model, ufo_path)
	else
	call global%read_model (name, global%model)
	end if
	global%model_is_copy = .false.
	else if (associated (global%context)) then
	global%model_is_copy = &
	global%model_list%model_exists (name, scheme, ufo, &
	follow_link=.false.)
	else
	global%model_is_copy = .false.
	end if
	end if
	if (associated (global%model)) then
	call global%model%link_var_list (global%var_list)
	call global%var_list%set_string (var_str ("$model_name"), &
	name, is_known = .true.)
	if (global%model%is_ufo_model ()) then
	call msg_message ("Switching to model '" // char (name) // "' " &
	// "(generated from UFO source)")
	else if (global%model%has_schemes ()) then
	call msg_message ("Switching to model '" // char (name) // "', " &
	// "scheme '" // char (global%model%get_scheme ()) // "'")
	else
	call msg_message ("Switching to model '" // char (name) // "'")
	end if
	else
	call global%var_list%set_string (var_str ("$model_name"), &
	var_str (""), is_known = .false.)
	end if
	end subroutine rt_data_select_model

	@ %def rt_data_select_model
	@
	Remove the model link. Do not unset the model name variable, because
	this may unset the variable in a parent [[rt_data]] object (via linked
	var lists).
	<<RT data: rt data: TBP>>=
	procedure :: unselect_model => rt_data_unselect_model
	<<RT data: procedures>>=
	subroutine rt_data_unselect_model (global)
	class(rt_data_t), intent(inout), target :: global
	if (associated (global%model)) then
	global%model => null ()
	global%model_is_copy = .false.
	end if
	end subroutine rt_data_unselect_model

	@ %def rt_data_unselect_model
	@
	Create a copy of the currently selected model and append it to the local model
	list. The model pointer is redirected to the copy.
	(Not applicable for the global model list, those models will be
	modified in-place.)
	<<RT data: rt data: TBP>>=
	procedure :: ensure_model_copy => rt_data_ensure_model_copy
	<<RT data: procedures>>=
	subroutine rt_data_ensure_model_copy (global)
	class(rt_data_t), intent(inout), target :: global
	if (associated (global%context)) then
	if (.not. global%model_is_copy) then
	call global%model_list%append_copy (global%model, global%model)
	global%model_is_copy = .true.
	call global%model%link_var_list (global%var_list)
	end if
	end if
	end subroutine rt_data_ensure_model_copy

	@ %def rt_data_ensure_model_copy
	@
	Modify a model variable. The update mechanism will ensure that the model
	parameter set remains consistent. This has to take place in a local copy
	of the current model. If there is none yet, create one.
	<<RT data: rt data: TBP>>=
	procedure :: model_set_real => rt_data_model_set_real
	<<RT data: procedures>>=
	subroutine rt_data_model_set_real (global, name, rval, verbose, pacified)
	class(rt_data_t), intent(inout), target :: global
	type(string_t), intent(in) :: name
	real(default), intent(in) :: rval
	logical, intent(in), optional :: verbose, pacified
	call global%ensure_model_copy ()
	call global%model%set_real (name, rval, verbose, pacified)
	end subroutine rt_data_model_set_real

	@ %def rt_data_model_set_real
	@
	Modify particle properties. This has to take place in a local copy
	of the current model. If there is none yet, create one.
	<<RT data: rt data: TBP>>=
	procedure :: modify_particle => rt_data_modify_particle
	<<RT data: procedures>>=
	subroutine rt_data_modify_particle &
	(global, pdg, polarized, stable, decay, &
	isotropic_decay, diagonal_decay, decay_helicity)
	class(rt_data_t), intent(inout), target :: global
	integer, intent(in) :: pdg
	logical, intent(in), optional :: polarized, stable
	logical, intent(in), optional :: isotropic_decay, diagonal_decay
	integer, intent(in), optional :: decay_helicity
	type(string_t), dimension(:), intent(in), optional :: decay
	call global%ensure_model_copy ()
	if (present (polarized)) then
	if (polarized) then
	call global%model%set_polarized (pdg)
	else
	call global%model%set_unpolarized (pdg)
	end if
	end if
	if (present (stable)) then
	if (stable) then
	call global%model%set_stable (pdg)
	else if (present (decay)) then
	call global%model%set_unstable &
	(pdg, decay, isotropic_decay, diagonal_decay, decay_helicity)
	else
	call msg_bug ("Setting particle unstable: missing decay processes")
	end if
	end if
	end subroutine rt_data_modify_particle

	@ %def rt_data_modify_particle
	@
	\subsection{Managing Variables}
	Return a pointer to the currently active variable list. If there is no model,
	this is the global variable list. If there is one, it is the model variable
	list, which should be linked to the former.
	<<RT data: rt data: TBP>>=
	procedure :: get_var_list_ptr => rt_data_get_var_list_ptr
	<<RT data: procedures>>=
	function rt_data_get_var_list_ptr (global) result (var_list)
	class(rt_data_t), intent(in), target :: global
	type(var_list_t), pointer :: var_list
	if (associated (global%model)) then
	var_list => global%model%get_var_list_ptr ()
	else
	var_list => global%var_list
	end if
	end function rt_data_get_var_list_ptr

	@ %def rt_data_get_var_list_ptr
	@ Initialize a local variable: append it to the current variable list. No
	initial value, yet.
	<<RT data: rt data: TBP>>=
	procedure :: append_log => rt_data_append_log
	procedure :: append_int => rt_data_append_int
	procedure :: append_real => rt_data_append_real
	procedure :: append_cmplx => rt_data_append_cmplx
	procedure :: append_subevt => rt_data_append_subevt
	procedure :: append_pdg_array => rt_data_append_pdg_array
	procedure :: append_string => rt_data_append_string
	<<RT data: procedures>>=
	subroutine rt_data_append_log (local, name, lval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	logical, intent(in), optional :: lval
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_log (name, lval, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_log

	subroutine rt_data_append_int (local, name, ival, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	integer, intent(in), optional :: ival
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_int (name, ival, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_int

	subroutine rt_data_append_real (local, name, rval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	real(default), intent(in), optional :: rval
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_real (name, rval, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_real

	subroutine rt_data_append_cmplx (local, name, cval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	complex(default), intent(in), optional :: cval
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_cmplx (name, cval, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_cmplx

	subroutine rt_data_append_subevt (local, name, pval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in), optional :: pval
	logical, intent(in) :: intrinsic, user
	call local%var_list%append_subevt (name, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_subevt

	subroutine rt_data_append_pdg_array (local, name, aval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in), optional :: aval
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_pdg_array (name, aval, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_pdg_array

	subroutine rt_data_append_string (local, name, sval, intrinsic, user)
	class(rt_data_t), intent(inout) :: local
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: sval
	logical, intent(in), optional :: intrinsic, user
	call local%var_list%append_string (name, sval, &
	intrinsic = intrinsic, user = user)
	end subroutine rt_data_append_string

	@ %def rt_data_append_log
	@ %def rt_data_append_int
	@ %def rt_data_append_real
	@ %def rt_data_append_cmplx
	@ %def rt_data_append_subevt
	@ %def rt_data_append_pdg_array
	@ %def rt_data_append_string
	@ Import values for all local variables, given a global context environment
	where these variables are defined.
	<<RT data: rt data: TBP>>=
	procedure :: import_values => rt_data_import_values
	<<RT data: procedures>>=
	subroutine rt_data_import_values (local)
	class(rt_data_t), intent(inout) :: local
	type(rt_data_t), pointer :: global
	global => local%context
	if (associated (global)) then
	call local%var_list%import (global%var_list)
	end if
	end subroutine rt_data_import_values

	@ %def rt_data_import_values
	@ Unset all variable values.
	<<RT data: rt data: TBP>>=
	procedure :: unset_values => rt_data_unset_values
	<<RT data: procedures>>=
	subroutine rt_data_unset_values (global)
	class(rt_data_t), intent(inout) :: global
	call global%var_list%undefine (follow_link=.false.)
	end subroutine rt_data_unset_values

	@ %def rt_data_unset_values
	@ Set a variable. (Not a model variable, these are handled separately.) We
	can assume that the variable has been initialized.
	<<RT data: rt data: TBP>>=
	procedure :: set_log => rt_data_set_log
	procedure :: set_int => rt_data_set_int
	procedure :: set_real => rt_data_set_real
	procedure :: set_cmplx => rt_data_set_cmplx
	procedure :: set_subevt => rt_data_set_subevt
	procedure :: set_pdg_array => rt_data_set_pdg_array
	procedure :: set_string => rt_data_set_string
	<<RT data: procedures>>=
	subroutine rt_data_set_log &
	(global, name, lval, is_known, force, verbose)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	logical, intent(in) :: lval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose
	call global%var_list%set_log (name, lval, is_known, &
	force=force, verbose=verbose)
	end subroutine rt_data_set_log

	subroutine rt_data_set_int &
	(global, name, ival, is_known, force, verbose)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	integer, intent(in) :: ival
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose
	call global%var_list%set_int (name, ival, is_known, &
	force=force, verbose=verbose)
	end subroutine rt_data_set_int

	subroutine rt_data_set_real &
	(global, name, rval, is_known, force, verbose, pacified)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	real(default), intent(in) :: rval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose, pacified
	call global%var_list%set_real (name, rval, is_known, &
	force=force, verbose=verbose, pacified=pacified)
	end subroutine rt_data_set_real

	subroutine rt_data_set_cmplx &
	(global, name, cval, is_known, force, verbose, pacified)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	complex(default), intent(in) :: cval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose, pacified
	call global%var_list%set_cmplx (name, cval, is_known, &
	force=force, verbose=verbose, pacified=pacified)
	end subroutine rt_data_set_cmplx

	subroutine rt_data_set_subevt &
	(global, name, pval, is_known, force, verbose)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	type(subevt_t), intent(in) :: pval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose
	call global%var_list%set_subevt (name, pval, is_known, &
	force=force, verbose=verbose)
	end subroutine rt_data_set_subevt

	subroutine rt_data_set_pdg_array &
	(global, name, aval, is_known, force, verbose)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	type(pdg_array_t), intent(in) :: aval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose
	call global%var_list%set_pdg_array (name, aval, is_known, &
	force=force, verbose=verbose)
	end subroutine rt_data_set_pdg_array

	subroutine rt_data_set_string &
	(global, name, sval, is_known, force, verbose)
	class(rt_data_t), intent(inout) :: global
	type(string_t), intent(in) :: name
	type(string_t), intent(in) :: sval
	logical, intent(in) :: is_known
	logical, intent(in), optional :: force, verbose
	call global%var_list%set_string (name, sval, is_known, &
	force=force, verbose=verbose)
	end subroutine rt_data_set_string

	@ %def rt_data_set_log
	@ %def rt_data_set_int
	@ %def rt_data_set_real
	@ %def rt_data_set_cmplx
	@ %def rt_data_set_subevt
	@ %def rt_data_set_pdg_array
	@ %def rt_data_set_string
	@ Return the value of a variable, assuming that the type is correct.
	<<RT data: rt data: TBP>>=
	procedure :: get_lval => rt_data_get_lval
	procedure :: get_ival => rt_data_get_ival
	procedure :: get_rval => rt_data_get_rval
	procedure :: get_cval => rt_data_get_cval
	procedure :: get_pval => rt_data_get_pval
	procedure :: get_aval => rt_data_get_aval
	procedure :: get_sval => rt_data_get_sval
	<<RT data: procedures>>=
	function rt_data_get_lval (global, name) result (lval)
	logical :: lval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	lval = var_list%get_lval (name)
	end function rt_data_get_lval

	function rt_data_get_ival (global, name) result (ival)
	integer :: ival
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	ival = var_list%get_ival (name)
	end function rt_data_get_ival

	function rt_data_get_rval (global, name) result (rval)
	real(default) :: rval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	rval = var_list%get_rval (name)
	end function rt_data_get_rval

	function rt_data_get_cval (global, name) result (cval)
	complex(default) :: cval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	cval = var_list%get_cval (name)
	end function rt_data_get_cval

	function rt_data_get_aval (global, name) result (aval)
	type(pdg_array_t) :: aval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	aval = var_list%get_aval (name)
	end function rt_data_get_aval

	function rt_data_get_pval (global, name) result (pval)
	type(subevt_t) :: pval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	pval = var_list%get_pval (name)
	end function rt_data_get_pval

	function rt_data_get_sval (global, name) result (sval)
	type(string_t) :: sval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	sval = var_list%get_sval (name)
	end function rt_data_get_sval

	@ %def rt_data_get_lval
	@ %def rt_data_get_ival
	@ %def rt_data_get_rval
	@ %def rt_data_get_cval
	@ %def rt_data_get_pval
	@ %def rt_data_get_aval
	@ %def rt_data_get_sval
	@ Return true if the variable exists in the global list.
	<<RT data: rt data: TBP>>=
	procedure :: contains => rt_data_contains
	<<RT data: procedures>>=
	function rt_data_contains (global, name) result (lval)
	logical :: lval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	lval = var_list%contains (name)
	end function rt_data_contains

	@ %def rt_data_contains
	@ Return true if the value of the variable is known.
	<<RT data: rt data: TBP>>=
	procedure :: is_known => rt_data_is_known
	<<RT data: procedures>>=
	function rt_data_is_known (global, name) result (lval)
	logical :: lval
	class(rt_data_t), intent(in), target :: global
	type(string_t), intent(in) :: name
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	lval = var_list%is_known (name)
	end function rt_data_is_known

	@ %def rt_data_is_known
	@
	\subsection{Further Content}
	Add a library (available via a pointer of type [[prclib_entry_t]]) to
	the stack and update the pointer and variable list to the current
	library. The pointer association of [[prclib_entry]] will be discarded.
	<<RT data: rt data: TBP>>=
	procedure :: add_prclib => rt_data_add_prclib
	<<RT data: procedures>>=
	subroutine rt_data_add_prclib (global, prclib_entry)
	class(rt_data_t), intent(inout) :: global
	type(prclib_entry_t), intent(inout), pointer :: prclib_entry
	call global%prclib_stack%push (prclib_entry)
	call global%update_prclib (global%prclib_stack%get_first_ptr ())
	end subroutine rt_data_add_prclib

	@ %def rt_data_add_prclib
	@ Given a pointer to a process library, make this the currently active
	library.
	<<RT data: rt data: TBP>>=
	procedure :: update_prclib => rt_data_update_prclib
	<<RT data: procedures>>=
	subroutine rt_data_update_prclib (global, lib)
	class(rt_data_t), intent(inout) :: global
	type(process_library_t), intent(in), target :: lib
	global%prclib => lib
	if (global%var_list%contains (&
	var_str ("$library_name"), follow_link = .false.)) then
	call global%var_list%set_string (var_str ("$library_name"), &
	global%prclib%get_name (), is_known=.true.)
	else
	call global%var_list%append_string ( &
	var_str ("$library_name"), global%prclib%get_name (), &
	intrinsic = .true.)
	end if
	end subroutine rt_data_update_prclib

	@ %def rt_data_update_prclib
	@
	\subsection{Miscellaneous}
	The helicity selection data are distributed among several parameters. Here,
	we collect them in a single record.
	<<RT data: rt data: TBP>>=
	procedure :: get_helicity_selection => rt_data_get_helicity_selection
	<<RT data: procedures>>=
	function rt_data_get_helicity_selection (rt_data) result (helicity_selection)
	class(rt_data_t), intent(in) :: rt_data
	type(helicity_selection_t) :: helicity_selection
	associate (var_list => rt_data%var_list)
	helicity_selection%active = var_list%get_lval (&
	var_str ("?helicity_selection_active"))
	if (helicity_selection%active) then
	helicity_selection%threshold = var_list%get_rval (&
	var_str ("helicity_selection_threshold"))
	helicity_selection%cutoff = var_list%get_ival (&
	var_str ("helicity_selection_cutoff"))
	end if
	end associate
	end function rt_data_get_helicity_selection

	@ %def rt_data_get_helicity_selection
	@ Show the beam setup: beam structure and relevant global variables.
	<<RT data: rt data: TBP>>=
	procedure :: show_beams => rt_data_show_beams
	<<RT data: procedures>>=
	subroutine rt_data_show_beams (rt_data, unit)
	class(rt_data_t), intent(in) :: rt_data
	integer, intent(in), optional :: unit
	type(string_t) :: s
	integer :: u
	u = given_output_unit (unit)
	associate (beams => rt_data%beam_structure, var_list => rt_data%var_list)
	call beams%write (u)
	if (.not. beams%asymmetric () .and. beams%get_n_beam () == 2) then
	write (u, "(2x,A," // FMT_19 // ",1x,'GeV')") "sqrts =", &
	var_list%get_rval (var_str ("sqrts"))
	end if
	if (beams%contains ("pdf_builtin")) then
	s = var_list%get_sval (var_str ("$pdf_builtin_set"))
	if (s /= "") then
	write (u, "(2x,A,1x,3A)") "PDF set =", '"', char (s), '"'
	else
	write (u, "(2x,A,1x,A)") "PDF set =", "[undefined]"
	end if
	end if
	if (beams%contains ("lhapdf")) then
	s = var_list%get_sval (var_str ("$lhapdf_dir"))
	if (s /= "") then
	write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"'
	end if
	s = var_list%get_sval (var_str ("$lhapdf_file"))
	if (s /= "") then
	write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"'
	write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
	var_list%get_ival (var_str ("lhapdf_member"))
	else
	write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]"
	end if
	end if
	if (beams%contains ("lhapdf_photon")) then
	s = var_list%get_sval (var_str ("$lhapdf_dir"))
	if (s /= "") then
	write (u, "(2x,A,1x,3A)") "LHAPDF dir =", '"', char (s), '"'
	end if
	s = var_list%get_sval (var_str ("$lhapdf_photon_file"))
	if (s /= "") then
	write (u, "(2x,A,1x,3A)") "LHAPDF file =", '"', char (s), '"'
	write (u, "(2x,A,1x,I0)") "LHAPDF member =", &
	var_list%get_ival (var_str ("lhapdf_member"))
	write (u, "(2x,A,1x,I0)") "LHAPDF scheme =", &
	var_list%get_ival (&
	var_str ("lhapdf_photon_scheme"))
	else
	write (u, "(2x,A,1x,A)") "LHAPDF file =", "[undefined]"
	end if
	end if
	if (beams%contains ("isr")) then
	write (u, "(2x,A," // FMT_19 // ")") "ISR alpha =", &
	var_list%get_rval (var_str ("isr_alpha"))
	write (u, "(2x,A," // FMT_19 // ")") "ISR Q max =", &
	var_list%get_rval (var_str ("isr_q_max"))
	write (u, "(2x,A," // FMT_19 // ")") "ISR mass =", &
	var_list%get_rval (var_str ("isr_mass"))
	write (u, "(2x,A,1x,I0)") "ISR order =", &
	var_list%get_ival (var_str ("isr_order"))
	write (u, "(2x,A,1x,L1)") "ISR recoil =", &
	var_list%get_lval (var_str ("?isr_recoil"))
	write (u, "(2x,A,1x,L1)") "ISR energy cons. =", &
	var_list%get_lval (var_str ("?isr_keep_energy"))
	end if
	if (beams%contains ("epa")) then
	write (u, "(2x,A," // FMT_19 // ")") "EPA alpha =", &
	var_list%get_rval (var_str ("epa_alpha"))
	write (u, "(2x,A," // FMT_19 // ")") "EPA x min =", &
	var_list%get_rval (var_str ("epa_x_min"))
	write (u, "(2x,A," // FMT_19 // ")") "EPA Q min =", &
	var_list%get_rval (var_str ("epa_q_min"))
	write (u, "(2x,A," // FMT_19 // ")") "EPA Q max =", &
	var_list%get_rval (var_str ("epa_q_max"))
	write (u, "(2x,A," // FMT_19 // ")") "EPA mass =", &
	var_list%get_rval (var_str ("epa_mass"))
	write (u, "(2x,A,1x,L1)") "EPA recoil =", &
	var_list%get_lval (var_str ("?epa_recoil"))
	write (u, "(2x,A,1x,L1)") "EPA energy cons. =", &
	var_list%get_lval (var_str ("?epa_keep_energy"))
	end if
	if (beams%contains ("ewa")) then
	write (u, "(2x,A," // FMT_19 // ")") "EWA x min =", &
	var_list%get_rval (var_str ("ewa_x_min"))
	write (u, "(2x,A," // FMT_19 // ")") "EWA Pt max =", &
	var_list%get_rval (var_str ("ewa_pt_max"))
	write (u, "(2x,A," // FMT_19 // ")") "EWA mass =", &
	var_list%get_rval (var_str ("ewa_mass"))
	write (u, "(2x,A,1x,L1)") "EWA recoil =", &
	var_list%get_lval (var_str ("?ewa_recoil"))
	write (u, "(2x,A,1x,L1)") "EWA energy cons. =", &
	var_list%get_lval (var_str ("ewa_keep_energy"))
	end if
	if (beams%contains ("circe1")) then
	write (u, "(2x,A,1x,I0)") "CIRCE1 version =", &
	var_list%get_ival (var_str ("circe1_ver"))
	write (u, "(2x,A,1x,I0)") "CIRCE1 revision =", &
	var_list%get_ival (var_str ("circe1_rev"))
	s = var_list%get_sval (var_str ("$circe1_acc"))
	write (u, "(2x,A,1x,A)") "CIRCE1 acceler. =", char (s)
	write (u, "(2x,A,1x,I0)") "CIRCE1 chattin. =", &
	var_list%get_ival (var_str ("circe1_chat"))
	write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 sqrts =", &
	var_list%get_rval (var_str ("circe1_sqrts"))
	write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 epsil. =", &
	var_list%get_rval (var_str ("circe1_eps"))
	write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 1 =", &
	var_list%get_lval (var_str ("?circe1_photon1"))
	write (u, "(2x,A,1x,L1)") "CIRCE1 phot. 2 =", &
	var_list%get_lval (var_str ("?circe1_photon2"))
	write (u, "(2x,A,1x,L1)") "CIRCE1 generat. =", &
	var_list%get_lval (var_str ("?circe1_generate"))
	write (u, "(2x,A,1x,L1)") "CIRCE1 mapping =", &
	var_list%get_lval (var_str ("?circe1_map"))
	write (u, "(2x,A," // FMT_19 // ")") "CIRCE1 map. slope =", &
	var_list%get_rval (var_str ("circe1_mapping_slope"))
	write (u, "(2x,A,1x,L1)") "CIRCE recoil photon =", &
	var_list%get_lval (var_str ("?circe1_with_radiation"))
	end if
	if (beams%contains ("circe2")) then
	s = var_list%get_sval (var_str ("$circe2_design"))
	write (u, "(2x,A,1x,A)") "CIRCE2 design =", char (s)
	s = var_list%get_sval (var_str ("$circe2_file"))
	write (u, "(2x,A,1x,A)") "CIRCE2 file =", char (s)
	write (u, "(2x,A,1x,L1)") "CIRCE2 polarized =", &
	var_list%get_lval (var_str ("?circe2_polarized"))
	end if
	if (beams%contains ("gaussian")) then
	write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 1 =", &
	var_list%get_rval (var_str ("gaussian_spread1"))
	write (u, "(2x,A,1x," // FMT_12 // ")") "Gaussian spread 2 =", &
	var_list%get_rval (var_str ("gaussian_spread2"))
	end if
	if (beams%contains ("beam_events")) then
	s = var_list%get_sval (var_str ("$beam_events_file"))
	write (u, "(2x,A,1x,A)") "Beam events file =", char (s)
	write (u, "(2x,A,1x,L1)") "Beam events EOF warn =", &
	var_list%get_lval (var_str ("?beam_events_warn_eof"))
	end if
	end associate
	end subroutine rt_data_show_beams

	@ %def rt_data_show_beams
	@ Return the collision energy as determined by the current beam
	settings. Without beam setup, this is the [[sqrts]] variable.

	If the value is meaningless for a setup, the function returns zero.
	<<RT data: rt data: TBP>>=
	procedure :: get_sqrts => rt_data_get_sqrts
	<<RT data: procedures>>=
	function rt_data_get_sqrts (rt_data) result (sqrts)
	class(rt_data_t), intent(in) :: rt_data
	real(default) :: sqrts
	sqrts = rt_data%var_list%get_rval (var_str ("sqrts"))
	end function rt_data_get_sqrts

	@ %def rt_data_get_sqrts
	@ For testing purposes, the [[rt_data_t]] contents can be pacified to
	suppress numerical fluctuations in (constant) test matrix elements.
	<<RT data: rt data: TBP>>=
	procedure :: pacify => rt_data_pacify
	<<RT data: procedures>>=
	subroutine rt_data_pacify (rt_data, efficiency_reset, error_reset)
	class(rt_data_t), intent(inout) :: rt_data
	logical, intent(in), optional :: efficiency_reset, error_reset
	type(process_entry_t), pointer :: process
	process => rt_data%process_stack%first
	do while (associated (process))
	call process%pacify (efficiency_reset, error_reset)
	process => process%next
	end do
	end subroutine rt_data_pacify

	@ %def rt_data_pacify
	@
	<<RT data: rt data: TBP>>=
	procedure :: set_event_callback => rt_data_set_event_callback
	<<RT data: procedures>>=
	subroutine rt_data_set_event_callback (global, callback)
	class(rt_data_t), intent(inout) :: global
	class(event_callback_t), intent(in) :: callback
	if (allocated (global%event_callback)) deallocate (global%event_callback)
	allocate (global%event_callback, source = callback)
	end subroutine rt_data_set_event_callback

	@ %def rt_data_set_event_callback
	@
	<<RT data: rt data: TBP>>=
	procedure :: has_event_callback => rt_data_has_event_callback
	procedure :: get_event_callback => rt_data_get_event_callback
	<<RT data: procedures>>=
	function rt_data_has_event_callback (global) result (flag)
	class(rt_data_t), intent(in) :: global
	logical :: flag
	flag = allocated (global%event_callback)
	end function rt_data_has_event_callback

	function rt_data_get_event_callback (global) result (callback)
	class(rt_data_t), intent(in) :: global
	class(event_callback_t), allocatable :: callback
	if (allocated (global%event_callback)) then
	allocate (callback, source = global%event_callback)
	end if
	end function rt_data_get_event_callback

	@ %def rt_data_has_event_callback
	@ %def rt_data_get_event_callback
	@ Force system-dependent objects to well-defined values. Some of the
	variables are locked and therefore must be addressed directly.

	This is, of course, only required for testing purposes. In principle,
	the [[real_specimen]] variables could be set to their values in
	[[rt_data_t]], but this depends on the precision again, so we set
	them to some dummy values.
	<<RT data: public>>=
	public :: fix_system_dependencies
	<<RT data: procedures>>=
	subroutine fix_system_dependencies (global)
	class(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list

	var_list => global%get_var_list_ptr ()
	call var_list%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true., force=.true.)
	call var_list%set_log (var_str ("?openmp_is_active"), &
	.false., is_known = .true., force=.true.)
	call var_list%set_int (var_str ("openmp_num_threads_default"), &
	1, is_known = .true., force=.true.)
	call var_list%set_int (var_str ("openmp_num_threads"), &
	1, is_known = .true., force=.true.)
	call var_list%set_int (var_str ("real_range"), &
	307, is_known = .true., force=.true.)
	call var_list%set_int (var_str ("real_precision"), &
	15, is_known = .true., force=.true.)
	call var_list%set_real (var_str ("real_epsilon"), &
	1.e-16_default, is_known = .true., force=.true.)
	call var_list%set_real (var_str ("real_tiny"), &
	1.e-300_default, is_known = .true., force=.true.)

	global%os_data%fc = "Fortran-compiler"
	global%os_data%fcflags = "Fortran-flags"
	global%os_data%fclibs = "Fortran-libs"

	end subroutine fix_system_dependencies

	@ %def fix_system_dependencies
	@
	<<RT data: public>>=
	public :: show_description_of_string
	<<RT data: procedures>>=
	subroutine show_description_of_string (string)
	type(string_t), intent(in) :: string
	type(rt_data_t), target :: global
	call global%global_init ()
	call global%show_description_of_string (string, ascii_output=.true.)
	end subroutine show_description_of_string

	@ %def show_description_of_string
	@
	<<RT data: public>>=
	public :: show_tex_descriptions
	<<RT data: procedures>>=
	subroutine show_tex_descriptions ()
	type(rt_data_t), target :: global
	call global%global_init ()
	call fix_system_dependencies (global)
	call global%set_int (var_str ("seed"), 0, is_known=.true.)
	call global%var_list%sort ()
	call global%write_var_descriptions ()
	end subroutine show_tex_descriptions

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

	module rt_data_ut
	use unit_tests
	use rt_data_uti

	<<Standard module head>>

	<<RT data: public test>>

	contains

	<<RT data: test driver>>

	end module rt_data_ut
	@ %def rt_data_ut
	@
	<<[[rt_data_uti.f90]]>>=
	<<File header>>

	module rt_data_uti

	<<Use kinds>>
	<<Use strings>>
	use format_defs, only: FMT_19
	use ifiles
	use lexers
	use parser
	use flavors
	use variables, only: var_list_t, var_entry_t, var_entry_init_int
	use eval_trees
	use models
	use prclib_stacks

	use rt_data

	<<Standard module head>>

	<<RT data: test declarations>>

	contains

	<<RT data: test auxiliary>>

	<<RT data: tests>>

	end module rt_data_uti
	@ %def rt_data_ut
	@ API: driver for the unit tests below.
	<<RT data: public test>>=
	public :: rt_data_test
	<<RT data: test driver>>=
	subroutine rt_data_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<RT data: execute tests>>
	end subroutine rt_data_test

	@ %def rt_data_test
	@
	\subsubsection{Initial content}
	@
	Display the RT data in the state just after (global) initialization.
	<<RT data: execute tests>>=
	call test (rt_data_1, "rt_data_1", &
	"initialize", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_1
	<<RT data: tests>>=
	subroutine rt_data_1 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: rt_data_1"
	write (u, "(A)") "* Purpose: initialize global runtime data"
	write (u, "(A)")

	call global%global_init (logfile = var_str ("rt_data.log"))
	call fix_system_dependencies (global)

	call global%set_int (var_str ("seed"), 0, is_known=.true.)

	call global%it_list%init ([2, 3], [5000, 20000])

	call global%write (u)

	call global%final ()

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

	end subroutine rt_data_1

	@ %def rt_data_1
	@
	\subsubsection{Fill values}
	Fill in empty slots in the runtime data block.
	<<RT data: execute tests>>=
	call test (rt_data_2, "rt_data_2", &
	"fill", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_2
	<<RT data: tests>>=
	subroutine rt_data_2 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(flavor_t), dimension(2) :: flv
	type(string_t) :: cut_expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: parse_tree

	write (u, "(A)") "* Test output: rt_data_2"
	write (u, "(A)") "* Purpose: initialize global runtime data &
	&and fill contents"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call fix_system_dependencies (global)

	call global%select_model (var_str ("Test"))

	call global%set_real (var_str ("sqrts"), &
	1000._default, is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)
	call flv%init ([25,25], global%model)

	call global%set_string (var_str ("$run_id"), &
	var_str ("run1"), is_known = .true.)
	call global%set_real (var_str ("luminosity"), &
	33._default, is_known = .true.)

	call syntax_pexpr_init ()
	cut_expr_text = "all Pt > 100 [s]"
	call ifile_append (ifile, cut_expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (parse_tree, stream, .true.)
	global%pn%cuts_lexpr => parse_tree%get_root_ptr ()

	allocate (global%sample_fmt (2))
	global%sample_fmt(1) = "foo_fmt"
	global%sample_fmt(2) = "bar_fmt"

	call global%write (u)

	call parse_tree_final (parse_tree)
	call stream_final (stream)
	call ifile_final (ifile)
	call syntax_pexpr_final ()

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine rt_data_2

	@ %def rt_data_2
	@
	\subsubsection{Save and restore}
	Set up a local runtime data block, change some contents, restore the
	global block.
	<<RT data: execute tests>>=
	call test (rt_data_3, "rt_data_3", &
	"save/restore", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_3
	<<RT data: tests>>=
	subroutine rt_data_3 (u)
	use event_base, only: event_callback_nop_t
	integer, intent(in) :: u
	type(rt_data_t), target :: global, local
	type(flavor_t), dimension(2) :: flv
	type(string_t) :: cut_expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: parse_tree
	type(prclib_entry_t), pointer :: lib
	type(event_callback_nop_t) :: event_callback_nop

	write (u, "(A)") "* Test output: rt_data_3"
	write (u, "(A)") "* Purpose: initialize global runtime data &
	&and fill contents;"
	write (u, "(A)") "* copy to local block and back"
	write (u, "(A)")

	write (u, "(A)") "* Init global data"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call fix_system_dependencies (global)

	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%select_model (var_str ("Test"))

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call flv%init ([25,25], global%model)

	call global%beam_structure%init_sf (flv%get_name (), [1])
	call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))

	call global%set_string (var_str ("$run_id"), &
	var_str ("run1"), is_known = .true.)
	call global%set_real (var_str ("luminosity"), &
	33._default, is_known = .true.)

	call syntax_pexpr_init ()
	cut_expr_text = "all Pt > 100 [s]"
	call ifile_append (ifile, cut_expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (parse_tree, stream, .true.)
	global%pn%cuts_lexpr => parse_tree%get_root_ptr ()

	allocate (global%sample_fmt (2))
	global%sample_fmt(1) = "foo_fmt"
	global%sample_fmt(2) = "bar_fmt"

	allocate (lib)
	call lib%init (var_str ("library_1"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Init and modify local data"
	write (u, "(A)")

	call local%local_init (global)
	call local%append_string (var_str ("$integration_method"), intrinsic=.true.)
	call local%append_string (var_str ("$phs_method"), intrinsic=.true.)

	call local%activate ()

	write (u, "(1x,A,L1)") "model associated = ", associated (local%model)
	write (u, "(1x,A,L1)") "library associated = ", associated (local%prclib)
	write (u, *)

	call local%model_set_real (var_str ("ms"), 150._default)
	call local%set_string (var_str ("$integration_method"), &
	var_str ("midpoint"), is_known = .true.)
	call local%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)

	local%os_data%fc = "Local compiler"

	allocate (lib)
	call lib%init (var_str ("library_2"))
	call local%add_prclib (lib)

	call local%set_event_callback (event_callback_nop)

	call local%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Restore global data"
	write (u, "(A)")

	call local%deactivate (global)

	write (u, "(1x,A,L1)") "model associated = ", associated (global%model)
	write (u, "(1x,A,L1)") "library associated = ", associated (global%prclib)
	write (u, *)

	call global%write (u)

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

	call parse_tree_final (parse_tree)
	call stream_final (stream)
	call ifile_final (ifile)
	call syntax_pexpr_final ()

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine rt_data_3

	@ %def rt_data_3
	@
	\subsubsection{Show variables}
	Display selected variables in the global record.
	<<RT data: execute tests>>=
	call test (rt_data_4, "rt_data_4", &
	"show variables", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_4
	<<RT data: tests>>=
	subroutine rt_data_4 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	type(string_t), dimension(0) :: empty_string_array

	write (u, "(A)") "* Test output: rt_data_4"
	write (u, "(A)") "* Purpose: display selected variables"
	write (u, "(A)")

	call global%global_init ()

	write (u, "(A)") "* No variables:"
	write (u, "(A)")

	call global%write_vars (u, empty_string_array)

	write (u, "(A)") "* Two variables:"
	write (u, "(A)")

	call global%write_vars (u, &
	[var_str ("?unweighted"), var_str ("$phs_method")])

	write (u, "(A)")
	write (u, "(A)") "* Display whole record with selected variables"
	write (u, "(A)")

	call global%write (u, &
	vars = [var_str ("?unweighted"), var_str ("$phs_method")])

	call global%final ()

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

	end subroutine rt_data_4

	@ %def rt_data_4
	@
	\subsubsection{Show parts}
	Display only selected parts in the state just after (global) initialization.
	<<RT data: execute tests>>=
	call test (rt_data_5, "rt_data_5", &
	"show parts", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_5
	<<RT data: tests>>=
	subroutine rt_data_5 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: rt_data_5"
	write (u, "(A)") "* Purpose: display parts of rt data"
	write (u, "(A)")

	call global%global_init ()
	call global%write_libraries (u)

	write (u, "(A)")

	call global%write_beams (u)

	write (u, "(A)")

	call global%write_process_stack (u)

	call global%final ()

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

	end subroutine rt_data_5

	@ %def rt_data_5
	@
	\subsubsection{Local Model}
	Locally modify a model and restore the global one. We need an auxiliary
	function to determine the status of a model particle:
	<<RT data: test auxiliary>>=
	function is_stable (pdg, global) result (flag)
	integer, intent(in) :: pdg
	type(rt_data_t), intent(in) :: global
	logical :: flag
	type(flavor_t) :: flv
	call flv%init (pdg, global%model)
	flag = flv%is_stable ()
	end function is_stable

	function is_polarized (pdg, global) result (flag)
	integer, intent(in) :: pdg
	type(rt_data_t), intent(in) :: global
	logical :: flag
	type(flavor_t) :: flv
	call flv%init (pdg, global%model)
	flag = flv%is_polarized ()
	end function is_polarized

	@ %def is_stable is_polarized
	<<RT data: execute tests>>=
	call test (rt_data_6, "rt_data_6", &
	"local model", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_6
	<<RT data: tests>>=
	subroutine rt_data_6 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global, local
	type(var_list_t), pointer :: model_vars
	type(string_t) :: var_name

	write (u, "(A)") "* Test output: rt_data_6"
	write (u, "(A)") "* Purpose: apply and keep local modifications to model"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%select_model (var_str ("Test"))

	write (u, "(A)") "* Original model"
	write (u, "(A)")

	call global%write_model_list (u)
	write (u, *)
	write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
	write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)

	write (u, *)

	var_name = "ff"

	write (u, "(A)", advance="no") "Global model variable: "
	model_vars => global%model%get_var_list_ptr ()
	call model_vars%write_var (var_name, u)

	write (u, "(A)")
	write (u, "(A)") "* Apply local modifications: unstable"
	write (u, "(A)")

	call local%local_init (global)
	call local%activate ()

	call local%model_set_real (var_name, 0.4_default)
	call local%modify_particle (25, stable = .false., decay = [var_str ("d1")])
	call local%modify_particle (6, stable = .false., &
	decay = [var_str ("f1")], isotropic_decay = .true.)
	call local%modify_particle (-6, stable = .false., &
	decay = [var_str ("f2"), var_str ("f3")], diagonal_decay = .true.)

	call local%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Further modifications"
	write (u, "(A)")

	call local%modify_particle (6, stable = .false., &
	decay = [var_str ("f1")], &
	diagonal_decay = .true., isotropic_decay = .false.)
	call local%modify_particle (-6, stable = .false., &
	decay = [var_str ("f2"), var_str ("f3")], &
	diagonal_decay = .false., isotropic_decay = .true.)
	call local%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Further modifications: f stable but polarized"
	write (u, "(A)")

	call local%modify_particle (6, stable = .true., polarized = .true.)
	call local%modify_particle (-6, stable = .true.)
	call local%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Global model"
	write (u, "(A)")

	call global%model%write (u)
	write (u, *)
	write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
	write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)

	write (u, "(A)")
	write (u, "(A)") "* Local model"
	write (u, "(A)")

	call local%model%write (u)
	write (u, *)
	write (u, "(A,L1)") "s is stable = ", is_stable (25, local)
	write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local)

	write (u, *)

	write (u, "(A)", advance="no") "Global model variable: "
	model_vars => global%model%get_var_list_ptr ()
	call model_vars%write_var (var_name, u)

	write (u, "(A)", advance="no") "Local model variable: "
	associate (model_var_list_ptr => local%model%get_var_list_ptr())
	call model_var_list_ptr%write_var (var_name, u)
	end associate

	write (u, "(A)")
	write (u, "(A)") "* Restore global"

	call local%deactivate (global, keep_local = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Global model"
	write (u, "(A)")

	call global%model%write (u)
	write (u, *)
	write (u, "(A,L1)") "s is stable = ", is_stable (25, global)
	write (u, "(A,L1)") "f is polarized = ", is_polarized (6, global)

	write (u, "(A)")
	write (u, "(A)") "* Local model"
	write (u, "(A)")

	call local%model%write (u)
	write (u, *)
	write (u, "(A,L1)") "s is stable = ", is_stable (25, local)
	write (u, "(A,L1)") "f is polarized = ", is_polarized (6, local)

	write (u, *)

	write (u, "(A)", advance="no") "Global model variable: "
	model_vars => global%model%get_var_list_ptr ()
	call model_vars%write_var (var_name, u)

	write (u, "(A)", advance="no") "Local model variable: "
	associate (model_var_list_ptr => local%model%get_var_list_ptr())
	call model_var_list_ptr%write_var (var_name, u)
	end associate

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

	call local%model%final ()
	deallocate (local%model)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine rt_data_6

	@ %def rt_data_6
	@
	\subsubsection{Result variables}
	Initialize result variables and check that they are accessible via the
	global variable list.
	<<RT data: execute tests>>=
	call test (rt_data_7, "rt_data_7", &
	"result variables", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_7
	<<RT data: tests>>=
	subroutine rt_data_7 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: rt_data_7"
	write (u, "(A)") "* Purpose: set and access result variables"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process variables"
	write (u, "(A)")

	call global%global_init ()
	call global%process_stack%init_result_vars (var_str ("testproc"))

	call global%var_list%write_var (&
	var_str ("integral(testproc)"), u, defined=.true.)
	call global%var_list%write_var (&
	var_str ("error(testproc)"), u, defined=.true.)

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

	call global%final ()

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

	end subroutine rt_data_7

	@ %def rt_data_7
	@
	\subsubsection{Beam energy}
	If beam parameters are set, the variable [[sqrts]] is not necessarily
	the collision energy. The method [[get_sqrts]] fetches the correct value.
	<<RT data: execute tests>>=
	call test (rt_data_8, "rt_data_8", &
	"beam energy", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_8
	<<RT data: tests>>=
	subroutine rt_data_8 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: rt_data_8"
	write (u, "(A)") "* Purpose: get correct collision energy"
	write (u, "(A)")

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

	call global%global_init ()

	write (u, "(A)") "* Set sqrts"
	write (u, "(A)")

	call global%set_real (var_str ("sqrts"), &
	1000._default, is_known = .true.)
	write (u, "(1x,A," // FMT_19 // ")") "sqrts =", global%get_sqrts ()

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

	call global%final ()

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

	end subroutine rt_data_8

	@ %def rt_data_8
	@
	\subsubsection{Local variable modifications}
	<<RT data: execute tests>>=
	call test (rt_data_9, "rt_data_9", &
	"local variables", &
	u, results)
	<<RT data: test declarations>>=
	public :: rt_data_9
	<<RT data: tests>>=
	subroutine rt_data_9 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global, local
	type(var_list_t), pointer :: var_list

	write (u, "(A)") "* Test output: rt_data_9"
	write (u, "(A)") "* Purpose: handle local variables"
	write (u, "(A)")

	call syntax_model_file_init ()

	write (u, "(A)") "* Initialize global record and set some variables"
	write (u, "(A)")

	call global%global_init ()
	call global%select_model (var_str ("Test"))

	call global%set_real (var_str ("sqrts"), 17._default, is_known = .true.)
	call global%set_real (var_str ("luminosity"), 2._default, is_known = .true.)
	call global%model_set_real (var_str ("ff"), 0.5_default)
	call global%model_set_real (var_str ("gy"), 1.2_default)

	var_list => global%get_var_list_ptr ()

	call var_list%write_var (var_str ("sqrts"), u, defined=.true.)
	call var_list%write_var (var_str ("luminosity"), u, defined=.true.)
	call var_list%write_var (var_str ("ff"), u, defined=.true.)
	call var_list%write_var (var_str ("gy"), u, defined=.true.)
	call var_list%write_var (var_str ("mf"), u, defined=.true.)
	call var_list%write_var (var_str ("x"), u, defined=.true.)

	write (u, "(A)")

	write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
	global%get_rval (var_str ("sqrts"))
	write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
	global%get_rval (var_str ("luminosity"))
	write (u, "(1x,A,1x,F5.2)") "ff = ", &
	global%get_rval (var_str ("ff"))
	write (u, "(1x,A,1x,F5.2)") "gy = ", &
	global%get_rval (var_str ("gy"))
	write (u, "(1x,A,1x,F5.2)") "mf = ", &
	global%get_rval (var_str ("mf"))
	write (u, "(1x,A,1x,F5.2)") "x = ", &
	global%get_rval (var_str ("x"))

	write (u, "(A)")
	write (u, "(A)") "* Create local record with local variables"
	write (u, "(A)")

	call local%local_init (global)

	call local%append_real (var_str ("luminosity"), intrinsic = .true.)
	call local%append_real (var_str ("x"), user = .true.)

	call local%activate ()

	var_list => local%get_var_list_ptr ()

	call var_list%write_var (var_str ("sqrts"), u)
	call var_list%write_var (var_str ("luminosity"), u)
	call var_list%write_var (var_str ("ff"), u)
	call var_list%write_var (var_str ("gy"), u)
	call var_list%write_var (var_str ("mf"), u)
	call var_list%write_var (var_str ("x"), u, defined=.true.)

	write (u, "(A)")

	write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
	local%get_rval (var_str ("sqrts"))
	write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
	local%get_rval (var_str ("luminosity"))
	write (u, "(1x,A,1x,F5.2)") "ff = ", &
	local%get_rval (var_str ("ff"))
	write (u, "(1x,A,1x,F5.2)") "gy = ", &
	local%get_rval (var_str ("gy"))
	write (u, "(1x,A,1x,F5.2)") "mf = ", &
	local%get_rval (var_str ("mf"))
	write (u, "(1x,A,1x,F5.2)") "x = ", &
	local%get_rval (var_str ("x"))

	write (u, "(A)")
	write (u, "(A)") "* Modify some local variables"
	write (u, "(A)")

	call local%set_real (var_str ("luminosity"), 42._default, is_known=.true.)
	call local%set_real (var_str ("x"), 6.66_default, is_known=.true.)
	call local%model_set_real (var_str ("ff"), 0.7_default)

	var_list => local%get_var_list_ptr ()

	call var_list%write_var (var_str ("sqrts"), u)
	call var_list%write_var (var_str ("luminosity"), u)
	call var_list%write_var (var_str ("ff"), u)
	call var_list%write_var (var_str ("gy"), u)
	call var_list%write_var (var_str ("mf"), u)
	call var_list%write_var (var_str ("x"), u, defined=.true.)

	write (u, "(A)")

	write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
	local%get_rval (var_str ("sqrts"))
	write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
	local%get_rval (var_str ("luminosity"))
	write (u, "(1x,A,1x,F5.2)") "ff = ", &
	local%get_rval (var_str ("ff"))
	write (u, "(1x,A,1x,F5.2)") "gy = ", &
	local%get_rval (var_str ("gy"))
	write (u, "(1x,A,1x,F5.2)") "mf = ", &
	local%get_rval (var_str ("mf"))
	write (u, "(1x,A,1x,F5.2)") "x = ", &
	local%get_rval (var_str ("x"))

	write (u, "(A)")
	write (u, "(A)") "* Restore globals"
	write (u, "(A)")

	call local%deactivate (global)

	var_list => global%get_var_list_ptr ()

	call var_list%write_var (var_str ("sqrts"), u)
	call var_list%write_var (var_str ("luminosity"), u)
	call var_list%write_var (var_str ("ff"), u)
	call var_list%write_var (var_str ("gy"), u)
	call var_list%write_var (var_str ("mf"), u)
	call var_list%write_var (var_str ("x"), u, defined=.true.)

	write (u, "(A)")

	write (u, "(1x,A,1x,F5.2)") "sqrts = ", &
	global%get_rval (var_str ("sqrts"))
	write (u, "(1x,A,1x,F5.2)") "luminosity = ", &
	global%get_rval (var_str ("luminosity"))
	write (u, "(1x,A,1x,F5.2)") "ff = ", &
	global%get_rval (var_str ("ff"))
	write (u, "(1x,A,1x,F5.2)") "gy = ", &
	global%get_rval (var_str ("gy"))
	write (u, "(1x,A,1x,F5.2)") "mf = ", &
	global%get_rval (var_str ("mf"))
	write (u, "(1x,A,1x,F5.2)") "x = ", &
	global%get_rval (var_str ("x"))

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

	call local%local_final ()

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine rt_data_9

	@ %def rt_data_9
	@
	\subsubsection{Descriptions}
	<<RT data: execute tests>>=
	call test(rt_data_10, "rt_data_10", &
	"descriptions", u, results)
	<<RT data: test declarations>>=
	public :: rt_data_10
	<<RT data: tests>>=
	subroutine rt_data_10 (u)
	integer, intent(in) :: u
	type(rt_data_t) :: global
	! type(var_list_t) :: var_list
	write (u, "(A)") "* Test output: rt_data_10"
	write (u, "(A)") "* Purpose: display descriptions"
	write (u, "(A)")

	call global%var_list%append_real (var_str ("sqrts"), &
	intrinsic=.true., &
	description=var_str ('Real variable in order to set the center-of-mass ' // &
	'energy for the collisions.'))
	call global%var_list%append_real (var_str ("luminosity"), 0._default, &
	intrinsic=.true., &
	description=var_str ('This specifier \ttt{luminosity = {\em ' // &
	'<num>}} sets the integrated luminosity (in inverse femtobarns, ' // &
	'fb${}^{-1}$) for the event generation of the processes in the ' // &
	'\sindarin\ input files.'))
	call global%var_list%append_int (var_str ("seed"), 1234, &
	intrinsic=.true., &
	description=var_str ('Integer variable \ttt{seed = {\em <num>}} ' // &
	'that allows to set a specific random seed \ttt{num}.'))
	call global%var_list%append_string (var_str ("$method"), var_str ("omega"), &
	intrinsic=.true., &
	description=var_str ('This string variable specifies the method ' // &
	'for the matrix elements to be used in the evaluation.'))
	call global%var_list%append_log (var_str ("?read_color_factors"), .true., &
	intrinsic=.true., &
	description=var_str ('This flag decides whether to read QCD ' // &
	'color factors from the matrix element provided by each method, ' // &
	'or to try and calculate the color factors in \whizard\ internally.'))

	call global%var_list%sort ()

	call global%write_var_descriptions (u)
	call global%final ()

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

	@ %def rt_data_10
	@
	\subsubsection{Export objects}
	Export objects are variables or other data that should be copied or otherwise
	applied to corresponding objects in the outer scope.

	We test appending and retrieval for the export list.
	<<RT data: execute tests>>=
	call test(rt_data_11, "rt_data_11", &
	"export objects", u, results)
	<<RT data: test declarations>>=
	public :: rt_data_11
	<<RT data: tests>>=
	subroutine rt_data_11 (u)
	integer, intent(in) :: u
	type(rt_data_t) :: global
	type(string_t), dimension(:), allocatable :: exports
	integer :: i

	write (u, "(A)") "* Test output: rt_data_11"
	write (u, "(A)") "* Purpose: handle export object list"
	write (u, "(A)")

	write (u, "(A)") "* Empty export list"
	write (u, "(A)")

	call global%write_exports (u)

	write (u, "(A)") "* Add an entry"
	write (u, "(A)")

	allocate (exports (1))
	exports(1) = var_str ("results")
	do i = 1, size (exports)
	write (u, "('+ ',A)") char (exports(i))
	end do
	write (u, *)

	call global%append_exports (exports)
	call global%write_exports (u)

	write (u, "(A)")
	write (u, "(A)") "* Add more entries, including doubler"
	write (u, "(A)")

	deallocate (exports)
	allocate (exports (3))
	exports(1) = var_str ("foo")
	exports(2) = var_str ("results")
	exports(3) = var_str ("bar")
	do i = 1, size (exports)
	write (u, "('+ ',A)") char (exports(i))
	end do
	write (u, *)

	call global%append_exports (exports)
	call global%write_exports (u)

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

	call global%final ()

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

	@ %def rt_data_11
	@
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Select implementations}
	For abstract types (process core, integrator, phase space, etc.), we need a
	way to dynamically select a concrete type, using either data given by the user
	or a previous selection of a concrete type. This is done by subroutines in
	the current module.

	We would like to put this in the [[me_methods]] folder but it also
	depends on [[gosam]] and [[openloops]], so it is unclear where to put
	it.
	<<[[dispatch_me_methods.f90]]>>=
	<<File header>>

	module dispatch_me_methods

	<<Use strings>>
	<<Use debug>>
	use physics_defs, only: BORN
	use diagnostics
	use sm_qcd
	use variables, only: var_list_t
	use models
	use model_data

	use prc_core_def
	use prc_core
	use prc_test_core
	use prc_template_me
	use prc_test
	use prc_omega
	use prc_external
	use prc_gosam
	use prc_openloops
	use prc_recola
	use prc_threshold

	<<Standard module head>>

	<<Dispatch me methods: public>>

	contains

	<<Dispatch me methods: procedures>>

	end module dispatch_me_methods
	@ %def dispatch_me_methods
	@
	\subsection{Process Core Definition}
	The [[prc_core_def_t]] abstract type can be instantiated by providing a
	[[$method]] string variable.
	<<Dispatch me methods: public>>=
	public :: dispatch_core_def
	<<Dispatch me methods: procedures>>=
	subroutine dispatch_core_def (core_def, prt_in, prt_out, &
	model, var_list, id, nlo_type, method)
	class(prc_core_def_t), allocatable, intent(out) :: core_def
	type(string_t), dimension(:), intent(in) :: prt_in
	type(string_t), dimension(:), intent(in) :: prt_out
	type(model_t), pointer, intent(in) :: model
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in), optional :: id
	integer, intent(in), optional :: nlo_type
	type(string_t), intent(in), optional :: method
	type(string_t) :: model_name, meth
	type(string_t) :: ufo_path
	type(string_t) :: restrictions
	logical :: ufo
	logical :: cms_scheme
	logical :: openmp_support
	logical :: report_progress
	logical :: diags, diags_color
	logical :: write_phs_output
	type(string_t) :: extra_options, correction_type
	integer :: nlo
	integer :: alpha_power
	integer :: alphas_power
	if (present (method)) then
	meth = method
	else
	meth = var_list%get_sval (var_str ("$method"))
	end if
	if (debug_on) call msg_debug2 (D_CORE, "dispatch_core_def")
	if (associated (model)) then
	model_name = model%get_name ()
	cms_scheme = model%get_scheme () == "Complex_Mass_Scheme"
	ufo = model%is_ufo_model ()
	ufo_path = model%get_ufo_path ()
	else
	model_name = ""
	cms_scheme = .false.
	ufo = .false.
	end if
	restrictions = var_list%get_sval (&
	var_str ("$restrictions"))
	diags = var_list%get_lval (&
	var_str ("?vis_diags"))
	diags_color = var_list%get_lval (&
	var_str ("?vis_diags_color"))
	openmp_support = var_list%get_lval (&
	var_str ("?omega_openmp"))
	report_progress = var_list%get_lval (&
	var_str ("?report_progress"))
	write_phs_output = var_list%get_lval (&
	var_str ("?omega_write_phs_output"))
	extra_options = var_list%get_sval (&
	var_str ("$omega_flags"))
	nlo = BORN; if (present (nlo_type)) nlo = nlo_type
	alpha_power = var_list%get_ival (var_str ("alpha_power"))
	alphas_power = var_list%get_ival (var_str ("alphas_power"))
	correction_type = var_list%get_sval (var_str ("$nlo_correction_type"))
	if (debug_on) call msg_debug2 (D_CORE, "dispatching core method: ", meth)
	select case (char (meth))
	case ("unit_test")
	allocate (prc_test_def_t :: core_def)
	select type (core_def)
	type is (prc_test_def_t)
	call core_def%init (model_name, prt_in, prt_out)
	end select
	case ("template")
	allocate (template_me_def_t :: core_def)
	select type (core_def)
	type is (template_me_def_t)
	call core_def%init (model, prt_in, prt_out, unity = .false.)
	end select
	case ("template_unity")
	allocate (template_me_def_t :: core_def)
	select type (core_def)
	type is (template_me_def_t)
	call core_def%init (model, prt_in, prt_out, unity = .true.)
	end select
	case ("omega")
	allocate (omega_def_t :: core_def)
	select type (core_def)
	type is (omega_def_t)
	call core_def%init (model_name, prt_in, prt_out, &
	.false., ufo, ufo_path, &
	restrictions, cms_scheme, &
	openmp_support, report_progress, write_phs_output, &
	extra_options, diags, diags_color)
	end select
	case ("ovm")
	allocate (omega_def_t :: core_def)
	select type (core_def)
	type is (omega_def_t)
	call core_def%init (model_name, prt_in, prt_out, &
	.true., .false., var_str (""), &
	restrictions, cms_scheme, &
	openmp_support, report_progress, write_phs_output, &
	extra_options, diags, diags_color)
	end select
	case ("gosam")
	allocate (gosam_def_t :: core_def)
	select type (core_def)
	type is (gosam_def_t)
	if (present (id)) then
	call core_def%init (id, model_name, prt_in, &
	prt_out, nlo, restrictions, var_list)
	else
	call msg_fatal ("Dispatch GoSam def: No id!")
	end if
	end select
	case ("openloops")
	allocate (openloops_def_t :: core_def)
	select type (core_def)
	type is (openloops_def_t)
	if (present (id)) then
	call core_def%init (id, model_name, prt_in, &
	prt_out, nlo, restrictions, var_list)
	else
	call msg_fatal ("Dispatch OpenLoops def: No id!")
	end if
	end select
	case ("recola")
	call abort_if_recola_not_active ()
	allocate (recola_def_t :: core_def)
	select type (core_def)
	type is (recola_def_t)
	if (present (id)) then
	call core_def%init (id, model_name, prt_in, prt_out, &
	nlo, alpha_power, alphas_power, correction_type, &
	restrictions)
	else
	call msg_fatal ("Dispatch RECOLA def: No id!")
	end if
	end select
	case ("dummy")
	allocate (prc_external_test_def_t :: core_def)
	select type (core_def)
	type is (prc_external_test_def_t)
	if (present (id)) then
	call core_def%init (id, model_name, prt_in, prt_out)
	else
	call msg_fatal ("Dispatch User-Defined Test def: No id!")
	end if
	end select
	case ("threshold")
	allocate (threshold_def_t :: core_def)
	select type (core_def)
	type is (threshold_def_t)
	if (present (id)) then
	call core_def%init (id, model_name, prt_in, prt_out, &
	nlo, restrictions)
	else
	call msg_fatal ("Dispatch Threshold def: No id!")
	end if
	end select
	case default
	call msg_fatal ("Process configuration: method '" &
	// char (meth) // "' not implemented")
	end select
	end subroutine dispatch_core_def

	@ %def dispatch_core_def
	@
	\subsection{Process core allocation}
	Here we allocate an object of abstract type [[prc_core_t]] with a concrete
	type that matches a process definition. The [[prc_omega_t]] extension
	will require the current parameter set, so we take the opportunity to
	grab it from the model.
	<<Dispatch me methods: public>>=
	public :: dispatch_core
	<<Dispatch me methods: procedures>>=
	subroutine dispatch_core (core, core_def, model, &
	helicity_selection, qcd, use_color_factors, has_beam_pol)
	class(prc_core_t), allocatable, intent(inout) :: core
	class(prc_core_def_t), intent(in) :: core_def
	class(model_data_t), intent(in), target, optional :: model
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	type(qcd_t), intent(in), optional :: qcd
	logical, intent(in), optional :: use_color_factors
	logical, intent(in), optional :: has_beam_pol
	select type (core_def)
	type is (prc_test_def_t)
	allocate (test_t :: core)
	type is (template_me_def_t)
	allocate (prc_template_me_t :: core)
	select type (core)
	type is (prc_template_me_t)
	call core%set_parameters (model)
	end select
	class is (omega_def_t)
	if (.not. allocated (core)) allocate (prc_omega_t :: core)
	select type (core)
	type is (prc_omega_t)
	call core%set_parameters (model, &
	helicity_selection, qcd, use_color_factors)
	end select
	type is (gosam_def_t)
	if (.not. allocated (core)) allocate (prc_gosam_t :: core)
	select type (core)
	type is (prc_gosam_t)
	call core%set_parameters (qcd)
	end select
	type is (openloops_def_t)
	if (.not. allocated (core)) allocate (prc_openloops_t :: core)
	select type (core)
	type is (prc_openloops_t)
	call core%set_parameters (qcd)
	end select
	type is (recola_def_t)
	if (.not. allocated (core)) allocate (prc_recola_t :: core)
	select type (core)
	type is (prc_recola_t)
	call core%set_parameters (qcd, model)
	end select
	type is (prc_external_test_def_t)
	if (.not. allocated (core)) allocate (prc_external_test_t :: core)
	select type (core)
	type is (prc_external_test_t)
	call core%set_parameters (qcd, model)
	end select
	type is (threshold_def_t)
	if (.not. allocated (core)) allocate (prc_threshold_t :: core)
	select type (core)
	type is (prc_threshold_t)
	call core%set_parameters (qcd, model)
	call core%set_beam_pol (has_beam_pol)
	end select
	class default
	call msg_bug ("Process core: unexpected process definition type")
	end select
	end subroutine dispatch_core

	@ %def dispatch_core
	@
	\subsection{Process core update and restoration}
	Here we take an existing object of abstract type [[prc_core_t]] and
	update the parameters as given by the current state of [[model]].
	Optionally, we can save the previous state as [[saved_core]]. The
	second routine restores the original from the save.

	(In the test case, there is no possible update.)
	<<Dispatch me methods: public>>=
	public :: dispatch_core_update
	public :: dispatch_core_restore
	<<Dispatch me methods: procedures>>=
	subroutine dispatch_core_update &
	(core, model, helicity_selection, qcd, saved_core)

	class(prc_core_t), allocatable, intent(inout) :: core
	class(model_data_t), intent(in), optional, target :: model
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	type(qcd_t), intent(in), optional :: qcd
	class(prc_core_t), allocatable, intent(inout), optional :: saved_core

	if (present (saved_core)) then
	allocate (saved_core, source = core)
	end if
	select type (core)
	type is (test_t)
	type is (prc_omega_t)
	call core%set_parameters (model, helicity_selection, qcd)
	call core%activate_parameters ()
	class is (prc_external_t)
	call msg_message ("Updating user defined cores is not implemented yet.")
	class default
	call msg_bug ("Process core update: unexpected process definition type")
	end select
	end subroutine dispatch_core_update

	subroutine dispatch_core_restore (core, saved_core)

	class(prc_core_t), allocatable, intent(inout) :: core
	class(prc_core_t), allocatable, intent(inout) :: saved_core

	call move_alloc (from = saved_core, to = core)
	select type (core)
	type is (test_t)
	type is (prc_omega_t)
	call core%activate_parameters ()
	class default
	call msg_bug ("Process core restore: unexpected process definition type")
	end select
	end subroutine dispatch_core_restore

	@ %def dispatch_core_update dispatch_core_restore
	@
	\subsection{Unit Tests}
	Test module, followed by the corresponding implementation module.
	<<[[dispatch_ut.f90]]>>=
	<<File header>>

	module dispatch_ut
	use unit_tests
	use dispatch_uti

	<<Standard module head>>

	<<Dispatch: public test>>

	<<Dispatch: public test auxiliary>>

	contains

	<<Dispatch: test driver>>

	end module dispatch_ut
	@ %def dispatch_ut
	@
	<<[[dispatch_uti.f90]]>>=
	<<File header>>

	module dispatch_uti
	<<Use kinds>>
	<<Use strings>>
	use os_interface, only: os_data_t
	use physics_defs, only: ELECTRON, PROTON
	use sm_qcd, only: qcd_t
	use flavors, only: flavor_t
	use interactions, only: reset_interaction_counter
	use pdg_arrays, only: pdg_array_t, assignment(=)
	use prc_core_def, only: prc_core_def_t
	use prc_test_core, only: test_t
	use prc_core, only: prc_core_t
	use prc_test, only: prc_test_def_t
	use prc_omega, only: omega_def_t, prc_omega_t
	use sf_mappings, only: sf_channel_t
	use sf_base, only: sf_data_t, sf_config_t
	use phs_base, only: phs_channel_collection_t
	use variables, only: var_list_t
	use model_data, only: model_data_t
	use models, only: syntax_model_file_init, syntax_model_file_final
	use rt_data, only: rt_data_t

	use dispatch_phase_space, only: dispatch_sf_channels
	use dispatch_beams, only: sf_prop_t, dispatch_qcd
	use dispatch_beams, only: dispatch_sf_config, dispatch_sf_data
	use dispatch_me_methods, only: dispatch_core_def, dispatch_core
	use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore

	use sf_base_ut, only: sf_test_data_t

	<<Standard module head>>

	<<Dispatch: public test auxiliary>>

	<<Dispatch: test declarations>>

	contains

	<<Dispatch: tests>>

	<<Dispatch: test auxiliary>>

	end module dispatch_uti

	@ %def dispatch_uti
	@ API: driver for the unit tests below.
	<<Dispatch: public test>>=
	public :: dispatch_test
	<<Dispatch: test driver>>=
	subroutine dispatch_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Dispatch: execute tests>>
	end subroutine dispatch_test

	@ %def dispatch_test
	@
	\subsubsection{Select type: process definition}
	<<Dispatch: execute tests>>=
	call test (dispatch_1, "dispatch_1", &
	"process configuration method", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_1
	<<Dispatch: tests>>=
	subroutine dispatch_1 (u)
	integer, intent(in) :: u
	type(string_t), dimension(2) :: prt_in, prt_out
	type(rt_data_t), target :: global
	class(prc_core_def_t), allocatable :: core_def

	write (u, "(A)") "* Test output: dispatch_1"
	write (u, "(A)") "* Purpose: select process configuration method"
	write (u, "(A)")

	call global%global_init ()

	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	prt_in = [var_str ("a"), var_str ("b")]
	prt_out = [var_str ("c"), var_str ("d")]

	write (u, "(A)") "* Allocate core_def as prc_test_def"

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
	select type (core_def)
	type is (prc_test_def_t)
	call core_def%write (u)
	end select

	deallocate (core_def)

	write (u, "(A)")
	write (u, "(A)") "* Allocate core_def as omega_def"
	write (u, "(A)")

	call global%set_string (var_str ("$method"), &
	var_str ("omega"), is_known = .true.)
	call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
	select type (core_def)
	type is (omega_def_t)
	call core_def%write (u)
	end select

	call global%final ()

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

	end subroutine dispatch_1

	@ %def dispatch_1
	@
	\subsubsection{Select type: process core}
	<<Dispatch: execute tests>>=
	call test (dispatch_2, "dispatch_2", &
	"process core", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_2
	<<Dispatch: tests>>=
	subroutine dispatch_2 (u)
	integer, intent(in) :: u
	type(string_t), dimension(2) :: prt_in, prt_out
	type(rt_data_t), target :: global
	class(prc_core_def_t), allocatable :: core_def
	class(prc_core_t), allocatable :: core

	write (u, "(A)") "* Test output: dispatch_2"
	write (u, "(A)") "* Purpose: select process configuration method"
	write (u, "(A)") " and allocate process core"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()

	prt_in = [var_str ("a"), var_str ("b")]
	prt_out = [var_str ("c"), var_str ("d")]

	write (u, "(A)") "* Allocate core as test_t"
	write (u, "(A)")

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)
	call dispatch_core (core, core_def)
	select type (core)
	type is (test_t)
	call core%write (u)
	end select

	deallocate (core)
	deallocate (core_def)

	write (u, "(A)")
	write (u, "(A)") "* Allocate core as prc_omega_t"
	write (u, "(A)")

	call global%set_string (var_str ("$method"), &
	var_str ("omega"), is_known = .true.)
	call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)

	call global%select_model (var_str ("Test"))

	call global%set_log (&
	var_str ("?helicity_selection_active"), &
	.true., is_known = .true.)
	call global%set_real (&
	var_str ("helicity_selection_threshold"), &
	1e9_default, is_known = .true.)
	call global%set_int (&
	var_str ("helicity_selection_cutoff"), &
	10, is_known = .true.)

	call dispatch_core (core, core_def, &
	global%model, &
	global%get_helicity_selection ())
	call core_def%allocate_driver (core%driver, var_str (""))

	select type (core)
	type is (prc_omega_t)
	call core%write (u)
	end select

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_2

	@ %def dispatch_2
	@
	\subsubsection{Select type: structure-function data}
	This is an extra dispatcher that enables the test structure
	functions. This procedure should be assigned to the
	[[dispatch_sf_data_extra]] hook before any tests are executed.
	<<Dispatch: public test auxiliary>>=
	public :: dispatch_sf_data_test
	<<Dispatch: test auxiliary>>=
	subroutine dispatch_sf_data_test (data, sf_method, i_beam, sf_prop, &
	var_list, var_list_global, model, os_data, sqrts, pdg_in, pdg_prc, polarized)
	class(sf_data_t), allocatable, intent(inout) :: data
	type(string_t), intent(in) :: sf_method
	integer, dimension(:), intent(in) :: i_beam
	type(var_list_t), intent(in) :: var_list
	type(var_list_t), intent(inout) :: var_list_global
	class(model_data_t), target, intent(in) :: model
	type(os_data_t), intent(in) :: os_data
	real(default), intent(in) :: sqrts
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_in
	type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
	type(sf_prop_t), intent(inout) :: sf_prop
	logical, intent(in) :: polarized
	select case (char (sf_method))
	case ("sf_test_0", "sf_test_1")
	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	select case (char (sf_method))
	case ("sf_test_0"); call data%init (model, pdg_in(i_beam(1)))
	case ("sf_test_1"); call data%init (model, pdg_in(i_beam(1)),&
	mode = 1)
	end select
	end select
	end select
	end subroutine dispatch_sf_data_test

	@ %def dispatch_sf_data_test
	@ The actual test. We can't move this to [[beams]] as it depends on
	[[model_features]] for the [[model_list_t]].
	<<Dispatch: execute tests>>=
	call test (dispatch_7, "dispatch_7", &
	"structure-function data", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_7
	<<Dispatch: tests>>=
	subroutine dispatch_7 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(os_data_t) :: os_data
	type(string_t) :: prt, sf_method
	type(sf_prop_t) :: sf_prop
	class(sf_data_t), allocatable :: data
	type(pdg_array_t), dimension(1) :: pdg_in
	type(pdg_array_t), dimension(1,1) :: pdg_prc
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1

	write (u, "(A)") "* Test output: dispatch_7"
	write (u, "(A)") "* Purpose: select and configure &
	&structure function data"
	write (u, "(A)")

	call global%global_init ()

	call os_data%init ()
	call syntax_model_file_init ()
	call global%select_model (var_str ("QCD"))

	call reset_interaction_counter ()
	call global%set_real (var_str ("sqrts"), &
	14000._default, is_known = .true.)
	prt = "p"
	call global%beam_structure%init_sf ([prt, prt], [1])
	pdg_in = 2212

	write (u, "(A)") "* Allocate data as sf_pdf_builtin_t"
	write (u, "(A)")

	sf_method = "pdf_builtin"
	call dispatch_sf_data (data, sf_method, [1], sf_prop, &
	global%get_var_list_ptr (), global%var_list, &
	global%model, global%os_data, global%get_sqrts (), &
	pdg_in, pdg_prc, .false.)
	call data%write (u)

	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(A)")
	write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1

	deallocate (data)

	write (u, "(A)")
	write (u, "(A)") "* Allocate data for different PDF set"
	write (u, "(A)")

	pdg_in = 2212

	call global%set_string (var_str ("$pdf_builtin_set"), &
	var_str ("CTEQ6M"), is_known = .true.)
	sf_method = "pdf_builtin"
	call dispatch_sf_data (data, sf_method, [1], sf_prop, &
	global%get_var_list_ptr (), global%var_list, &
	global%model, global%os_data, global%get_sqrts (), &
	pdg_in, pdg_prc, .false.)
	call data%write (u)

	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(A)")
	write (u, "(1x,A,99(1x,I0))") "PDG(out) = ", pdg1

	deallocate (data)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_7

	@ %def dispatch_7
	@
	\subsubsection{Beam structure}
	The actual test. We can't move this to [[beams]] as it depends on
	[[model_features]] for the [[model_list_t]].
	<<Dispatch: execute tests>>=
	call test (dispatch_8, "dispatch_8", &
	"beam structure", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_8
	<<Dispatch: tests>>=
	subroutine dispatch_8 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(os_data_t) :: os_data
	type(flavor_t), dimension(2) :: flv
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_prop_t) :: sf_prop
	type(sf_channel_t), dimension(:), allocatable :: sf_channel
	type(phs_channel_collection_t) :: coll
	type(string_t) :: sf_string
	integer :: i
	type(pdg_array_t), dimension (2,1) :: pdg_prc

	write (u, "(A)") "* Test output: dispatch_8"
	write (u, "(A)") "* Purpose: configure a structure-function chain"
	write (u, "(A)")

	call global%global_init ()

	call os_data%init ()
	call syntax_model_file_init ()
	call global%select_model (var_str ("QCD"))

	write (u, "(A)") "* Allocate LHC beams with PDF builtin"
	write (u, "(A)")

	call flv(1)%init (PROTON, global%model)
	call flv(2)%init (PROTON, global%model)

	call reset_interaction_counter ()
	call global%set_real (var_str ("sqrts"), &
	14000._default, is_known = .true.)

	call global%beam_structure%init_sf (flv%get_name (), [1])
	call global%beam_structure%set_sf (1, 1, var_str ("pdf_builtin"))

	call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
	global%get_var_list_ptr (), global%var_list, &
	global%model, global%os_data, global%get_sqrts (), pdg_prc)
	do i = 1, size (sf_config)
	call sf_config(i)%write (u)
	end do

	call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
	global%var_list, global%get_sqrts(), global%beam_structure)
	write (u, "(1x,A)") "Mapping configuration:"
	do i = 1, size (sf_channel)
	write (u, "(2x)", advance = "no")
	call sf_channel(i)%write (u)
	end do

	write (u, "(A)")
	write (u, "(A)") "* Allocate ILC beams with CIRCE1"
	write (u, "(A)")

	call global%select_model (var_str ("QED"))
	call flv(1)%init ( ELECTRON, global%model)
	call flv(2)%init (-ELECTRON, global%model)

	call reset_interaction_counter ()
	call global%set_real (var_str ("sqrts"), &
	500._default, is_known = .true.)
	call global%set_log (var_str ("?circe1_generate"), &
	.false., is_known = .true.)

	call global%beam_structure%init_sf (flv%get_name (), [1])
	call global%beam_structure%set_sf (1, 1, var_str ("circe1"))

	call dispatch_sf_config (sf_config, sf_prop, global%beam_structure, &
	global%get_var_list_ptr (), global%var_list, &
	global%model, global%os_data, global%get_sqrts (), pdg_prc)
	do i = 1, size (sf_config)
	call sf_config(i)%write (u)
	end do

	call dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
	global%var_list, global%get_sqrts(), global%beam_structure)
	write (u, "(1x,A)") "Mapping configuration:"
	do i = 1, size (sf_channel)
	write (u, "(2x)", advance = "no")
	call sf_channel(i)%write (u)
	end do

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_8

	@ %def dispatch_8
	@
	\subsubsection{Update process core parameters}
	This test dispatches a process core, temporarily modifies parameters,
	then restores the original.
	<<Dispatch: execute tests>>=
	call test (dispatch_10, "dispatch_10", &
	"process core update", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_10
	<<Dispatch: tests>>=
	subroutine dispatch_10 (u)
	integer, intent(in) :: u
	type(string_t), dimension(2) :: prt_in, prt_out
	type(rt_data_t), target :: global
	class(prc_core_def_t), allocatable :: core_def
	class(prc_core_t), allocatable :: core, saved_core
	type(var_list_t), pointer :: model_vars

	write (u, "(A)") "* Test output: dispatch_10"
	write (u, "(A)") "* Purpose: select process configuration method,"
	write (u, "(A)") " allocate process core,"
	write (u, "(A)") " temporarily reset parameters"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()

	prt_in = [var_str ("a"), var_str ("b")]
	prt_out = [var_str ("c"), var_str ("d")]

	write (u, "(A)") "* Allocate core as prc_omega_t"
	write (u, "(A)")

	call global%set_string (var_str ("$method"), &
	var_str ("omega"), is_known = .true.)
	call dispatch_core_def (core_def, prt_in, prt_out, global%model, global%var_list)

	call global%select_model (var_str ("Test"))

	call dispatch_core (core, core_def, global%model)
	call core_def%allocate_driver (core%driver, var_str (""))

	select type (core)
	type is (prc_omega_t)
	call core%write (u)
	end select

	write (u, "(A)")
	write (u, "(A)") "* Update core with modified model and helicity selection"
	write (u, "(A)")

	model_vars => global%model%get_var_list_ptr ()

	call model_vars%set_real (var_str ("gy"), 2._default, &
	is_known = .true.)
	call global%model%update_parameters ()

	call global%set_log (&
	var_str ("?helicity_selection_active"), &
	.true., is_known = .true.)
	call global%set_real (&
	var_str ("helicity_selection_threshold"), &
	2e10_default, is_known = .true.)
	call global%set_int (&
	var_str ("helicity_selection_cutoff"), &
	5, is_known = .true.)

	call dispatch_core_update (core, &
	global%model, &
	global%get_helicity_selection (), &
	saved_core = saved_core)
	select type (core)
	type is (prc_omega_t)
	call core%write (u)
	end select

	write (u, "(A)")
	write (u, "(A)") "* Restore core from save"
	write (u, "(A)")

	call dispatch_core_restore (core, saved_core)
	select type (core)
	type is (prc_omega_t)
	call core%write (u)
	end select

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_10

	@ %def dispatch_10
	@
	\subsubsection{QCD Coupling}
	This test dispatches an [[qcd]] object, which is used to compute the
	(running) coupling by one of several possible methods.

	We can't move this to [[beams]] as it depends on
	[[model_features]] for the [[model_list_t]].
	<<Dispatch: execute tests>>=
	call test (dispatch_11, "dispatch_11", &
	"QCD coupling", &
	u, results)
	<<Dispatch: test declarations>>=
	public :: dispatch_11
	<<Dispatch: tests>>=
	subroutine dispatch_11 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(var_list_t), pointer :: model_vars
	type(qcd_t) :: qcd

	write (u, "(A)") "* Test output: dispatch_11"
	write (u, "(A)") "* Purpose: select QCD coupling formula"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()
	call global%select_model (var_str ("SM"))
	model_vars => global%get_var_list_ptr ()

	write (u, "(A)") "* Allocate alpha_s as fixed"
	write (u, "(A)")

	call global%set_log (var_str ("?alphas_is_fixed"), &
	.true., is_known = .true.)
	call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
	call qcd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Allocate alpha_s as running (built-in)"
	write (u, "(A)")

	call global%set_log (var_str ("?alphas_is_fixed"), &
	.false., is_known = .true.)
	call global%set_log (var_str ("?alphas_from_mz"), &
	.true., is_known = .true.)
	call global%set_int &
	(var_str ("alphas_order"), 1, is_known = .true.)
	call model_vars%set_real (var_str ("alphas"), 0.1234_default, &
	is_known=.true.)
	call model_vars%set_real (var_str ("mZ"), 91.234_default, &
	is_known=.true.)
	call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
	call qcd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Allocate alpha_s as running (built-in, Lambda defined)"
	write (u, "(A)")

	call global%set_log (var_str ("?alphas_from_mz"), &
	.false., is_known = .true.)
	call global%set_log (&
	var_str ("?alphas_from_lambda_qcd"), &
	.true., is_known = .true.)
	call global%set_real &
	(var_str ("lambda_qcd"), 250.e-3_default, &
	is_known=.true.)
	call global%set_int &
	(var_str ("alphas_order"), 2, is_known = .true.)
	call global%set_int &
	(var_str ("alphas_nf"), 4, is_known = .true.)
	call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
	call qcd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Allocate alpha_s as running (using builtin PDF set)"
	write (u, "(A)")

	call global%set_log (&
	var_str ("?alphas_from_lambda_qcd"), &
	.false., is_known = .true.)
	call global%set_log &
	(var_str ("?alphas_from_pdf_builtin"), &
	.true., is_known = .true.)
	call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
	call qcd%write (u)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine dispatch_11

	@ %def dispatch_11
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Process Configuration}
	This module communicates between the toplevel command structure with
	its runtime data set and the process-library handling modules which
	collect the definition of individual processes. Its primary purpose
	is to select from the available matrix-element generating methods and
	configure the entry in the process library accordingly.
	<<[[process_configurations.f90]]>>=
	<<File header>>

	module process_configurations

	<<Use strings>>
	<<Use debug>>
	use diagnostics
	use io_units
	use physics_defs, only: BORN, NLO_VIRTUAL, NLO_REAL, NLO_DGLAP, &
	NLO_SUBTRACTION, NLO_MISMATCH
	use models
	use prc_core_def
	use particle_specifiers
	use process_libraries
	use rt_data
	use variables, only: var_list_t

	use dispatch_me_methods, only: dispatch_core_def
	use prc_external, only: prc_external_def_t

	<<Standard module head>>

	<<Process configurations: public>>

	<<Process configurations: types>>

	contains

	<<Process configurations: procedures>>

	end module process_configurations
	@ %def process_configurations
	@
	\subsection{Data Type}
	<<Process configurations: public>>=
	public :: process_configuration_t
	<<Process configurations: types>>=
	type :: process_configuration_t
	type(process_def_entry_t), pointer :: entry => null ()
	type(string_t) :: id
	integer :: num_id = 0
	contains
	<<Process configurations: process configuration: TBP>>
	end type process_configuration_t

	@ %def process_configuration_t
	@ Output (for unit tests).
	<<Process configurations: process configuration: TBP>>=
	procedure :: write => process_configuration_write
	<<Process configurations: procedures>>=
	subroutine process_configuration_write (config, unit)
	class(process_configuration_t), intent(in) :: config
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(A)") "Process configuration:"
	if (associated (config%entry)) then
	call config%entry%write (u)
	else
	write (u, "(1x,3A)") "ID = '", char (config%id), "'"
	write (u, "(1x,A,1x,I0)") "num ID =", config%num_id
	write (u, "(2x,A)") "[no entry]"
	end if
	end subroutine process_configuration_write

	@ %def process_configuration_write
	@ Initialize a process. We only need the name, the number of incoming
	particles, and the number of components.
	<<Process configurations: process configuration: TBP>>=
	procedure :: init => process_configuration_init
	<<Process configurations: procedures>>=
	subroutine process_configuration_init &
	(config, prc_name, n_in, n_components, model, var_list, &
	nlo_process, negative_sf)
	class(process_configuration_t), intent(out) :: config
	type(string_t), intent(in) :: prc_name
	integer, intent(in) :: n_in
	integer, intent(in) :: n_components
	type(model_t), intent(in), pointer :: model
	type(var_list_t), intent(in) :: var_list
	logical, intent(in), optional :: nlo_process, negative_sf
	logical :: nlo_proc, neg_sf
	logical :: requires_resonances
	if (debug_on) call msg_debug (D_CORE, "process_configuration_init")
	config%id = prc_name
	if (present (nlo_process)) then
	nlo_proc = nlo_process
	else
	nlo_proc = .false.
	end if
	if (present (negative_sf)) then
	neg_sf = negative_sf
	else
	neg_sf = .false.
	end if
	requires_resonances = var_list%get_lval (var_str ("?resonance_history"))

	if (debug_on) call msg_debug (D_CORE, "nlo_process", nlo_proc)
	allocate (config%entry)
	if (var_list%is_known (var_str ("process_num_id"))) then
	config%num_id = &
	var_list%get_ival (var_str ("process_num_id"))
	call config%entry%init (prc_name, &
	model = model, n_in = n_in, n_components = n_components, &
	num_id = config%num_id, &
	nlo_process = nlo_proc, &
	negative_sf = neg_sf, &
	requires_resonances = requires_resonances)
	else
	call config%entry%init (prc_name, &
	model = model, n_in = n_in, n_components = n_components, &
	nlo_process = nlo_proc, &
	negative_sf = neg_sf, &
	requires_resonances = requires_resonances)
	end if
	end subroutine process_configuration_init

	@ %def process_configuration_init
	@ Initialize a process component. The details depend on the process method,
	which determines the type of the process component core. We set the incoming
	and outgoing particles (as strings, to be interpreted by the process driver).
	All other information is taken from the variable list.

	The dispatcher gets only the names of the particles. The process
	component definition gets the complete specifiers which contains a
	polarization flag and names of decay processes, where applicable.
	<<Process configurations: process configuration: TBP>>=
	procedure :: setup_component => process_configuration_setup_component
	<<Process configurations: procedures>>=
	subroutine process_configuration_setup_component &
	(config, i_component, prt_in, prt_out, model, var_list, &
	nlo_type, can_be_integrated)
	class(process_configuration_t), intent(inout) :: config
	integer, intent(in) :: i_component
	type(prt_spec_t), dimension(:), intent(in) :: prt_in
	type(prt_spec_t), dimension(:), intent(in) :: prt_out
	type(model_t), pointer, intent(in) :: model
	type(var_list_t), intent(in) :: var_list
	integer, intent(in), optional :: nlo_type
	logical, intent(in), optional :: can_be_integrated
	type(string_t), dimension(:), allocatable :: prt_str_in
	type(string_t), dimension(:), allocatable :: prt_str_out
	class(prc_core_def_t), allocatable :: core_def
	type(string_t) :: method
	type(string_t) :: born_me_method
	type(string_t) :: real_tree_me_method
	type(string_t) :: loop_me_method
	type(string_t) :: correlation_me_method
	type(string_t) :: dglap_me_method
	integer :: i
	if (debug_on) call msg_debug2 (D_CORE, "process_configuration_setup_component")
	allocate (prt_str_in (size (prt_in)))
	allocate (prt_str_out (size (prt_out)))
	forall (i = 1:size (prt_in)) prt_str_in(i) = prt_in(i)% get_name ()
	forall (i = 1:size (prt_out)) prt_str_out(i) = prt_out(i)%get_name ()

	method = var_list%get_sval (var_str ("$method"))
	if (present (nlo_type)) then
	select case (nlo_type)
	case (BORN)
	born_me_method = var_list%get_sval (var_str ("$born_me_method"))
	if (born_me_method /= var_str ("")) then
	method = born_me_method
	end if
	case (NLO_VIRTUAL)
	loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
	if (loop_me_method /= var_str ("")) then
	method = loop_me_method
	end if
	case (NLO_REAL)
	real_tree_me_method = &
	var_list%get_sval (var_str ("$real_tree_me_method"))
	if (real_tree_me_method /= var_str ("")) then
	method = real_tree_me_method
	end if
	case (NLO_DGLAP)
	dglap_me_method = &
	var_list%get_sval (var_str ("$dglap_me_method"))
	if (dglap_me_method /= var_str ("")) then
	method = dglap_me_method
	end if
	case (NLO_SUBTRACTION,NLO_MISMATCH)
	correlation_me_method = &
	var_list%get_sval (var_str ("$correlation_me_method"))
	if (correlation_me_method /= var_str ("")) then
	method = correlation_me_method
	end if
	case default
	end select
	end if
	call dispatch_core_def (core_def, prt_str_in, prt_str_out, &
	model, var_list, config%id, nlo_type, method)
	select type (core_def)
	class is (prc_external_def_t)
	if (present (can_be_integrated)) then
	call core_def%set_active_writer (can_be_integrated)
	else
	call msg_fatal ("Cannot decide if external core is integrated!")
	end if
	end select

	if (debug_on) call msg_debug2 (D_CORE, "import_component with method ", method)
	call config%entry%import_component (i_component, &
	n_out = size (prt_out), &
	prt_in = prt_in, &
	prt_out = prt_out, &
	method = method, &
	variant = core_def, &
	nlo_type = nlo_type, &
	can_be_integrated = can_be_integrated)
	end subroutine process_configuration_setup_component

	@ %def process_configuration_setup_component
	@
	<<Process configurations: process configuration: TBP>>=
	procedure :: set_fixed_emitter => process_configuration_set_fixed_emitter
	<<Process configurations: procedures>>=
	subroutine process_configuration_set_fixed_emitter (config, i, emitter)
	class(process_configuration_t), intent(inout) :: config
	integer, intent(in) :: i, emitter
	call config%entry%set_fixed_emitter (i, emitter)
	end subroutine process_configuration_set_fixed_emitter

	@ %def process_configuration_set_fixed_emitter
	@
	<<Process configurations: process configuration: TBP>>=
	procedure :: set_coupling_powers => process_configuration_set_coupling_powers
	<<Process configurations: procedures>>=
	subroutine process_configuration_set_coupling_powers &
	(config, alpha_power, alphas_power)
	class(process_configuration_t), intent(inout) :: config
	integer, intent(in) :: alpha_power, alphas_power
	call config%entry%set_coupling_powers (alpha_power, alphas_power)
	end subroutine process_configuration_set_coupling_powers

	@ %def process_configuration_set_coupling_powers
	@
	<<Process configurations: process configuration: TBP>>=
	procedure :: set_component_associations => &
	process_configuration_set_component_associations
	<<Process configurations: procedures>>=
	subroutine process_configuration_set_component_associations &
	(config, i_list, remnant, use_real_finite, mismatch)
	class(process_configuration_t), intent(inout) :: config
	integer, dimension(:), intent(in) :: i_list
	logical, intent(in) :: remnant, use_real_finite, mismatch
	integer :: i_component
	do i_component = 1, config%entry%get_n_components ()
	if (any (i_list == i_component)) then
	call config%entry%set_associated_components (i_component, &
	i_list, remnant, use_real_finite, mismatch)
	end if
	end do
	end subroutine process_configuration_set_component_associations

	@ %def process_configuration_set_component_associations
	@ Record a process configuration: append it to the currently selected process
	definition library.
	<<Process configurations: process configuration: TBP>>=
	procedure :: record => process_configuration_record
	<<Process configurations: procedures>>=
	subroutine process_configuration_record (config, global)
	class(process_configuration_t), intent(inout) :: config
	type(rt_data_t), intent(inout) :: global
	if (associated (global%prclib)) then
	call global%prclib%open ()
	call global%prclib%append (config%entry)
	if (config%num_id /= 0) then
	write (msg_buffer, "(5A,I0,A)") "Process library '", &
	char (global%prclib%get_name ()), &
	"': recorded process '", char (config%id), "' (", &
	config%num_id, ")"
	else
	write (msg_buffer, "(5A)") "Process library '", &
	char (global%prclib%get_name ()), &
	"': recorded process '", char (config%id), "'"
	end if
	call msg_message ()
	else
	call msg_fatal ("Recording process '" // char (config%id) &
	// "': active process library undefined")
	end if
	end subroutine process_configuration_record

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

	module process_configurations_ut
	use unit_tests
	use process_configurations_uti

	<<Standard module head>>

	<<Process configurations: public test>>

	<<Process configurations: public test auxiliary>>

	contains

	<<Process configurations: test driver>>

	end module process_configurations_ut
	@ %def process_configurations_ut
	@
	<<[[process_configurations_uti.f90]]>>=
	<<File header>>

	module process_configurations_uti

	<<Use strings>>
	use particle_specifiers, only: new_prt_spec
	use prclib_stacks
	use models
	use rt_data

	use process_configurations

	<<Standard module head>>

	<<Process configurations: test declarations>>

	<<Process configurations: public test auxiliary>>

	contains

	<<Process configurations: test auxiliary>>

	<<Process configurations: tests>>

	end module process_configurations_uti

	@ %def process_configurations_uti
	@ API: driver for the unit tests below.
	<<Process configurations: public test>>=
	public :: process_configurations_test
	<<Process configurations: test driver>>=
	subroutine process_configurations_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Process configurations: execute tests>>
	end subroutine process_configurations_test

	@ %def process_configurations_test
	@
	\subsubsection{Minimal setup}
	The workflow for setting up a minimal process configuration with the
	test matrix element method.

	We wrap this in a public procedure, so we can reuse it in later modules.
	The procedure prepares a process definition list for two processes
	(one [[prc_test]] and one [[omega]] type) and appends this to the
	process library stack in the global data set.

	The [[mode]] argument determines which processes to build.

	The [[procname]] argument replaces the predefined procname(s).

	This is re-exported by the UT module.
	<<Process configurations: public test auxiliary>>=
	public :: prepare_test_library
	<<Process configurations: test auxiliary>>=
	subroutine prepare_test_library (global, libname, mode, procname)
	type(rt_data_t), intent(inout), target :: global
	type(string_t), intent(in) :: libname
	integer, intent(in) :: mode
	type(string_t), intent(in), dimension(:), optional :: procname
	type(prclib_entry_t), pointer :: lib
	type(string_t) :: prc_name
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	integer :: n_components
	type(process_configuration_t) :: prc_config

	if (.not. associated (global%prclib_stack%get_first_ptr ())) then
	allocate (lib)
	call lib%init (libname)
	call global%add_prclib (lib)
	end if

	if (btest (mode, 0)) then

	call global%select_model (var_str ("Test"))

	if (present (procname)) then
	prc_name = procname(1)
	else
	prc_name = "prc_config_a"
	end if
	n_components = 1
	allocate (prt_in (2), prt_out (2))
	prt_in = [var_str ("s"), var_str ("s")]
	prt_out = [var_str ("s"), var_str ("s")]

	call global%set_string (var_str ("$method"),&
	var_str ("unit_test"), is_known = .true.)

	call prc_config%init (prc_name, &
	size (prt_in), n_components, &
	global%model, global%var_list)
	call prc_config%setup_component (1, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), &
	global%model, global%var_list)
	call prc_config%record (global)

	deallocate (prt_in, prt_out)

	end if

	if (btest (mode, 1)) then

	call global%select_model (var_str ("QED"))

	if (present (procname)) then
	prc_name = procname(2)
	else
	prc_name = "prc_config_b"
	end if
	n_components = 1
	allocate (prt_in (2), prt_out (2))
	prt_in = [var_str ("e+"), var_str ("e-")]
	prt_out = [var_str ("m+"), var_str ("m-")]

	call global%set_string (var_str ("$method"),&
	var_str ("omega"), is_known = .true.)

	call prc_config%init (prc_name, &
	size (prt_in), n_components, &
	global%model, global%var_list)
	call prc_config%setup_component (1, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), &
	global%model, global%var_list)
	call prc_config%record (global)

	deallocate (prt_in, prt_out)

	end if

	if (btest (mode, 2)) then

	call global%select_model (var_str ("Test"))

	if (present (procname)) then
	prc_name = procname(1)
	else
	prc_name = "prc_config_a"
	end if
	n_components = 1
	allocate (prt_in (1), prt_out (2))
	prt_in = [var_str ("s")]
	prt_out = [var_str ("f"), var_str ("fbar")]

	call global%set_string (var_str ("$method"),&
	var_str ("unit_test"), is_known = .true.)

	call prc_config%init (prc_name, &
	size (prt_in), n_components, &
	global%model, global%var_list)
	call prc_config%setup_component (1, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), &
	global%model, global%var_list)
	call prc_config%record (global)

	deallocate (prt_in, prt_out)

	end if

	end subroutine prepare_test_library

	@ %def prepare_test_library
	@ The actual test: the previous procedure with some prelude and postlude.
	In the global variable list, just before printing we reset the
	variables where the value may depend on the system and run environment.
	<<Process configurations: execute tests>>=
	call test (process_configurations_1, "process_configurations_1", &
	"test processes", &
	u, results)
	<<Process configurations: test declarations>>=
	public :: process_configurations_1
	<<Process configurations: tests>>=
	subroutine process_configurations_1 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: process_configurations_1"
	write (u, "(A)") "* Purpose: configure test processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	write (u, "(A)") "* Configure processes as prc_test, model Test"
	write (u, "(A)") "* and omega, model QED"
	write (u, *)

	call global%set_int (var_str ("process_num_id"), &
	42, is_known = .true.)
	call prepare_test_library (global, var_str ("prc_config_lib_1"), 3)

	global%os_data%fc = "Fortran-compiler"
	global%os_data%fcflags = "Fortran-flags"
	global%os_data%fclibs = "Fortran-libs"

	call global%write_libraries (u)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine process_configurations_1

	@ %def process_configurations_1
	@
	\subsubsection{\oMega\ options}
	Slightly extended example where we pass \oMega\ options to the
	library. The [[prepare_test_library]] contents are spelled out.
	<<Process configurations: execute tests>>=
	call test (process_configurations_2, "process_configurations_2", &
	"omega options", &
	u, results)
	<<Process configurations: test declarations>>=
	public :: process_configurations_2
	<<Process configurations: tests>>=
	subroutine process_configurations_2 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global

	type(string_t) :: libname
	type(prclib_entry_t), pointer :: lib
	type(string_t) :: prc_name
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	integer :: n_components
	type(process_configuration_t) :: prc_config

	write (u, "(A)") "* Test output: process_configurations_2"
	write (u, "(A)") "* Purpose: configure test processes with options"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	write (u, "(A)") "* Configure processes as omega, model QED"
	write (u, *)

	libname = "prc_config_lib_2"

	allocate (lib)
	call lib%init (libname)
	call global%add_prclib (lib)

	call global%select_model (var_str ("QED"))

	prc_name = "prc_config_c"
	n_components = 2
	allocate (prt_in (2), prt_out (2))
	prt_in = [var_str ("e+"), var_str ("e-")]
	prt_out = [var_str ("m+"), var_str ("m-")]

	call global%set_string (var_str ("$method"),&
	var_str ("omega"), is_known = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	call prc_config%init (prc_name, size (prt_in), n_components, &
	global%model, global%var_list)

	call global%set_log (var_str ("?report_progress"), &
	.true., is_known = .true.)
	call prc_config%setup_component (1, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)

	call global%set_log (var_str ("?report_progress"), &
	.false., is_known = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.true., is_known = .true.)
	call global%set_string (var_str ("$restrictions"),&
	var_str ("3+4~A"), is_known = .true.)
	call global%set_string (var_str ("$omega_flags"), &
	var_str ("-fusion:progress_file omega_prc_config.log"), &
	is_known = .true.)
	call prc_config%setup_component (2, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), global%model, global%var_list)

	call prc_config%record (global)

	deallocate (prt_in, prt_out)

	global%os_data%fc = "Fortran-compiler"
	global%os_data%fcflags = "Fortran-flags"
	global%os_data%fclibs = "Fortran-libs"

	call global%write_vars (u, [ &
	var_str ("$model_name"), &
	var_str ("$method"), &
	var_str ("?report_progress"), &
	var_str ("$restrictions"), &
	var_str ("$omega_flags")])
	write (u, "(A)")
	call global%write_libraries (u)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine process_configurations_2

	@ %def process_configurations_2
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Compilation}
	This module manages compilation and loading of of process libraries. It is
	needed as a separate module because integration depends on it.
	<<[[compilations.f90]]>>=
	<<File header>>

	module compilations

	<<Use strings>>
	use io_units
	use system_defs, only: TAB
	use system_dependencies, only: OS_IS_DARWIN
	use diagnostics
	use os_interface
	use variables, only: var_list_t
	use model_data
	use process_libraries
	use prclib_stacks
	use rt_data

	<<Standard module head>>

	<<Compilations: public>>

	<<Compilations: types>>

	<<Compilations: parameters>>

	contains

	<<Compilations: procedures>>

	end module compilations
	@ %def compilations
	@
	\subsection{The data type}
	The compilation item handles the compilation and loading of a single
	process library.
	<<Compilations: public>>=
	public :: compilation_item_t
	<<Compilations: types>>=
	type :: compilation_item_t
	private
	type(string_t) :: libname
	type(string_t) :: static_external_tag
	type(process_library_t), pointer :: lib => null ()
	logical :: recompile_library = .false.
	logical :: verbose = .false.
	logical :: use_workspace = .false.
	type(string_t) :: workspace
	contains
	<<Compilations: compilation item: TBP>>
	end type compilation_item_t

	@ %def compilation_item_t
	@ Initialize.

	Set flags and global properties of the library. Establish the workspace name,
	if defined.
	<<Compilations: compilation item: TBP>>=
	procedure :: init => compilation_item_init
	<<Compilations: procedures>>=
	subroutine compilation_item_init (comp, libname, stack, var_list)
	class(compilation_item_t), intent(out) :: comp
	type(string_t), intent(in) :: libname
	type(prclib_stack_t), intent(inout) :: stack
	type(var_list_t), intent(in) :: var_list
	comp%libname = libname
	comp%lib => stack%get_library_ptr (comp%libname)
	if (.not. associated (comp%lib)) then
	call msg_fatal ("Process library '" // char (comp%libname) &
	// "' has not been declared.")
	end if
	comp%recompile_library = &
	var_list%get_lval (var_str ("?recompile_library"))
	comp%verbose = &
	var_list%get_lval (var_str ("?me_verbose"))
	comp%use_workspace = &
	var_list%is_known (var_str ("$compile_workspace"))
	if (comp%use_workspace) then
	comp%workspace = &
	var_list%get_sval (var_str ("$compile_workspace"))
	if (comp%workspace == "") comp%use_workspace = .false.
	else
	comp%workspace = ""
	end if
	end subroutine compilation_item_init

	@ %def compilation_item_init
	@ Compile the current library. The [[force]] flag has the
	effect that we first delete any previous files, as far as accessible
	by the current makefile. It also guarantees that previous files not
	accessible by a makefile will be overwritten.
	<<Compilations: compilation item: TBP>>=
	procedure :: compile => compilation_item_compile
	<<Compilations: procedures>>=
	subroutine compilation_item_compile (comp, model, os_data, force, recompile)
	class(compilation_item_t), intent(inout) :: comp
	class(model_data_t), intent(in), target :: model
	type(os_data_t), intent(in) :: os_data
	logical, intent(in) :: force, recompile
	if (associated (comp%lib)) then
	if (comp%use_workspace) call setup_workspace (comp%workspace, os_data)
	call msg_message ("Process library '" &
	// char (comp%libname) // "': compiling ...")
	call comp%lib%configure (os_data)
	if (signal_is_pending ()) return
	call comp%lib%compute_md5sum (model)
	call comp%lib%write_makefile &
	(os_data, force, verbose=comp%verbose, workspace=comp%workspace)
	if (signal_is_pending ()) return
	if (force) then
	call comp%lib%clean &
	(os_data, distclean = .false., workspace=comp%workspace)
	if (signal_is_pending ()) return
	end if
	call comp%lib%write_driver (force, workspace=comp%workspace)
	if (signal_is_pending ()) return
	if (recompile) then
	call comp%lib%load &
	(os_data, keep_old_source = .true., workspace=comp%workspace)
	if (signal_is_pending ()) return
	end if
	call comp%lib%update_status (os_data, workspace=comp%workspace)
	end if
	end subroutine compilation_item_compile

	@ %def compilation_item_compile
	@ The workspace directory is created if it does not exist. (Applies only if
	the use has set the workspace directory.)
	<<Compilations: parameters>>=
	character(*), parameter :: ALLOWED_IN_DIRNAME = &
	"abcdefghijklmnopqrstuvwxyz&
	&ABCDEFGHIJKLMNOPQRSTUVWXYZ&
	&1234567890&
	&.,_-+="
	@ %def ALLOWED_IN_DIRNAME
	<<Compilations: procedures>>=
	subroutine setup_workspace (workspace, os_data)
	type(string_t), intent(in) :: workspace
	type(os_data_t), intent(in) :: os_data
	if (verify (workspace, ALLOWED_IN_DIRNAME) == 0) then
	call msg_message ("Compile: preparing workspace directory '" &
	// char (workspace) // "'")
	call os_system_call ("mkdir -p '" // workspace // "'")
	else
	call msg_fatal ("compile: workspace name '" &
	// char (workspace) // "' contains illegal characters")
	end if
	end subroutine setup_workspace

	@ %def setup_workspace
	@ Load the current library, just after compiling it.
	<<Compilations: compilation item: TBP>>=
	procedure :: load => compilation_item_load
	<<Compilations: procedures>>=
	subroutine compilation_item_load (comp, os_data)
	class(compilation_item_t), intent(inout) :: comp
	type(os_data_t), intent(in) :: os_data
	if (associated (comp%lib)) then
	call comp%lib%load (os_data, workspace=comp%workspace)
	end if
	end subroutine compilation_item_load

	@ %def compilation_item_load
	@ Message as a separate call:
	<<Compilations: compilation item: TBP>>=
	procedure :: success => compilation_item_success
	<<Compilations: procedures>>=
	subroutine compilation_item_success (comp)
	class(compilation_item_t), intent(in) :: comp
	if (associated (comp%lib)) then
	call msg_message ("Process library '" // char (comp%libname) &
	// "': ... success.")
	else
	call msg_fatal ("Process library '" // char (comp%libname) &
	// "': ... failure.")
	end if
	end subroutine compilation_item_success

	@ %def compilation_item_success
	@ %def compilation_item_failure
	@
	\subsection{API for library compilation and loading}
	This is a shorthand for compiling and loading a single library. The
	[[compilation_item]] object is used only internally.

	The [[global]] data set may actually be local to the caller. The
	compilation affects the library specified by its name if it is on the
	stack, but it does not reset the currently selected library.
	<<Compilations: public>>=
	public :: compile_library
	<<Compilations: procedures>>=
	subroutine compile_library (libname, global)
	type(string_t), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: global
	type(compilation_item_t) :: comp
	logical :: force, recompile
	force = &
	global%var_list%get_lval (var_str ("?rebuild_library"))
	recompile = &
	global%var_list%get_lval (var_str ("?recompile_library"))
	if (associated (global%model)) then
	call comp%init (libname, global%prclib_stack, global%var_list)
	call comp%compile (global%model, global%os_data, force, recompile)
	if (signal_is_pending ()) return
	call comp%load (global%os_data)
	if (signal_is_pending ()) return
	else
	call msg_fatal ("Process library compilation: " &
	// " model is undefined.")
	end if
	call comp%success ()
	end subroutine compile_library

	@ %def compile_library
	@
	\subsection{Compiling static executable}
	This object handles the creation of a static executable which should
	contain a set of static process libraries.
	<<Compilations: public>>=
	public :: compilation_t
	<<Compilations: types>>=
	type :: compilation_t
	private
	type(string_t) :: exe_name
	type(string_t), dimension(:), allocatable :: lib_name
	contains
	<<Compilations: compilation: TBP>>
	end type compilation_t

	@ %def compilation_t
	@ Output.
	<<Compilations: compilation: TBP>>=
	procedure :: write => compilation_write
	<<Compilations: procedures>>=
	subroutine compilation_write (object, unit)
	class(compilation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Compilation object:"
	write (u, "(3x,3A)") "executable = '", &
	char (object%exe_name), "'"
	write (u, "(3x,A)", advance="no") "process libraries ="
	do i = 1, size (object%lib_name)
	write (u, "(1x,3A)", advance="no") "'", char (object%lib_name(i)), "'"
	end do
	write (u, *)
	end subroutine compilation_write

	@ %def compilation_write
	@ Initialize: we know the names of the executable and of the libraries.
	Optionally, we may provide a workspace directory.
	<<Compilations: compilation: TBP>>=
	procedure :: init => compilation_init
	<<Compilations: procedures>>=
	subroutine compilation_init (compilation, exe_name, lib_name)
	class(compilation_t), intent(out) :: compilation
	type(string_t), intent(in) :: exe_name
	type(string_t), dimension(:), intent(in) :: lib_name
	compilation%exe_name = exe_name
	allocate (compilation%lib_name (size (lib_name)))
	compilation%lib_name = lib_name
	end subroutine compilation_init

	@ %def compilation_init
	@ Write the dispatcher subroutine for the compiled libraries. Also
	write a subroutine which returns the names of the compiled libraries.
	<<Compilations: compilation: TBP>>=
	procedure :: write_dispatcher => compilation_write_dispatcher
	<<Compilations: procedures>>=
	subroutine compilation_write_dispatcher (compilation)
	class(compilation_t), intent(in) :: compilation
	type(string_t) :: file
	integer :: u, i
	file = compilation%exe_name // "_prclib_dispatcher.f90"
	call msg_message ("Static executable '" // char (compilation%exe_name) &
	// "': writing library dispatcher")
	u = free_unit ()
	open (u, file = char (file), status="replace", action="write")
	write (u, "(3A)") "! Whizard: process libraries for executable '", &
	char (compilation%exe_name), "'"
	write (u, "(A)") "! Automatically generated file, do not edit"
	write (u, "(A)") "subroutine dispatch_prclib_static " // &
	"(driver, basename, modellibs_ldflags)"
	write (u, "(A)") " use iso_varying_string, string_t => varying_string"
	write (u, "(A)") " use prclib_interfaces"
	do i = 1, size (compilation%lib_name)
	associate (lib_name => compilation%lib_name(i))
	write (u, "(A)") " use " // char (lib_name) // "_driver"
	end associate
	end do
	write (u, "(A)") " implicit none"
	write (u, "(A)") " class(prclib_driver_t), intent(inout), allocatable &
	&:: driver"
	write (u, "(A)") " type(string_t), intent(in) :: basename"
	write (u, "(A)") " logical, intent(in), optional :: " // &
	"modellibs_ldflags"
	write (u, "(A)") " select case (char (basename))"
	do i = 1, size (compilation%lib_name)
	associate (lib_name => compilation%lib_name(i))
	write (u, "(3A)") " case ('", char (lib_name), "')"
	write (u, "(3A)") " allocate (", char (lib_name), "_driver_t &
	&:: driver)"
	end associate
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") "end subroutine dispatch_prclib_static"
	write (u, *)
	write (u, "(A)") "subroutine get_prclib_static (libname)"
	write (u, "(A)") " use iso_varying_string, string_t => varying_string"
	write (u, "(A)") " implicit none"
	write (u, "(A)") " type(string_t), dimension(:), intent(inout), &
	&allocatable :: libname"
	write (u, "(A,I0,A)") " allocate (libname (", &
	size (compilation%lib_name), "))"
	do i = 1, size (compilation%lib_name)
	associate (lib_name => compilation%lib_name(i))
	write (u, "(A,I0,A,A,A)") " libname(", i, ") = '", &
	char (lib_name), "'"
	end associate
	end do
	write (u, "(A)") "end subroutine get_prclib_static"
	close (u)
	end subroutine compilation_write_dispatcher

	@ %def compilation_write_dispatcher
	@ Write the Makefile subroutine for the compiled libraries.
	<<Compilations: compilation: TBP>>=
	procedure :: write_makefile => compilation_write_makefile
	<<Compilations: procedures>>=
	subroutine compilation_write_makefile &
	(compilation, os_data, ext_libtag, verbose, overwrite_os)
	class(compilation_t), intent(in) :: compilation
	type(os_data_t), intent(in) :: os_data
	logical, intent(in) :: verbose
	logical, intent(in), optional :: overwrite_os
	logical :: overwrite
	type(string_t), intent(in), optional :: ext_libtag
	type(string_t) :: file, ext_tag
	integer :: u, i
	overwrite = .false.
	if (present (overwrite_os)) overwrite = overwrite_os
	if (present (ext_libtag)) then
	ext_tag = ext_libtag
	else
	ext_tag = ""
	end if
	file = compilation%exe_name // ".makefile"
	call msg_message ("Static executable '" // char (compilation%exe_name) &
	// "': writing makefile")
	u = free_unit ()
	open (u, file = char (file), status="replace", action="write")
	write (u, "(3A)") "# WHIZARD: Makefile for executable '", &
	char (compilation%exe_name), "'"
	write (u, "(A)") "# Automatically generated file, do not edit"
	write (u, "(A)") ""
	write (u, "(A)") "# Executable name"
	write (u, "(A)") "EXE = " // char (compilation%exe_name)
	write (u, "(A)") ""
	write (u, "(A)") "# Compiler"
	write (u, "(A)") "FC = " // char (os_data%fc)
	write (u, "(A)") "CXX = " // char (os_data%cxx)
	write (u, "(A)") ""
	write (u, "(A)") "# Included libraries"
	write (u, "(A)") "FCINCL = " // char (os_data%whizard_includes)
	write (u, "(A)") ""
	write (u, "(A)") "# Compiler flags"
	write (u, "(A)") "FCFLAGS = " // char (os_data%fcflags)
	write (u, "(A)") "FCLIBS = " // char (os_data%fclibs)
	write (u, "(A)") "CXXFLAGS = " // char (os_data%cxxflags)
	write (u, "(A)") "CXXLIBSS = " // char (os_data%cxxlibs)
	write (u, "(A)") "LDFLAGS = " // char (os_data%ldflags)
	write (u, "(A)") "LDFLAGS_STATIC = " // char (os_data%ldflags_static)
	write (u, "(A)") "LDFLAGS_HEPMC = " // char (os_data%ldflags_hepmc)
	write (u, "(A)") "LDFLAGS_LCIO = " // char (os_data%ldflags_lcio)
	write (u, "(A)") "LDFLAGS_HOPPET = " // char (os_data%ldflags_hoppet)
	write (u, "(A)") "LDFLAGS_LOOPTOOLS = " // char (os_data%ldflags_looptools)
	write (u, "(A)") "LDWHIZARD = " // char (os_data%whizard_ldflags)
	write (u, "(A)") ""
	write (u, "(A)") "# Libtool"
	write (u, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool)
	if (verbose) then
	write (u, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile"
	if (OS_IS_DARWIN .and. .not. overwrite) then
	write (u, "(A)") "LINK = $(LIBTOOL) --tag=CXX --mode=link"
	else
	write (u, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link"
	end if
	else
	write (u, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile"
	if (OS_IS_DARWIN .and. .not. overwrite) then
	write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=CXX --mode=link"
	else
	write (u, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link"
	end if
	end if
	write (u, "(A)") ""
	write (u, "(A)") "# Compile commands (default)"
	write (u, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS)"
	write (u, "(A)") ""
	write (u, "(A)") "# Default target"
	write (u, "(A)") "all: link"
	write (u, "(A)") ""
	write (u, "(A)") "# Libraries"
	do i = 1, size (compilation%lib_name)
	associate (lib_name => compilation%lib_name(i))
	write (u, "(A)") "LIBRARIES += " // char (lib_name) // ".la"
	write (u, "(A)") char (lib_name) // ".la:"
	write (u, "(A)") TAB // "$(MAKE) -f " // char (lib_name) // ".makefile"
	end associate
	end do
	write (u, "(A)") ""
	write (u, "(A)") "# Library dispatcher"
	write (u, "(A)") "DISP = $(EXE)_prclib_dispatcher"
	write (u, "(A)") "$(DISP).lo: $(DISP).f90 $(LIBRARIES)"
	if (.not. verbose) then
	write (u, "(A)") TAB // '@echo " FC " $@'
	end if
	write (u, "(A)") TAB // "$(LTFCOMPILE) $<"
	write (u, "(A)") ""
	write (u, "(A)") "# Executable"
	write (u, "(A)") "$(EXE): $(DISP).lo $(LIBRARIES)"
	if (.not. verbose) then
	if (OS_IS_DARWIN .and. .not. overwrite) then
	write (u, "(A)") TAB // '@echo " CXXLD " $@'
	else
	write (u, "(A)") TAB // '@echo " FCLD " $@'
	end if
	end if
	if (OS_IS_DARWIN .and. .not. overwrite) then
	write (u, "(A)") TAB // "$(LINK) $(CXX) -static $(CXXFLAGS) \"
	else
	write (u, "(A)") TAB // "$(LINK) $(FC) -static $(FCFLAGS) \"
	end if
	write (u, "(A)") TAB // " $(LDWHIZARD) $(LDFLAGS) \"
	write (u, "(A)") TAB // " -o $(EXE) $^ \"
	write (u, "(A)") TAB // " $(LDFLAGS_HEPMC) $(LDFLAGS_LCIO) $(LDFLAGS_HOPPET) \"
	if (OS_IS_DARWIN .and. .not. overwrite) then
	write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC) \"
	write (u, "(A)") TAB // " $(CXXLIBS) $(FCLIBS)" // char (ext_tag)
	else
	write (u, "(A)") TAB // " $(LDFLAGS_LOOPTOOLS) $(LDFLAGS_STATIC)" // char (ext_tag)
	end if
	write (u, "(A)") ""
	write (u, "(A)") "# Main targets"
	write (u, "(A)") "link: compile $(EXE)"
	write (u, "(A)") "compile: $(LIBRARIES) $(DISP).lo"
	write (u, "(A)") ".PHONY: link compile"
	write (u, "(A)") ""
	write (u, "(A)") "# Cleanup targets"
	write (u, "(A)") "clean-exe:"
	write (u, "(A)") TAB // "rm -f $(EXE)"
	write (u, "(A)") "clean-objects:"
	write (u, "(A)") TAB // "rm -f $(DISP).lo"
	write (u, "(A)") "clean-source:"
	write (u, "(A)") TAB // "rm -f $(DISP).f90"
	write (u, "(A)") "clean-makefile:"
	write (u, "(A)") TAB // "rm -f $(EXE).makefile"
	write (u, "(A)") ""
	write (u, "(A)") "clean: clean-exe clean-objects clean-source"
	write (u, "(A)") "distclean: clean clean-makefile"
	write (u, "(A)") ".PHONY: clean distclean"
	close (u)
	end subroutine compilation_write_makefile

	@ %def compilation_write_makefile
	@ Compile the dispatcher source code.
	<<Compilations: compilation: TBP>>=
	procedure :: make_compile => compilation_make_compile
	<<Compilations: procedures>>=
	subroutine compilation_make_compile (compilation, os_data)
	class(compilation_t), intent(in) :: compilation
	type(os_data_t), intent(in) :: os_data
	call os_system_call ("make compile " // os_data%makeflags &
	// " -f " // compilation%exe_name // ".makefile")
	end subroutine compilation_make_compile

	@ %def compilation_make_compile
	@ Link the dispatcher together with all matrix-element code and the
	\whizard\ and \oMega\ main libraries, to generate a static executable.
	<<Compilations: compilation: TBP>>=
	procedure :: make_link => compilation_make_link
	<<Compilations: procedures>>=
	subroutine compilation_make_link (compilation, os_data)
	class(compilation_t), intent(in) :: compilation
	type(os_data_t), intent(in) :: os_data
	call os_system_call ("make link " // os_data%makeflags &
	// " -f " // compilation%exe_name // ".makefile")
	end subroutine compilation_make_link

	@ %def compilation_make_link
	@ Cleanup.
	<<Compilations: compilation: TBP>>=
	procedure :: make_clean_exe => compilation_make_clean_exe
	<<Compilations: procedures>>=
	subroutine compilation_make_clean_exe (compilation, os_data)
	class(compilation_t), intent(in) :: compilation
	type(os_data_t), intent(in) :: os_data
	call os_system_call ("make clean-exe " // os_data%makeflags &
	// " -f " // compilation%exe_name // ".makefile")
	end subroutine compilation_make_clean_exe

	@ %def compilation_make_clean_exe
	@
	\subsection{API for executable compilation}
	This is a shorthand for compiling and loading an executable, including
	the enclosed libraries. The [[compilation]] object is used only internally.

	The [[global]] data set may actually be local to the caller. The
	compilation affects the library specified by its name if it is on the
	stack, but it does not reset the currently selected library.
	<<Compilations: public>>=
	public :: compile_executable
	<<Compilations: procedures>>=
	subroutine compile_executable (exename, libname, global)
	type(string_t), intent(in) :: exename
	type(string_t), dimension(:), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: global
	type(compilation_t) :: compilation
	type(compilation_item_t) :: item
	type(string_t) :: ext_libtag
	logical :: force, recompile, verbose
	integer :: i
	ext_libtag = ""
	force = &
	global%var_list%get_lval (var_str ("?rebuild_library"))
	recompile = &
	global%var_list%get_lval (var_str ("?recompile_library"))
	verbose = &
	global%var_list%get_lval (var_str ("?me_verbose"))
	call compilation%init (exename, [libname])
	if (signal_is_pending ()) return
	call compilation%write_dispatcher ()
	if (signal_is_pending ()) return
	do i = 1, size (libname)
	call item%init (libname(i), global%prclib_stack, global%var_list)
	call item%compile (global%model, global%os_data, &
	force=force, recompile=recompile)
	ext_libtag = "" // item%lib%get_static_modelname (global%os_data)
	if (signal_is_pending ()) return
	call item%success ()
	end do
	call compilation%write_makefile &
	(global%os_data, ext_libtag=ext_libtag, verbose=verbose)
	if (signal_is_pending ()) return
	call compilation%make_compile (global%os_data)
	if (signal_is_pending ()) return
	call compilation%make_link (global%os_data)
	end subroutine compile_executable

	@ %def compile_executable
	@
	\subsection{Unit Tests}
	Test module, followed by the stand-alone unit-test procedures.
	<<[[compilations_ut.f90]]>>=
	<<File header>>

	module compilations_ut
	use unit_tests
	use compilations_uti

	<<Standard module head>>

	<<Compilations: public test>>

	contains

	<<Compilations: test driver>>

	end module compilations_ut
	@ %def compilations_ut
	@
	<<[[compilations_uti.f90]]>>=
	<<File header>>

	module compilations_uti

	<<Use strings>>
	use io_units
	use models
	use rt_data
	use process_configurations_ut, only: prepare_test_library

	use compilations

	<<Standard module head>>

	<<Compilations: test declarations>>

	contains

	<<Compilations: tests>>

	end module compilations_uti

	@ %def compilations_uti
	@ API: driver for the unit tests below.
	<<Compilations: public test>>=
	public :: compilations_test
	<<Compilations: test driver>>=
	subroutine compilations_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Compilations: execute tests>>
	end subroutine compilations_test

	@ %def compilations_test
	@
	\subsubsection{Intrinsic Matrix Element}
	Compile an intrinsic test matrix element ([[prc_test]] type).

	Note: In this and the following test, we reset the Fortran compiler and flag
	variables immediately before they are printed, so the test is portable.
	<<Compilations: execute tests>>=
	call test (compilations_1, "compilations_1", &
	"intrinsic test processes", &
	u, results)
	<<Compilations: test declarations>>=
	public :: compilations_1
	<<Compilations: tests>>=
	subroutine compilations_1 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: compilations_1"
	write (u, "(A)") "* Purpose: configure and compile test process"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	libname = "compilation_1"
	procname = "prc_comp_1"
	call prepare_test_library (global, libname, 1, [procname])

	call compile_library (libname, global)

	call global%write_libraries (u)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine compilations_1

	@ %def compilations_1
	@
	\subsubsection{External Matrix Element}
	Compile an external test matrix element ([[omega]] type)
	<<Compilations: execute tests>>=
	call test (compilations_2, "compilations_2", &
	"external process (omega)", &
	u, results)
	<<Compilations: test declarations>>=
	public :: compilations_2
	<<Compilations: tests>>=
	subroutine compilations_2 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: compilations_2"
	write (u, "(A)") "* Purpose: configure and compile test process"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	libname = "compilation_2"
	procname = "prc_comp_2"
	call prepare_test_library (global, libname, 2, [procname,procname])

	call compile_library (libname, global)

	call global%write_libraries (u, libpath = .false.)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine compilations_2

	@ %def compilations_2
	@
	\subsubsection{External Matrix Element}
	Compile an external test matrix element ([[omega]] type) and
	create driver files for a static executable.
	<<Compilations: execute tests>>=
	call test (compilations_3, "compilations_3", &
	"static executable: driver", &
	u, results)
	<<Compilations: test declarations>>=
	public :: compilations_3
	<<Compilations: tests>>=
	subroutine compilations_3 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname, exename
	type(rt_data_t), target :: global
	type(compilation_t) :: compilation
	integer :: u_file
	character(80) :: buffer

	write (u, "(A)") "* Test output: compilations_3"
	write (u, "(A)") "* Purpose: make static executable"
	write (u, "(A)")

	write (u, "(A)") "* Initialize library"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	libname = "compilations_3_lib"
	procname = "prc_comp_3"
	exename = "compilations_3"

	call prepare_test_library (global, libname, 2, [procname,procname])

	call compilation%init (exename, [libname])
	call compilation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write dispatcher"
	write (u, "(A)")

	call compilation%write_dispatcher ()

	u_file = free_unit ()
	open (u_file, file = char (exename) // "_prclib_dispatcher.f90", &
	status = "old", action = "read")
	do
	read (u_file, "(A)", end = 1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 close (u_file)

	write (u, "(A)")
	write (u, "(A)") "* Write Makefile"
	write (u, "(A)")

	associate (os_data => global%os_data)
	os_data%fc = "fortran-compiler"
	os_data%cxx = "c++-compiler"
	os_data%whizard_includes = "my-includes"
	os_data%fcflags = "my-fcflags"
	os_data%fclibs = "my-fclibs"
	os_data%cxxflags = "my-cxxflags"
	os_data%cxxlibs = "my-cxxlibs"
	os_data%ldflags = "my-ldflags"
	os_data%ldflags_static = "my-ldflags-static"
	os_data%ldflags_hepmc = "my-ldflags-hepmc"
	os_data%ldflags_lcio = "my-ldflags-lcio"
	os_data%ldflags_hoppet = "my-ldflags-hoppet"
	os_data%ldflags_looptools = "my-ldflags-looptools"
	os_data%whizard_ldflags = "my-ldwhizard"
	os_data%whizard_libtool = "my-libtool"
	end associate

	call compilation%write_makefile &
	(global%os_data, verbose = .true., overwrite_os = .true.)

	open (u_file, file = char (exename) // ".makefile", &
	status = "old", action = "read")
	do
	read (u_file, "(A)", end = 2) buffer
	write (u, "(A)") trim (buffer)
	end do
	2 close (u_file)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine compilations_3

	@ %def compilations_3
	@
	\subsection{Test static build}
	The tests for building a static executable are separate, since they
	should be skipped if the \whizard\ build itself has static libraries
	disabled.
	<<Compilations: public test>>=
	public :: compilations_static_test
	<<Compilations: test driver>>=
	subroutine compilations_static_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Compilations: static tests>>
	end subroutine compilations_static_test

	@ %def compilations_static_test
	@
	\subsubsection{External Matrix Element}
	Compile an external test matrix element ([[omega]] type) and
	incorporate this in a new static WHIZARD executable.
	<<Compilations: static tests>>=
	call test (compilations_static_1, "compilations_static_1", &
	"static executable: compilation", &
	u, results)
	<<Compilations: test declarations>>=
	public :: compilations_static_1
	<<Compilations: tests>>=
	subroutine compilations_static_1 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname, exename
	type(rt_data_t), target :: global
	type(compilation_item_t) :: item
	type(compilation_t) :: compilation
	logical :: exist

	write (u, "(A)") "* Test output: compilations_static_1"
	write (u, "(A)") "* Purpose: make static executable"
	write (u, "(A)")

	write (u, "(A)") "* Initialize library"

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	libname = "compilations_static_1_lib"
	procname = "prc_comp_stat_1"
	exename = "compilations_static_1"

	call prepare_test_library (global, libname, 2, [procname,procname])

	call compilation%init (exename, [libname])

	write (u, "(A)")
	write (u, "(A)") "* Write dispatcher"

	call compilation%write_dispatcher ()

	write (u, "(A)")
	write (u, "(A)") "* Write Makefile"

	call compilation%write_makefile (global%os_data, verbose = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Build libraries"

	call item%init (libname, global%prclib_stack, global%var_list)
	call item%compile &
	(global%model, global%os_data, force=.true., recompile=.false.)
	call item%success ()

	write (u, "(A)")
	write (u, "(A)") "* Check executable (should be absent)"
	write (u, "(A)")

	call compilation%make_clean_exe (global%os_data)
	inquire (file = char (exename), exist = exist)
	write (u, "(A,A,L1)") char (exename), " exists = ", exist

	write (u, "(A)")
	write (u, "(A)") "* Build executable"
	write (u, "(A)")

	call compilation%make_compile (global%os_data)
	call compilation%make_link (global%os_data)

	write (u, "(A)") "* Check executable (should be present)"
	write (u, "(A)")

	inquire (file = char (exename), exist = exist)
	write (u, "(A,A,L1)") char (exename), " exists = ", exist

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

	call compilation%make_clean_exe (global%os_data)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine compilations_static_1

	@ %def compilations_static_1
	@
	\subsubsection{External Matrix Element}
	Compile an external test matrix element ([[omega]] type) and
	incorporate this in a new static WHIZARD executable. In this version,
	we use the wrapper [[compile_executable]] procedure.
	<<Compilations: static tests>>=
	call test (compilations_static_2, "compilations_static_2", &
	"static executable: shortcut", &
	u, results)
	<<Compilations: test declarations>>=
	public :: compilations_static_2
	<<Compilations: tests>>=
	subroutine compilations_static_2 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname, exename
	type(rt_data_t), target :: global
	logical :: exist
	integer :: u_file

	write (u, "(A)") "* Test output: compilations_static_2"
	write (u, "(A)") "* Purpose: make static executable"
	write (u, "(A)")

	write (u, "(A)") "* Initialize library and compile"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	libname = "compilations_static_2_lib"
	procname = "prc_comp_stat_2"
	exename = "compilations_static_2"

	call prepare_test_library (global, libname, 2, [procname,procname])

	call compile_executable (exename, [libname], global)

	write (u, "(A)") "* Check executable (should be present)"
	write (u, "(A)")

	inquire (file = char (exename), exist = exist)
	write (u, "(A,A,L1)") char (exename), " exists = ", exist

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

	u_file = free_unit ()
	open (u_file, file = char (exename), status = "old", action = "write")
	close (u_file, status = "delete")

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine compilations_static_2

	@ %def compilations_static_2
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Integration}
	This module manages phase space setup, matrix-element evaluation and
	integration, as far as it is not done by lower-level routines, in particular
	in the [[processes]] module.
	<<[[integrations.f90]]>>=
	<<File header>>

	module integrations

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use diagnostics
	use os_interface
	use cputime
	use sm_qcd
	use physics_defs
	use model_data
	use pdg_arrays
	use variables, only: var_list_t
	use eval_trees
	use sf_mappings
	use sf_base
	use phs_base
	use rng_base
	use mci_base
	use process_libraries
	use prc_core
	use process_config, only: COMP_MASTER, COMP_REAL_FIN, &
	COMP_MISMATCH, COMP_PDF, COMP_REAL, COMP_SUB, COMP_VIRT, &
	COMP_REAL_SING
	use process
	use pcm_base, only: pcm_t
	use instances
	use process_stacks
	use models
	use iterations
	use rt_data

	use dispatch_me_methods, only: dispatch_core
	use dispatch_beams, only: dispatch_qcd, sf_prop_t, dispatch_sf_config
	use dispatch_phase_space, only: dispatch_sf_channels
	use dispatch_phase_space, only: dispatch_phs
	use dispatch_mci, only: dispatch_mci_s, setup_grid_path
	use dispatch_transforms, only: dispatch_evt_shower_hook

	use compilations, only: compile_library

	use dispatch_fks, only: dispatch_fks_s
	use nlo_data
	<<Use mpi f08>>

	<<Standard module head>>

	<<Integrations: public>>

	<<Integrations: types>>

	contains

	<<Integrations: procedures>>

	end module integrations
	@ %def integrations
	@
	\subsection{The integration type}
	This type holds all relevant data, the integration methods operates on this.
	In contrast to the [[simulation_t]] introduced later, the [[integration_t]]
	applies to a single process.
	<<Integrations: public>>=
	public :: integration_t
	<<Integrations: types>>=
	type :: integration_t
	private
	type(string_t) :: process_id
	type(string_t) :: run_id
	type(process_t), pointer :: process => null ()
	logical :: rebuild_phs = .false.
	logical :: ignore_phs_mismatch = .false.
	logical :: phs_only = .false.
	logical :: process_has_me = .true.
	integer :: n_calls_test = 0
	logical :: vis_history = .true.
	type(string_t) :: history_filename
	type(string_t) :: log_filename
	type(helicity_selection_t) :: helicity_selection
	logical :: use_color_factors = .false.
	logical :: has_beam_pol = .false.
	logical :: combined_integration = .false.
	type(iteration_multipliers_t) :: iteration_multipliers
	type(nlo_settings_t) :: nlo_settings
	contains
	<<Integrations: integration: TBP>>
	end type integration_t

	@ %def integration_t
	@
	@
	\subsection{Initialization}
	Initialization, first part: Create a process entry.
	Push it on the stack if the [[global]] environment is supplied.
	<<Integrations: integration: TBP>>=
	procedure :: create_process => integration_create_process
	<<Integrations: procedures>>=
	subroutine integration_create_process (intg, process_id, global)
	class(integration_t), intent(out) :: intg
	type(rt_data_t), intent(inout), optional, target :: global
	type(string_t), intent(in) :: process_id
	type(process_entry_t), pointer :: process_entry
	if (debug_on) call msg_debug (D_CORE, "integration_create_process")
	intg%process_id = process_id
	if (present (global)) then
	allocate (process_entry)
	intg%process => process_entry%process_t
	call global%process_stack%push (process_entry)
	else
	allocate (process_t :: intg%process)
	end if
	end subroutine integration_create_process

	@ %def integration_create_process
	@ Initialization, second part: Initialize the process object, using the local
	environment. We allocate a RNG factory and a QCD object.
	We also fetch a pointer to the model that the process uses. The
	process initializer will create a snapshot of that model.

	This procedure
	does not modify the [[local]] stack directly. The intent(inout) attribute for
	the [[local]] data set is due to the random generator seed which may be
	incremented during initialization.

	NOTE: Changes to model parameters within the current context are respected
	only if the process model coincides with the current model. This is the usual
	case. If not, we read
	the model from the global model library, which has default parameters. To
	become more flexible, we should implement a local model library which records
	local changes to currently inactive models.
	<<Integrations: integration: TBP>>=
	procedure :: init_process => integration_init_process
	<<Integrations: procedures>>=
	subroutine integration_init_process (intg, local)
	class(integration_t), intent(inout) :: intg
	type(rt_data_t), intent(inout), target :: local
	type(string_t) :: model_name
	type(model_t), pointer :: model
	class(model_data_t), pointer :: model_instance
	type(var_list_t), pointer :: var_list
	if (debug_on) call msg_debug (D_CORE, "integration_init_process")
	if (.not. local%prclib%contains (intg%process_id)) then
	call msg_fatal ("Process '" // char (intg%process_id) // "' not found" &
	// " in library '" // char (local%prclib%get_name ()) // "'")
	return
	end if
	model_name = local%prclib%get_model_name (intg%process_id)
	if (local%get_sval (var_str ("$model_name")) == model_name) then
	model => local%model
	else
	model => local%model_list%get_model_ptr (model_name)
	end if
	var_list => local%get_var_list_ptr ()
	call intg%process%init (intg%process_id, &
	local%prclib, &
	local%os_data, &
	model, &
	var_list, &
	local%beam_structure)
	intg%run_id = intg%process%get_run_id ()
	end subroutine integration_init_process

	@ %def integration_init_process
	@ Initialization, third part: complete process configuration.
	<<Integrations: integration: TBP>>=
	procedure :: setup_process => integration_setup_process
	<<Integrations: procedures>>=
	subroutine integration_setup_process (intg, local, verbose, init_only)
	class(integration_t), intent(inout) :: intg
	type(rt_data_t), intent(inout), target :: local
	logical, intent(in), optional :: verbose
	logical, intent(in), optional :: init_only

	type(var_list_t), pointer :: var_list
	class(mci_t), allocatable :: mci_template
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_prop_t) :: sf_prop
	type(sf_channel_t), dimension(:), allocatable :: sf_channel
	type(phs_channel_collection_t) :: phs_channel_collection
	logical :: sf_trace
	logical :: verb, initialize_only
	type(string_t) :: sf_string
	type(string_t) :: workspace
	real(default) :: sqrts

	verb = .true.; if (present (verbose)) verb = verbose

	initialize_only = .false.
	if (present (init_only)) initialize_only = init_only

	call display_init_message (verb)

	var_list => local%get_var_list_ptr ()
	call setup_log_and_history ()

	associate (process => intg%process)
	call set_intg_parameters (process)

	call process%setup_cores (dispatch_core, &
	intg%helicity_selection, intg%use_color_factors, intg%has_beam_pol)

	call process%init_phs_config ()
	call process%init_components ()

	call process%record_inactive_components ()
	intg%process_has_me = process%has_matrix_element ()
	if (.not. intg%process_has_me) then
	call msg_warning ("Process '" &
	// char (intg%process_id) // "': matrix element vanishes")
	end if

	call setup_beams ()
	call setup_structure_functions ()

	workspace = var_list%get_sval (var_str ("$integrate_workspace"))
	if (workspace == "") then
	call process%configure_phs &
	(intg%rebuild_phs, &
	intg%ignore_phs_mismatch, &
	intg%combined_integration)
	else
	call setup_grid_path (workspace)
	call process%configure_phs &
	(intg%rebuild_phs, &
	intg%ignore_phs_mismatch, &
	intg%combined_integration, &
	workspace)
	end if

	call process%complete_pcm_setup ()

	call process%prepare_blha_cores ()
	call process%create_blha_interface ()
	call process%prepare_any_external_code ()

	call process%setup_terms (with_beams = intg%has_beam_pol)
	call process%check_masses ()
	call process%optimize_nlo_singular_regions ()

	if (verb) then
	call process%write (screen = .true.)
	call process%print_phs_startup_message ()
	end if

	if (intg%process_has_me) then
	if (size (sf_config) > 0) then
	call process%collect_channels (phs_channel_collection)
	else if (.not. initialize_only &
	.and. process%contains_trivial_component ()) then
	call msg_fatal ("Integrate: 2 -> 1 process can't be handled &
	&with fixed-energy beams")
	end if
	if (local%beam_structure%asymmetric ()) then
	sqrts = process%get_sqrts ()
	else
	sqrts = local%get_sqrts ()
	end if
	call dispatch_sf_channels &
	(sf_channel, sf_string, sf_prop, phs_channel_collection, &
	local%var_list, sqrts, local%beam_structure)
	if (allocated (sf_channel)) then
	if (size (sf_channel) > 0) then
	call process%set_sf_channel (sf_channel)
	end if
	end if
	call phs_channel_collection%final ()
	if (verb) call process%sf_startup_message (sf_string)
	end if

	call process%setup_mci (dispatch_mci_s)

	call setup_expressions ()

	call process%compute_md5sum ()
	end associate

	contains

	subroutine setup_log_and_history ()
	if (intg%run_id /= "") then
	intg%history_filename = intg%process_id // "." // intg%run_id &
	// ".history"
	intg%log_filename = intg%process_id // "." // intg%run_id // ".log"
	else
	intg%history_filename = intg%process_id // ".history"
	intg%log_filename = intg%process_id // ".log"
	end if
	intg%vis_history = &
	var_list%get_lval (var_str ("?vis_history"))
	end subroutine setup_log_and_history

	subroutine set_intg_parameters (process)
	type(process_t), intent(in) :: process
	intg%n_calls_test = &
	var_list%get_ival (var_str ("n_calls_test"))
	intg%combined_integration = &
	var_list%get_lval (var_str ('?combined_nlo_integration')) &
	.and. process%is_nlo_calculation ()
	intg%use_color_factors = &
	var_list%get_lval (var_str ("?read_color_factors"))
	intg%has_beam_pol = &
	local%beam_structure%has_polarized_beams ()
	intg%helicity_selection = &
	local%get_helicity_selection ()
	intg%rebuild_phs = &
	var_list%get_lval (var_str ("?rebuild_phase_space"))
	intg%ignore_phs_mismatch = &
	.not. var_list%get_lval (var_str ("?check_phs_file"))
	intg%phs_only = &
	var_list%get_lval (var_str ("?phs_only"))
	end subroutine set_intg_parameters

	subroutine display_init_message (verb)
	logical, intent(in) :: verb
	if (verb) then
	call msg_message ("Initializing integration for process " &
	// char (intg%process_id) // ":")
	if (intg%run_id /= "") &
	call msg_message ("Run ID = " // '"' // char (intg%run_id) // '"')
	end if
	end subroutine display_init_message

	subroutine setup_beams ()
	real(default) :: sqrts
	logical :: decay_rest_frame
	sqrts = local%get_sqrts ()
	decay_rest_frame = &
	var_list%get_lval (var_str ("?decay_rest_frame"))
	if (intg%process_has_me) then
	call intg%process%setup_beams_beam_structure &
	(local%beam_structure, sqrts, decay_rest_frame)
	end if
	if (verb .and. intg%process_has_me) then
	call intg%process%beams_startup_message &
	(beam_structure = local%beam_structure)
	end if
	end subroutine setup_beams

	subroutine setup_structure_functions ()
	integer :: n_in
	type(pdg_array_t), dimension(:,:), allocatable :: pdg_prc
	type(string_t) :: sf_trace_file
	if (intg%process_has_me) then
	call intg%process%get_pdg_in (pdg_prc)
	else
	n_in = intg%process%get_n_in ()
	allocate (pdg_prc (n_in, intg%process%get_n_components ()))
	pdg_prc = 0
	end if
	call dispatch_sf_config (sf_config, sf_prop, local%beam_structure, &
	local%get_var_list_ptr (), local%var_list, &
	local%model, local%os_data, local%get_sqrts (), pdg_prc)

	sf_trace = &
	var_list%get_lval (var_str ("?sf_trace"))
	sf_trace_file = &
	var_list%get_sval (var_str ("$sf_trace_file"))
	if (sf_trace) then
	call intg%process%init_sf_chain (sf_config, sf_trace_file)
	else
	call intg%process%init_sf_chain (sf_config)
	end if
	end subroutine setup_structure_functions

	subroutine setup_expressions ()
	type(eval_tree_factory_t) :: expr_factory
	if (associated (local%pn%cuts_lexpr)) then
	if (verb) call msg_message ("Applying user-defined cuts.")
	call expr_factory%init (local%pn%cuts_lexpr)
	call intg%process%set_cuts (expr_factory)
	else
	if (verb) call msg_warning ("No cuts have been defined.")
	end if
	if (associated (local%pn%scale_expr)) then
	if (verb) call msg_message ("Using user-defined general scale.")
	call expr_factory%init (local%pn%scale_expr)
	call intg%process%set_scale (expr_factory)
	end if
	if (associated (local%pn%fac_scale_expr)) then
	if (verb) call msg_message ("Using user-defined factorization scale.")
	call expr_factory%init (local%pn%fac_scale_expr)
	call intg%process%set_fac_scale (expr_factory)
	end if
	if (associated (local%pn%ren_scale_expr)) then
	if (verb) call msg_message ("Using user-defined renormalization scale.")
	call expr_factory%init (local%pn%ren_scale_expr)
	call intg%process%set_ren_scale (expr_factory)
	end if
	if (associated (local%pn%weight_expr)) then
	if (verb) call msg_message ("Using user-defined reweighting factor.")
	call expr_factory%init (local%pn%weight_expr)
	call intg%process%set_weight (expr_factory)
	end if
	end subroutine setup_expressions
	end subroutine integration_setup_process

	@ %def integration_setup_process
	@
	\subsection{Integration}
	Integrate: do the final integration. Here, we do a multi-iteration
	integration. Again, we skip iterations that are already on file.
	Record the results in the global variable list.
	<<Integrations: integration: TBP>>=
	procedure :: evaluate => integration_evaluate
	<<Integrations: procedures>>=
	subroutine integration_evaluate &
	(intg, process_instance, i_mci, pass, it_list, pacify)
	class(integration_t), intent(inout) :: intg
	type(process_instance_t), intent(inout), target :: process_instance
	integer, intent(in) :: i_mci
	integer, intent(in) :: pass
	type(iterations_list_t), intent(in) :: it_list
	logical, intent(in), optional :: pacify
	integer :: n_calls, n_it
	logical :: adapt_grids, adapt_weights, final
	n_it = it_list%get_n_it (pass)
	n_calls = it_list%get_n_calls (pass)
	adapt_grids = it_list%adapt_grids (pass)
	adapt_weights = it_list%adapt_weights (pass)
	final = pass == it_list%get_n_pass ()
	call process_instance%integrate ( &
	i_mci, n_it, n_calls, adapt_grids, adapt_weights, &
	final, pacify)
	end subroutine integration_evaluate

	@ %def integration_evaluate
	@ In case the user has not provided a list of iterations, make a
	reasonable default. This can depend on the process. The usual
	approach is to define two distinct passes, one for adaptation and one
	for integration.
	<<Integrations: integration: TBP>>=
	procedure :: make_iterations_list => integration_make_iterations_list
	<<Integrations: procedures>>=
	subroutine integration_make_iterations_list (intg, it_list)
	class(integration_t), intent(in) :: intg
	type(iterations_list_t), intent(out) :: it_list
	integer :: pass, n_pass
	integer, dimension(:), allocatable :: n_it, n_calls
	logical, dimension(:), allocatable :: adapt_grids, adapt_weights
	n_pass = intg%process%get_n_pass_default ()
	allocate (n_it (n_pass), n_calls (n_pass))
	allocate (adapt_grids (n_pass), adapt_weights (n_pass))
	do pass = 1, n_pass
	n_it(pass) = intg%process%get_n_it_default (pass)
	n_calls(pass) = intg%process%get_n_calls_default (pass)
	adapt_grids(pass) = intg%process%adapt_grids_default (pass)
	adapt_weights(pass) = intg%process%adapt_weights_default (pass)
	end do
	call it_list%init (n_it, n_calls, &
	adapt_grids = adapt_grids, adapt_weights = adapt_weights)
	end subroutine integration_make_iterations_list

	@ %def integration_make_iterations_list
	@ In NLO calculations, the individual components might scale very differently
	with the number of calls. This especially applies to the real-subtracted
	component, which usually fluctuates more than the Born and virtual
	component, making it a bottleneck of the calculation. Thus, the calculation
	is throttled twice, first by the number of calls for the real component,
	second by the number of surplus calls of computation-intense virtual
	matrix elements. Therefore, we want to set a different number of calls
	for each component, which is done by the subroutine [[integration_apply_call_multipliers]].
	<<Integrations: integration: TBP>>=
	procedure :: init_iteration_multipliers => integration_init_iteration_multipliers
	<<Integrations: procedures>>=
	subroutine integration_init_iteration_multipliers (intg, local)
	class(integration_t), intent(inout) :: intg
	type(rt_data_t), intent(in) :: local
	integer :: n_pass, pass
	type(iterations_list_t) :: it_list
	n_pass = local%it_list%get_n_pass ()
	if (n_pass == 0) then
	call intg%make_iterations_list (it_list)
	n_pass = it_list%get_n_pass ()
	end if
	associate (it_multipliers => intg%iteration_multipliers)
	allocate (it_multipliers%n_calls0 (n_pass))
	do pass = 1, n_pass
	it_multipliers%n_calls0(pass) = local%it_list%get_n_calls (pass)
	end do
	it_multipliers%mult_real = local%var_list%get_rval &
	(var_str ("mult_call_real"))
	it_multipliers%mult_virt = local%var_list%get_rval &
	(var_str ("mult_call_virt"))
	it_multipliers%mult_dglap = local%var_list%get_rval &
	(var_str ("mult_call_dglap"))
	end associate
	end subroutine integration_init_iteration_multipliers

	@ %def integration_init_iteration_multipliers
	@
	<<Integrations: integration: TBP>>=
	procedure :: apply_call_multipliers => integration_apply_call_multipliers
	<<Integrations: procedures>>=
	subroutine integration_apply_call_multipliers (intg, n_pass, i_component, it_list)
	class(integration_t), intent(in) :: intg
	integer, intent(in) :: n_pass, i_component
	type(iterations_list_t), intent(inout) :: it_list
	integer :: nlo_type
	integer :: n_calls0, n_calls
	integer :: pass
	real(default) :: multiplier
	nlo_type = intg%process%get_component_nlo_type (i_component)
	do pass = 1, n_pass
	associate (multipliers => intg%iteration_multipliers)
	select case (nlo_type)
	case (NLO_REAL)
	multiplier = multipliers%mult_real
	case (NLO_VIRTUAL)
	multiplier = multipliers%mult_virt
	case (NLO_DGLAP)
	multiplier = multipliers%mult_dglap
	case default
	return
	end select
	end associate
	if (n_pass <= size (intg%iteration_multipliers%n_calls0)) then
	n_calls0 = intg%iteration_multipliers%n_calls0 (pass)
	n_calls = floor (multiplier * n_calls0)
	call it_list%set_n_calls (pass, n_calls)
	end if
	end do
	end subroutine integration_apply_call_multipliers

	@ %def integration_apply_call_multipliers
	@
	\subsection{API for integration objects}
	This initializer does everything except assigning cuts/scale/weight
	expressions.
	<<Integrations: integration: TBP>>=
	procedure :: init => integration_init
	<<Integrations: procedures>>=
	subroutine integration_init &
	(intg, process_id, local, global, local_stack, init_only)
	class(integration_t), intent(out) :: intg
	type(string_t), intent(in) :: process_id
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	logical, intent(in), optional :: init_only
	logical, intent(in), optional :: local_stack
	logical :: use_local
	use_local = .false.; if (present (local_stack)) use_local = local_stack
	if (present (global)) then
	call intg%create_process (process_id, global)
	else if (use_local) then
	call intg%create_process (process_id, local)
	else
	call intg%create_process (process_id)
	end if
	call intg%init_process (local)
	call intg%setup_process (local, init_only = init_only)
	call intg%init_iteration_multipliers (local)
	end subroutine integration_init

	@ %def integration_init
	@ Do the integration for a single process, both warmup and final evaluation.
	The [[eff_reset]] flag is to suppress numerical noise in the graphical output
	of the integration history.
	<<Integrations: integration: TBP>>=
	procedure :: integrate => integration_integrate
	<<Integrations: procedures>>=
	subroutine integration_integrate (intg, local, eff_reset)
	class(integration_t), intent(inout) :: intg
	type(rt_data_t), intent(in), target :: local
	logical, intent(in), optional :: eff_reset
	type(string_t) :: log_filename
	type(var_list_t), pointer :: var_list
	type(process_instance_t), allocatable, target :: process_instance
	type(iterations_list_t) :: it_list
	logical :: pacify
	integer :: pass, i_mci, n_mci, n_pass
	integer :: i_component
	integer :: nlo_type
	logical :: display_summed
	logical :: nlo_active
	type(string_t) :: component_output

	allocate (process_instance)
	call process_instance%init (intg%process)

	var_list => intg%process%get_var_list_ptr ()
	call openmp_set_num_threads_verbose &
	(var_list%get_ival (var_str ("openmp_num_threads")), &
	var_list%get_lval (var_str ("?openmp_logging")))
	pacify = var_list%get_lval (var_str ("?pacify"))

	display_summed = .true.
	n_mci = intg%process%get_n_mci ()
	if (n_mci == 1) then
	write (msg_buffer, "(A,A,A)") &
	"Starting integration for process '", &
	char (intg%process%get_id ()), "'"
	call msg_message ()
	end if

	call setup_hooks ()

	nlo_active = any (intg%process%get_component_nlo_type &
	([(i_mci, i_mci = 1, n_mci)]) /= BORN)
	do i_mci = 1, n_mci
	i_component = intg%process%get_master_component (i_mci)
	nlo_type = intg%process%get_component_nlo_type (i_component)
	if (intg%process%component_can_be_integrated (i_component)) then
	if (n_mci > 1) then
	if (nlo_active) then
	if (intg%combined_integration .and. nlo_type == BORN) then
	component_output = var_str ("Combined")
	else
	component_output = component_status (nlo_type)
	end if
	write (msg_buffer, "(A,A,A,A,A)") &
	"Starting integration for process '", &
	char (intg%process%get_id ()), "' part '", &
	char (component_output), "'"
	else
	write (msg_buffer, "(A,A,A,I0)") &
	"Starting integration for process '", &
	char (intg%process%get_id ()), "' part ", i_mci
	end if
	call msg_message ()
	end if
	n_pass = local%it_list%get_n_pass ()
	if (n_pass == 0) then
	call msg_message ("Integrate: iterations not specified, &
	&using default")
	call intg%make_iterations_list (it_list)
	n_pass = it_list%get_n_pass ()
	else
	it_list = local%it_list
	end if
	call intg%apply_call_multipliers (n_pass, i_mci, it_list)
	call msg_message ("Integrate: " // char (it_list%to_string ()))
	do pass = 1, n_pass
	call intg%evaluate (process_instance, i_mci, pass, it_list, pacify)
	if (signal_is_pending ()) return
	end do
	call intg%process%final_integration (i_mci)
	if (intg%vis_history) then
	call intg%process%display_integration_history &
	(i_mci, intg%history_filename, local%os_data, eff_reset)
	end if
	if (local%logfile == intg%log_filename) then
	if (intg%run_id /= "") then
	log_filename = intg%process_id // "." // intg%run_id // &
	".var.log"
	else
	log_filename = intg%process_id // ".var.log"
	end if
	call msg_message ("Name clash for global logfile and process log: ", &
	arr =[var_str ("\| Renaming log file from ") // local%logfile, &
	var_str ("\| to ") // log_filename // var_str (" .")])
	else
	log_filename = intg%log_filename
	end if
	call intg%process%write_logfile (i_mci, log_filename)
	end if
	end do

	if (n_mci > 1 .and. display_summed) then
	call msg_message ("Integrate: sum of all components")
	call intg%process%display_summed_results (pacify)
	end if

	call process_instance%final ()
	deallocate (process_instance)
	contains
	subroutine setup_hooks ()
	class(process_instance_hook_t), pointer :: hook
	call dispatch_evt_shower_hook (hook, var_list, process_instance)
	if (associated (hook)) then
	call process_instance%append_after_hook (hook)
	end if
	end subroutine setup_hooks
	end subroutine integration_integrate

	@ %def integration_integrate
	@ Do a dummy integration for a process which could not be initialized (e.g.,
	has no matrix element). The result is zero.
	<<Integrations: integration: TBP>>=
	procedure :: integrate_dummy => integration_integrate_dummy
	<<Integrations: procedures>>=
	subroutine integration_integrate_dummy (intg)
	class(integration_t), intent(inout) :: intg
	call intg%process%integrate_dummy ()
	end subroutine integration_integrate_dummy

	@ %def integration_integrate_dummy
	@ Just sample the matrix element under realistic conditions (but no
	cuts); throw away the results.
	<<Integrations: integration: TBP>>=
	procedure :: sampler_test => integration_sampler_test
	<<Integrations: procedures>>=
	subroutine integration_sampler_test (intg)
	class(integration_t), intent(inout) :: intg
	type(process_instance_t), allocatable, target :: process_instance
	integer :: n_mci, i_mci
	type(timer_t) :: timer_mci, timer_tot
	real(default) :: t_mci, t_tot
	allocate (process_instance)
	call process_instance%init (intg%process)
	n_mci = intg%process%get_n_mci ()
	if (n_mci == 1) then
	write (msg_buffer, "(A,A,A)") &
	"Test: probing process '", &
	char (intg%process%get_id ()), "'"
	call msg_message ()
	end if
	call timer_tot%start ()
	do i_mci = 1, n_mci
	if (n_mci > 1) then
	write (msg_buffer, "(A,A,A,I0)") &
	"Test: probing process '", &
	char (intg%process%get_id ()), "' part ", i_mci
	call msg_message ()
	end if
	call timer_mci%start ()
	call process_instance%sampler_test (i_mci, intg%n_calls_test)
	call timer_mci%stop ()
	t_mci = timer_mci
	write (msg_buffer, "(A,ES12.5)") "Test: " &
	// "time in seconds (wallclock): ", t_mci
	call msg_message ()
	end do
	call timer_tot%stop ()
	t_tot = timer_tot
	if (n_mci > 1) then
	write (msg_buffer, "(A,ES12.5)") "Test: " &
	// "total time (wallclock): ", t_tot
	call msg_message ()
	end if
	call process_instance%final ()
	end subroutine integration_sampler_test

	@ %def integration_sampler_test
	@ Return the process pointer (needed by simulate):
	<<Integrations: integration: TBP>>=
	procedure :: get_process_ptr => integration_get_process_ptr
	<<Integrations: procedures>>=
	function integration_get_process_ptr (intg) result (ptr)
	class(integration_t), intent(in) :: intg
	type(process_t), pointer :: ptr
	ptr => intg%process
	end function integration_get_process_ptr

	@ %def integration_get_process_ptr
	@ Simply integrate, do a dummy integration if necessary. The [[integration]]
	object exists only internally.

	If the [[global]] environment is provided, the process object is appended to
	the global stack. Otherwise, if [[local_stack]] is set, we append to the
	local process stack. If this is unset, the [[process]] object is not recorded
	permanently.

	The [[init_only]] flag can be used to skip the actual integration part. We
	will end up with a process object that is completely initialized, including
	phase space configuration.

	The [[eff_reset]] flag is to suppress numerical noise in the visualization
	of the integration history.
	<<Integrations: public>>=
	public :: integrate_process
	<<Integrations: procedures>>=
	subroutine integrate_process (process_id, local, global, local_stack, init_only, eff_reset)
	type(string_t), intent(in) :: process_id
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	logical, intent(in), optional :: local_stack, init_only, eff_reset
	type(string_t) :: prclib_name
	type(integration_t) :: intg
	character(32) :: buffer
	<<Integrations: integrate process: variables>>
	<<Integrations: integrate process: init>>
	if (.not. associated (local%prclib)) then
	call msg_fatal ("Integrate: current process library is undefined")
	return
	end if

	if (.not. local%prclib%is_active ()) then
	call msg_message ("Integrate: current process library needs compilation")
	prclib_name = local%prclib%get_name ()
	call compile_library (prclib_name, local)
	if (signal_is_pending ()) return
	call msg_message ("Integrate: compilation done")
	end if

	call intg%init (process_id, local, global, local_stack, init_only)
	if (signal_is_pending ()) return

	if (present (init_only)) then
	if (init_only) return
	end if

	if (intg%n_calls_test > 0) then
	write (buffer, "(I0)") intg%n_calls_test
	call msg_message ("Integrate: test (" // trim (buffer) // " calls) ...")
	call intg%sampler_test ()
	call msg_message ("Integrate: ... test complete.")
	if (signal_is_pending ()) return
	end if
	<<Integrations: integrate process: end init>>

	if (intg%phs_only) then
	call msg_message ("Integrate: phase space only, skipping integration")
	else
	if (intg%process_has_me) then
	call intg%integrate (local, eff_reset)
	else
	call intg%integrate_dummy ()
	end if
	end if
	end subroutine integrate_process

	@ %def integrate_process
	<<Integrations: integrate process: variables>>=
	@
	<<Integrations: integrate process: init>>=
	@
	<<Integrations: integrate process: end init>>=
	@
	@ The parallelization leads to undefined behavior while writing simultaneously to one file.
	The master worker has to initialize single-handed the corresponding library files and the phase space file.
	The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
	<<MPI: Integrations: integrate process: variables>>=
	type(var_list_t), pointer :: var_list
	logical :: mpi_logging, process_init
	integer :: rank, n_size
	<<MPI: Integrations: integrate process: init>>=
	if (debug_on) call msg_debug (D_MPI, "integrate_process")
	var_list => local%get_var_list_ptr ()
	process_init = .false.
	call mpi_get_comm_id (n_size, rank)
	mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) .and. &
	& (n_size > 1)) .or. var_list%get_lval (var_str ("?mpi_logging")))
	if (debug_on) call msg_debug (D_MPI, "n_size", rank)
	if (debug_on) call msg_debug (D_MPI, "rank", rank)
	if (debug_on) call msg_debug (D_MPI, "mpi_logging", mpi_logging)
	if (rank /= 0) then
	if (mpi_logging) then
	call msg_message ("MPI: wait for master to finish process initialization ...")
	end if
	call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
	else
	process_init = .true.
	end if

	if (process_init) then
	<<MPI: Integrations: integrate process: end init>>=
	if (rank == 0) then
	if (mpi_logging) then
	call msg_message ("MPI: finish process initialization, load slaves ...")
	end if
	call MPI_bcast (process_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
	end if
	end if
	call MPI_barrier (MPI_COMM_WORLD)
	call mpi_set_logging (mpi_logging)
	@ %def integrate_process_mpi
	@
	\subsection{Unit Tests}
	Test module, followed by the stand-alone unit-test procedures.
	<<[[integrations_ut.f90]]>>=
	<<File header>>

	module integrations_ut
	use unit_tests
	use integrations_uti

	<<Standard module head>>

	<<Integrations: public test>>

	contains

	<<Integrations: test driver>>

	end module integrations_ut
	@ %def integrations_ut
	@
	<<[[integrations_uti.f90]]>>=
	<<File header>>

	module integrations_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use ifiles
	use lexers
	use parser
	use flavors
	use interactions, only: reset_interaction_counter
	use phs_forests
	use eval_trees
	use models
	use rt_data
	use process_configurations_ut, only: prepare_test_library
	use compilations, only: compile_library

	use integrations

	use phs_wood_ut, only: write_test_phs_file

	<<Standard module head>>

	<<Integrations: test declarations>>

	contains

	<<Integrations: tests>>

	end module integrations_uti

	@ %def integrations_uti
	@ API: driver for the unit tests below.
	<<Integrations: public test>>=
	public :: integrations_test
	<<Integrations: test driver>>=
	subroutine integrations_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Integrations: execute tests>>
	end subroutine integrations_test

	@ %def integrations_test
	@
	<<Integrations: public test>>=
	public :: integrations_history_test
	<<Integrations: test driver>>=
	subroutine integrations_history_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Integrations: execute history tests>>
	end subroutine integrations_history_test

	@ %def integrations_history_test
	@
	\subsubsection{Integration of test process}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type). The phase-space implementation is [[phs_single]]
	(single-particle phase space), the integrator is [[mci_midpoint]].

	The cross section for the $2\to 2$ process $ss\to ss$ with its
	constant matrix element is given by
	\begin{equation}
	\sigma = c\times f\times \Phi_2 \times \|M\|^2.
	\end{equation}
	$c$ is the conversion constant
	\begin{equation}
	c = 0.3894\times 10^{12}\;\mathrm{fb}\,\mathrm{GeV}^2.
	\end{equation}
	$f$ is the flux of the incoming particles with mass
	$m=125\,\mathrm{GeV}$ and energy $\sqrt{s}=1000\,\mathrm{GeV}$
	\begin{equation}
	f = \frac{(2\pi)^4}{2\lambda^{1/2}(s,m^2,m^2)}
	= \frac{(2\pi)^4}{2\sqrt{s}\,\sqrt{s - 4m^2}}
	= 8.048\times 10^{-4}\;\mathrm{GeV}^{-2}
	\end{equation}
	$\Phi_2$ is the volume of the two-particle phase space
	\begin{equation}
	\Phi_2 = \frac{1}{4(2\pi)^5} = 2.5529\times 10^{-5}.
	\end{equation}
	The squared matrix element $\|M\|^2$ is unity.
	Combining everything, we obtain
	\begin{equation}
	\sigma = 8000\;\mathrm{fb}
	\end{equation}
	This number should appear as the final result.

	Note: In this and the following test, we reset the Fortran compiler and flag
	variables immediately before they are printed, so the test is portable.
	<<Integrations: execute tests>>=
	call test (integrations_1, "integrations_1", &
	"intrinsic test process", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_1
	<<Integrations: tests>>=
	subroutine integrations_1 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: integrations_1"
	write (u, "(A)") "* Purpose: integrate test process"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	libname = "integration_1"
	procname = "prc_config_a"

	call prepare_test_library (global, libname, 1)
	call compile_library (libname, global)

	call global%set_string (var_str ("$run_id"), &
	var_str ("integrations1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%write (u, vars = [ &
	var_str ("$method"), &
	var_str ("sqrts"), &
	var_str ("$integration_method"), &
	var_str ("$phs_method"), &
	var_str ("$run_id")])

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_1

	@ %def integrations_1
	@
	\subsubsection{Integration with cuts}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) with cuts set.
	<<Integrations: execute tests>>=
	call test (integrations_2, "integrations_2", &
	"intrinsic test process with cut", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_2
	<<Integrations: tests>>=
	subroutine integrations_2 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	type(string_t) :: cut_expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: parse_tree

	type(string_t), dimension(0) :: empty_string_array

	write (u, "(A)") "* Test output: integrations_2"
	write (u, "(A)") "* Purpose: integrate test process with cut"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	write (u, "(A)") "* Prepare a cut expression"
	write (u, "(A)")

	call syntax_pexpr_init ()
	cut_expr_text = "all Pt > 100 [s]"
	call ifile_append (ifile, cut_expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (parse_tree, stream, .true.)
	global%pn%cuts_lexpr => parse_tree%get_root_ptr ()

	write (u, "(A)") "* Build and initialize a test process"
	write (u, "(A)")

	libname = "integration_3"
	procname = "prc_config_a"

	call prepare_test_library (global, libname, 1)
	call compile_library (libname, global)

	call global%set_string (var_str ("$run_id"), &
	var_str ("integrations1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%write (u, vars = empty_string_array)

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_2

	@ %def integrations_2
	@
	\subsubsection{Standard phase space}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the default ([[phs_wood]]) phase-space implementation. We
	use an explicit phase-space configuration file with a single channel
	and integrate by [[mci_midpoint]].
	<<Integrations: execute tests>>=
	call test (integrations_3, "integrations_3", &
	"standard phase space", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_3
	<<Integrations: tests>>=
	subroutine integrations_3 (u)
	<<Use kinds>>
	<<Use strings>>
	use interactions, only: reset_interaction_counter
	use models
	use rt_data
	use process_configurations_ut, only: prepare_test_library
	use compilations, only: compile_library
	use integrations

	implicit none

	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global
	integer :: u_phs

	write (u, "(A)") "* Test output: integrations_3"
	write (u, "(A)") "* Purpose: integrate test process"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()

	libname = "integration_3"
	procname = "prc_config_a"

	call prepare_test_library (global, libname, 1)
	call compile_library (libname, global)

	call global%set_string (var_str ("$run_id"), &
	var_str ("integrations1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("default"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?phs_s_mapping"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	write (u, "(A)") "* Create a scratch phase-space file"
	write (u, "(A)")

	u_phs = free_unit ()
	open (u_phs, file = "integrations_3.phs", &
	status = "replace", action = "write")
	call write_test_phs_file (u_phs, var_str ("prc_config_a_i1"))
	close (u_phs)

	call global%set_string (var_str ("$phs_file"),&
	var_str ("integrations_3.phs"), is_known = .true.)

	call global%it_list%init ([1], [1000])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%write (u, vars = [ &
	var_str ("$phs_method"), &
	var_str ("$phs_file")])

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_3

	@ %def integrations_3
	@
	\subsubsection{VAMP integration}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the single-channel ([[phs_single]]) phase-space
	implementation. The integration method is [[vamp]].
	<<Integrations: execute tests>>=
	call test (integrations_4, "integrations_4", &
	"VAMP integration (one iteration)", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_4
	<<Integrations: tests>>=
	subroutine integrations_4 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: integrations_4"
	write (u, "(A)") "* Purpose: integrate test process using VAMP"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	libname = "integrations_4_lib"
	procname = "integrations_4"

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%pacify (efficiency_reset = .true., error_reset = .true.)
	call global%write (u, vars = [var_str ("$integration_method")], &
	pacify = .true.)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_4

	@ %def integrations_4
	@
	\subsubsection{Multiple iterations integration}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the single-channel ([[phs_single]]) phase-space
	implementation. The integration method is [[vamp]]. We launch three
	iterations.
	<<Integrations: execute tests>>=
	call test (integrations_5, "integrations_5", &
	"VAMP integration (three iterations)", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_5
	<<Integrations: tests>>=
	subroutine integrations_5 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	write (u, "(A)") "* Test output: integrations_5"
	write (u, "(A)") "* Purpose: integrate test process using VAMP"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	libname = "integrations_5_lib"
	procname = "integrations_5"

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([3], [1000])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%pacify (efficiency_reset = .true., error_reset = .true.)
	call global%write (u, vars = [var_str ("$integration_method")], &
	pacify = .true.)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_5

	@ %def integrations_5
	@
	\subsubsection{Multiple passes integration}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the single-channel ([[phs_single]]) phase-space
	implementation. The integration method is [[vamp]]. We launch three
	passes with three iterations each.
	<<Integrations: execute tests>>=
	call test (integrations_6, "integrations_6", &
	"VAMP integration (three passes)", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_6
	<<Integrations: tests>>=
	subroutine integrations_6 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: no_vars

	write (u, "(A)") "* Test output: integrations_6"
	write (u, "(A)") "* Purpose: integrate test process using VAMP"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	libname = "integrations_6_lib"
	procname = "integrations_6"

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
	adapt = [.true., .true., .false.], &
	adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%pacify (efficiency_reset = .true., error_reset = .true.)
	call global%write (u, vars = no_vars, pacify = .true.)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_6

	@ %def integrations_6
	@
	\subsubsection{VAMP and default phase space}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the default ([[phs_wood]]) phase-space
	implementation. The integration method is [[vamp]]. We launch three
	passes with three iterations each. We enable channel equivalences and
	groves.
	<<Integrations: execute tests>>=
	call test (integrations_7, "integrations_7", &
	"VAMP integration with wood phase space", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_7
	<<Integrations: tests>>=
	subroutine integrations_7 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: no_vars
	integer :: iostat, u_phs
	character(95) :: buffer
	type(string_t) :: phs_file
	logical :: exist

	write (u, "(A)") "* Test output: integrations_7"
	write (u, "(A)") "* Purpose: integrate test process using VAMP"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()

	libname = "integrations_7_lib"
	procname = "integrations_7"

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?phs_s_mapping"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([3, 3, 3], [1000, 1000, 1000], &
	adapt = [.true., .true., .false.], &
	adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%pacify (efficiency_reset = .true., error_reset = .true.)
	call global%write (u, vars = no_vars, pacify = .true.)

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

	write (u, "(A)")
	write (u, "(A)") "* Generated phase-space file"
	write (u, "(A)")

	phs_file = procname // ".r1.i1.phs"
	inquire (file = char (phs_file), exist = exist)
	if (exist) then
	u_phs = free_unit ()
	open (u_phs, file = char (phs_file), action = "read", status = "old")
	iostat = 0
	do while (iostat == 0)
	read (u_phs, "(A)", iostat = iostat) buffer
	if (iostat == 0) write (u, "(A)") trim (buffer)
	end do
	close (u_phs)
	else
	write (u, "(A)") "[file is missing]"
	end if

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

	end subroutine integrations_7

	@ %def integrations_7
	@
	\subsubsection{Structure functions}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type) using the default ([[phs_wood]]) phase-space
	implementation. The integration method is [[vamp]]. There is a structure
	function of type [[unit_test]].

	We use a test structure function $f(x)=x$ for both beams. Together with the
	$1/x_1x_2$ factor from the phase-space flux and a unit matrix element, we
	should get the same result as previously for the process without structure
	functions. There is a slight correction due to the $m_s$ mass which we set to
	zero here.
	<<Integrations: execute tests>>=
	call test (integrations_8, "integrations_8", &
	"integration with structure function", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_8
	<<Integrations: tests>>=
	subroutine integrations_8 (u)
	<<Use kinds>>
	<<Use strings>>
	use interactions, only: reset_interaction_counter
	use phs_forests
	use models
	use rt_data
	use process_configurations_ut, only: prepare_test_library
	use compilations, only: compile_library
	use integrations

	implicit none

	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global
	type(flavor_t) :: flv
	type(string_t) :: name

	write (u, "(A)") "* Test output: integrations_8"
	write (u, "(A)") "* Purpose: integrate test process using VAMP &
	&with structure function"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()

	libname = "integrations_8_lib"
	procname = "integrations_8"

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?phs_s_mapping"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), 0._default)

	call reset_interaction_counter ()

	call flv%init (25, global%model)

	name = flv%get_name ()
	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

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

	call global%it_list%init ([1], [1000])
	call integrate_process (procname, global, local_stack=.true.)

	call global%write (u, vars = [var_str ("ms")])

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_8

	@ %def integrations_8
	@
	\subsubsection{Integration with sign change}
	Compile and integrate an intrinsic test matrix element ([[prc_test]]
	type). The phase-space implementation is [[phs_single]]
	(single-particle phase space), the integrator is [[mci_midpoint]].
	The weight that is applied changes the sign in half of phase space.
	The weight is $-3$ and $1$, respectively, so the total result is equal
	to the original, but negative sign.

	The efficiency should (approximately) become the average of $1$ and
	$1/3$, that is $2/3$.
	<<Integrations: execute tests>>=
	call test (integrations_9, "integrations_9", &
	"handle sign change", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_9
	<<Integrations: tests>>=
	subroutine integrations_9 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global

	type(string_t) :: wgt_expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: parse_tree

	write (u, "(A)") "* Test output: integrations_9"
	write (u, "(A)") "* Purpose: integrate test process"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()

	write (u, "(A)") "* Prepare a weight expression"
	write (u, "(A)")

	call syntax_pexpr_init ()
	wgt_expr_text = "eval 2 * sgn (Pz) - 1 [s]"
	call ifile_append (ifile, wgt_expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (parse_tree, stream, .true.)
	global%pn%weight_expr => parse_tree%get_root_ptr ()

	write (u, "(A)") "* Build and evaluate a test process"
	write (u, "(A)")

	libname = "integration_9"
	procname = "prc_config_a"

	call prepare_test_library (global, libname, 1)
	call compile_library (libname, global)

	call global%set_string (var_str ("$run_id"), &
	var_str ("integrations1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true.)

	call global%write (u, vars = [ &
	var_str ("$method"), &
	var_str ("sqrts"), &
	var_str ("$integration_method"), &
	var_str ("$phs_method"), &
	var_str ("$run_id")])

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_9

	@ %def integrations_9
	@
	\subsubsection{Integration history for VAMP integration with default
	phase space}
	This test is only run when event analysis can be done.
	<<Integrations: execute history tests>>=
	call test (integrations_history_1, "integrations_history_1", &
	"Test integration history files", &
	u, results)
	<<Integrations: test declarations>>=
	public :: integrations_history_1
	<<Integrations: tests>>=
	subroutine integrations_history_1 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: no_vars
	integer :: iostat, u_his
	character(91) :: buffer
	type(string_t) :: his_file, ps_file, pdf_file
	logical :: exist, exist_ps, exist_pdf

	write (u, "(A)") "* Test output: integrations_history_1"
	write (u, "(A)") "* Purpose: test integration history files"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and parameters"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()

	libname = "integrations_history_1_lib"
	procname = "integrations_history_1"

	call global%set_log (var_str ("?vis_history"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?phs_s_mapping"),&
	.false., is_known = .true.)

	call prepare_test_library (global, libname, 1, [procname])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_real (var_str ("error_threshold"),&
	5E-6_default, is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known=.true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([2, 2, 2], [1000, 1000, 1000], &
	adapt = [.true., .true., .false.], &
	adapt_code = [var_str ("wg"), var_str ("g"), var_str ("")])

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

	call reset_interaction_counter ()
	call integrate_process (procname, global, local_stack=.true., &
	eff_reset = .true.)

	call global%pacify (efficiency_reset = .true., error_reset = .true.)
	call global%write (u, vars = no_vars, pacify = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Generated history files"
	write (u, "(A)")

	his_file = procname // ".r1.history.tex"
	ps_file = procname // ".r1.history.ps"
	pdf_file = procname // ".r1.history.pdf"
	inquire (file = char (his_file), exist = exist)
	if (exist) then
	u_his = free_unit ()
	open (u_his, file = char (his_file), action = "read", status = "old")
	iostat = 0
	do while (iostat == 0)
	read (u_his, "(A)", iostat = iostat) buffer
	if (iostat == 0) write (u, "(A)") trim (buffer)
	end do
	close (u_his)
	else
	write (u, "(A)") "[History LaTeX file is missing]"
	end if
	inquire (file = char (ps_file), exist = exist_ps)
	if (exist_ps) then
	write (u, "(A)") "[History Postscript file exists and is nonempty]"
	else
	write (u, "(A)") "[History Postscript file is missing/non-regular]"
	end if
	inquire (file = char (pdf_file), exist = exist_pdf)
	if (exist_pdf) then
	write (u, "(A)") "[History PDF file exists and is nonempty]"
	else
	write (u, "(A)") "[History PDF file is missing/non-regular]"
	end if

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine integrations_history_1

	@ %def integrations_history_1
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Event Streams}
	This module manages I/O from/to multiple concurrent event streams.
	Usually, there is at most one input stream, but several output
	streams. For the latter, we set up an array which can hold [[eio_t]]
	(event I/O) objects of different dynamic types simultaneously. One of
	them may be marked as an input channel.
	<<[[event_streams.f90]]>>=
	<<File header>>

	module event_streams

	<<Use strings>>
	use io_units
	use diagnostics
	use events
	use event_handles, only: event_handle_t
	use eio_data
	use eio_base
	use rt_data

	use dispatch_transforms, only: dispatch_eio

	<<Standard module head>>

	<<Event streams: public>>

	<<Event streams: types>>

	contains

	<<Event streams: procedures>>

	end module event_streams
	@ %def event_streams
	@
	\subsection{Event Stream Array}
	Each entry is an [[eio_t]] object. Since the type is dynamic, we need
	a wrapper:
	<<Event streams: types>>=
	type :: event_stream_entry_t
	class(eio_t), allocatable :: eio
	end type event_stream_entry_t

	@ %def event_stream_entry_t
	@ An array of event-stream entry objects. If one of the entries is an
	input channel, [[i_in]] is the corresponding index.
	<<Event streams: public>>=
	public :: event_stream_array_t
	<<Event streams: types>>=
	type :: event_stream_array_t
	type(event_stream_entry_t), dimension(:), allocatable :: entry
	integer :: i_in = 0
	contains
	<<Event streams: event stream array: TBP>>
	end type event_stream_array_t

	@ %def event_stream_array_t
	@ Output.
	<<Event streams: event stream array: TBP>>=
	procedure :: write => event_stream_array_write
	<<Event streams: procedures>>=
	subroutine event_stream_array_write (object, unit)
	class(event_stream_array_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Event stream array:"
	if (allocated (object%entry)) then
	select case (size (object%entry))
	case (0)
	write (u, "(3x,A)") "[empty]"
	case default
	do i = 1, size (object%entry)
	if (i == object%i_in) write (u, "(1x,A)") "Input stream:"
	call object%entry(i)%eio%write (u)
	end do
	end select
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine event_stream_array_write

	@ %def event_stream_array_write
	@ Check if there is content.
	<<Event streams: event stream array: TBP>>=
	procedure :: is_valid => event_stream_array_is_valid
	<<Event streams: procedures>>=
	function event_stream_array_is_valid (es_array) result (flag)
	class(event_stream_array_t), intent(in) :: es_array
	logical :: flag

	flag = allocated (es_array%entry)

	end function event_stream_array_is_valid

	@ %def event_stream_array_is_valid
	@ Finalize all streams.
	<<Event streams: event stream array: TBP>>=
	procedure :: final => event_stream_array_final
	<<Event streams: procedures>>=
	subroutine event_stream_array_final (es_array)
	class(event_stream_array_t), intent(inout) :: es_array
	integer :: i
	if (allocated (es_array%entry)) then
	do i = 1, size (es_array%entry)
	call es_array%entry(i)%eio%final ()
	end do
	end if
	end subroutine event_stream_array_final

	@ %def event_stream_array_final
	@ Initialization. We use a generic [[sample]] name, open event I/O
	objects for all provided stream types (using the [[dispatch_eio]]
	routine), and initialize for the given list of process pointers. If
	there is an [[input]] argument, this channel is initialized as an input
	channel and appended to the array.

	The [[input_data]] or, if not present, [[data]] may be modified. This
	happens if we open a stream for reading and get new information there.
	<<Event streams: event stream array: TBP>>=
	procedure :: init => event_stream_array_init
	<<Event streams: procedures>>=
	subroutine event_stream_array_init &
	(es_array, sample, stream_fmt, global, &
	data, input, input_sample, input_data, allow_switch, &
	checkpoint, callback, &
	error)
	class(event_stream_array_t), intent(out) :: es_array
	type(string_t), intent(in) :: sample
	type(string_t), dimension(:), intent(in) :: stream_fmt
	type(rt_data_t), intent(in) :: global
	type(event_sample_data_t), intent(inout), optional :: data
	type(string_t), intent(in), optional :: input
	type(string_t), intent(in), optional :: input_sample
	type(event_sample_data_t), intent(inout), optional :: input_data
	logical, intent(in), optional :: allow_switch
	integer, intent(in), optional :: checkpoint
	integer, intent(in), optional :: callback
	logical, intent(out), optional :: error
	type(string_t) :: sample_in
	integer :: n, i, n_output, i_input, i_checkpoint, i_callback
	logical :: success, switch
	if (present (input_sample)) then
	sample_in = input_sample
	else
	sample_in = sample
	end if
	if (present (allow_switch)) then
	switch = allow_switch
	else
	switch = .true.
	end if
	if (present (error)) then
	error = .false.
	end if
	n = size (stream_fmt)
	n_output = n
	if (present (input)) then
	n = n + 1
	i_input = n
	else
	i_input = 0
	end if
	if (present (checkpoint)) then
	n = n + 1
	i_checkpoint = n
	else
	i_checkpoint = 0
	end if
	if (present (callback)) then
	n = n + 1
	i_callback = n
	else
	i_callback = 0
	end if
	allocate (es_array%entry (n))
	if (i_checkpoint > 0) then
	call dispatch_eio &
	(es_array%entry(i_checkpoint)%eio, var_str ("checkpoint"), &
	global%var_list, global%fallback_model, &
	global%event_callback)
	call es_array%entry(i_checkpoint)%eio%init_out (sample, data)
	end if
	if (i_callback > 0) then
	call dispatch_eio &
	(es_array%entry(i_callback)%eio, var_str ("callback"), &
	global%var_list, global%fallback_model, &
	global%event_callback)
	call es_array%entry(i_callback)%eio%init_out (sample, data)
	end if
	if (i_input > 0) then
	call dispatch_eio (es_array%entry(i_input)%eio, input, &
	global%var_list, global%fallback_model, &
	global%event_callback)
	if (present (input_data)) then
	call es_array%entry(i_input)%eio%init_in &
	(sample_in, input_data, success)
	else
	call es_array%entry(i_input)%eio%init_in &
	(sample_in, data, success)
	end if
	if (success) then
	es_array%i_in = i_input
	else if (present (input_sample)) then
	if (present (error)) then
	error = .true.
	else
	call msg_fatal ("Events: &
	&parameter mismatch in input, aborting")
	end if
	else
	call msg_message ("Events: &
	&parameter mismatch, discarding old event set")
	call es_array%entry(i_input)%eio%final ()
	if (switch) then
	call msg_message ("Events: generating new events")
	call es_array%entry(i_input)%eio%init_out (sample, data)
	end if
	end if
	end if
	do i = 1, n_output
	call dispatch_eio (es_array%entry(i)%eio, stream_fmt(i), &
	global%var_list, global%fallback_model, &
	global%event_callback)
	call es_array%entry(i)%eio%init_out (sample, data)
	end do
	end subroutine event_stream_array_init

	@ %def event_stream_array_init
	@ Switch the (only) input channel to an output channel, so further
	events are appended to the respective stream.
	<<Event streams: event stream array: TBP>>=
	procedure :: switch_inout => event_stream_array_switch_inout
	<<Event streams: procedures>>=
	subroutine event_stream_array_switch_inout (es_array)
	class(event_stream_array_t), intent(inout) :: es_array
	integer :: n
	if (es_array%has_input ()) then
	n = es_array%i_in
	call es_array%entry(n)%eio%switch_inout ()
	es_array%i_in = 0
	else
	call msg_bug ("Reading events: switch_inout: no input stream selected")
	end if
	end subroutine event_stream_array_switch_inout

	@ %def event_stream_array_switch_inout
	@ Output an event (with given process number) to all output streams.
	If there is no output stream, do nothing.
	<<Event streams: event stream array: TBP>>=
	procedure :: output => event_stream_array_output
	<<Event streams: procedures>>=
	subroutine event_stream_array_output &
	(es_array, event, i_prc, event_index, passed, pacify, event_handle)
	class(event_stream_array_t), intent(inout) :: es_array
	type(event_t), intent(in), target :: event
	integer, intent(in) :: i_prc, event_index
	logical, intent(in), optional :: passed, pacify
	class(event_handle_t), intent(inout), optional :: event_handle
	logical :: increased
	integer :: i
	do i = 1, size (es_array%entry)
	if (i /= es_array%i_in) then
	associate (eio => es_array%entry(i)%eio)
	if (eio%split) then
	if (eio%split_n_evt > 0 .and. event_index > 1) then
	if (mod (event_index, eio%split_n_evt) == 1) then
	call eio%split_out ()
	end if
	else if (eio%split_n_kbytes > 0) then
	call eio%update_split_count (increased)
	if (increased) call eio%split_out ()
	end if
	end if
	call eio%output (event, i_prc, reading = es_array%i_in /= 0, &
	passed = passed, &
	pacify = pacify, &
	event_handle = event_handle)
	end associate
	end if
	end do
	end subroutine event_stream_array_output

	@ %def event_stream_array_output
	@ Input the [[i_prc]] index which selects the process for the current
	event. This is separated from reading the event, because it
	determines which event record to read. [[iostat]] may indicate an
	error or an EOF condition, as usual.
	<<Event streams: event stream array: TBP>>=
	procedure :: input_i_prc => event_stream_array_input_i_prc
	<<Event streams: procedures>>=
	subroutine event_stream_array_input_i_prc (es_array, i_prc, iostat)
	class(event_stream_array_t), intent(inout) :: es_array
	integer, intent(out) :: i_prc
	integer, intent(out) :: iostat
	integer :: n
	if (es_array%has_input ()) then
	n = es_array%i_in
	call es_array%entry(n)%eio%input_i_prc (i_prc, iostat)
	else
	call msg_fatal ("Reading events: no input stream selected")
	end if
	end subroutine event_stream_array_input_i_prc

	@ %def event_stream_array_input_i_prc
	@ Input an event from the selected input stream. [[iostat]] may indicate an
	error or an EOF condition, as usual.
	<<Event streams: event stream array: TBP>>=
	procedure :: input_event => event_stream_array_input_event
	<<Event streams: procedures>>=
	subroutine event_stream_array_input_event &
	(es_array, event, iostat, event_handle)
	class(event_stream_array_t), intent(inout) :: es_array
	type(event_t), intent(inout), target :: event
	integer, intent(out) :: iostat
	class(event_handle_t), intent(inout), optional :: event_handle
	integer :: n
	if (es_array%has_input ()) then
	n = es_array%i_in
	call es_array%entry(n)%eio%input_event (event, iostat, event_handle)
	else
	call msg_fatal ("Reading events: no input stream selected")
	end if
	end subroutine event_stream_array_input_event

	@ %def event_stream_array_input_event
	@ Skip an entry of eio\_t. Used to synchronize the event read-in for
	NLO events.
	<<Event streams: event stream array: TBP>>=
	procedure :: skip_eio_entry => event_stream_array_skip_eio_entry
	<<Event streams: procedures>>=
	subroutine event_stream_array_skip_eio_entry (es_array, iostat)
	class(event_stream_array_t), intent(inout) :: es_array
	integer, intent(out) :: iostat
	integer :: n
	if (es_array%has_input ()) then
	n = es_array%i_in
	call es_array%entry(n)%eio%skip (iostat)
	else
	call msg_fatal ("Reading events: no input stream selected")
	end if
	end subroutine event_stream_array_skip_eio_entry

	@ %def event_stream_array_skip_eio_entry
	@ Return true if there is an input channel among the event streams.
	<<Event streams: event stream array: TBP>>=
	procedure :: has_input => event_stream_array_has_input
	<<Event streams: procedures>>=
	function event_stream_array_has_input (es_array) result (flag)
	class(event_stream_array_t), intent(in) :: es_array
	logical :: flag
	flag = es_array%i_in /= 0
	end function event_stream_array_has_input

	@ %def event_stream_array_has_input
	@
	\subsection{Unit Tests}
	Test module, followed by the stand-alone unit-test procedures.
	<<[[event_streams_ut.f90]]>>=
	<<File header>>

	module event_streams_ut
	use unit_tests
	use event_streams_uti

	<<Standard module head>>

	<<Event streams: public test>>

	contains

	<<Event streams: test driver>>

	end module event_streams_ut
	@
	<<[[event_streams_uti.f90]]>>=
	<<File header>>

	module event_streams_uti

	<<Use kinds>>
	<<Use strings>>
	use model_data
	use eio_data
	use process, only: process_t
	use instances, only: process_instance_t
	use models
	use rt_data
	use events

	use event_streams

	<<Standard module head>>

	<<Event streams: test declarations>>

	contains

	<<Event streams: tests>>

	end module event_streams_uti

	@ %def event_streams_uti
	@ API: driver for the unit tests below.
	<<Event streams: public test>>=
	public :: event_streams_test
	<<Event streams: test driver>>=
	subroutine event_streams_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Event streams: execute tests>>
	end subroutine event_streams_test

	@ %def event_streams_test
	@
	\subsubsection{Empty event stream}
	This should set up an empty event output stream array, including
	initialization, output, and finalization (which are all no-ops).
	<<Event streams: execute tests>>=
	call test (event_streams_1, "event_streams_1", &
	"empty event stream array", &
	u, results)
	<<Event streams: test declarations>>=
	public :: event_streams_1
	<<Event streams: tests>>=
	subroutine event_streams_1 (u)
	integer, intent(in) :: u
	type(event_stream_array_t) :: es_array
	type(rt_data_t) :: global
	type(event_t) :: event
	type(string_t) :: sample
	type(string_t), dimension(0) :: empty_string_array

	write (u, "(A)") "* Test output: event_streams_1"
	write (u, "(A)") "* Purpose: handle empty event stream array"
	write (u, "(A)")

	sample = "event_streams_1"

	call es_array%init (sample, empty_string_array, global)
	call es_array%output (event, 42, 1)
	call es_array%write (u)
	call es_array%final ()

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

	end subroutine event_streams_1

	@ %def event_streams_1
	@
	\subsubsection{Nontrivial event stream}
	Here we generate a trivial event and choose [[raw]] output as an entry in
	the stream array.
	<<Event streams: execute tests>>=
	call test (event_streams_2, "event_streams_2", &
	"nontrivial event stream array", &
	u, results)
	<<Event streams: test declarations>>=
	public :: event_streams_2
	<<Event streams: tests>>=
	subroutine event_streams_2 (u)
	use processes_ut, only: prepare_test_process
	integer, intent(in) :: u
	type(event_stream_array_t) :: es_array
	type(rt_data_t) :: global
	type(model_data_t), target :: model
	type(event_t), allocatable, target :: event
	type(process_t), allocatable, target :: process
	type(process_instance_t), allocatable, target :: process_instance
	type(string_t) :: sample
	type(string_t), dimension(0) :: empty_string_array
	integer :: i_prc, iostat

	write (u, "(A)") "* Test output: event_streams_2"
	write (u, "(A)") "* Purpose: handle empty event stream array"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call model%init_test ()

	write (u, "(A)") "* Generate test process event"
	write (u, "(A)")

	allocate (process)
	allocate (process_instance)
	call prepare_test_process (process, process_instance, model, &
	run_id = var_str ("run_test"))
	call process_instance%setup_event_data ()

	allocate (event)
	call event%basic_init ()
	call event%connect (process_instance, process%get_model_ptr ())
	call event%generate (1, [0.4_default, 0.4_default])
	call event%set_index (42)
	call event%evaluate_expressions ()
	call event%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Allocate raw eio stream and write event to file"
	write (u, "(A)")

	sample = "event_streams_2"

	call es_array%init (sample, [var_str ("raw")], global)
	call es_array%output (event, 1, 1)
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	write (u, "(A)") "* Reallocate raw eio stream for reading"
	write (u, "(A)")

	sample = "foo"
	call es_array%init (sample, empty_string_array, global, &
	input = var_str ("raw"), input_sample = var_str ("event_streams_2"))
	call es_array%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Reread event"
	write (u, "(A)")

	call es_array%input_i_prc (i_prc, iostat)

	write (u, "(1x,A,I0)") "i_prc = ", i_prc
	write (u, "(A)")
	call es_array%input_event (event, iostat)
	call es_array%final ()

	call event%write (u)

	call global%final ()

	call model%final ()
	call syntax_model_file_final ()

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

	end subroutine event_streams_2

	@ %def event_streams_2
	@
	\subsubsection{Switch in/out}
	Here we generate an event file and test switching from writing to
	reading when the file is exhausted.
	<<Event streams: execute tests>>=
	call test (event_streams_3, "event_streams_3", &
	"switch input/output", &
	u, results)
	<<Event streams: test declarations>>=
	public :: event_streams_3
	<<Event streams: tests>>=
	subroutine event_streams_3 (u)
	use processes_ut, only: prepare_test_process
	integer, intent(in) :: u
	type(event_stream_array_t) :: es_array
	type(rt_data_t) :: global
	type(model_data_t), target :: model
	type(event_t), allocatable, target :: event
	type(process_t), allocatable, target :: process
	type(process_instance_t), allocatable, target :: process_instance
	type(string_t) :: sample
	type(string_t), dimension(0) :: empty_string_array
	integer :: i_prc, iostat

	write (u, "(A)") "* Test output: event_streams_3"
	write (u, "(A)") "* Purpose: handle in/out switching"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call model%init_test ()

	write (u, "(A)") "* Generate test process event"
	write (u, "(A)")

	allocate (process)
	allocate (process_instance)
	call prepare_test_process (process, process_instance, model, &
	run_id = var_str ("run_test"))
	call process_instance%setup_event_data ()

	allocate (event)
	call event%basic_init ()
	call event%connect (process_instance, process%get_model_ptr ())
	call event%generate (1, [0.4_default, 0.4_default])
	call event%increment_index ()
	call event%evaluate_expressions ()

	write (u, "(A)") "* Allocate raw eio stream and write event to file"
	write (u, "(A)")

	sample = "event_streams_3"

	call es_array%init (sample, [var_str ("raw")], global)
	call es_array%output (event, 1, 1)
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	write (u, "(A)") "* Reallocate raw eio stream for reading"
	write (u, "(A)")

	call es_array%init (sample, empty_string_array, global, &
	input = var_str ("raw"))
	call es_array%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Reread event"
	write (u, "(A)")

	call es_array%input_i_prc (i_prc, iostat)
	call es_array%input_event (event, iostat)

	write (u, "(A)") "* Attempt to read another event (fail), then generate"
	write (u, "(A)")

	call es_array%input_i_prc (i_prc, iostat)
	if (iostat < 0) then
	call es_array%switch_inout ()
	call event%generate (1, [0.3_default, 0.3_default])
	call event%increment_index ()
	call event%evaluate_expressions ()
	call es_array%output (event, 1, 2)
	end if
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	call event%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Reallocate raw eio stream for reading"
	write (u, "(A)")

	call es_array%init (sample, empty_string_array, global, &
	input = var_str ("raw"))
	call es_array%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Reread two events and display 2nd event"
	write (u, "(A)")

	call es_array%input_i_prc (i_prc, iostat)
	call es_array%input_event (event, iostat)
	call es_array%input_i_prc (i_prc, iostat)

	call es_array%input_event (event, iostat)
	call es_array%final ()

	call event%write (u)

	call global%final ()

	call model%final ()
	call syntax_model_file_final ()

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

	end subroutine event_streams_3

	@ %def event_streams_3
	@
	\subsubsection{Checksum}
	Here we generate an event file and repeat twice, once with identical
	parameters and once with modified parameters.
	<<Event streams: execute tests>>=
	call test (event_streams_4, "event_streams_4", &
	"check MD5 sum", &
	u, results)
	<<Event streams: test declarations>>=
	public :: event_streams_4
	<<Event streams: tests>>=
	subroutine event_streams_4 (u)
	integer, intent(in) :: u
	type(event_stream_array_t) :: es_array
	type(rt_data_t) :: global
	type(process_t), allocatable, target :: process
	type(string_t) :: sample
	type(string_t), dimension(0) :: empty_string_array
	type(event_sample_data_t) :: data

	write (u, "(A)") "* Test output: event_streams_4"
	write (u, "(A)") "* Purpose: handle in/out switching"
	write (u, "(A)")

	write (u, "(A)") "* Generate test process event"
	write (u, "(A)")

	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%set_log (var_str ("?check_event_file"), &
	.true., is_known = .true.)

	allocate (process)

	write (u, "(A)") "* Allocate raw eio stream for writing"
	write (u, "(A)")

	sample = "event_streams_4"
	data%md5sum_cfg = "1234567890abcdef1234567890abcdef"

	call es_array%init (sample, [var_str ("raw")], global, data)
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	write (u, "(A)") "* Reallocate raw eio stream for reading"
	write (u, "(A)")

	call es_array%init (sample, empty_string_array, global, &
	data, input = var_str ("raw"))
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	write (u, "(A)") "* Reallocate modified raw eio stream for reading (fail)"
	write (u, "(A)")

	data%md5sum_cfg = "1234567890______1234567890______"
	call es_array%init (sample, empty_string_array, global, &
	data, input = var_str ("raw"))
	call es_array%write (u)
	call es_array%final ()

	write (u, "(A)")
	write (u, "(A)") "* Repeat ignoring checksum"
	write (u, "(A)")

	call global%set_log (var_str ("?check_event_file"), &
	.false., is_known = .true.)
	call es_array%init (sample, empty_string_array, global, &
	data, input = var_str ("raw"))
	call es_array%write (u)
	call es_array%final ()

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine event_streams_4

	@ %def event_streams_4
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Restricted Subprocesses}
	This module provides an automatic means to construct restricted subprocesses
	of a current process object. A restricted subprocess has the same initial and
	final state as the current process, but a restricted set of Feynman graphs.

	The actual application extracts the set of resonance histories that apply to
	the process and uses this to construct subprocesses that are restricted to one
	of those histories, respectively. The resonance histories are derived from
	the phase-space setup. This implies that the method is tied to the OMega
	matrix element generator and to the wood phase space method.

	The processes are collected in a new process library that is generated
	on-the-fly.

	The [[resonant_subprocess_t]] object is intended as a component of the event
	record, which manages all operations regarding resonance handling.

	The run-time calculations are delegated to an event transform
	([[evt_resonance_t]]), as a part of the event transform chain. The transform
	selects one (or none) of the resonance histories, given the momentum
	configuration, computes matrix elements and inserts resonances into the
	particle set.
	<<[[restricted_subprocesses.f90]]>>=
	<<File header>>

	module restricted_subprocesses

	<<Use kinds>>
	<<Use strings>>
	use diagnostics, only: msg_message, msg_fatal, msg_bug
	use diagnostics, only: signal_is_pending
	use io_units, only: given_output_unit
	use format_defs, only: FMT_14, FMT_19
	use string_utils, only: str
	use lorentz, only: vector4_t
	use particle_specifiers, only: prt_spec_t
	use particles, only: particle_set_t
	use resonances, only: resonance_history_t, resonance_history_set_t
	use variables, only: var_list_t
	use models, only: model_t
	use process_libraries, only: process_component_def_t
	use process_libraries, only: process_library_t
	use process_libraries, only: STAT_ACTIVE
	use prclib_stacks, only: prclib_entry_t
	use event_transforms, only: evt_t
	use resonance_insertion, only: evt_resonance_t
	use rt_data, only: rt_data_t
	use compilations, only: compile_library
	use process_configurations, only: process_configuration_t
	use process, only: process_t, process_ptr_t
	use instances, only: process_instance_t, process_instance_ptr_t
	use integrations, only: integrate_process

	<<Use mpi f08>>

	<<Standard module head>>

	<<Restricted subprocesses: public>>

	<<Restricted subprocesses: types>>

	<<Restricted subprocesses: interfaces>>

	contains

	<<Restricted subprocesses: procedures>>

	end module restricted_subprocesses
	@ %def restricted_subprocesses
	@
	\subsection{Process configuration}
	We extend the [[process_configuration_t]] by another method for initialization
	that takes into account a resonance history.
	<<Restricted subprocesses: public>>=
	public :: restricted_process_configuration_t
	<<Restricted subprocesses: types>>=
	type, extends (process_configuration_t) :: restricted_process_configuration_t
	private
	contains
	<<Restricted subprocesses: restricted process configuration: TBP>>
	end type restricted_process_configuration_t

	@ %def restricted_process_configuration_t
	@
	Resonance history as an argument. We use it to override the [[restrictions]]
	setting in a local variable list. Since we can construct the restricted
	process only by using OMega, we enforce it as the ME method. Other settings
	are taken from the variable list. The model will most likely be set, but we
	insert a safeguard just in case.

	Also, the resonant subprocess should not itself spawn resonant
	subprocesses, so we unset [[?resonance_history]].

	We have to create a local copy of the model here, via pointer
	allocation. The reason is that the model as stored (via pointer) in
	the base type will be finalized and deallocated.

	The current implementation will generate a LO process, the optional
	[[nlo_process]] is unset. (It is not obvious
	whether the construction makes sense beyond LO.)
	<<Restricted subprocesses: restricted process configuration: TBP>>=
	procedure :: init_resonant_process
	<<Restricted subprocesses: procedures>>=
	subroutine init_resonant_process &
	(prc_config, prc_name, prt_in, prt_out, res_history, model, var_list)
	class(restricted_process_configuration_t), intent(out) :: prc_config
	type(string_t), intent(in) :: prc_name
	type(prt_spec_t), dimension(:), intent(in) :: prt_in
	type(prt_spec_t), dimension(:), intent(in) :: prt_out
	type(resonance_history_t), intent(in) :: res_history
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(in), target :: var_list
	type(model_t), pointer :: local_model
	type(var_list_t) :: local_var_list
	allocate (local_model)
	call local_model%init_instance (model)
	call local_var_list%link (var_list)
	call local_var_list%append_string (var_str ("$model_name"), &
	sval = local_model%get_name (), &
	intrinsic=.true.)
	call local_var_list%append_string (var_str ("$method"), &
	sval = var_str ("omega"), &
	intrinsic=.true.)
	call local_var_list%append_string (var_str ("$restrictions"), &
	sval = res_history%as_omega_string (size (prt_in)), &
	intrinsic = .true.)
	call local_var_list%append_log (var_str ("?resonance_history"), &
	lval = .false., &
	intrinsic = .true.)
	call prc_config%init (prc_name, size (prt_in), 1, &
	local_model, local_var_list)
	call prc_config%setup_component (1, &
	prt_in, prt_out, &
	local_model, local_var_list)
	end subroutine init_resonant_process

	@ %def init_resonant_process
	@
	\subsection{Resonant-subprocess set manager}
	This data type enables generation of a library of resonant subprocesses for a
	given master process, and it allows for convenient access. The matrix
	elements from the subprocesses can be used as channel weights to activate a
	selector, which then returns a preferred channel via some random number
	generator.
	<<Restricted subprocesses: public>>=
	public :: resonant_subprocess_set_t
	<<Restricted subprocesses: types>>=
	type :: resonant_subprocess_set_t
	private
	integer, dimension(:), allocatable :: n_history
	type(resonance_history_set_t), dimension(:), allocatable :: res_history_set
	logical :: lib_active = .false.
	type(string_t) :: libname
	type(string_t), dimension(:), allocatable :: proc_id
	type(process_ptr_t), dimension(:), allocatable :: subprocess
	type(process_instance_ptr_t), dimension(:), allocatable :: instance
	logical :: filled = .false.
	type(evt_resonance_t), pointer :: evt => null ()
	contains
	<<Restricted subprocesses: resonant subprocess set: TBP>>
	end type resonant_subprocess_set_t

	@ %def resonant_subprocess_set_t
	@ Output
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: write => resonant_subprocess_set_write
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_write (prc_set, unit, testflag)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	logical :: truncate
	integer :: u, i
	u = given_output_unit (unit)
	truncate = .false.; if (present (testflag)) truncate = testflag
	write (u, "(1x,A)") "Resonant subprocess set:"
	if (allocated (prc_set%n_history)) then
	if (any (prc_set%n_history > 0)) then
	do i = 1, size (prc_set%n_history)
	if (prc_set%n_history(i) > 0) then
	write (u, "(1x,A,I0)") "Component #", i
	call prc_set%res_history_set(i)%write (u, indent=1)
	end if
	end do
	if (prc_set%lib_active) then
	write (u, "(3x,A,A,A)") "Process library = '", &
	char (prc_set%libname), "'"
	else
	write (u, "(3x,A)") "Process library: [inactive]"
	end if
	if (associated (prc_set%evt)) then
	if (truncate) then
	write (u, "(3x,A,1x," // FMT_14 // ")") &
	"Process sqme =", prc_set%get_master_sqme ()
	else
	write (u, "(3x,A,1x," // FMT_19 // ")") &
	"Process sqme =", prc_set%get_master_sqme ()
	end if
	end if
	if (associated (prc_set%evt)) then
	write (u, "(3x,A)") "Event transform: associated"
	write (u, "(2x)", advance="no")
	call prc_set%evt%write_selector (u, testflag)
	else
	write (u, "(3x,A)") "Event transform: not associated"
	end if
	else
	write (u, "(2x,A)") "[empty]"
	end if
	else
	write (u, "(3x,A)") "[not allocated]"
	end if
	end subroutine resonant_subprocess_set_write

	@ %def resonant_subprocess_set_write
	@
	\subsection{Resonance history set}
	Initialize subprocess set with an array of pre-created resonance
	history sets.

	Safeguard: if there are no resonances in the input, initialize the local set
	as empty, but complete.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: init => resonant_subprocess_set_init
	procedure :: fill_resonances => resonant_subprocess_set_fill_resonances
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_init (prc_set, n_component)
	class(resonant_subprocess_set_t), intent(out) :: prc_set
	integer, intent(in) :: n_component
	allocate (prc_set%res_history_set (n_component))
	allocate (prc_set%n_history (n_component), source = 0)
	end subroutine resonant_subprocess_set_init

	subroutine resonant_subprocess_set_fill_resonances (prc_set, &
	res_history_set, i_component)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	type(resonance_history_set_t), intent(in) :: res_history_set
	integer, intent(in) :: i_component
	prc_set%n_history(i_component) = res_history_set%get_n_history ()
	if (prc_set%n_history(i_component) > 0) then
	prc_set%res_history_set(i_component) = res_history_set
	else
	call prc_set%res_history_set(i_component)%init (initial_size = 0)
	call prc_set%res_history_set(i_component)%freeze ()
	end if
	end subroutine resonant_subprocess_set_fill_resonances

	@ %def resonant_subprocess_set_init
	@ %def resonant_subprocess_set_fill_resonances
	@ Return the resonance history set.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: get_resonance_history_set &
	=> resonant_subprocess_set_get_resonance_history_set
	<<Restricted subprocesses: procedures>>=
	function resonant_subprocess_set_get_resonance_history_set (prc_set) &
	result (res_history_set)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	type(resonance_history_set_t), dimension(:), allocatable :: res_history_set
	res_history_set = prc_set%res_history_set
	end function resonant_subprocess_set_get_resonance_history_set

	@ %def resonant_subprocess_set_get_resonance_history_set
	@
	\subsection{Library for the resonance history set}
	The recommended library name: append [[_R]] to the process name.
	<<Restricted subprocesses: public>>=
	public :: get_libname_res
	<<Restricted subprocesses: procedures>>=
	elemental function get_libname_res (proc_id) result (libname)
	type(string_t), intent(in) :: proc_id
	type(string_t) :: libname
	libname = proc_id // "_R"
	end function get_libname_res

	@ %def get_libname_res
	@ Here we scan the global process library whether any
	processes require resonant subprocesses to be constructed. If yes,
	create process objects with phase space and construct the process
	libraries as usual. Then append the library names to the array.

	The temporary integration objects should carry the [[phs_only]]
	flag. We set this in the local environment.

	Once a process object with resonance histories (derived from phase
	space) has been created, we extract the resonance histories and use
	them, together with the process definition, to create the new library.

	Finally, compile the library.
	<<Restricted subprocesses: public>>=
	public :: spawn_resonant_subprocess_libraries
	<<Restricted subprocesses: procedures>>=
	subroutine spawn_resonant_subprocess_libraries &
	(libname, local, global, libname_res)
	type(string_t), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), target :: global
	type(string_t), dimension(:), allocatable, intent(inout) :: libname_res
	type(process_library_t), pointer :: lib
	type(string_t), dimension(:), allocatable :: process_id_res
	type(process_t), pointer :: process
	type(resonance_history_set_t) :: res_history_set
	type(process_component_def_t), pointer :: process_component_def
	logical :: phs_only_saved, exist
	integer :: i_proc, i_component
	lib => global%prclib_stack%get_library_ptr (libname)
	call lib%get_process_id_req_resonant (process_id_res)
	if (size (process_id_res) > 0) then
	call msg_message ("Creating resonant-subprocess libraries &
	&for library '" // char (libname) // "'")
	libname_res = get_libname_res (process_id_res)
	phs_only_saved = local%var_list%get_lval (var_str ("?phs_only"))
	call local%var_list%set_log &
	(var_str ("?phs_only"), .true., is_known=.true.)
	do i_proc = 1, size (process_id_res)
	associate (proc_id => process_id_res (i_proc))
	call msg_message ("Process '" // char (proc_id) // "': &
	&constructing phase space for resonance structure")
	call integrate_process (proc_id, local, global)
	process => global%process_stack%get_process_ptr (proc_id)
	call create_library (libname_res(i_proc), global, exist)
	if (.not. exist) then
	do i_component = 1, process%get_n_components ()
	call process%extract_resonance_history_set &
	(res_history_set, i_component = i_component)
	process_component_def &
	=> process%get_component_def_ptr (i_component)
	call add_to_library (libname_res(i_proc), &
	res_history_set, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end do
	call msg_message ("Process library '" &
	// char (libname_res(i_proc)) &
	// "': created")
	end if
	call global%update_prclib (lib)
	end associate
	end do
	call local%var_list%set_log &
	(var_str ("?phs_only"), phs_only_saved, is_known=.true.)
	end if
	end subroutine spawn_resonant_subprocess_libraries

	@ %def spawn_resonant_subprocess_libraries
	@ This is another version of the library constructor, bound to a
	restricted-subprocess set object. Create the appropriate
	process library, add processes, and close the library.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: create_library => resonant_subprocess_set_create_library
	procedure :: add_to_library => resonant_subprocess_set_add_to_library
	procedure :: freeze_library => resonant_subprocess_set_freeze_library
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_create_library (prc_set, &
	libname, global, exist)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	type(string_t), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: global
	logical, intent(out) :: exist
	prc_set%libname = libname
	call create_library (prc_set%libname, global, exist)
	end subroutine resonant_subprocess_set_create_library

	subroutine resonant_subprocess_set_add_to_library (prc_set, &
	i_component, prt_in, prt_out, global)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	integer, intent(in) :: i_component
	type(prt_spec_t), dimension(:), intent(in) :: prt_in
	type(prt_spec_t), dimension(:), intent(in) :: prt_out
	type(rt_data_t), intent(inout), target :: global
	call add_to_library (prc_set%libname, &
	prc_set%res_history_set(i_component), &
	prt_in, prt_out, global)
	end subroutine resonant_subprocess_set_add_to_library

	subroutine resonant_subprocess_set_freeze_library (prc_set, global)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	type(rt_data_t), intent(inout), target :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	lib => global%prclib_stack%get_library_ptr (prc_set%libname)
	call lib%get_process_id_list (prc_set%proc_id)
	prc_set%lib_active = .true.
	end subroutine resonant_subprocess_set_freeze_library

	@ %def resonant_subprocess_set_create_library
	@ %def resonant_subprocess_set_add_to_library
	@ %def resonant_subprocess_set_freeze_library
	@ The common parts of the procedures above: (i) create a new process
	library or recover it, (ii) for each history, create a
	process configuration and record it.
	<<Restricted subprocesses: procedures>>=
	subroutine create_library (libname, global, exist)
	type(string_t), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: global
	logical, intent(out) :: exist
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	type(resonance_history_t) :: res_history
	type(string_t), dimension(:), allocatable :: proc_id
	type(restricted_process_configuration_t) :: prc_config
	integer :: i
	lib => global%prclib_stack%get_library_ptr (libname)
	exist = associated (lib)
	if (.not. exist) then
	call msg_message ("Creating library for resonant subprocesses '" &
	// char (libname) // "'")
	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)
	else
	call msg_message ("Using library for resonant subprocesses '" &
	// char (libname) // "'")
	call global%update_prclib (lib)
	end if
	end subroutine create_library

	subroutine add_to_library (libname, res_history_set, prt_in, prt_out, global)
	type(string_t), intent(in) :: libname
	type(resonance_history_set_t), intent(in) :: res_history_set
	type(prt_spec_t), dimension(:), intent(in) :: prt_in
	type(prt_spec_t), dimension(:), intent(in) :: prt_out
	type(rt_data_t), intent(inout), target :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	type(resonance_history_t) :: res_history
	type(string_t), dimension(:), allocatable :: proc_id
	type(restricted_process_configuration_t) :: prc_config
	integer :: n0, i
	lib => global%prclib_stack%get_library_ptr (libname)
	if (associated (lib)) then
	n0 = lib%get_n_processes ()
	allocate (proc_id (res_history_set%get_n_history ()))
	do i = 1, size (proc_id)
	proc_id(i) = libname // str (n0 + i)
	res_history = res_history_set%get_history(i)
	call prc_config%init_resonant_process (proc_id(i), &
	prt_in, prt_out, &
	res_history, &
	global%model, global%var_list)
	call msg_message ("Resonant subprocess #" &
	// char (str(n0+i)) // ": " &
	// char (res_history%as_omega_string (size (prt_in))))
	call prc_config%record (global)
	if (signal_is_pending ()) return
	end do
	else
	call msg_bug ("Adding subprocesses: library '" &
	// char (libname) // "' not found")
	end if
	end subroutine add_to_library

	@ %def create_library
	@ %def add_to_library
	@ Compile the generated library, required settings taken from the
	[[global]] data set.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: compile_library => resonant_subprocess_set_compile_library
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_compile_library (prc_set, global)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	type(rt_data_t), intent(inout), target :: global
	type(process_library_t), pointer :: lib
	lib => global%prclib_stack%get_library_ptr (prc_set%libname)
	if (lib%get_status () < STAT_ACTIVE) then
	call compile_library (prc_set%libname, global)
	end if
	end subroutine resonant_subprocess_set_compile_library

	@ %def resonant_subprocess_set_compile_library
	@ Check if the library has been created / the process has been evaluated.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: is_active => resonant_subprocess_set_is_active
	<<Restricted subprocesses: procedures>>=
	function resonant_subprocess_set_is_active (prc_set) result (flag)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	logical :: flag
	flag = prc_set%lib_active
	end function resonant_subprocess_set_is_active

	@ %def resonant_subprocess_set_is_active
	@ Return number of generated process objects, library, and process IDs.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: get_n_process => resonant_subprocess_set_get_n_process
	procedure :: get_libname => resonant_subprocess_set_get_libname
	procedure :: get_proc_id => resonant_subprocess_set_get_proc_id
	<<Restricted subprocesses: procedures>>=
	function resonant_subprocess_set_get_n_process (prc_set) result (n)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	integer :: n
	if (prc_set%lib_active) then
	n = size (prc_set%proc_id)
	else
	n = 0
	end if
	end function resonant_subprocess_set_get_n_process

	function resonant_subprocess_set_get_libname (prc_set) result (libname)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	type(string_t) :: libname
	if (prc_set%lib_active) then
	libname = prc_set%libname
	else
	libname = ""
	end if
	end function resonant_subprocess_set_get_libname

	function resonant_subprocess_set_get_proc_id (prc_set, i) result (proc_id)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	integer, intent(in) :: i
	type(string_t) :: proc_id
	if (allocated (prc_set%proc_id)) then
	proc_id = prc_set%proc_id(i)
	else
	proc_id = ""
	end if
	end function resonant_subprocess_set_get_proc_id

	@ %def resonant_subprocess_set_get_n_process
	@ %def resonant_subprocess_set_get_libname
	@ %def resonant_subprocess_set_get_proc_id
	@
	\subsection{Process objects and instances}
	Prepare process objects for all entries in the resonant-subprocesses
	library. The process objects are appended to the global process
	stack. A local environment can be used where we place temporary
	variable settings that affect process-object generation. We
	initialize the processes, such that we can evaluate matrix elements,
	but we do not need to integrate them.

	The internal procedure [[prepare_process]] is an abridged version of
	the procedure with this name in the [[simulations]] module.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: prepare_process_objects &
	=> resonant_subprocess_set_prepare_process_objects
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_prepare_process_objects &
	(prc_set, local, global)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	type(rt_data_t), pointer :: current
	type(process_library_t), pointer :: lib
	type(string_t) :: phs_method_saved, integration_method_saved
	type(string_t) :: proc_id, libname_cur, libname_res
	integer :: i, n
	if (.not. prc_set%is_active ()) return
	if (present (global)) then
	current => global
	else
	current => local
	end if
	libname_cur = current%prclib%get_name ()
	libname_res = prc_set%get_libname ()
	lib => current%prclib_stack%get_library_ptr (libname_res)
	if (associated (lib)) call current%update_prclib (lib)
	phs_method_saved = local%get_sval (var_str ("$phs_method"))
	integration_method_saved = local%get_sval (var_str ("$integration_method"))
	call local%set_string (var_str ("$phs_method"), &
	var_str ("none"), is_known = .true.)
	call local%set_string (var_str ("$integration_method"), &
	var_str ("none"), is_known = .true.)
	n = prc_set%get_n_process ()
	allocate (prc_set%subprocess (n))
	do i = 1, n
	proc_id = prc_set%get_proc_id (i)
	call prepare_process (prc_set%subprocess(i)%p, proc_id)
	if (signal_is_pending ()) return
	end do
	call local%set_string (var_str ("$phs_method"), &
	phs_method_saved, is_known = .true.)
	call local%set_string (var_str ("$integration_method"), &
	integration_method_saved, is_known = .true.)
	lib => current%prclib_stack%get_library_ptr (libname_cur)
	if (associated (lib)) call current%update_prclib (lib)
	contains
	subroutine prepare_process (process, process_id)
	type(process_t), pointer, intent(out) :: process
	type(string_t), intent(in) :: process_id
	call msg_message ("Simulate: initializing resonant subprocess '" &
	// char (process_id) // "'")
	if (present (global)) then
	call integrate_process (process_id, local, global, &
	init_only = .true.)
	else
	call integrate_process (process_id, local, local_stack = .true., &
	init_only = .true.)
	end if
	process => current%process_stack%get_process_ptr (process_id)
	if (.not. associated (process)) then
	call msg_fatal ("Simulate: resonant subprocess '" &
	// char (process_id) // "' could not be initialized: aborting")
	end if
	end subroutine prepare_process
	end subroutine resonant_subprocess_set_prepare_process_objects

	@ %def resonant_subprocess_set_prepare_process_objects
	@ Workspace for the resonant subprocesses.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: prepare_process_instances &
	=> resonant_subprocess_set_prepare_process_instances
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_prepare_process_instances (prc_set, global)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	type(rt_data_t), intent(in), target :: global
	integer :: i, n
	if (.not. prc_set%is_active ()) return
	n = size (prc_set%subprocess)
	allocate (prc_set%instance (n))
	do i = 1, n
	allocate (prc_set%instance(i)%p)
	call prc_set%instance(i)%p%init (prc_set%subprocess(i)%p)
	call prc_set%instance(i)%p%setup_event_data (global%model)
	end do
	end subroutine resonant_subprocess_set_prepare_process_instances

	@ %def resonant_subprocess_set_prepare_process_instances
	@
	\subsection{Event transform connection}
	The idea is that the resonance-insertion event transform has been
	allocated somewhere (namely, in the standard event-transform chain),
	but we maintain a link such that we can inject matrix-element results
	event by event. The event transform holds a selector, to choose one
	of the resonance histories (or none), and it manages resonance
	insertion for the particle set.

	The data that the event transform requires can be provided here. The
	resonance history set has already been assigned with the [[dispatch]]
	initializer. Here, we supply the set of subprocess instances that we
	have generated (see above). The master-process instance is set
	when we [[connect]] the transform by the standard method.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: connect_transform => &
	resonant_subprocess_set_connect_transform
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_connect_transform (prc_set, evt)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	class(evt_t), intent(in), target :: evt
	select type (evt)
	type is (evt_resonance_t)
	prc_set%evt => evt
	call prc_set%evt%set_subprocess_instances (prc_set%instance)
	class default
	call msg_bug ("Resonant subprocess set: event transform has wrong type")
	end select
	end subroutine resonant_subprocess_set_connect_transform

	@ %def resonant_subprocess_set_connect_transform
	@ Set the on-shell limit value in the connected transform.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: set_on_shell_limit => resonant_subprocess_set_on_shell_limit
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_on_shell_limit (prc_set, on_shell_limit)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	real(default), intent(in) :: on_shell_limit
	call prc_set%evt%set_on_shell_limit (on_shell_limit)
	end subroutine resonant_subprocess_set_on_shell_limit

	@ %def resonant_subprocess_set_on_shell_limit
	@ Set the Gaussian turnoff parameter in the connected transform.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: set_on_shell_turnoff => resonant_subprocess_set_on_shell_turnoff
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_on_shell_turnoff &
	(prc_set, on_shell_turnoff)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	real(default), intent(in) :: on_shell_turnoff
	call prc_set%evt%set_on_shell_turnoff (on_shell_turnoff)
	end subroutine resonant_subprocess_set_on_shell_turnoff

	@ %def resonant_subprocess_set_on_shell_turnoff
	@ Reweight (suppress) the background contribution probability, for the
	kinematics where a resonance history is active.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: set_background_factor &
	=> resonant_subprocess_set_background_factor
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_background_factor &
	(prc_set, background_factor)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	real(default), intent(in) :: background_factor
	call prc_set%evt%set_background_factor (background_factor)
	end subroutine resonant_subprocess_set_background_factor

	@ %def resonant_subprocess_set_background_factor
	@
	\subsection{Wrappers for runtime calculations}
	All runtime calculations are delegated to the event transform. The
	following procedures are essentially redundant wrappers. We retain
	them for a unit test below.

	Debugging aid:
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: dump_instances => resonant_subprocess_set_dump_instances
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_dump_instances (prc_set, unit, testflag)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: i, n, u
	u = given_output_unit (unit)
	write (u, "(A)") "*** Process instances of resonant subprocesses"
	write (u, *)
	n = size (prc_set%subprocess)
	do i = 1, n
	associate (instance => prc_set%instance(i)%p)
	call instance%write (u, testflag)
	write (u, *)
	write (u, *)
	end associate
	end do
	end subroutine resonant_subprocess_set_dump_instances

	@ %def resonant_subprocess_set_dump_instances
	@ Inject the current kinematics configuration, reading from the
	previous event transform or from the process instance.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: fill_momenta => resonant_subprocess_set_fill_momenta
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_fill_momenta (prc_set)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	integer :: i, n
	call prc_set%evt%fill_momenta ()
	end subroutine resonant_subprocess_set_fill_momenta

	@ %def resonant_subprocess_set_fill_momenta
	@ Determine the indices of the resonance histories that can be
	considered on-shell for the current kinematics.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: determine_on_shell_histories &
	=> resonant_subprocess_set_determine_on_shell_histories
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_determine_on_shell_histories &
	(prc_set, i_component, index_array)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	integer, intent(in) :: i_component
	integer, dimension(:), allocatable, intent(out) :: index_array
	call prc_set%evt%determine_on_shell_histories (index_array)
	end subroutine resonant_subprocess_set_determine_on_shell_histories

	@ %def resonant_subprocess_set_determine_on_shell_histories
	@ Evaluate selected subprocesses. (In actual operation, the ones that
	have been tagged as on-shell.)
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: evaluate_subprocess &
	=> resonant_subprocess_set_evaluate_subprocess
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_evaluate_subprocess (prc_set, index_array)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	integer, dimension(:), intent(in) :: index_array
	call prc_set%evt%evaluate_subprocess (index_array)
	end subroutine resonant_subprocess_set_evaluate_subprocess

	@ %def resonant_subprocess_set_evaluate_subprocess
	@ Extract the matrix elements of the master process / the resonant
	subprocesses. After the previous routine has been executed, they
	should be available and stored in the corresponding process instances.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: get_master_sqme &
	=> resonant_subprocess_set_get_master_sqme
	procedure :: get_subprocess_sqme &
	=> resonant_subprocess_set_get_subprocess_sqme
	<<Restricted subprocesses: procedures>>=
	function resonant_subprocess_set_get_master_sqme (prc_set) result (sqme)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	real(default) :: sqme
	sqme = prc_set%evt%get_master_sqme ()
	end function resonant_subprocess_set_get_master_sqme

	subroutine resonant_subprocess_set_get_subprocess_sqme (prc_set, sqme)
	class(resonant_subprocess_set_t), intent(in) :: prc_set
	real(default), dimension(:), intent(inout) :: sqme
	integer :: i
	call prc_set%evt%get_subprocess_sqme (sqme)
	end subroutine resonant_subprocess_set_get_subprocess_sqme

	@ %def resonant_subprocess_set_get_master_sqme
	@ %def resonant_subprocess_set_get_subprocess_sqme
	@ We use the calculations of resonant matrix elements to determine
	probabilities for all resonance configurations.
	<<Restricted subprocesses: resonant subprocess set: TBP>>=
	procedure :: compute_probabilities &
	=> resonant_subprocess_set_compute_probabilities
	<<Restricted subprocesses: procedures>>=
	subroutine resonant_subprocess_set_compute_probabilities (prc_set, prob_array)
	class(resonant_subprocess_set_t), intent(inout) :: prc_set
	real(default), dimension(:), allocatable, intent(out) :: prob_array
	integer, dimension(:), allocatable :: index_array
	real(default) :: sqme, sqme_sum, sqme_bg
	real(default), dimension(:), allocatable :: sqme_res
	integer :: n
	n = size (prc_set%subprocess)
	allocate (prob_array (0:n), source = 0._default)
	call prc_set%evt%compute_probabilities ()
	call prc_set%evt%get_selector_weights (prob_array)
	end subroutine resonant_subprocess_set_compute_probabilities

	@ %def resonant_subprocess_set_compute_probabilities
	@
	\subsection{Unit tests}
	Test module, followed by the stand-alone unit-test procedures.
	<<[[restricted_subprocesses_ut.f90]]>>=
	<<File header>>

	module restricted_subprocesses_ut
	use unit_tests
	use restricted_subprocesses_uti

	<<Standard module head>>

	<<Restricted subprocesses: public test>>

	contains

	<<Restricted subprocesses: test driver>>

	end module restricted_subprocesses_ut
	@ %def restricted_subprocesses_ut
	@
	<<[[restricted_subprocesses_uti.f90]]>>=
	<<File header>>

	module restricted_subprocesses_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units, only: free_unit
	use format_defs, only: FMT_10, FMT_12
	use lorentz, only: vector4_t, vector3_moving, vector4_moving
	use particle_specifiers, only: new_prt_spec
	use process_libraries, only: process_library_t
	use resonances, only: resonance_info_t
	use resonances, only: resonance_history_t
	use resonances, only: resonance_history_set_t
	use state_matrices, only: FM_IGNORE_HELICITY
	use particles, only: particle_set_t
	use model_data, only: model_data_t
	use models, only: syntax_model_file_init, syntax_model_file_final
	use models, only: model_t
	use rng_base_ut, only: rng_test_factory_t
	use mci_base, only: mci_t
	use phs_base, only: phs_config_t
	use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
	use phs_wood, only: phs_wood_config_t
	use process_libraries, only: process_def_entry_t
	use process_libraries, only: process_component_def_t
	use prclib_stacks, only: prclib_entry_t
	use prc_core_def, only: prc_core_def_t
	use prc_omega, only: omega_def_t
	use process, only: process_t
	use instances, only: process_instance_t
	use process_stacks, only: process_entry_t
	use event_transforms, only: evt_trivial_t
	use resonance_insertion, only: evt_resonance_t
	use integrations, only: integrate_process
	use rt_data, only: rt_data_t

	use restricted_subprocesses

	<<Standard module head>>

	<<Restricted subprocesses: test declarations>>

	<<Restricted subprocesses: test auxiliary types>>

	<<Restricted subprocesses: public test auxiliary>>

	contains

	<<Restricted subprocesses: tests>>

	<<Restricted subprocesses: test auxiliary>>

	end module restricted_subprocesses_uti

	@ %def restricted_subprocesses_uti
	@ API: driver for the unit tests below.
	<<Restricted subprocesses: public test>>=
	public :: restricted_subprocesses_test
	<<Restricted subprocesses: test driver>>=
	subroutine restricted_subprocesses_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Restricted subprocesses: execute tests>>
	end subroutine restricted_subprocesses_test

	@ %def restricted_subprocesses_test
	@
	\subsubsection{subprocess configuration}
	Initialize a [[restricted_subprocess_configuration_t]] object which represents
	a given process with a defined resonance history.
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_1, "restricted_subprocesses_1", &
	"single subprocess", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_1
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_1 (u)
	integer, intent(in) :: u
	type(rt_data_t) :: global
	type(resonance_info_t) :: res_info
	type(resonance_history_t) :: res_history
	type(string_t) :: prc_name
	type(string_t), dimension(2) :: prt_in
	type(string_t), dimension(3) :: prt_out
	type(restricted_process_configuration_t) :: prc_config

	write (u, "(A)") "* Test output: restricted_subprocesses_1"
	write (u, "(A)") "* Purpose: create subprocess list from resonances"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%select_model (var_str ("SM"))

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

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

	write (u, "(A)")
	write (u, "(A)") "* Create process configuration"
	write (u, "(A)")

	prc_name = "restricted_subprocesses_1_p"
	prt_in(1) = "e-"
	prt_in(2) = "e+"
	prt_out(1) = "d"
	prt_out(2) = "u"
	prt_out(3) = "W+"

	call prc_config%init_resonant_process (prc_name, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), &
	res_history, global%model, global%var_list)

	call prc_config%write (u)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_1

	@ %def restricted_subprocesses_1
	@
	\subsubsection{Subprocess library configuration}
	Create a process library that represents restricted subprocesses for a given
	set of resonance histories
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_2, "restricted_subprocesses_2", &
	"subprocess library", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_2
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_2 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(resonance_info_t) :: res_info
	type(resonance_history_t), dimension(2) :: res_history
	type(resonance_history_set_t) :: res_history_set
	type(string_t) :: libname
	type(string_t), dimension(2) :: prt_in
	type(string_t), dimension(3) :: prt_out
	type(resonant_subprocess_set_t) :: prc_set
	type(process_library_t), pointer :: lib
	logical :: exist

	write (u, "(A)") "* Test output: restricted_subprocesses_2"
	write (u, "(A)") "* Purpose: create subprocess library from resonances"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%select_model (var_str ("SM"))

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

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

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

	call res_history_set%init ()
	call res_history_set%enter (res_history(1))
	call res_history_set%enter (res_history(2))
	call res_history_set%freeze ()

	write (u, "(A)")
	write (u, "(A)") "* Empty restricted subprocess set"
	write (u, "(A)")

	write (u, "(A,1x,L1)") "active =", prc_set%is_active ()
	write (u, "(A)")

	call prc_set%write (u, testflag=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Fill restricted subprocess set"
	write (u, "(A)")

	libname = "restricted_subprocesses_2_p_R"
	prt_in(1) = "e-"
	prt_in(2) = "e+"
	prt_out(1) = "d"
	prt_out(2) = "u"
	prt_out(3) = "W+"

	call prc_set%init (1)
	call prc_set%fill_resonances (res_history_set, 1)
	call prc_set%create_library (libname, global, exist)
	if (.not. exist) then
	call prc_set%add_to_library (1, &
	new_prt_spec (prt_in), new_prt_spec (prt_out), &
	global)
	end if
	call prc_set%freeze_library (global)

	write (u, "(A,1x,L1)") "active =", prc_set%is_active ()
	write (u, "(A)")

	call prc_set%write (u, testflag=.true.)

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

	write (u, "(A,1x,I0)") "n_process =", prc_set%get_n_process ()
	write (u, "(A)")
	write (u, "(A,A,A)") "libname = '", char (prc_set%get_libname ()), "'"
	write (u, "(A)")
	write (u, "(A,A,A)") "proc_id(1) = '", char (prc_set%get_proc_id (1)), "'"
	write (u, "(A,A,A)") "proc_id(2) = '", char (prc_set%get_proc_id (2)), "'"


	write (u, "(A)")
	write (u, "(A)") "* Process library"
	write (u, "(A)")

	call prc_set%compile_library (global)

	lib => global%prclib_stack%get_library_ptr (libname)
	if (associated (lib)) call lib%write (u, libpath=.false.)

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

	call global%final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_2

	@ %def restricted_subprocesses_2
	@
	\subsubsection{Auxiliary: Test processes}
	Auxiliary subroutine that constructs the process library for the above test.
	This parallels a similar subroutine in [[processes_uti]], but this time we
	want an \oMega\ process.
	<<Restricted subprocesses: public test auxiliary>>=
	public :: prepare_resonance_test_library
	<<Restricted subprocesses: test auxiliary>>=
	subroutine prepare_resonance_test_library &
	(lib, libname, procname, model, global, u)
	type(process_library_t), target, intent(out) :: lib
	type(string_t), intent(in) :: libname
	type(string_t), intent(in) :: procname
	class(model_data_t), intent(in), pointer :: model
	type(rt_data_t), intent(in), target :: global
	integer, intent(in) :: u
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	class(prc_core_def_t), allocatable :: def
	type(process_def_entry_t), pointer :: entry

	call lib%init (libname)

	allocate (prt_in (2), prt_out (3))
	prt_in = [var_str ("e+"), var_str ("e-")]
	prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]

	allocate (omega_def_t :: def)
	select type (def)
	type is (omega_def_t)
	call def%init (model%get_name (), prt_in, prt_out, &
	ovm=.false., ufo=.false.)
	end select
	allocate (entry)
	call entry%init (procname, &
	model_name = model%get_name (), &
	n_in = 2, n_components = 1, &
	requires_resonances = .true.)
	call entry%import_component (1, n_out = size (prt_out), &
	prt_in = new_prt_spec (prt_in), &
	prt_out = new_prt_spec (prt_out), &
	method = var_str ("omega"), &
	variant = def)
	call entry%write (u)

	call lib%append (entry)

	call lib%configure (global%os_data)
	call lib%write_makefile (global%os_data, force = .true., verbose = .false.)
	call lib%clean (global%os_data, distclean = .false.)
	call lib%write_driver (force = .true.)
	call lib%load (global%os_data)

	end subroutine prepare_resonance_test_library

	@ %def prepare_resonance_test_library
	@
	\subsubsection{Kinematics and resonance selection}
	Prepare an actual process with resonant subprocesses. Insert
	kinematics and apply the resonance selector in an associated event
	transform.
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_3, "restricted_subprocesses_3", &
	"resonance kinematics and probability", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_3
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_3 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(string_t) :: libname, libname_res
	type(string_t) :: procname
	type(process_component_def_t), pointer :: process_component_def
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	logical :: exist
	type(process_t), pointer :: process
	type(process_instance_t), target :: process_instance
	type(resonance_history_set_t), dimension(1) :: res_history_set
	type(resonant_subprocess_set_t) :: prc_set
	type(particle_set_t) :: pset
	real(default) :: sqrts, mw, pp
	real(default), dimension(3) :: p3
	type(vector4_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: m
	integer, dimension(:), allocatable :: pdg
	real(default), dimension(:), allocatable :: sqme
	logical, dimension(:), allocatable :: mask
	real(default) :: on_shell_limit
	integer, dimension(:), allocatable :: i_array
	real(default), dimension(:), allocatable :: prob_array
	type(evt_resonance_t), target :: evt_resonance
	integer :: i, u_dump

	write (u, "(A)") "* Test output: restricted_subprocesses_3"
	write (u, "(A)") "* Purpose: handle process and resonance kinematics"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)

	call global%select_model (var_str ("SM"))
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	libname = "restricted_subprocesses_3_lib"
	libname_res = "restricted_subprocesses_3_lib_res"
	procname = "restricted_subprocesses_3_p"

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	call integrate_process (procname, global, &
	local_stack = .true., init_only = .true.)

	process => global%process_stack%get_process_ptr (procname)

	call process_instance%init (process)
	call process_instance%setup_event_data ()

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

	call process%extract_resonance_history_set &
	(res_history_set(1), include_trivial=.true., i_component=1)
	call res_history_set(1)%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Build resonant-subprocess library"
	write (u, "(A)")

	call prc_set%init (1)
	call prc_set%fill_resonances (res_history_set(1), 1)

	process_component_def => process%get_component_def_ptr (1)
	call prc_set%create_library (libname_res, global, exist)
	if (.not. exist) then
	call prc_set%add_to_library (1, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end if
	call prc_set%freeze_library (global)
	call prc_set%compile_library (global)
	call prc_set%write (u, testflag=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Build particle set"
	write (u, "(A)")

	sqrts = global%get_rval (var_str ("sqrts"))
	mw = 80._default ! deliberately slightly different from true mw
	pp = sqrt (sqrts*2 - 4 mw**2) / 2

	allocate (pdg (5), p (5), m (5))
	pdg(1) = -11
	p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
	m(1) = 0
	pdg(2) = 11
	p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
	m(2) = 0
	pdg(3) = 1
	p3(1) = pp/2
	p3(2) = mw/2
	p3(3) = 0
	p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(3) = 0
	p3(2) = -mw/2
	pdg(4) = -2
	p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(4) = 0
	pdg(5) = 24
	p(5) = vector4_moving (sqrts/2,-pp, 1)
	m(5) = mw

	call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
	call pset%set_momentum (p, m**2)
	call pset%write (u, testflag=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Fill process instance"

	! workflow from event_recalculate
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1)
	call process_instance%recover &
	(1, 1, update_sqme=.true., recover_phs=.false.)
	call process_instance%evaluate_event_data (weight = 1._default)

	write (u, "(A)")
	write (u, "(A)") "* Prepare resonant subprocesses"

	call prc_set%prepare_process_objects (global)
	call prc_set%prepare_process_instances (global)

	call evt_resonance%set_resonance_data (res_history_set)
	call evt_resonance%select_component (1)
	call prc_set%connect_transform (evt_resonance)
	call evt_resonance%connect (process_instance, model)

	call prc_set%fill_momenta ()

	write (u, "(A)")
	write (u, "(A)") "* Show squared matrix element of master process,"
	write (u, "(A)") " should coincide with 2nd subprocess sqme"
	write (u, "(A)")

	write (u, "(1x,I0,1x," // FMT_12 // ")") 0, prc_set%get_master_sqme ()

	write (u, "(A)")
	write (u, "(A)") "* Compute squared matrix elements &
	&of selected resonant subprocesses [1,2]"
	write (u, "(A)")

	call prc_set%evaluate_subprocess ([1,2])

	allocate (sqme (3), source = 0._default)
	call prc_set%get_subprocess_sqme (sqme)
	do i = 1, size (sqme)
	write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i)
	end do
	deallocate (sqme)

	write (u, "(A)")
	write (u, "(A)") "* Compute squared matrix elements &
	&of all resonant subprocesses"
	write (u, "(A)")

	call prc_set%evaluate_subprocess ([1,2,3])

	allocate (sqme (3), source = 0._default)
	call prc_set%get_subprocess_sqme (sqme)
	do i = 1, size (sqme)
	write (u, "(1x,I0,1x," // FMT_12 // ")") i, sqme(i)
	end do
	deallocate (sqme)

	write (u, "(A)")
	write (u, "(A)") "* Write process instances to file &
	&restricted_subprocesses_3_lib_res.dat"

	u_dump = free_unit ()
	open (unit = u_dump, file = "restricted_subprocesses_3_lib_res.dat", &
	action = "write", status = "replace")
	call prc_set%dump_instances (u_dump)
	close (u_dump)

	write (u, "(A)")
	write (u, "(A)") "* Determine on-shell resonant subprocesses"
	write (u, "(A)")

	on_shell_limit = 0
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	write (u, "(1x,A,9(1x,I0))") "resonant =", i_array

	on_shell_limit = 0.1_default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	write (u, "(1x,A,9(1x,I0))") "resonant =", i_array

	on_shell_limit = 10._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	write (u, "(1x,A,9(1x,I0))") "resonant =", i_array

	on_shell_limit = 10000._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	write (u, "(1x,A,9(1x,I0))") "resonant =", i_array

	write (u, "(A)")
	write (u, "(A)") "* Compute probabilities for applicable resonances"
	write (u, "(A)") " and initialize the process selector"
	write (u, "(A)") " (The first number is the probability for background)"
	write (u, "(A)")

	on_shell_limit = 0
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	call prc_set%compute_probabilities (prob_array)
	write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
	call prc_set%write (u, testflag=.true.)
	write (u, *)

	on_shell_limit = 10._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	call prc_set%compute_probabilities (prob_array)
	write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
	call prc_set%write (u, testflag=.true.)
	write (u, *)

	on_shell_limit = 10000._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call prc_set%set_on_shell_limit (on_shell_limit)
	call prc_set%determine_on_shell_histories (1, i_array)
	call prc_set%compute_probabilities (prob_array)
	write (u, "(1x,A,9(1x,"// FMT_12 // "))") "resonant =", prob_array
	write (u, *)
	call prc_set%write (u, testflag=.true.)
	write (u, *)

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_3

	@ %def restricted_subprocesses_3
	@
	\subsubsection{Event transform}
	Prepare an actual process with resonant subprocesses. Prepare the
	resonance selector for a fixed event and apply the resonance-insertion
	event transform.
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_4, "restricted_subprocesses_4", &
	"event transform", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_4
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_4 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(string_t) :: libname, libname_res
	type(string_t) :: procname
	type(process_component_def_t), pointer :: process_component_def
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	logical :: exist
	type(process_t), pointer :: process
	type(process_instance_t), target :: process_instance
	type(resonance_history_set_t), dimension(1) :: res_history_set
	type(resonant_subprocess_set_t) :: prc_set
	type(particle_set_t) :: pset
	real(default) :: sqrts, mw, pp
	real(default), dimension(3) :: p3
	type(vector4_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: m
	integer, dimension(:), allocatable :: pdg
	real(default) :: on_shell_limit
	type(evt_trivial_t), target :: evt_trivial
	type(evt_resonance_t), target :: evt_resonance
	real(default) :: probability
	integer :: i

	write (u, "(A)") "* Test output: restricted_subprocesses_4"
	write (u, "(A)") "* Purpose: employ event transform"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)

	call global%select_model (var_str ("SM"))
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	libname = "restricted_subprocesses_4_lib"
	libname_res = "restricted_subprocesses_4_lib_res"
	procname = "restricted_subprocesses_4_p"

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	call integrate_process (procname, global, &
	local_stack = .true., init_only = .true.)

	process => global%process_stack%get_process_ptr (procname)

	call process_instance%init (process)
	call process_instance%setup_event_data ()

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

	call process%extract_resonance_history_set &
	(res_history_set(1), include_trivial=.false., i_component=1)

	write (u, "(A)")
	write (u, "(A)") "* Build resonant-subprocess library"

	call prc_set%init (1)
	call prc_set%fill_resonances (res_history_set(1), 1)

	process_component_def => process%get_component_def_ptr (1)
	call prc_set%create_library (libname_res, global, exist)
	if (.not. exist) then
	call prc_set%add_to_library (1, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end if
	call prc_set%freeze_library (global)
	call prc_set%compile_library (global)

	write (u, "(A)")
	write (u, "(A)") "* Build particle set"
	write (u, "(A)")

	sqrts = global%get_rval (var_str ("sqrts"))
	mw = 80._default ! deliberately slightly different from true mw
	pp = sqrt (sqrts*2 - 4 mw**2) / 2

	allocate (pdg (5), p (5), m (5))
	pdg(1) = -11
	p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
	m(1) = 0
	pdg(2) = 11
	p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
	m(2) = 0
	pdg(3) = 1
	p3(1) = pp/2
	p3(2) = mw/2
	p3(3) = 0
	p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(3) = 0
	p3(2) = -mw/2
	pdg(4) = -2
	p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(4) = 0
	pdg(5) = 24
	p(5) = vector4_moving (sqrts/2,-pp, 1)
	m(5) = mw

	call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
	call pset%set_momentum (p, m**2)

	write (u, "(A)") "* Fill process instance"
	write (u, "(A)")

	! workflow from event_recalculate
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1)
	call process_instance%recover &
	(1, 1, update_sqme=.true., recover_phs=.false.)
	call process_instance%evaluate_event_data (weight = 1._default)

	write (u, "(A)") "* Prepare resonant subprocesses"
	write (u, "(A)")

	call prc_set%prepare_process_objects (global)
	call prc_set%prepare_process_instances (global)

	write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
	write (u, "(A)")

	call evt_trivial%connect (process_instance, model)
	call evt_trivial%set_particle_set (pset, 1, 1)
	call evt_trivial%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize resonance-insertion event transform"
	write (u, "(A)")

	evt_trivial%next => evt_resonance
	evt_resonance%previous => evt_trivial

	call evt_resonance%set_resonance_data (res_history_set)
	call evt_resonance%select_component (1)
	call evt_resonance%connect (process_instance, model)
	call prc_set%connect_transform (evt_resonance)
	call evt_resonance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute probabilities for applicable resonances"
	write (u, "(A)") " and initialize the process selector"
	write (u, "(A)")

	on_shell_limit = 10._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", on_shell_limit
	call evt_resonance%set_on_shell_limit (on_shell_limit)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate resonance-insertion event transform"
	write (u, "(A)")

	call evt_resonance%prepare_new_event (1, 1)
	call evt_resonance%generate_weighted (probability)
	call evt_resonance%make_particle_set (1, .false.)

	call evt_resonance%write (u, testflag=.true.)

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_4

	@ %def restricted_subprocesses_4
	@
	\subsubsection{Gaussian turnoff}
	Identical to the previous process, except that we apply a Gaussian
	turnoff to the resonance kinematics, which affects the subprocess selector.
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_5, "restricted_subprocesses_5", &
	"event transform with gaussian turnoff", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_5
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_5 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(string_t) :: libname, libname_res
	type(string_t) :: procname
	type(process_component_def_t), pointer :: process_component_def
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	logical :: exist
	type(process_t), pointer :: process
	type(process_instance_t), target :: process_instance
	type(resonance_history_set_t), dimension(1) :: res_history_set
	type(resonant_subprocess_set_t) :: prc_set
	type(particle_set_t) :: pset
	real(default) :: sqrts, mw, pp
	real(default), dimension(3) :: p3
	type(vector4_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: m
	integer, dimension(:), allocatable :: pdg
	real(default) :: on_shell_limit
	real(default) :: on_shell_turnoff
	type(evt_trivial_t), target :: evt_trivial
	type(evt_resonance_t), target :: evt_resonance
	real(default) :: probability
	integer :: i

	write (u, "(A)") "* Test output: restricted_subprocesses_5"
	write (u, "(A)") "* Purpose: employ event transform &
	&with gaussian turnoff"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)

	call global%select_model (var_str ("SM"))
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	libname = "restricted_subprocesses_5_lib"
	libname_res = "restricted_subprocesses_5_lib_res"
	procname = "restricted_subprocesses_5_p"

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	call integrate_process (procname, global, &
	local_stack = .true., init_only = .true.)

	process => global%process_stack%get_process_ptr (procname)

	call process_instance%init (process)
	call process_instance%setup_event_data ()

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

	call process%extract_resonance_history_set &
	(res_history_set(1), include_trivial=.false., i_component=1)

	write (u, "(A)")
	write (u, "(A)") "* Build resonant-subprocess library"

	call prc_set%init (1)
	call prc_set%fill_resonances (res_history_set(1), 1)

	process_component_def => process%get_component_def_ptr (1)
	call prc_set%create_library (libname_res, global, exist)
	if (.not. exist) then
	call prc_set%add_to_library (1, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end if
	call prc_set%freeze_library (global)
	call prc_set%compile_library (global)

	write (u, "(A)")
	write (u, "(A)") "* Build particle set"
	write (u, "(A)")

	sqrts = global%get_rval (var_str ("sqrts"))
	mw = 80._default ! deliberately slightly different from true mw
	pp = sqrt (sqrts*2 - 4 mw**2) / 2

	allocate (pdg (5), p (5), m (5))
	pdg(1) = -11
	p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
	m(1) = 0
	pdg(2) = 11
	p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
	m(2) = 0
	pdg(3) = 1
	p3(1) = pp/2
	p3(2) = mw/2
	p3(3) = 0
	p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(3) = 0
	p3(2) = -mw/2
	pdg(4) = -2
	p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(4) = 0
	pdg(5) = 24
	p(5) = vector4_moving (sqrts/2,-pp, 1)
	m(5) = mw

	call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
	call pset%set_momentum (p, m**2)

	write (u, "(A)") "* Fill process instance"
	write (u, "(A)")

	! workflow from event_recalculate
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1)
	call process_instance%recover &
	(1, 1, update_sqme=.true., recover_phs=.false.)
	call process_instance%evaluate_event_data (weight = 1._default)

	write (u, "(A)") "* Prepare resonant subprocesses"
	write (u, "(A)")

	call prc_set%prepare_process_objects (global)
	call prc_set%prepare_process_instances (global)

	write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
	write (u, "(A)")

	call evt_trivial%connect (process_instance, model)
	call evt_trivial%set_particle_set (pset, 1, 1)
	call evt_trivial%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize resonance-insertion event transform"
	write (u, "(A)")

	evt_trivial%next => evt_resonance
	evt_resonance%previous => evt_trivial

	call evt_resonance%set_resonance_data (res_history_set)
	call evt_resonance%select_component (1)
	call evt_resonance%connect (process_instance, model)
	call prc_set%connect_transform (evt_resonance)
	call evt_resonance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute probabilities for applicable resonances"
	write (u, "(A)") " and initialize the process selector"
	write (u, "(A)")

	on_shell_limit = 10._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_limit =", &
	on_shell_limit
	call evt_resonance%set_on_shell_limit (on_shell_limit)

	on_shell_turnoff = 1._default
	write (u, "(1x,A,1x," // FMT_10 // ")") "on_shell_turnoff =", &
	on_shell_turnoff
	call evt_resonance%set_on_shell_turnoff (on_shell_turnoff)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate resonance-insertion event transform"
	write (u, "(A)")

	call evt_resonance%prepare_new_event (1, 1)
	call evt_resonance%generate_weighted (probability)
	call evt_resonance%make_particle_set (1, .false.)

	call evt_resonance%write (u, testflag=.true.)

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_5

	@ %def restricted_subprocesses_5
	@
	\subsubsection{Event transform}
	The same process and event again. This time, switch off the background
	contribution, so the selector becomes trivial.
	<<Restricted subprocesses: execute tests>>=
	call test (restricted_subprocesses_6, "restricted_subprocesses_6", &
	"event transform with background switched off", &
	u, results)
	<<Restricted subprocesses: test declarations>>=
	public :: restricted_subprocesses_6
	<<Restricted subprocesses: tests>>=
	subroutine restricted_subprocesses_6 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(string_t) :: libname, libname_res
	type(string_t) :: procname
	type(process_component_def_t), pointer :: process_component_def
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	logical :: exist
	type(process_t), pointer :: process
	type(process_instance_t), target :: process_instance
	type(resonance_history_set_t), dimension(1) :: res_history_set
	type(resonant_subprocess_set_t) :: prc_set
	type(particle_set_t) :: pset
	real(default) :: sqrts, mw, pp
	real(default), dimension(3) :: p3
	type(vector4_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: m
	integer, dimension(:), allocatable :: pdg
	real(default) :: on_shell_limit
	real(default) :: background_factor
	type(evt_trivial_t), target :: evt_trivial
	type(evt_resonance_t), target :: evt_resonance
	real(default) :: probability
	integer :: i

	write (u, "(A)") "* Test output: restricted_subprocesses_6"
	write (u, "(A)") "* Purpose: employ event transform &
	&with background switched off"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)

	call global%select_model (var_str ("SM"))
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	libname = "restricted_subprocesses_6_lib"
	libname_res = "restricted_subprocesses_6_lib_res"
	procname = "restricted_subprocesses_6_p"

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	call integrate_process (procname, global, &
	local_stack = .true., init_only = .true.)

	process => global%process_stack%get_process_ptr (procname)

	call process_instance%init (process)
	call process_instance%setup_event_data ()

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

	call process%extract_resonance_history_set &
	(res_history_set(1), include_trivial=.false., i_component=1)

	write (u, "(A)")
	write (u, "(A)") "* Build resonant-subprocess library"

	call prc_set%init (1)
	call prc_set%fill_resonances (res_history_set(1), 1)

	process_component_def => process%get_component_def_ptr (1)
	call prc_set%create_library (libname_res, global, exist)
	if (.not. exist) then
	call prc_set%add_to_library (1, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end if
	call prc_set%freeze_library (global)
	call prc_set%compile_library (global)

	write (u, "(A)")
	write (u, "(A)") "* Build particle set"
	write (u, "(A)")

	sqrts = global%get_rval (var_str ("sqrts"))
	mw = 80._default ! deliberately slightly different from true mw
	pp = sqrt (sqrts*2 - 4 mw**2) / 2

	allocate (pdg (5), p (5), m (5))
	pdg(1) = -11
	p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
	m(1) = 0
	pdg(2) = 11
	p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
	m(2) = 0
	pdg(3) = 1
	p3(1) = pp/2
	p3(2) = mw/2
	p3(3) = 0
	p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(3) = 0
	p3(2) = -mw/2
	pdg(4) = -2
	p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(4) = 0
	pdg(5) = 24
	p(5) = vector4_moving (sqrts/2,-pp, 1)
	m(5) = mw

	call pset%init_direct (0, 2, 0, 0, 3, pdg, model)
	call pset%set_momentum (p, m**2)

	write (u, "(A)") "* Fill process instance"
	write (u, "(A)")

	! workflow from event_recalculate
	call process_instance%choose_mci (1)
	call process_instance%set_trace (pset, 1)
	call process_instance%recover &
	(1, 1, update_sqme=.true., recover_phs=.false.)
	call process_instance%evaluate_event_data (weight = 1._default)

	write (u, "(A)") "* Prepare resonant subprocesses"
	write (u, "(A)")

	call prc_set%prepare_process_objects (global)
	call prc_set%prepare_process_instances (global)

	write (u, "(A)") "* Fill trivial event transform (deliberately w/o color)"
	write (u, "(A)")

	call evt_trivial%connect (process_instance, model)
	call evt_trivial%set_particle_set (pset, 1, 1)
	call evt_trivial%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize resonance-insertion event transform"
	write (u, "(A)")

	evt_trivial%next => evt_resonance
	evt_resonance%previous => evt_trivial

	call evt_resonance%set_resonance_data (res_history_set)
	call evt_resonance%select_component (1)
	call evt_resonance%connect (process_instance, model)
	call prc_set%connect_transform (evt_resonance)
	call evt_resonance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Compute probabilities for applicable resonances"
	write (u, "(A)") " and initialize the process selector"
	write (u, "(A)")

	on_shell_limit = 10._default
	write (u, "(1x,A,1x," // FMT_10 // ")") &
	"on_shell_limit =", on_shell_limit
	call evt_resonance%set_on_shell_limit (on_shell_limit)

	background_factor = 0
	write (u, "(1x,A,1x," // FMT_10 // ")") &
	"background_factor =", background_factor
	call evt_resonance%set_background_factor (background_factor)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate resonance-insertion event transform"
	write (u, "(A)")

	call evt_resonance%prepare_new_event (1, 1)
	call evt_resonance%generate_weighted (probability)
	call evt_resonance%make_particle_set (1, .false.)

	call evt_resonance%write (u, testflag=.true.)

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

	call global%final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()

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

	end subroutine restricted_subprocesses_6

	@ %def restricted_subprocesses_6
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Simulation}
	This module manages simulation: event generation and reading/writing of event
	files. The [[simulation]] object is intended to be used (via a pointer)
	outside of \whizard, if events are generated individually by an external
	driver.
	<<[[simulations.f90]]>>=
	<<File header>>

	module simulations

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use format_utils, only: write_separator
	use format_defs, only: FMT_15, FMT_19
	use os_interface
	use numeric_utils
	use string_utils, only: str
	use diagnostics
	use lorentz, only: vector4_t
	use sm_qcd
	use md5
	use variables, only: var_list_t
	use eval_trees
	use model_data
	use flavors
	use particles
	use state_matrices, only: FM_IGNORE_HELICITY
	use beam_structures, only: beam_structure_t
	use beams
	use rng_base
	use rng_stream, only: rng_stream_t
	use selectors
	use resonances, only: resonance_history_set_t
	use process_libraries, only: process_library_t
	use process_libraries, only: process_component_def_t
	use prc_core
	! TODO: (bcn 2016-09-13) should be ideally only pcm_base
	use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t
	! TODO: (bcn 2016-09-13) details of process config should not be necessary here
	use process_config, only: COMP_REAL_FIN
	use process
	use instances
	use event_base
	use event_handles, only: event_handle_t
	use events
	use event_transforms
	use shower
	use eio_data
	use eio_base
	use rt_data

	use dispatch_beams, only: dispatch_qcd
	use dispatch_rng, only: dispatch_rng_factory
	use dispatch_rng, only: update_rng_seed_in_var_list
	use dispatch_me_methods, only: dispatch_core_update, dispatch_core_restore
	use dispatch_transforms, only: dispatch_evt_isr_epa_handler
	use dispatch_transforms, only: dispatch_evt_resonance
	use dispatch_transforms, only: dispatch_evt_decay
	use dispatch_transforms, only: dispatch_evt_shower
	use dispatch_transforms, only: dispatch_evt_hadrons
	use dispatch_transforms, only: dispatch_evt_nlo

	use integrations
	use event_streams
	use restricted_subprocesses, only: resonant_subprocess_set_t
	use restricted_subprocesses, only: get_libname_res

	use evt_nlo

	<<Use mpi f08>>

	<<Standard module head>>

	<<Simulations: public>>

	<<Simulations: types>>

	<<Simulations: interfaces>>

	contains

	<<Simulations: procedures>>

	end module simulations
	@ %def simulations
	@
	\subsection{Event counting}
	In this object we collect statistical information about an event
	sample or sub-sample.
	<<Simulations: types>>=
	type :: counter_t
	integer :: total = 0
	integer :: generated = 0
	integer :: read = 0
	integer :: positive = 0
	integer :: negative = 0
	integer :: zero = 0
	integer :: excess = 0
	integer :: dropped = 0
	real(default) :: max_excess = 0
	real(default) :: sum_excess = 0
	logical :: reproduce_xsection = .false.
	real(default) :: mean = 0
	real(default) :: varsq = 0
	integer :: nlo_weight_counter = 0
	contains
	<<Simulations: counter: TBP>>
	end type counter_t

	@ %def simulation_counter_t
	@ Output.
	<<Simulations: counter: TBP>>=
	procedure :: write => counter_write
	<<Simulations: procedures>>=
	subroutine counter_write (counter, unit)
	class(counter_t), intent(in) :: counter
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	1 format (3x,A,I0)
	2 format (5x,A,I0)
	3 format (5x,A,ES19.12)
	write (u, 1) "Events total = ", counter%total
	write (u, 2) "generated = ", counter%generated
	write (u, 2) "read = ", counter%read
	write (u, 2) "positive weight = ", counter%positive
	write (u, 2) "negative weight = ", counter%negative
	write (u, 2) "zero weight = ", counter%zero
	write (u, 2) "excess weight = ", counter%excess
	if (counter%excess /= 0) then
	write (u, 3) "max excess = ", counter%max_excess
	write (u, 3) "avg excess = ", counter%sum_excess / counter%total
	end if
	write (u, 1) "Events dropped = ", counter%dropped
	end subroutine counter_write

	@ %def counter_write
	@ This is a screen message: if there was an excess, display statistics.
	<<Simulations: counter: TBP>>=
	procedure :: show_excess => counter_show_excess
	<<Simulations: procedures>>=
	subroutine counter_show_excess (counter)
	class(counter_t), intent(in) :: counter
	if (counter%excess > 0) then
	write (msg_buffer, "(A,1x,I0,1x,A,1x,'(',F7.3,' %)')") &
	"Encountered events with excess weight:", counter%excess, &
	"events", 100 * counter%excess / real (counter%total)
	call msg_warning ()
	write (msg_buffer, "(A,ES10.3)") &
	"Maximum excess weight =", counter%max_excess
	call msg_message ()
	write (msg_buffer, "(A,ES10.3)") &
	"Average excess weight =", counter%sum_excess / counter%total
	call msg_message ()
	end if
	end subroutine counter_show_excess

	@ %def counter_show_excess
	@ If events have been dropped during simulation of weighted events,
	issue a message here.
	If a fraction [[n_dropped / n_total]] of the events fail the cuts, we keep
	generating new ones until we have [[n_total]] events with [[weight > 0]].
	Thus, the total sum of weights will be a fraction of [[n_dropped / n_total]]
	too large. However, we do not know how many events will pass or fail the cuts
	prior to generating them so we leave it to the user to correct for this factor.
	<<Simulations: counter: TBP>>=
	procedure :: show_dropped => counter_show_dropped
	<<Simulations: procedures>>=
	subroutine counter_show_dropped (counter)
	class(counter_t), intent(in) :: counter
	if (counter%dropped > 0) then
	write (msg_buffer, "(A,1x,I0,1x,'(',A,1x,I0,')')") &
	"Dropped events (weight zero) =", &
	counter%dropped, "total", counter%dropped + counter%total
	call msg_message ()
	write (msg_buffer, "(A,ES15.8)") &
	"All event weights must be rescaled by f =", &
	real (counter%total, default) &
	/ real (counter%dropped + counter%total, default)
	call msg_warning ()
	end if
	end subroutine counter_show_dropped

	@ %def counter_show_dropped
	@
	<<Simulations: counter: TBP>>=
	procedure :: show_mean_and_variance => counter_show_mean_and_variance
	<<Simulations: procedures>>=
	subroutine counter_show_mean_and_variance (counter)
	class(counter_t), intent(in) :: counter
	if (counter%reproduce_xsection .and. counter%nlo_weight_counter > 1) then
	print *, "Reconstructed cross-section from event weights: "
	print *, counter%mean, '+-', sqrt (counter%varsq / (counter%nlo_weight_counter - 1))
	end if
	end subroutine counter_show_mean_and_variance

	@ %def counter_show_mean_and_variance
	@ Count an event. The weight and event source are optional; by
	default we assume that the event has been generated and has positive
	weight.

	The optional integer [[n_dropped]] counts weighted events with weight
	zero that were encountered while generating the current event, but
	dropped (because of their zero weight). Accumulating this number
	allows for renormalizing event weight sums in histograms, after the
	generation step has been completed.
	<<Simulations: counter: TBP>>=
	procedure :: record => counter_record
	<<Simulations: procedures>>=
	subroutine counter_record (counter, weight, excess, n_dropped, from_file)
	class(counter_t), intent(inout) :: counter
	real(default), intent(in), optional :: weight, excess
	integer, intent(in), optional :: n_dropped
	logical, intent(in), optional :: from_file
	counter%total = counter%total + 1
	if (present (from_file)) then
	if (from_file) then
	counter%read = counter%read + 1
	else
	counter%generated = counter%generated + 1
	end if
	else
	counter%generated = counter%generated + 1
	end if
	if (present (weight)) then
	if (weight > 0) then
	counter%positive = counter%positive + 1
	else if (weight < 0) then
	counter%negative = counter%negative + 1
	else
	counter%zero = counter%zero + 1
	end if
	else
	counter%positive = counter%positive + 1
	end if
	if (present (excess)) then
	if (excess > 0) then
	counter%excess = counter%excess + 1
	counter%max_excess = max (counter%max_excess, excess)
	counter%sum_excess = counter%sum_excess + excess
	end if
	end if
	if (present (n_dropped)) then
	counter%dropped = counter%dropped + n_dropped
	end if
	end subroutine counter_record

	@ %def counter_record
	<<MPI: Simulations: counter: TBP>>=
	procedure :: allreduce_record => counter_allreduce_record
	<<MPI: Simulations: procedures>>=
	subroutine counter_allreduce_record (counter)
	class(counter_t), intent(inout) :: counter
	integer :: read, generated
	integer :: positive, negative, zero, excess, dropped
	real(default) :: max_excess, sum_excess
	read = counter%read
	generated = counter%generated
	positive = counter%positive
	negative = counter%negative
	zero = counter%zero
	excess = counter%excess
	max_excess = counter%max_excess
	sum_excess = counter%sum_excess
	dropped = counter%dropped
	call MPI_ALLREDUCE (read, counter%read, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (generated, counter%generated, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (positive, counter%positive, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (negative, counter%negative, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (zero, counter%zero, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (excess, counter%excess, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (max_excess, counter%max_excess, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (sum_excess, counter%sum_excess, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD)
	call MPI_ALLREDUCE (dropped, counter%dropped, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD)
	!! \todo{sbrass - Implement allreduce of mean and variance, relevant for weighted events.}
	end subroutine counter_allreduce_record

	@
	<<Simulations: counter: TBP>>=
	procedure :: record_mean_and_variance => &
	counter_record_mean_and_variance
	<<Simulations: procedures>>=
	subroutine counter_record_mean_and_variance (counter, weight, i_nlo)
	class(counter_t), intent(inout) :: counter
	real(default), intent(in) :: weight
	integer, intent(in) :: i_nlo
	real(default), save :: weight_buffer = 0._default
	integer, save :: nlo_count = 1
	if (.not. counter%reproduce_xsection) return
	if (i_nlo == 1) then
	call flush_weight_buffer (weight_buffer, nlo_count)
	weight_buffer = weight
	nlo_count = 1
	else
	weight_buffer = weight_buffer + weight
	nlo_count = nlo_count + 1
	end if
	contains
	subroutine flush_weight_buffer (w, n_nlo)
	real(default), intent(in) :: w
	integer, intent(in) :: n_nlo
	integer :: n
	real(default) :: mean_new
	counter%nlo_weight_counter = counter%nlo_weight_counter + 1
	!!! Minus 1 to take into account offset from initialization
	n = counter%nlo_weight_counter - 1
	if (n > 0) then
	mean_new = counter%mean + (w / n_nlo - counter%mean) / n
	if (n > 1) &
	counter%varsq = counter%varsq - counter%varsq / (n - 1) + &
	n * (mean_new - counter%mean)**2
	counter%mean = mean_new
	end if
	end subroutine flush_weight_buffer
	end subroutine counter_record_mean_and_variance

	@ %def counter_record_mean_and_variance
	@
	\subsection{Simulation: component sets}
	For each set of process components that share a MCI entry in the
	process configuration, we keep a separate event record.
	<<Simulations: types>>=
	type :: mci_set_t
	private
	integer :: n_components = 0
	integer, dimension(:), allocatable :: i_component
	type(string_t), dimension(:), allocatable :: component_id
	logical :: has_integral = .false.
	real(default) :: integral = 0
	real(default) :: error = 0
	real(default) :: weight_mci = 0
	type(counter_t) :: counter
	contains
	<<Simulations: mci set: TBP>>
	end type mci_set_t

	@ %def mci_set_t
	@ Output.
	<<Simulations: mci set: TBP>>=
	procedure :: write => mci_set_write
	<<Simulations: procedures>>=
	subroutine mci_set_write (object, unit, pacified)
	class(mci_set_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: pacified
	logical :: pacify
	integer :: u, i
	u = given_output_unit (unit)
	pacify = .false.; if (present (pacified)) pacify = pacified
	write (u, "(3x,A)") "Components:"
	do i = 1, object%n_components
	write (u, "(5x,I0,A,A,A)") object%i_component(i), &
	": '", char (object%component_id(i)), "'"
	end do
	if (object%has_integral) then
	if (pacify) then
	write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral
	write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error
	write (u, "(3x,A,F9.6)") "Weight =", object%weight_mci
	else
	write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral
	write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error
	write (u, "(3x,A,F13.10)") "Weight =", object%weight_mci
	end if
	else
	write (u, "(3x,A)") "Integral = [undefined]"
	end if
	call object%counter%write (u)
	end subroutine mci_set_write

	@ %def mci_set_write
	@ Initialize: Get the indices and names for the process components
	that will contribute to this set.
	<<Simulations: mci set: TBP>>=
	procedure :: init => mci_set_init
	<<Simulations: procedures>>=
	subroutine mci_set_init (object, i_mci, process)
	class(mci_set_t), intent(out) :: object
	integer, intent(in) :: i_mci
	type(process_t), intent(in), target :: process
	integer :: i
	call process%get_i_component (i_mci, object%i_component)
	object%n_components = size (object%i_component)
	allocate (object%component_id (object%n_components))
	do i = 1, size (object%component_id)
	object%component_id(i) = &
	process%get_component_id (object%i_component(i))
	end do
	if (process%has_integral (i_mci)) then
	object%integral = process%get_integral (i_mci)
	object%error = process%get_error (i_mci)
	object%has_integral = .true.
	end if
	end subroutine mci_set_init

	@ %def mci_set_init
	@
	\subsection{Process-core Safe}
	This is an object that temporarily holds a process core object. We
	need this while rescanning a process with modified parameters. After
	the rescan, we want to restore the original state.
	<<Simulations: types>>=
	type :: core_safe_t
	class(prc_core_t), allocatable :: core
	end type core_safe_t

	@ %def core_safe_t
	@
	\subsection{Process Object}
	The simulation works on process objects. This subroutine makes a
	process object available for simulation. The process is in the
	process stack. [[use_process]] implies that the process should
	already exist as an object in the process stack. If integration is
	not yet done, do it. Any generated process object should be put on
	the global stack, if it is separate from the local one.
	<<Simulations: procedures>>=
	subroutine prepare_process &
	(process, process_id, use_process, integrate, local, global)
	type(process_t), pointer, intent(out) :: process
	type(string_t), intent(in) :: process_id
	logical, intent(in) :: use_process, integrate
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	type(rt_data_t), pointer :: current
	if (debug_on) call msg_debug (D_CORE, "prepare_process")
	if (debug_on) call msg_debug (D_CORE, "global present", present (global))
	if (present (global)) then
	current => global
	else
	current => local
	end if
	process => current%process_stack%get_process_ptr (process_id)
	if (debug_on) call msg_debug (D_CORE, "use_process", use_process)
	if (debug_on) call msg_debug (D_CORE, "associated process", associated (process))
	if (use_process .and. .not. associated (process)) then
	if (integrate) then
	call msg_message ("Simulate: process '" &
	// char (process_id) // "' needs integration")
	else
	call msg_message ("Simulate: process '" &
	// char (process_id) // "' needs initialization")
	end if
	if (present (global)) then
	call integrate_process (process_id, local, global, &
	init_only = .not. integrate)
	else
	call integrate_process (process_id, local, &
	local_stack = .true., init_only = .not. integrate)
	end if
	if (signal_is_pending ()) return
	process => current%process_stack%get_process_ptr (process_id)
	if (associated (process)) then
	if (integrate) then
	call msg_message ("Simulate: integration done")
	call current%process_stack%fill_result_vars (process_id)
	else
	call msg_message ("Simulate: process initialization done")
	end if
	else
	call msg_fatal ("Simulate: process '" &
	// char (process_id) // "' could not be initialized: aborting")
	end if
	else if (.not. associated (process)) then
	if (present (global)) then
	call integrate_process (process_id, local, global, &
	init_only = .true.)
	else
	call integrate_process (process_id, local, &
	local_stack = .true., init_only = .true.)
	end if
	process => current%process_stack%get_process_ptr (process_id)
	call msg_message &
	("Simulate: process '" &
	// char (process_id) // "': enabled for rescan only")
	end if
	end subroutine prepare_process

	@ %def prepare_process
	@
	\subsection{Simulation-entry object}
	For each process that we consider for event generation, we need a
	separate entry. The entry separately records the process ID and run ID. The
	[[weight_mci]] array is used for selecting a component set (which
	shares an MCI record inside the process container) when generating an
	event for the current process.

	The simulation entry is an extension of the [[event_t]] event record.
	This core object contains configuration data, pointers to the process
	and process instance, the expressions, flags and values that are
	evaluated at runtime, and the resulting particle set.

	The entry explicitly allocates the [[process_instance]], which becomes
	the process-specific workspace for the event record.

	If entries with differing environments are present simultaneously, we
	may need to switch QCD parameters and/or the model event by event. In
	this case, the [[qcd]] and/or [[model]] components are present.

	For the purpose of NLO events, [[entry_t]] contains a pointer list
	to other simulation-entries. This is due to the fact that we have to
	associate an event for each component of the fixed order simulation,
	i.e. one $N$-particle event and $N_\text{phs}$ $N+1$-particle events.
	However, all entries share the same event transforms.
	<<Simulations: types>>=
	type, extends (event_t) :: entry_t
	private
	type(string_t) :: process_id
	type(string_t) :: library
	type(string_t) :: run_id
	logical :: has_integral = .false.
	real(default) :: integral = 0
	real(default) :: error = 0
	real(default) :: process_weight = 0
	logical :: valid = .false.
	type(counter_t) :: counter
	integer :: n_in = 0
	integer :: n_mci = 0
	type(mci_set_t), dimension(:), allocatable :: mci_sets
	type(selector_t) :: mci_selector
	logical :: has_resonant_subprocess_set = .false.
	type(resonant_subprocess_set_t) :: resonant_subprocess_set
	type(core_safe_t), dimension(:), allocatable :: core_safe
	class(model_data_t), pointer :: model => null ()
	type(qcd_t) :: qcd
	type(entry_t), pointer :: first => null ()
	type(entry_t), pointer :: next => null ()
	class(evt_t), pointer :: evt_powheg => null ()
	contains
	<<Simulations: entry: TBP>>
	end type entry_t

	@ %def entry_t
	@ Output. Write just the configuration, the event is written by a
	separate routine.

	The [[verbose]] option is unused, it is required by the interface of
	the base-object method.
	<<Simulations: entry: TBP>>=
	procedure :: write_config => entry_write_config
	<<Simulations: procedures>>=
	subroutine entry_write_config (object, unit, pacified)
	class(entry_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: pacified
	logical :: pacify
	integer :: u, i
	u = given_output_unit (unit)
	pacify = .false.; if (present (pacified)) pacify = pacified
	write (u, "(3x,A,A,A)") "Process = '", char (object%process_id), "'"
	write (u, "(3x,A,A,A)") "Library = '", char (object%library), "'"
	write (u, "(3x,A,A,A)") "Run = '", char (object%run_id), "'"
	write (u, "(3x,A,L1)") "is valid = ", object%valid
	if (object%has_integral) then
	if (pacify) then
	write (u, "(3x,A," // FMT_15 // ")") "Integral = ", object%integral
	write (u, "(3x,A," // FMT_15 // ")") "Error = ", object%error
	write (u, "(3x,A,F9.6)") "Weight =", object%process_weight
	else
	write (u, "(3x,A," // FMT_19 // ")") "Integral = ", object%integral
	write (u, "(3x,A," // FMT_19 // ")") "Error = ", object%error
	write (u, "(3x,A,F13.10)") "Weight =", object%process_weight
	end if
	else
	write (u, "(3x,A)") "Integral = [undefined]"
	end if
	write (u, "(3x,A,I0)") "MCI sets = ", object%n_mci
	call object%counter%write (u)
	do i = 1, size (object%mci_sets)
	write (u, "(A)")
	write (u, "(1x,A,I0,A)") "MCI set #", i, ":"
	call object%mci_sets(i)%write (u, pacified)
	end do
	if (object%resonant_subprocess_set%is_active ()) then
	write (u, "(A)")
	call object%write_resonant_subprocess_data (u)
	end if
	if (allocated (object%core_safe)) then
	do i = 1, size (object%core_safe)
	write (u, "(1x,A,I0,A)") "Saved process-component core #", i, ":"
	call object%core_safe(i)%core%write (u)
	end do
	end if
	end subroutine entry_write_config

	@ %def entry_write_config
	@ Finalizer. The [[instance]] pointer component of the [[event_t]]
	base type points to a target which we did explicitly allocate in the
	[[entry_init]] procedure. Therefore, we finalize and explicitly
	deallocate it here. Then we call the finalizer of the base type.
	<<Simulations: entry: TBP>>=
	procedure :: final => entry_final
	<<Simulations: procedures>>=
	subroutine entry_final (object)
	class(entry_t), intent(inout) :: object
	integer :: i
	if (associated (object%instance)) then
	do i = 1, object%n_mci
	call object%instance%final_simulation (i)
	end do
	call object%instance%final ()
	deallocate (object%instance)
	end if
	call object%event_t%final ()
	end subroutine entry_final

	@ %def entry_final
	@ Copy the content of an entry into another one, except for the next-pointer
	<<Simulations: entry: TBP>>=
	procedure :: copy_entry => entry_copy_entry
	<<Simulations: procedures>>=
	subroutine entry_copy_entry (entry1, entry2)
	class(entry_t), intent(in), target :: entry1
	type(entry_t), intent(inout), target :: entry2
	call entry1%event_t%clone (entry2%event_t)
	entry2%process_id = entry1%process_id
	entry2%library = entry1%library
	entry2%run_id = entry1%run_id
	entry2%has_integral = entry1%has_integral
	entry2%integral = entry1%integral
	entry2%error = entry1%error
	entry2%process_weight = entry1%process_weight
	entry2%valid = entry1%valid
	entry2%counter = entry1%counter
	entry2%n_in = entry1%n_in
	entry2%n_mci = entry1%n_mci
	if (allocated (entry1%mci_sets)) then
	allocate (entry2%mci_sets (size (entry1%mci_sets)))
	entry2%mci_sets = entry1%mci_sets
	end if
	entry2%mci_selector = entry1%mci_selector
	if (allocated (entry1%core_safe)) then
	allocate (entry2%core_safe (size (entry1%core_safe)))
	entry2%core_safe = entry1%core_safe
	end if
	entry2%model => entry1%model
	entry2%qcd = entry1%qcd
	end subroutine entry_copy_entry

	@ %def entry_copy_entry
	@
	\subsubsection{Simulation-entry initialization}
	Search for a process entry and allocate a process
	instance as an anonymous object, temporarily accessible via the
	[[process_instance]] pointer. Assign data by looking at the process
	object and at the environment.

	If [[n_alt]] is set, we prepare for additional alternate sqme and weight
	entries.

	The [[compile]] flag is only false if we do not need the Whizard
	process at all, just its definition. In that case, we skip process
	initialization.

	Otherwise, and if the process object is not found initially: if
	[[integrate]] is set, attempt an integration pass and try again.
	Otherwise, just initialize the object.

	If [[generate]] is set, prepare the MCI objects for generating new events.
	For pure rescanning, this is not necessary.

	If [[resonance_history]] is set, we create a separate process library
	which contains all possible restricted subprocesses with distinct
	resonance histories. These processes will not be integrated, but
	their matrix element codes are used for determining probabilities of
	resonance histories. Note that this can work only if the process
	method is OMega, and the phase-space method is 'wood'.

	When done, we assign the [[instance]] and [[process]] pointers of the
	base type by the [[connect]] method, so we can reference them later.

	TODO: In case of NLO event generation, copying the configuration from the
	master process is rather intransparent. For instance, we override the process
	var list by the global var list.
	<<Simulations: entry: TBP>>=
	procedure :: init => entry_init
	<<Simulations: procedures>>=
	subroutine entry_init &
	(entry, process_id, &
	use_process, integrate, generate, update_sqme, &
	support_resonance_history, &
	local, global, n_alt)
	class(entry_t), intent(inout), target :: entry
	type(string_t), intent(in) :: process_id
	logical, intent(in) :: use_process, integrate, generate, update_sqme
	logical, intent(in) :: support_resonance_history
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	integer, intent(in), optional :: n_alt
	type(process_t), pointer :: process, master_process
	type(process_instance_t), pointer :: process_instance
	type(process_library_t), pointer :: prclib_saved
	integer :: i
	logical :: res_include_trivial
	logical :: combined_integration
	integer :: selected_mci
	selected_mci = 0
	if (debug_on) call msg_debug (D_CORE, "entry_init")
	if (debug_on) call msg_debug (D_CORE, "process_id", process_id)
	call prepare_process &
	(master_process, process_id, use_process, integrate, local, global)
	if (signal_is_pending ()) return

	if (associated (master_process)) then
	if (.not. master_process%has_matrix_element ()) then
	entry%has_integral = .true.
	entry%process_id = process_id
	entry%valid = .false.
	return
	end if
	else
	call entry%basic_init (local%var_list)
	entry%has_integral = .false.
	entry%process_id = process_id
	call entry%import_process_def_characteristics (local%prclib, process_id)
	entry%valid = .true.
	return
	end if

	call entry%basic_init (local%var_list, n_alt)

	entry%process_id = process_id
	if (generate .or. integrate) then
	entry%run_id = master_process%get_run_id ()
	process => master_process
	else
	call local%set_log (var_str ("?rebuild_phase_space"), &
	.false., is_known = .true.)
	call local%set_log (var_str ("?check_phs_file"), &
	.false., is_known = .true.)
	call local%set_log (var_str ("?rebuild_grids"), &
	.false., is_known = .true.)
	entry%run_id = &
	local%var_list%get_sval (var_str ("$run_id"))
	if (update_sqme) then
	call prepare_local_process (process, process_id, local)
	else
	process => master_process
	end if
	end if

	call entry%import_process_characteristics (process)

	allocate (entry%mci_sets (entry%n_mci))
	do i = 1, size (entry%mci_sets)
	call entry%mci_sets(i)%init (i, master_process)
	end do

	call entry%import_process_results (master_process)
	call entry%prepare_expressions (local)

	if (process%is_nlo_calculation ()) then
	call process%init_nlo_settings (global%var_list)
	end if
	combined_integration = local%get_lval (var_str ("?combined_nlo_integration"))
	if (.not. combined_integration) &
	selected_mci = process%extract_active_component_mci ()
	call prepare_process_instance (process_instance, process, local%model, &
	local = local)

	if (generate) then
	if (selected_mci > 0) then
	call process%prepare_simulation (selected_mci)
	call process_instance%init_simulation (selected_mci, entry%config%safety_factor, &
	local%get_lval (var_str ("?keep_failed_events")))
	else
	do i = 1, entry%n_mci
	call process%prepare_simulation (i)
	call process_instance%init_simulation (i, entry%config%safety_factor, &
	local%get_lval (var_str ("?keep_failed_events")))
	end do
	end if
	end if

	if (support_resonance_history) then
	prclib_saved => local%prclib
	call entry%setup_resonant_subprocesses (local, process)
	if (entry%has_resonant_subprocess_set) then
	if (signal_is_pending ()) return
	call entry%compile_resonant_subprocesses (local)
	if (signal_is_pending ()) return
	call entry%prepare_resonant_subprocesses (local, global)
	if (signal_is_pending ()) return
	call entry%prepare_resonant_subprocess_instances (local)
	end if
	if (signal_is_pending ()) return
	if (associated (prclib_saved)) call local%update_prclib (prclib_saved)
	end if

	call entry%setup_event_transforms (process, local)

	call dispatch_qcd (entry%qcd, local%get_var_list_ptr (), local%os_data)

	call entry%connect_qcd ()

	if (present (global)) then
	call entry%connect (process_instance, local%model, global%process_stack)
	else
	call entry%connect (process_instance, local%model, local%process_stack)
	end if
	call entry%setup_expressions ()

	entry%model => process%get_model_ptr ()

	entry%valid = .true.

	end subroutine entry_init

	@ %def entry_init
	@
	<<Simulations: entry: TBP>>=
	procedure :: set_active_real_components => entry_set_active_real_components
	<<Simulations: procedures>>=
	subroutine entry_set_active_real_components (entry)
	class(entry_t), intent(inout) :: entry
	integer :: i_active_real
	select type (pcm => entry%instance%pcm)
	class is (pcm_nlo_t)
	i_active_real = entry%instance%get_real_of_mci ()
	if (debug_on) call msg_debug2 (D_CORE, "i_active_real", i_active_real)
	if (associated (entry%evt_powheg)) then
	select type (evt => entry%evt_powheg)
	type is (evt_shower_t)
	if (entry%process%get_component_type(i_active_real) == COMP_REAL_FIN) then
	if (debug_on) call msg_debug (D_CORE, "Disabling Powheg matching for ", i_active_real)
	call evt%disable_powheg_matching ()
	else
	if (debug_on) call msg_debug (D_CORE, "Enabling Powheg matching for ", i_active_real)
	call evt%enable_powheg_matching ()
	end if
	class default
	call msg_fatal ("powheg-evt should be evt_shower_t!")
	end select
	end if
	end select
	end subroutine entry_set_active_real_components

	@ %def entry_set_active_real_components
	@ Part of simulation-entry initialization: set up a process object for
	local use.
	<<Simulations: procedures>>=
	subroutine prepare_local_process (process, process_id, local)
	type(process_t), pointer, intent(inout) :: process
	type(string_t), intent(in) :: process_id
	type(rt_data_t), intent(inout), target :: local
	type(integration_t) :: intg
	call intg%create_process (process_id)
	call intg%init_process (local)
	call intg%setup_process (local, verbose=.false.)
	process => intg%get_process_ptr ()
	end subroutine prepare_local_process

	@ %def prepare_local_process
	@ Part of simulation-entry initialization: set up a process instance
	matching the selected process object.

	The model that we can provide as an extra argument can modify particle
	settings (polarization) in the density matrices that will be constructed. It
	does not affect parameters.
	<<Simulations: procedures>>=
	subroutine prepare_process_instance &
	(process_instance, process, model, local)
	type(process_instance_t), pointer, intent(inout) :: process_instance
	type(process_t), intent(inout), target :: process
	class(model_data_t), intent(in), optional :: model
	type(rt_data_t), intent(in), optional, target :: local
	allocate (process_instance)
	call process_instance%init (process)
	if (process%is_nlo_calculation ()) then
	select type (pcm_work => process_instance%pcm_work)
	type is (pcm_nlo_workspace_t)
	select type (pcm => process_instance%pcm)
	type is (pcm_nlo_t)
	if (.not. pcm%settings%combined_integration) &
	call pcm_work%set_radiation_event ()
	if (pcm%settings%fixed_order_nlo) &
	call pcm_work%set_fixed_order_event_mode ()
	end select
	end select
	call process%prepare_any_external_code ()
	end if
	call process_instance%setup_event_data (model)
	end subroutine prepare_process_instance

	@ %def prepare_process_instance
	@ Part of simulation-entry initialization: query the
	process for basic information.
	<<Simulations: entry: TBP>>=
	procedure, private :: import_process_characteristics &
	=> entry_import_process_characteristics
	<<Simulations: procedures>>=
	subroutine entry_import_process_characteristics (entry, process)
	class(entry_t), intent(inout) :: entry
	type(process_t), intent(in), target :: process
	entry%library = process%get_library_name ()
	entry%n_in = process%get_n_in ()
	entry%n_mci = process%get_n_mci ()
	end subroutine entry_import_process_characteristics

	@ %def entry_import_process_characteristics
	@ This is the alternative form which applies if there is no process
	entry, but just a process definition which we take from the provided
	[[prclib]] definition library.
	<<Simulations: entry: TBP>>=
	procedure, private :: import_process_def_characteristics &
	=> entry_import_process_def_characteristics
	<<Simulations: procedures>>=
	subroutine entry_import_process_def_characteristics (entry, prclib, id)
	class(entry_t), intent(inout) :: entry
	type(process_library_t), intent(in), target :: prclib
	type(string_t), intent(in) :: id
	entry%library = prclib%get_name ()
	entry%n_in = prclib%get_n_in (id)
	end subroutine entry_import_process_def_characteristics

	@ %def entry_import_process_def_characteristics
	@ Part of simulation-entry initialization: query the
	process for integration results.
	<<Simulations: entry: TBP>>=
	procedure, private :: import_process_results &
	=> entry_import_process_results
	<<Simulations: procedures>>=
	subroutine entry_import_process_results (entry, process)
	class(entry_t), intent(inout) :: entry
	type(process_t), intent(in), target :: process
	if (process%has_integral ()) then
	entry%integral = process%get_integral ()
	entry%error = process%get_error ()
	call entry%set_sigma (entry%integral)
	entry%has_integral = .true.
	end if
	end subroutine entry_import_process_results

	@ %def entry_import_process_characteristics
	@ Part of simulation-entry initialization: create expression factory
	objects and store them.
	<<Simulations: entry: TBP>>=
	procedure, private :: prepare_expressions &
	=> entry_prepare_expressions
	<<Simulations: procedures>>=
	subroutine entry_prepare_expressions (entry, local)
	class(entry_t), intent(inout) :: entry
	type(rt_data_t), intent(in), target :: local
	type(eval_tree_factory_t) :: expr_factory
	call expr_factory%init (local%pn%selection_lexpr)
	call entry%set_selection (expr_factory)
	call expr_factory%init (local%pn%reweight_expr)
	call entry%set_reweight (expr_factory)
	call expr_factory%init (local%pn%analysis_lexpr)
	call entry%set_analysis (expr_factory)
	end subroutine entry_prepare_expressions

	@ %def entry_prepare_expressions
	@
	\subsubsection{Extra (NLO) entries}
	Initializes the list of additional NLO entries. The routine gets the
	information about how many entries to associate from [[region_data]].
	<<Simulations: entry: TBP>>=
	procedure :: setup_additional_entries => entry_setup_additional_entries
	<<Simulations: procedures>>=
	subroutine entry_setup_additional_entries (entry)
	class(entry_t), intent(inout), target :: entry
	type(entry_t), pointer :: current_entry
	integer :: i, n_phs
	type(evt_nlo_t), pointer :: evt
	integer :: mode
	evt => null ()
	select type (pcm => entry%instance%pcm)
	type is (pcm_nlo_t)
	n_phs = pcm%region_data%n_phs
	end select
	select type (entry)
	type is (entry_t)
	current_entry => entry
	current_entry%first => entry
	call get_nlo_evt_ptr (current_entry, evt, mode)
	if (mode > EVT_NLO_SEPARATE_BORNLIKE) then
	allocate (evt%particle_set_nlo (n_phs + 1))
	evt%event_deps%n_phs = n_phs
	evt%qcd = entry%qcd
	do i = 1, n_phs
	allocate (current_entry%next)
	current_entry%next%first => current_entry%first
	current_entry => current_entry%next
	call entry%copy_entry (current_entry)
	current_entry%i_event = i
	end do
	else
	allocate (evt%particle_set_nlo (1))
	end if
	end select
	contains
	subroutine get_nlo_evt_ptr (entry, evt, mode)
	type(entry_t), intent(in), target :: entry
	type(evt_nlo_t), intent(out), pointer :: evt
	integer, intent(out) :: mode
	class(evt_t), pointer :: current_evt
	evt => null ()
	current_evt => entry%transform_first
	do
	select type (current_evt)
	type is (evt_nlo_t)
	evt => current_evt
	mode = evt%mode
	exit
	end select
	if (associated (current_evt%next)) then
	current_evt => current_evt%next
	else
	call msg_fatal ("evt_nlo not in list of event transforms")
	end if
	end do
	end subroutine get_nlo_evt_ptr
	end subroutine entry_setup_additional_entries

	@ %def entry_setup_additional_entries
	@
	<<Simulations: entry: TBP>>=
	procedure :: get_first => entry_get_first
	<<Simulations: procedures>>=
	function entry_get_first (entry) result (entry_out)
	class(entry_t), intent(in), target :: entry
	type(entry_t), pointer :: entry_out
	entry_out => null ()
	select type (entry)
	type is (entry_t)
	if (entry%is_nlo ()) then
	entry_out => entry%first
	else
	entry_out => entry
	end if
	end select
	end function entry_get_first

	@ %def entry_get_first
	@
	<<Simulations: entry: TBP>>=
	procedure :: get_next => entry_get_next
	<<Simulations: procedures>>=
	function entry_get_next (entry) result (next_entry)
	class(entry_t), intent(in) :: entry
	type(entry_t), pointer :: next_entry
	next_entry => null ()
	if (associated (entry%next)) then
	next_entry => entry%next
	else
	call msg_fatal ("Get next entry: No next entry")
	end if
	end function entry_get_next

	@ %def entry_get_next
	@
	<<Simulations: entry: TBP>>=
	procedure :: count_nlo_entries => entry_count_nlo_entries
	<<Simulations: procedures>>=
	function entry_count_nlo_entries (entry) result (n)
	class(entry_t), intent(in), target :: entry
	integer :: n
	type(entry_t), pointer :: current_entry
	n = 1
	if (.not. associated (entry%next)) then
	return
	else
	current_entry => entry%next
	do
	n = n + 1
	if (.not. associated (current_entry%next)) exit
	current_entry => current_entry%next
	end do
	end if
	end function entry_count_nlo_entries

	@ %def entry_count_nlo_entries
	@
	<<Simulations: entry: TBP>>=
	procedure :: reset_nlo_counter => entry_reset_nlo_counter
	<<Simulations: procedures>>=
	subroutine entry_reset_nlo_counter (entry)
	class(entry_t), intent(inout) :: entry
	class(evt_t), pointer :: evt
	evt => entry%transform_first
	do
	select type (evt)
	type is (evt_nlo_t)
	evt%i_evaluation = 0
	exit
	end select
	if (associated (evt%next)) evt => evt%next
	end do
	end subroutine entry_reset_nlo_counter

	@ %def entry_reset_nlo_counter
	@
	<<Simulations: entry: TBP>>=
	procedure :: determine_if_powheg_matching => entry_determine_if_powheg_matching
	<<Simulations: procedures>>=
	subroutine entry_determine_if_powheg_matching (entry)
	class(entry_t), intent(inout) :: entry
	class(evt_t), pointer :: current_transform
	if (associated (entry%transform_first)) then
	current_transform => entry%transform_first
	do
	select type (current_transform)
	type is (evt_shower_t)
	if (current_transform%contains_powheg_matching ()) &
	entry%evt_powheg => current_transform
	exit
	end select
	if (associated (current_transform%next)) then
	current_transform => current_transform%next
	else
	exit
	end if
	end do
	end if
	end subroutine entry_determine_if_powheg_matching

	@ %def entry_determine_if_powheg_matching
	@
	\subsubsection{Event-transform initialization}
	Part of simulation-entry initialization: dispatch event transforms
	(decay, shower) as requested. If a transform is not applicable or
	switched off via some variable, it will be skipped.

	Regarding resonances/decays: these two transforms are currently mutually
	exclusive. Resonance insertion will not be applied if there is an
	unstable particle in the game.

	The initial particle set is the output of the trivial transform; this
	has already been applied when the transforms listed here are
	encountered. Each transform takes a particle set and produces a new
	one, with one exception: the decay module takes its input from the
	process object, ignoring the trivial transform. (Reason: spin
	correlations.) Therefore, the decay module must be first in line.

	Settings that we don't or can't support (yet) are rejected by the
	embedded call to [[event_transforms_check]].
	<<Simulations: entry: TBP>>=
	procedure, private :: setup_event_transforms &
	=> entry_setup_event_transforms
	<<Simulations: procedures>>=
	subroutine entry_setup_event_transforms (entry, process, local)
	class(entry_t), intent(inout) :: entry
	type(process_t), intent(inout), target :: process
	type(rt_data_t), intent(in), target :: local
	class(evt_t), pointer :: evt
	type(var_list_t), pointer :: var_list
	logical :: enable_isr_handler
	logical :: enable_epa_handler
	logical :: enable_fixed_order
	logical :: enable_shower
	character(len=7) :: sample_normalization

	call event_transforms_check (entry, process, local)
	var_list => local%get_var_list_ptr ()

	if (process%contains_unstable (local%model)) then
	call dispatch_evt_decay (evt, local%var_list)
	if (associated (evt)) call entry%import_transform (evt)
	end if

	if (entry%resonant_subprocess_set%is_active ()) then
	call dispatch_evt_resonance (evt, local%var_list, &
	entry%resonant_subprocess_set%get_resonance_history_set (), &
	entry%resonant_subprocess_set%get_libname ())
	if (associated (evt)) then
	call entry%resonant_subprocess_set%connect_transform (evt)
	call entry%resonant_subprocess_set%set_on_shell_limit &
	(local%get_rval (var_str ("resonance_on_shell_limit")))
	call entry%resonant_subprocess_set%set_on_shell_turnoff &
	(local%get_rval (var_str ("resonance_on_shell_turnoff")))
	call entry%resonant_subprocess_set%set_background_factor &
	(local%get_rval (var_str ("resonance_background_factor")))
	call entry%import_transform (evt)
	end if
	end if

	enable_fixed_order = local%get_lval (var_str ("?fixed_order_nlo_events"))
	if (enable_fixed_order) then
	call dispatch_evt_nlo &
	(evt, local%get_lval (var_str ("?keep_failed_events")))
	call entry%import_transform (evt)
	end if

	enable_isr_handler = local%get_lval (var_str ("?isr_handler"))
	enable_epa_handler = local%get_lval (var_str ("?epa_handler"))
	if (enable_isr_handler .or. enable_epa_handler) then
	call dispatch_evt_isr_epa_handler (evt, local%var_list)
	if (associated (evt)) call entry%import_transform (evt)
	end if

	enable_shower = local%get_lval (var_str ("?allow_shower")) .and. &
	(local%get_lval (var_str ("?ps_isr_active")) &
	.or. local%get_lval (var_str ("?ps_fsr_active")) &
	.or. local%get_lval (var_str ("?muli_active")) &
	.or. local%get_lval (var_str ("?mlm_matching")) &
	.or. local%get_lval (var_str ("?ckkw_matching")) &
	.or. local%get_lval (var_str ("?powheg_matching")))
	if (enable_shower) then
	call dispatch_evt_shower (evt, var_list, local%model, &
	local%fallback_model, local%os_data, local%beam_structure, &
	process)
	call entry%import_transform (evt)
	end if

	if (local%get_lval (var_str ("?hadronization_active"))) then
	call dispatch_evt_hadrons (evt, var_list, local%fallback_model)
	call entry%import_transform (evt)
	end if

	end subroutine entry_setup_event_transforms

	@ %def entry_setup_event_transforms
	@
	This routine rejects all event-transform settings which we don't
	support at present.
	<<Simulations: procedures>>=
	subroutine event_transforms_check (entry, process, local)
	class(entry_t), intent(in) :: entry
	type(process_t), intent(in), target :: process
	type(rt_data_t), intent(in), target :: local

	if (local%get_lval (var_str ("?fixed_order_nlo_events"))) then
	if (local%get_lval (var_str ("?unweighted"))) then
	call msg_fatal ("NLO fixed-order events have to be generated with &
	&?unweighted = false")
	end if
	select case (char (local%get_sval (var_str ("$sample_normalization"))))
	case ("sigma", "auto")
	case default
	call msg_fatal ("NLO fixed-order events: only &
	&$sample_normalization = 'sigma' is supported.")
	end select
	if (process%contains_unstable (local%model)) then
	call msg_fatal ("NLO fixed-order events: unstable final-state &
	&particles not supported yet")
	end if
	if (entry%resonant_subprocess_set%is_active ()) then
	call msg_fatal ("NLO fixed-order events: resonant subprocess &
	&insertion not supported")
	end if
	if (local%get_lval (var_str ("?isr_handler")) &
	.or. local%get_lval (var_str ("?epa_handler"))) then
	call msg_fatal ("NLO fixed-order events: ISR handler for &
	&photon-pT generation not supported yet")
	end if
	end if

	if (process%contains_unstable (local%model) &
	.and. entry%resonant_subprocess_set%is_active ()) then
	call msg_fatal ("Simulation: resonant subprocess insertion with &
	&unstable final-state particles not supported")
	end if

	end subroutine event_transforms_check

	@ %def event_transforms_check
	@
	\subsubsection{Process/MCI selector}
	Compute weights. The integral in the argument is the sum of integrals for
	all processes in the sample. After computing the process weights, we repeat
	the normalization procedure for the process components.
	<<Simulations: entry: TBP>>=
	procedure :: init_mci_selector => entry_init_mci_selector
	<<Simulations: procedures>>=
	subroutine entry_init_mci_selector (entry, negative_weights)
	class(entry_t), intent(inout), target :: entry
	logical, intent(in), optional :: negative_weights
	type(entry_t), pointer :: current_entry
	integer :: i, j, k
	if (debug_on) call msg_debug (D_CORE, "entry_init_mci_selector")
	if (entry%has_integral) then
	select type (entry)
	type is (entry_t)
	current_entry => entry
	do j = 1, current_entry%count_nlo_entries ()
	if (j > 1) current_entry => current_entry%get_next ()
	do k = 1, size(current_entry%mci_sets%integral)
	if (debug_on) call msg_debug (D_CORE, "current_entry%mci_sets(k)%integral", &
	current_entry%mci_sets(k)%integral)
	end do
	call current_entry%mci_selector%init &
	(current_entry%mci_sets%integral, negative_weights)
	do i = 1, current_entry%n_mci
	current_entry%mci_sets(i)%weight_mci = &
	current_entry%mci_selector%get_weight (i)
	end do
	end do
	end select
	end if
	end subroutine entry_init_mci_selector

	@ %def entry_init_mci_selector
	@ Select a MCI entry, using the embedded random-number generator.
	<<Simulations: entry: TBP>>=
	procedure :: select_mci => entry_select_mci
	<<Simulations: procedures>>=
	function entry_select_mci (entry) result (i_mci)
	class(entry_t), intent(inout) :: entry
	integer :: i_mci
	if (debug_on) call msg_debug2 (D_CORE, "entry_select_mci")
	i_mci = entry%process%extract_active_component_mci ()
	if (i_mci == 0) call entry%mci_selector%generate (entry%rng, i_mci)
	if (debug_on) call msg_debug2 (D_CORE, "i_mci", i_mci)
	end function entry_select_mci

	@ %def entry_select_mci
	@
	\subsubsection{Entries: event-wise updates}
	Record an event for this entry, i.e., increment the appropriate counters.
	<<Simulations: entry: TBP>>=
	procedure :: record => entry_record
	<<Simulations: procedures>>=
	subroutine entry_record (entry, i_mci, from_file)
	class(entry_t), intent(inout) :: entry
	integer, intent(in) :: i_mci
	logical, intent(in), optional :: from_file
	real(default) :: weight, excess
	integer :: n_dropped
	weight = entry%get_weight_prc ()
	excess = entry%get_excess_prc ()
	n_dropped = entry%get_n_dropped ()
	call entry%counter%record (weight, excess, n_dropped, from_file)
	if (i_mci > 0) then
	call entry%mci_sets(i_mci)%counter%record (weight, excess)
	end if
	end subroutine entry_record

	@ %def entry_record
	@ Update and restore the process core that this entry accesses, when
	parameters change. If explicit arguments [[model]], [[qcd]], or
	[[helicity_selection]] are provided, use those. Otherwise use the
	parameters stored in the process object.

	These two procedures come with a caching mechanism which guarantees
	that the current core object is saved when calling [[update_process]],
	and restored by calling [[restore_process]]. If the flag [[saved]] is
	unset, saving is skipped, and the [[restore]] procedure should not be
	called.
	<<Simulations: entry: TBP>>=
	procedure :: update_process => entry_update_process
	procedure :: restore_process => entry_restore_process
	<<Simulations: procedures>>=
	subroutine entry_update_process &
	(entry, model, qcd, helicity_selection, saved)
	class(entry_t), intent(inout) :: entry
	class(model_data_t), intent(in), optional, target :: model
	type(qcd_t), intent(in), optional :: qcd
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	logical, intent(in), optional :: saved
	type(process_t), pointer :: process
	class(prc_core_t), allocatable :: core
	integer :: i, n_terms
	class(model_data_t), pointer :: model_local
	type(qcd_t) :: qcd_local
	logical :: use_saved
	if (present (model)) then
	model_local => model
	else
	model_local => entry%model
	end if
	if (present (qcd)) then
	qcd_local = qcd
	else
	qcd_local = entry%qcd
	end if
	use_saved = .true.; if (present (saved)) use_saved = saved
	process => entry%get_process_ptr ()
	n_terms = process%get_n_terms ()
	if (use_saved) allocate (entry%core_safe (n_terms))
	do i = 1, n_terms
	if (process%has_matrix_element (i, is_term_index = .true.)) then
	call process%extract_core (i, core)
	if (use_saved) then
	call dispatch_core_update (core, &
	model_local, helicity_selection, qcd_local, &
	entry%core_safe(i)%core)
	else
	call dispatch_core_update (core, &
	model_local, helicity_selection, qcd_local)
	end if
	call process%restore_core (i, core)
	end if
	end do
	end subroutine entry_update_process

	subroutine entry_restore_process (entry)
	class(entry_t), intent(inout) :: entry
	type(process_t), pointer :: process
	class(prc_core_t), allocatable :: core
	integer :: i, n_terms
	process => entry%get_process_ptr ()
	n_terms = process%get_n_terms ()
	do i = 1, n_terms
	if (process%has_matrix_element (i, is_term_index = .true.)) then
	call process%extract_core (i, core)
	call dispatch_core_restore (core, entry%core_safe(i)%core)
	call process%restore_core (i, core)
	end if
	end do
	deallocate (entry%core_safe)
	end subroutine entry_restore_process

	@ %def entry_update_process
	@ %def entry_restore_process
	<<Simulations: entry: TBP>>=
	procedure :: connect_qcd => entry_connect_qcd
	<<Simulations: procedures>>=
	subroutine entry_connect_qcd (entry)
	class(entry_t), intent(inout), target :: entry
	class(evt_t), pointer :: evt
	evt => entry%transform_first
	do while (associated (evt))
	select type (evt)
	type is (evt_shower_t)
	evt%qcd = entry%qcd
	if (allocated (evt%matching)) then
	evt%matching%qcd = entry%qcd
	end if
	end select
	evt => evt%next
	end do
	end subroutine entry_connect_qcd

	@ %def entry_connect_qcd
	@
	\subsection{Handling resonant subprocesses}
	Resonant subprocesses are required if we want to determine resonance histories
	when generating events. The feature is optional, to be switched on by
	the user.

	This procedure initializes a new, separate process library that
	contains copies of the current process, restricted to the relevant
	resonance histories. (If this library exists already, it is just
	kept.) The histories can be extracted from the process object.

	The code has to match the assignments in
	[[create_resonant_subprocess_library]]. The library may already
	exist -- in that case, here it will be recovered without recompilation.
	<<Simulations: entry: TBP>>=
	procedure :: setup_resonant_subprocesses &
	=> entry_setup_resonant_subprocesses
	<<Simulations: procedures>>=
	subroutine entry_setup_resonant_subprocesses (entry, global, process)
	class(entry_t), intent(inout) :: entry
	type(rt_data_t), intent(inout), target :: global
	type(process_t), intent(in), target :: process
	type(string_t) :: libname
	type(resonance_history_set_t) :: res_history_set
	type(process_library_t), pointer :: lib
	type(process_component_def_t), pointer :: process_component_def
	logical :: req_resonant, library_exist
	integer :: i_component
	libname = process%get_library_name ()
	lib => global%prclib_stack%get_library_ptr (libname)
	entry%has_resonant_subprocess_set = lib%req_resonant (process%get_id ())
	if (entry%has_resonant_subprocess_set) then
	libname = get_libname_res (process%get_id ())
	call entry%resonant_subprocess_set%init (process%get_n_components ())
	call entry%resonant_subprocess_set%create_library &
	(libname, global, library_exist)
	do i_component = 1, process%get_n_components ()
	call process%extract_resonance_history_set &
	(res_history_set, i_component = i_component)
	call entry%resonant_subprocess_set%fill_resonances &
	(res_history_set, i_component)
	if (.not. library_exist) then
	process_component_def &
	=> process%get_component_def_ptr (i_component)
	call entry%resonant_subprocess_set%add_to_library &
	(i_component, &
	process_component_def%get_prt_spec_in (), &
	process_component_def%get_prt_spec_out (), &
	global)
	end if
	end do
	call entry%resonant_subprocess_set%freeze_library (global)
	end if
	end subroutine entry_setup_resonant_subprocesses

	@ %def entry_setup_resonant_subprocesses
	@ Compile the resonant-subprocesses library. The library is assumed
	to be the current library in the [[global]] object. This is a simple wrapper.
	<<Simulations: entry: TBP>>=
	procedure :: compile_resonant_subprocesses &
	=> entry_compile_resonant_subprocesses
	<<Simulations: procedures>>=
	subroutine entry_compile_resonant_subprocesses (entry, global)
	class(entry_t), intent(inout) :: entry
	type(rt_data_t), intent(inout), target :: global
	call entry%resonant_subprocess_set%compile_library (global)
	end subroutine entry_compile_resonant_subprocesses

	@ %def entry_compile_resonant_subprocesses
	@ Prepare process objects for the resonant-subprocesses library. The
	process objects are appended to the global process stack. We
	initialize the processes, such that we can evaluate matrix elements,
	but we do not need to integrate them.
	<<Simulations: entry: TBP>>=
	procedure :: prepare_resonant_subprocesses &
	=> entry_prepare_resonant_subprocesses
	<<Simulations: procedures>>=
	subroutine entry_prepare_resonant_subprocesses (entry, local, global)
	class(entry_t), intent(inout) :: entry
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	call entry%resonant_subprocess_set%prepare_process_objects (local, global)
	end subroutine entry_prepare_resonant_subprocesses

	@ %def entry_prepare_resonant_subprocesses
	@ Prepare process instances. They are linked to their corresponding process
	objects. Both, process and instance objects, are allocated as anonymous
	targets inside the [[resonant_subprocess_set]] component.

	NOTE: those anonymous object are likely forgotten during finalization of the
	parent [[event_t]] (extended as [[entry_t]]) object. This should be checked!
	The memory leak is probably harmless as long as the event object is created
	once per run, not once per event.
	<<Simulations: entry: TBP>>=
	procedure :: prepare_resonant_subprocess_instances &
	=> entry_prepare_resonant_subprocess_instances
	<<Simulations: procedures>>=
	subroutine entry_prepare_resonant_subprocess_instances (entry, global)
	class(entry_t), intent(inout) :: entry
	type(rt_data_t), intent(in), target :: global
	call entry%resonant_subprocess_set%prepare_process_instances (global)
	end subroutine entry_prepare_resonant_subprocess_instances

	@ %def entry_prepare_resonant_subprocess_instances
	@ Display the resonant subprocesses. This includes, upon request, the
	resonance set that defines those subprocess, and a short or long account of the
	process objects themselves.
	<<Simulations: entry: TBP>>=
	procedure :: write_resonant_subprocess_data &
	=> entry_write_resonant_subprocess_data
	<<Simulations: procedures>>=
	subroutine entry_write_resonant_subprocess_data (entry, unit)
	class(entry_t), intent(in) :: entry
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	call entry%resonant_subprocess_set%write (unit)
	write (u, "(1x,A,I0)") "Resonant subprocesses refer to &
	&process component #", 1
	end subroutine entry_write_resonant_subprocess_data

	@ %def entry_write_resonant_subprocess_data
	@ Display of the master process for the current event, for diagnostics.
	<<Simulations: entry: TBP>>=
	procedure :: write_process_data => entry_write_process_data
	<<Simulations: procedures>>=
	subroutine entry_write_process_data &
	(entry, unit, show_process, show_instance, verbose)
	class(entry_t), intent(in) :: entry
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: show_process
	logical, intent(in), optional :: show_instance
	logical, intent(in), optional :: verbose
	integer :: u, i
	logical :: s_proc, s_inst, verb
	type(process_t), pointer :: process
	type(process_instance_t), pointer :: instance
	u = given_output_unit (unit)
	s_proc = .false.; if (present (show_process)) s_proc = show_process
	s_inst = .false.; if (present (show_instance)) s_inst = show_instance
	verb = .false.; if (present (verbose)) verb = verbose
	if (s_proc .or. s_inst) then
	write (u, "(1x,A,':')") "Process data"
	if (s_proc) then
	process => entry%process
	if (associated (process)) then
	if (verb) then
	call write_separator (u, 2)
	call process%write (.false., u)
	else
	call process%show (u, verbose=.false.)
	end if
	else
	write (u, "(3x,A)") "[not associated]"
	end if
	end if
	if (s_inst) then
	instance => entry%instance
	if (associated (instance)) then
	if (verb) then
	call instance%write (u)
	else
	call instance%write_header (u)
	end if
	else
	write (u, "(3x,A)") "Process instance: [not associated]"
	end if
	end if
	end if
	end subroutine entry_write_process_data

	@ %def entry_write_process_data
	@
	\subsection{Entries for alternative environment}
	Entries for alternate environments. [No additional components
	anymore, so somewhat redundant.]
	<<Simulations: types>>=
	type, extends (entry_t) :: alt_entry_t
	contains
	<<Simulations: alt entry: TBP>>
	end type alt_entry_t

	@ %def alt_entry_t
	@ The alternative entries are there to re-evaluate the event, given
	momenta, in a different context.

	Therefore, we allocate a local process object and use this as the
	reference for the local process instance, when initializing the entry.
	We temporarily import the [[process]] object into an [[integration_t]]
	wrapper, to take advantage of the associated methods. The local
	process object is built in the context of the current environment,
	here called [[global]]. Then, we initialize the process instance.

	The [[master_process]] object contains the integration results to which we
	refer when recalculating an event. Therefore, we use this object instead of
	the locally built [[process]] when we extract the integration results.

	The locally built [[process]] object should be finalized when done. It
	remains accessible via the [[event_t]] base object of [[entry]], which
	contains pointers to the process and instance.
	<<Simulations: alt entry: TBP>>=
	procedure :: init_alt => alt_entry_init
	<<Simulations: procedures>>=
	subroutine alt_entry_init (entry, process_id, master_process, local)
	class(alt_entry_t), intent(inout), target :: entry
	type(string_t), intent(in) :: process_id
	type(process_t), intent(in), target :: master_process
	type(rt_data_t), intent(inout), target :: local
	type(process_t), pointer :: process
	type(process_instance_t), pointer :: process_instance
	type(string_t) :: run_id
	integer :: i

	call msg_message ("Simulate: initializing alternate process setup ...")

	run_id = &
	local%var_list%get_sval (var_str ("$run_id"))
	call local%set_log (var_str ("?rebuild_phase_space"), &
	.false., is_known = .true.)
	call local%set_log (var_str ("?check_phs_file"), &
	.false., is_known = .true.)
	call local%set_log (var_str ("?rebuild_grids"), &
	.false., is_known = .true.)

	call entry%basic_init (local%var_list)

	call prepare_local_process (process, process_id, local)
	entry%process_id = process_id
	entry%run_id = run_id

	call entry%import_process_characteristics (process)

	allocate (entry%mci_sets (entry%n_mci))
	do i = 1, size (entry%mci_sets)
	call entry%mci_sets(i)%init (i, master_process)
	end do

	call entry%import_process_results (master_process)
	call entry%prepare_expressions (local)

	call prepare_process_instance (process_instance, process, local%model)
	call entry%setup_event_transforms (process, local)

	call entry%connect (process_instance, local%model, local%process_stack)
	call entry%setup_expressions ()

	entry%model => process%get_model_ptr ()

	call msg_message ("... alternate process setup complete.")

	end subroutine alt_entry_init

	@ %def alt_entry_init
	@ Copy the particle set from the master entry to the alternate entry.
	This is the particle set of the hard process.
	<<Simulations: alt entry: TBP>>=
	procedure :: fill_particle_set => entry_fill_particle_set
	<<Simulations: procedures>>=
	subroutine entry_fill_particle_set (alt_entry, entry)
	class(alt_entry_t), intent(inout) :: alt_entry
	class(entry_t), intent(in), target :: entry
	type(particle_set_t) :: pset
	call entry%get_hard_particle_set (pset)
	call alt_entry%set_hard_particle_set (pset)
	call pset%final ()
	end subroutine entry_fill_particle_set

	@ %def particle_set_copy_prt
	@
	\subsection{The simulation object}
	Each simulation object corresponds to an event sample, identified by
	the [[sample_id]].

	The simulation may cover several processes simultaneously. All
	process-specific data, including the event records, are stored in the
	[[entry]] subobjects. The [[current]] index indicates which record
	was selected last. [[version]] is foreseen to contain a tag on the \whizard\
	event file version. It can be
	<<Simulations: public>>=
	public :: simulation_t
	<<Simulations: types>>=
	type :: simulation_t
	private
	type(rt_data_t), pointer :: local => null ()
	type(string_t) :: sample_id
	logical :: unweighted = .true.
	logical :: negative_weights = .false.
	logical :: support_resonance_history = .false.
	logical :: respect_selection = .true.
	integer :: norm_mode = NORM_UNDEFINED
	logical :: update_sqme = .false.
	logical :: update_weight = .false.
	logical :: update_event = .false.
	logical :: recover_beams = .false.
	logical :: pacify = .false.
	integer :: n_max_tries = 10000
	integer :: n_prc = 0
	integer :: n_alt = 0
	logical :: has_integral = .false.
	logical :: valid = .false.
	real(default) :: integral = 0
	real(default) :: error = 0
	integer :: version = 1
	character(32) :: md5sum_prc = ""
	character(32) :: md5sum_cfg = ""
	character(32), dimension(:), allocatable :: md5sum_alt
	type(entry_t), dimension(:), allocatable :: entry
	type(alt_entry_t), dimension(:,:), allocatable :: alt_entry
	type(selector_t) :: process_selector
	integer :: n_evt_requested = 0
	integer :: event_index_offset = 0
	logical :: event_index_set = .false.
	integer :: event_index = 0
	integer :: split_n_evt = 0
	integer :: split_n_kbytes = 0
	integer :: split_index = 0
	type(counter_t) :: counter
	class(rng_t), allocatable :: rng
	integer :: i_prc = 0
	integer :: i_mci = 0
	real(default) :: weight = 0
	real(default) :: excess = 0
	integer :: n_dropped = 0
	contains
	<<Simulations: simulation: TBP>>
	end type simulation_t

	@ %def simulation_t
	@
	\subsubsection{Output of the simulation data}
	[[write_config]] writes just the configuration. [[write]]
	as a method of the base type [[event_t]]
	writes the current event and process instance, depending on options.
	<<Simulations: simulation: TBP>>=
	procedure :: write => simulation_write
	<<Simulations: procedures>>=
	subroutine simulation_write (object, unit, testflag)
	class(simulation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	logical :: pacified
	integer :: u, i
	u = given_output_unit (unit)
	pacified = object%pacify; if (present (testflag)) pacified = testflag
	call write_separator (u, 2)
	write (u, "(1x,A,A,A)") "Event sample: '", char (object%sample_id), "'"
	write (u, "(3x,A,I0)") "Processes = ", object%n_prc
	if (object%n_alt > 0) then
	write (u, "(3x,A,I0)") "Alt.wgts = ", object%n_alt
	end if
	write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted
	write (u, "(3x,A,A)") "Event norm = ", &
	char (event_normalization_string (object%norm_mode))
	write (u, "(3x,A,L1)") "Neg. weights = ", object%negative_weights
	write (u, "(3x,A,L1)") "Res. history = ", object%support_resonance_history
	write (u, "(3x,A,L1)") "Respect sel. = ", object%respect_selection
	write (u, "(3x,A,L1)") "Update sqme = ", object%update_sqme
	write (u, "(3x,A,L1)") "Update wgt = ", object%update_weight
	write (u, "(3x,A,L1)") "Update event = ", object%update_event
	write (u, "(3x,A,L1)") "Recov. beams = ", object%recover_beams
	write (u, "(3x,A,L1)") "Pacify = ", object%pacify
	write (u, "(3x,A,I0)") "Max. tries = ", object%n_max_tries
	if (object%has_integral) then
	if (pacified) then
	write (u, "(3x,A," // FMT_15 // ")") &
	"Integral = ", object%integral
	write (u, "(3x,A," // FMT_15 // ")") &
	"Error = ", object%error
	else
	write (u, "(3x,A," // FMT_19 // ")") &
	"Integral = ", object%integral
	write (u, "(3x,A," // FMT_19 // ")") &
	"Error = ", object%error
	end if
	else
	write (u, "(3x,A)") "Integral = [undefined]"
	end if
	write (u, "(3x,A,L1)") "Sim. valid = ", object%valid
	write (u, "(3x,A,I0)") "Ev.file ver. = ", object%version
	if (object%md5sum_prc /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", object%md5sum_prc, "'"
	end if
	if (object%md5sum_cfg /= "") then
	write (u, "(3x,A,A,A)") "MD5 sum (config) = '", object%md5sum_cfg, "'"
	end if
	write (u, "(3x,A,I0)") "Events requested = ", object%n_evt_requested
	if (object%event_index_offset /= 0) then
	write (u, "(3x,A,I0)") "Event index offset= ", object%event_index_offset
	end if
	if (object%event_index_set) then
	write (u, "(3x,A,I0)") "Event index = ", object%event_index
	end if
	if (object%split_n_evt > 0 .or. object%split_n_kbytes > 0) then
	write (u, "(3x,A,I0)") "Events per file = ", object%split_n_evt
	write (u, "(3x,A,I0)") "KBytes per file = ", object%split_n_kbytes
	write (u, "(3x,A,I0)") "First file index = ", object%split_index
	end if
	call object%counter%write (u)
	call write_separator (u)
	if (object%i_prc /= 0) then
	write (u, "(1x,A)") "Current event:"
	write (u, "(3x,A,I0,A,A)") "Process #", &
	object%i_prc, ": ", &
	char (object%entry(object%i_prc)%process_id)
	write (u, "(3x,A,I0)") "MCI set #", object%i_mci
	write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%weight
	if (.not. vanishes (object%excess)) &
	write (u, "(3x,A," // FMT_19 // ")") "Excess = ", object%excess
	write (u, "(3x,A,I0)") "Zero-weight events dropped = ", object%n_dropped
	else
	write (u, "(1x,A,I0,A,A)") "Current event: [undefined]"
	end if
	call write_separator (u)
	if (allocated (object%rng)) then
	call object%rng%write (u)
	else
	write (u, "(3x,A)") "Random-number generator: [undefined]"
	end if
	if (allocated (object%entry)) then
	do i = 1, size (object%entry)
	if (i == 1) then
	call write_separator (u, 2)
	else
	call write_separator (u)
	end if
	write (u, "(1x,A,I0,A)") "Process #", i, ":"
	call object%entry(i)%write_config (u, pacified)
	end do
	end if
	call write_separator (u, 2)
	end subroutine simulation_write

	@ %def simulation_write
	@ Write the current event record. If an explicit index is given,
	write that event record.

	We implement writing to [[unit]] (event contents / debugging format)
	and writing to an [[eio]] event stream (storage). We include a [[testflag]]
	in order to suppress numerical noise in the testsuite.
	<<Simulations: simulation: TBP>>=
	generic :: write_event => write_event_unit
	procedure :: write_event_unit => simulation_write_event_unit
	<<Simulations: procedures>>=
	subroutine simulation_write_event_unit &
	(object, unit, i_prc, verbose, testflag)
	class(simulation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer, intent(in), optional :: i_prc
	logical, intent(in), optional :: testflag
	logical :: pacified
	integer :: current
	pacified = .false.; if (present(testflag)) pacified = testflag
	pacified = pacified .or. object%pacify
	if (present (i_prc)) then
	current = i_prc
	else
	current = object%i_prc
	end if
	if (current > 0) then
	call object%entry(current)%write (unit, verbose = verbose, &
	testflag = pacified)
	else
	call msg_fatal ("Simulation: write event: no process selected")
	end if
	end subroutine simulation_write_event_unit

	@ %def simulation_write_event
	@ This writes one of the alternate events, if allocated.
	<<Simulations: simulation: TBP>>=
	procedure :: write_alt_event => simulation_write_alt_event
	<<Simulations: procedures>>=
	subroutine simulation_write_alt_event (object, unit, j_alt, i_prc, &
	verbose, testflag)
	class(simulation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: j_alt
	integer, intent(in), optional :: i_prc
	logical, intent(in), optional :: verbose
	logical, intent(in), optional :: testflag
	integer :: i, j
	if (present (j_alt)) then
	j = j_alt
	else
	j = 1
	end if
	if (present (i_prc)) then
	i = i_prc
	else
	i = object%i_prc
	end if
	if (i > 0) then
	if (j> 0 .and. j <= object%n_alt) then
	call object%alt_entry(i,j)%write (unit, verbose = verbose, &
	testflag = testflag)
	else
	call msg_fatal ("Simulation: write alternate event: out of range")
	end if
	else
	call msg_fatal ("Simulation: write alternate event: no process selected")
	end if
	end subroutine simulation_write_alt_event

	@ %def simulation_write_alt_event
	@ This writes the contents of the resonant subprocess set in the current event
	record.
	<<Simulations: simulation: TBP>>=
	procedure :: write_resonant_subprocess_data &
	=> simulation_write_resonant_subprocess_data
	<<Simulations: procedures>>=
	subroutine simulation_write_resonant_subprocess_data (object, unit, i_prc)
	class(simulation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: i_prc
	integer :: i
	if (present (i_prc)) then
	i = i_prc
	else
	i = object%i_prc
	end if
	call object%entry(i)%write_resonant_subprocess_data (unit)
	end subroutine simulation_write_resonant_subprocess_data

	@ %def simulation_write_resonant_subprocess_data
	@ The same for the master process, as an additional debugging aid.
	<<Simulations: simulation: TBP>>=
	procedure :: write_process_data &
	=> simulation_write_process_data
	<<Simulations: procedures>>=
	subroutine simulation_write_process_data &
	(object, unit, i_prc, &
	show_process, show_instance, verbose)
	class(simulation_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer, intent(in), optional :: i_prc
	logical, intent(in), optional :: show_process
	logical, intent(in), optional :: show_instance
	logical, intent(in), optional :: verbose
	integer :: i
	if (present (i_prc)) then
	i = i_prc
	else
	i = object%i_prc
	end if
	call object%entry(i)%write_process_data &
	(unit, show_process, show_instance, verbose)
	end subroutine simulation_write_process_data

	@ %def simulation_write_process_data
	@ Write the actual efficiency of the simulation run. We get the total
	number of events stored in the simulation counter and compare this
	with the total number of calls stored in the event entries.

	In order not to miscount samples that are partly read from file, use
	the [[generated]] counter, not the [[total]] counter.
	<<Simulations: simulation: TBP>>=
	procedure :: show_efficiency => simulation_show_efficiency
	<<Simulations: procedures>>=
	subroutine simulation_show_efficiency (simulation)
	class(simulation_t), intent(inout) :: simulation
	integer :: n_events, n_calls
	real(default) :: eff
	n_events = simulation%counter%generated
	n_calls = sum (simulation%entry%get_actual_calls_total ())
	if (n_calls > 0) then
	eff = real (n_events, kind=default) / n_calls
	write (msg_buffer, "(A,1x,F6.2,1x,A)") &
	"Events: actual unweighting efficiency =", 100 * eff, "%"
	call msg_message ()
	end if
	end subroutine simulation_show_efficiency

	@ %def simulation_show_efficiency
	@ Compute the checksum of the process set. We retrieve the MD5 sums
	of all processes. This depends only on the process definitions, while
	parameters are not considered. The configuration checksum is
	retrieved from the MCI records in the process objects and furthermore
	includes beams, parameters, integration results, etc., so matching the
	latter should guarantee identical physics.
	<<Simulations: simulation: TBP>>=
	procedure :: compute_md5sum => simulation_compute_md5sum
	<<Simulations: procedures>>=
	subroutine simulation_compute_md5sum (simulation)
	class(simulation_t), intent(inout) :: simulation
	type(process_t), pointer :: process
	type(string_t) :: buffer
	integer :: j, i, n_mci, i_mci, n_component, i_component
	if (simulation%md5sum_prc == "") then
	buffer = ""
	do i = 1, simulation%n_prc
	if (.not. simulation%entry(i)%valid) cycle
	process => simulation%entry(i)%get_process_ptr ()
	if (associated (process)) then
	n_component = process%get_n_components ()
	do i_component = 1, n_component
	if (process%has_matrix_element (i_component)) then
	buffer = buffer // process%get_md5sum_prc (i_component)
	end if
	end do
	end if
	end do
	simulation%md5sum_prc = md5sum (char (buffer))
	end if
	if (simulation%md5sum_cfg == "") then
	buffer = ""
	do i = 1, simulation%n_prc
	if (.not. simulation%entry(i)%valid) cycle
	process => simulation%entry(i)%get_process_ptr ()
	if (associated (process)) then
	n_mci = process%get_n_mci ()
	do i_mci = 1, n_mci
	buffer = buffer // process%get_md5sum_mci (i_mci)
	end do
	end if
	end do
	simulation%md5sum_cfg = md5sum (char (buffer))
	end if
	do j = 1, simulation%n_alt
	if (simulation%md5sum_alt(j) == "") then
	buffer = ""
	do i = 1, simulation%n_prc
	process => simulation%alt_entry(i,j)%get_process_ptr ()
	if (associated (process)) then
	buffer = buffer // process%get_md5sum_cfg ()
	end if
	end do
	simulation%md5sum_alt(j) = md5sum (char (buffer))
	end if
	end do
	end subroutine simulation_compute_md5sum

	@ %def simulation_compute_md5sum
	@
	\subsubsection{Simulation-object finalizer}
	<<Simulations: simulation: TBP>>=
	procedure :: final => simulation_final
	<<Simulations: procedures>>=
	subroutine simulation_final (object)
	class(simulation_t), intent(inout) :: object
	integer :: i, j
	if (allocated (object%entry)) then
	do i = 1, size (object%entry)
	call object%entry(i)%final ()
	end do
	end if
	if (allocated (object%alt_entry)) then
	do j = 1, size (object%alt_entry, 2)
	do i = 1, size (object%alt_entry, 1)
	call object%alt_entry(i,j)%final ()
	end do
	end do
	end if
	if (allocated (object%rng)) call object%rng%final ()
	end subroutine simulation_final

	@ %def simulation_final
	@
	\subsubsection{Simulation-object initialization}
	We can deduce all data from the given list of
	process IDs and the global data set. The process objects are taken
	from the stack. Once the individual integrals are known, we add them (and the
	errors), to get the sample integral.

	If there are alternative environments, we suspend initialization for
	setting up alternative process objects, then restore the master
	process and its parameters. The generator or rescanner can then
	switch rapidly between processes.

	If [[integrate]] is set, we make sure that all affected processes are
	integrated before simulation. This is necessary if we want to actually
	generate events. If [[integrate]] is unset, we do not need the integral
	because we just rescan existing events. In that case, we just need compiled
	matrix elements.

	If [[generate]] is set, we prepare for actually generating events. Otherwise,
	we may only read and rescan events.
	<<Simulations: simulation: TBP>>=
	procedure :: init => simulation_init
	<<Simulations: procedures>>=
	subroutine simulation_init (simulation, &
	process_id, integrate, generate, local, global, alt_env)
	class(simulation_t), intent(out), target :: simulation
	type(string_t), dimension(:), intent(in) :: process_id
	logical, intent(in) :: integrate, generate
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), optional, target :: global
	type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env
	class(rng_factory_t), allocatable :: rng_factory
	integer :: next_rng_seed
	type(string_t) :: norm_string, version_string
	logical :: use_process
	integer :: i, j
	type(string_t) :: sample_suffix
	<<Simulations: simulation init: extra variables>>
	sample_suffix = ""
	<<Simulations: simulation init: extra init>>
	simulation%local => local
	simulation%sample_id = &
	local%get_sval (var_str ("$sample"))
	simulation%unweighted = &
	local%get_lval (var_str ("?unweighted"))
	simulation%negative_weights = &
	local%get_lval (var_str ("?negative_weights"))
	simulation%support_resonance_history = &
	local%get_lval (var_str ("?resonance_history"))
	simulation%respect_selection = &
	local%get_lval (var_str ("?sample_select"))
	version_string = &
	local%get_sval (var_str ("$event_file_version"))
	norm_string = &
	local%get_sval (var_str ("$sample_normalization"))
	simulation%norm_mode = &
	event_normalization_mode (norm_string, simulation%unweighted)
	simulation%pacify = &
	local%get_lval (var_str ("?sample_pacify"))
	simulation%event_index_offset = &
	local%get_ival (var_str ("event_index_offset"))
	simulation%n_max_tries = &
	local%get_ival (var_str ("sample_max_tries"))
	simulation%split_n_evt = &
	local%get_ival (var_str ("sample_split_n_evt"))
	simulation%split_n_kbytes = &
	local%get_ival (var_str ("sample_split_n_kbytes"))
	simulation%split_index = &
	local%get_ival (var_str ("sample_split_index"))
	simulation%update_sqme = &
	local%get_lval (var_str ("?update_sqme"))
	simulation%update_weight = &
	local%get_lval (var_str ("?update_weight"))
	simulation%update_event = &
	local%get_lval (var_str ("?update_event"))
	simulation%recover_beams = &
	local%get_lval (var_str ("?recover_beams"))
	simulation%counter%reproduce_xsection = &
	local%get_lval (var_str ("?check_event_weights_against_xsection"))
	use_process = &
	integrate .or. generate &
	.or. simulation%update_sqme &
	.or. simulation%update_weight &
	.or. simulation%update_event &
	.or. present (alt_env)
	select case (size (process_id))
	case (0)
	call msg_error ("Simulation: no process selected")
	case (1)
	write (msg_buffer, "(A,A,A)") &
	"Starting simulation for process '", &
	char (process_id(1)), "'"
	call msg_message ()
	case default
	write (msg_buffer, "(A,A,A)") &
	"Starting simulation for processes '", &
	char (process_id(1)), "' etc."
	call msg_message ()
	end select
	select case (char (version_string))
	case ("", "2.2.4")
	simulation%version = 2
	case ("2.2")
	simulation%version = 1
	case default
	simulation%version = 0
	end select
	if (simulation%version == 0) then
	call msg_fatal ("Event file format '" &
	// char (version_string) &
	// "' is not compatible with this version.")
	end if
	simulation%n_prc = size (process_id)
	allocate (simulation%entry (simulation%n_prc))
	if (present (alt_env)) then
	simulation%n_alt = size (alt_env)
	do i = 1, simulation%n_prc
	call simulation%entry(i)%init (process_id(i), &
	use_process, integrate, generate, &
	simulation%update_sqme, &
	simulation%support_resonance_history, &
	local, global, simulation%n_alt)
	if (signal_is_pending ()) return
	end do
	simulation%valid = any (simulation%entry%valid)
	if (.not. simulation%valid) then
	call msg_error ("Simulate: no process has a valid matrix element.")
	return
	end if
	call simulation%update_processes ()
	allocate (simulation%alt_entry (simulation%n_prc, simulation%n_alt))
	allocate (simulation%md5sum_alt (simulation%n_alt))
	simulation%md5sum_alt = ""
	do j = 1, simulation%n_alt
	do i = 1, simulation%n_prc
	call simulation%alt_entry(i,j)%init_alt (process_id(i), &
	simulation%entry(i)%get_process_ptr (), alt_env(j))
	if (signal_is_pending ()) return
	end do
	end do
	call simulation%restore_processes ()
	else
	do i = 1, simulation%n_prc
	call simulation%entry(i)%init &
	(process_id(i), &
	use_process, integrate, generate, &
	simulation%update_sqme, &
	simulation%support_resonance_history, &
	local, global)
	call simulation%entry(i)%determine_if_powheg_matching ()
	if (signal_is_pending ()) return
	if (simulation%entry(i)%is_nlo ()) &
	call simulation%entry(i)%setup_additional_entries ()
	end do
	simulation%valid = any (simulation%entry%valid)
	if (.not. simulation%valid) then
	call msg_error ("Simulate: " &
	// "no process has a valid matrix element.")
	return
	end if
	end if
	!!! if this becomes conditional, some ref files will need update (seed change)
	! if (generate) then
	call dispatch_rng_factory (rng_factory, local%var_list, next_rng_seed)
	call update_rng_seed_in_var_list (local%var_list, next_rng_seed)
	call rng_factory%make (simulation%rng)
	<<Simulations: simulation init: extra RNG init>>
	! end if
	if (all (simulation%entry%has_integral)) then
	simulation%integral = sum (simulation%entry%integral)
	simulation%error = sqrt (sum (simulation%entry%error ** 2))
	simulation%has_integral = .true.
	if (integrate .and. generate) then
	do i = 1, simulation%n_prc
	if (simulation%entry(i)%integral < 0 .and. .not. &
	simulation%negative_weights) then
	call msg_fatal ("Integral of process '" // &
	char (process_id (i)) // "'is negative.")
	end if
	end do
	end if
	else
	if (integrate .and. generate) &
	call msg_error ("Simulation contains undefined integrals.")
	end if
	if (simulation%integral > 0 .or. &
	(simulation%integral < 0 .and. simulation%negative_weights)) then
	simulation%valid = .true.
	else if (generate) then
	call msg_error ("Simulate: " &
	// "sum of process integrals must be positive; skipping.")
	simulation%valid = .false.
	else
	simulation%valid = .true.
	end if
	if (simulation%sample_id == "") then
	simulation%sample_id = simulation%get_default_sample_name ()
	end if
	simulation%sample_id = simulation%sample_id // sample_suffix
	if (simulation%valid) call simulation%compute_md5sum ()
	end subroutine simulation_init

	@ %def simulation_init
	@ The RNG initialization depends on serial/MPI mode.
	<<Simulations: simulation init: extra variables>>=
	<<MPI: Simulations: simulation init: extra variables>>=
	integer :: rank, n_size
	<<Simulations: simulation init: extra init>>=
	<<MPI: Simulations: simulation init: extra init>>=
	call mpi_get_comm_id (n_size, rank)
	if (n_size > 1) then
	sample_suffix = var_str ("_") // str (rank)
	end if
	<<Simulations: simulation init: extra RNG init>>=
	<<MPI: Simulations: simulation init: extra RNG init>>=
	do i = 2, rank + 1
	select type (rng => simulation%rng)
	type is (rng_stream_t)
	call rng%next_substream ()
	if (i == rank) &
	call msg_message ("Simulate: Advance RNG for parallel event generation")
	class default
	call rng%write ()
	call msg_bug ("Parallel event generation: random-number generator &
	&must be 'rng_stream'.")
	end select
	end do
	@ The number of events that we want to simulate is determined by the
	settings of [[n_events]], [[luminosity]], and [[?unweighted]]. For
	weighted events, we take [[n_events]] at face value as the number of
	matrix element calls. For unweighted events, if the process is a
	decay, [[n_events]] is the number of unweighted events. In these
	cases, the luminosity setting is ignored.

	For unweighted events with a scattering process, we calculate the
	event number that corresponds to the luminosity, given the current
	value of the integral. We then compare this with [[n_events]] and
	choose the larger number.
	<<Simulations: simulation: TBP>>=
	procedure :: compute_n_events => simulation_compute_n_events
	<<Simulations: procedures>>=
	subroutine simulation_compute_n_events (simulation, n_events)
	class(simulation_t), intent(in) :: simulation
	integer, intent(out) :: n_events
	real(default) :: lumi, x_events_lumi
	integer :: n_events_lumi
	logical :: is_scattering
	n_events = &
	simulation%local%get_ival (var_str ("n_events"))
	lumi = &
	simulation%local%get_rval (var_str ("luminosity"))
	if (simulation%unweighted) then
	is_scattering = simulation%entry(1)%n_in == 2
	if (is_scattering) then
	x_events_lumi = abs (simulation%integral * lumi)
	if (x_events_lumi < huge (n_events)) then
	n_events_lumi = nint (x_events_lumi)
	else
	call msg_message ("Simulation: luminosity too large, &
	&limiting number of events")
	n_events_lumi = huge (n_events)
	end if
	if (n_events_lumi > n_events) then
	call msg_message ("Simulation: using n_events as computed from &
	&luminosity value")
	n_events = n_events_lumi
	else
	write (msg_buffer, "(A,1x,I0)") &
	"Simulation: requested number of events =", n_events
	call msg_message ()
	if (.not. vanishes (simulation%integral)) then
	write (msg_buffer, "(A,1x,ES11.4)") &
	" corr. to luminosity [fb-1] = ", &
	n_events / simulation%integral
	call msg_message ()
	end if
	end if
	end if
	end if
	end subroutine simulation_compute_n_events

	@ %def simulation_compute_n_events
	@ Configuration of the OpenMP parameters, in case OpenMP is active. We use
	the settings accessible via the local environment.
	<<Simulations: simulation: TBP>>=
	procedure :: setup_openmp => simulation_setup_openmp
	<<Simulations: procedures>>=
	subroutine simulation_setup_openmp (simulation)
	class(simulation_t), intent(inout) :: simulation

	call openmp_set_num_threads_verbose &
	(simulation%local%get_ival (var_str ("openmp_num_threads")), &
	simulation%local%get_lval (var_str ("?openmp_logging")))

	end subroutine simulation_setup_openmp

	@ %def simulation_setup_openmp
	@ Configuration of the event-stream array -- i.e., the setup of
	output file formats.
	<<Simulations: simulation: TBP>>=
	procedure :: prepare_event_streams => simulation_prepare_event_streams
	<<Simulations: procedures>>=
	subroutine simulation_prepare_event_streams (sim, es_array)
	class(simulation_t), intent(inout) :: sim
	type(event_stream_array_t), intent(out) :: es_array

	integer :: n_events
	logical :: rebuild_events, read_raw, write_raw
	integer :: checkpoint, callback
	integer :: n_fmt
	type(event_sample_data_t) :: data
	type(string_t), dimension(:), allocatable :: sample_fmt

	n_events = &
	sim%n_evt_requested
	rebuild_events = &
	sim%local%get_lval (var_str ("?rebuild_events"))
	read_raw = &
	sim%local%get_lval (var_str ("?read_raw")) .and. .not. rebuild_events
	write_raw = &
	sim%local%get_lval (var_str ("?write_raw"))
	checkpoint = &
	sim%local%get_ival (var_str ("checkpoint"))
	callback = &
	sim%local%get_ival (var_str ("event_callback_interval"))
	if (read_raw) then
	inquire (file = char (sim%sample_id) // ".evx", exist = read_raw)
	end if
	if (allocated (sim%local%sample_fmt)) then
	n_fmt = size (sim%local%sample_fmt)
	else
	n_fmt = 0
	end if
	data = sim%get_data ()
	data%n_evt = n_events
	data%nlo_multiplier = sim%get_n_nlo_entries (1)
	if (read_raw) then
	allocate (sample_fmt (n_fmt))
	if (n_fmt > 0) sample_fmt = sim%local%sample_fmt
	call es_array%init (sim%sample_id, &
	sample_fmt, sim%local, &
	data = data, &
	input = var_str ("raw"), &
	allow_switch = write_raw, &
	checkpoint = checkpoint, &
	callback = callback)
	else if (write_raw) then
	allocate (sample_fmt (n_fmt + 1))
	if (n_fmt > 0) sample_fmt(:n_fmt) = sim%local%sample_fmt
	sample_fmt(n_fmt+1) = var_str ("raw")
	call es_array%init (sim%sample_id, &
	sample_fmt, sim%local, &
	data = data, &
	checkpoint = checkpoint, &
	callback = callback)
	else if (allocated (sim%local%sample_fmt) &
	.or. checkpoint > 0 &
	.or. callback > 0) then
	allocate (sample_fmt (n_fmt))
	if (n_fmt > 0) sample_fmt = sim%local%sample_fmt
	call es_array%init (sim%sample_id, &
	sample_fmt, sim%local, &
	data = data, &
	checkpoint = checkpoint, &
	callback = callback)
	end if
	end subroutine simulation_prepare_event_streams

	@ %def simulation_prepare_event_streams
	@
	<<Simulations: simulation: TBP>>=
	procedure :: get_n_nlo_entries => simulation_get_n_nlo_entries
	<<Simulations: procedures>>=
	function simulation_get_n_nlo_entries (simulation, i_prc) result (n_extra)
	class(simulation_t), intent(in) :: simulation
	integer, intent(in) :: i_prc
	integer :: n_extra
	n_extra = simulation%entry(i_prc)%count_nlo_entries ()
	end function simulation_get_n_nlo_entries

	@ %def simulation_get_n_nlo_entries
	@ Initialize the process selector, using the entry integrals as process
	weights.
	<<Simulations: simulation: TBP>>=
	procedure :: init_process_selector => simulation_init_process_selector
	<<Simulations: procedures>>=
	subroutine simulation_init_process_selector (simulation)
	class(simulation_t), intent(inout) :: simulation
	integer :: i
	if (simulation%has_integral) then
	call simulation%process_selector%init (simulation%entry%integral, &
	negative_weights = simulation%negative_weights)
	do i = 1, simulation%n_prc
	associate (entry => simulation%entry(i))
	if (.not. entry%valid) then
	call msg_warning ("Process '" // char (entry%process_id) // &
	"': matrix element vanishes, no events can be generated.")
	cycle
	end if
	call entry%init_mci_selector (simulation%negative_weights)
	entry%process_weight = simulation%process_selector%get_weight (i)
	end associate
	end do
	end if
	end subroutine simulation_init_process_selector

	@ %def simulation_init_process_selector
	@ Select a process, using the random-number generator.
	<<Simulations: simulation: TBP>>=
	procedure :: select_prc => simulation_select_prc
	<<Simulations: procedures>>=
	function simulation_select_prc (simulation) result (i_prc)
	class(simulation_t), intent(inout) :: simulation
	integer :: i_prc
	call simulation%process_selector%generate (simulation%rng, i_prc)
	end function simulation_select_prc

	@ %def simulation_select_prc
	@ Select a MCI set for the selected process.
	<<Simulations: simulation: TBP>>=
	procedure :: select_mci => simulation_select_mci
	<<Simulations: procedures>>=
	function simulation_select_mci (simulation) result (i_mci)
	class(simulation_t), intent(inout) :: simulation
	integer :: i_mci
	i_mci = 0
	if (simulation%i_prc /= 0) then
	i_mci = simulation%entry(simulation%i_prc)%select_mci ()
	end if
	end function simulation_select_mci

	@ %def simulation_select_mci
	@
	\subsubsection{Generate-event loop}
	The requested number of events should be set by this, in time for the
	event-array initializers that may use this number.
	<<Simulations: simulation: TBP>>=
	procedure :: set_n_events_requested => simulation_set_n_events_requested
	procedure :: get_n_events_requested => simulation_get_n_events_requested
	<<Simulations: procedures>>=
	subroutine simulation_set_n_events_requested (simulation, n)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: n

	simulation%n_evt_requested = n

	end subroutine simulation_set_n_events_requested

	function simulation_get_n_events_requested (simulation) result (n)
	class(simulation_t), intent(in) :: simulation
	integer :: n

	n = simulation%n_evt_requested

	end function simulation_get_n_events_requested

	@ %def simulation_set_n_events_requested
	@ %def simulation_get_n_events_requested
	@ Generate the number of events that has been set by
	[[simulation_set_n_events_requested]]. First select a process and a component
	set, then generate an event for that process and factorize the quantum state.
	The pair of random numbers can be used for factorization.

	When generating events, we drop all configurations where the event is
	marked as incomplete. This happens if the event fails cuts. In fact,
	such events are dropped already by the sampler if unweighting is in
	effect, so this can happen only for weighted events. By setting a
	limit given by [[sample_max_tries]] (user parameter), we can avoid an
	endless loop.

	The [[begin_it]] and [[end_it]] limits are equal to 1 and the number of
	events, repspectively, in serial mode, but differ for MPI mode.

	TODO: When reading from file, event transforms cannot be applied because the
	process instance will not be complete. (?)
	<<Simulations: simulation: TBP>>=
	procedure :: generate => simulation_generate
	<<Simulations: procedures>>=
	subroutine simulation_generate (simulation, es_array)
	class(simulation_t), intent(inout), target :: simulation
	type(event_stream_array_t), intent(inout), optional :: es_array

	integer :: begin_it, end_it
	integer :: i, j, k

	call simulation%before_first_event (begin_it, end_it, es_array)
	do i = begin_it, end_it
	call simulation%next_event (es_array)
	end do
	call simulation%after_last_event (begin_it, end_it)

	end subroutine simulation_generate

	@ %def simulation_generate
	@ The header of the event loop: with all necessary information present in the
	[[simulation]] and [[es_array]] objects, and given a number of events [[n]] to
	generate, we prepare for actually generating/reading/writing events.

	The procedure returns the real iteration bounds [[begin_it]] and [[end_it]]
	for the event loop. This is nontrivial only for MPI; in serial mode those are
	equal to 1 and to [[n_events]], respectively.
	<<Simulations: simulation: TBP>>=
	procedure :: before_first_event => simulation_before_first_event
	<<Simulations: procedures>>=
	subroutine simulation_before_first_event (simulation, begin_it, end_it, &
	es_array)
	class(simulation_t), intent(inout), target :: simulation
	integer, intent(out) :: begin_it
	integer, intent(out) :: end_it
	type(event_stream_array_t), intent(inout), optional :: es_array

	integer :: n_evt_requested
	logical :: has_input
	integer :: n_events_print
	logical :: is_leading_order
	logical :: is_weighted
	logical :: is_polarized

	n_evt_requested = simulation%n_evt_requested
	n_events_print = n_evt_requested * simulation%get_n_nlo_entries (1)
	is_leading_order = (n_events_print == n_evt_requested)

	has_input = .false.
	if (present (es_array)) has_input = es_array%has_input ()

	is_weighted = .not. simulation%entry(1)%config%unweighted
	is_polarized = simulation%entry(1)%config%factorization_mode &
	/= FM_IGNORE_HELICITY

	call simulation%startup_message_generate ( &
	has_input = has_input, &
	is_weighted = is_weighted, &
	is_polarized = is_polarized, &
	is_leading_order = is_leading_order, &
	n_events = n_events_print)

	call simulation%entry%set_n (n_evt_requested)
	if (simulation%n_alt > 0) call simulation%alt_entry%set_n (n_evt_requested)
	call simulation%init_event_index ()

	begin_it = 1
	end_it = n_evt_requested
	<<Simulations: simulation generate: extra init>>

	end subroutine simulation_before_first_event

	@ %def simulation_before_first_event
	@ Keep the user informed:
	<<Simulations: simulation: TBP>>=
	procedure, private :: startup_message_generate &
	=> simulation_startup_message_generate
	<<Simulations: procedures>>=
	subroutine simulation_startup_message_generate (simulation, &
	has_input, is_weighted, is_polarized, is_leading_order, n_events)
	class(simulation_t), intent(in) :: simulation
	logical, intent(in) :: has_input
	logical, intent(in) :: is_weighted
	logical, intent(in) :: is_polarized
	logical, intent(in) :: is_leading_order
	integer, intent(in) :: n_events

	type(string_t) :: str1, str2, str3, str4

	if (has_input) then
	str1 = "Events: reading"
	else
	str1 = "Events: generating"
	end if
	if (is_weighted) then
	str2 = "weighted"
	else
	str2 = "unweighted"
	end if
	if (is_polarized) then
	str3 = ", polarized"
	else
	str3 = ", unpolarized"
	end if
	str4 = ""
	if (.not. is_leading_order) str4 = " NLO"

	write (msg_buffer, "(A,1X,I0,1X,A,1X,A)") char (str1), n_events, &
	char (str2) // char(str3) // char(str4), "events ..."
	call msg_message ()

	write (msg_buffer, "(A,1x,A)") "Events: event normalization mode", &
	char (event_normalization_string (simulation%norm_mode))
	call msg_message ()

	end subroutine simulation_startup_message_generate

	@ %def simulation_startup_message_generate
	@
	The body of the event loop: generate and process a single event.

	Optionally transfer the current event to one of the provided event handles,
	for in and/or output streams. This works for any stream for which the I/O
	stream type matches the event-handle type.
	<<Simulations: simulation: TBP>>=
	procedure :: next_event => simulation_next_event
	<<Simulations: procedures>>=
	subroutine simulation_next_event &
	(simulation, es_array, event_handle_out, event_handle_in)
	class(simulation_t), intent(inout) :: simulation
	type(event_stream_array_t), intent(inout), optional :: es_array
	class(event_handle_t), intent(inout), optional :: event_handle_out
	class(event_handle_t), intent(inout), optional :: event_handle_in

	type(entry_t), pointer :: current_entry
	logical :: generate_new
	logical :: passed
	integer :: j, k

	call simulation%increment_event_index ()

	if (present (es_array)) then
	call simulation%read_event &
	(es_array, .true., generate_new, event_handle_in)
	else
	generate_new = .true.
	end if

	if (generate_new) then
	simulation%i_prc = simulation%select_prc ()
	simulation%i_mci = simulation%select_mci ()

	associate (entry => simulation%entry(simulation%i_prc))

	entry%instance%i_mci = simulation%i_mci
	call entry%set_active_real_components ()
	current_entry => entry%get_first ()

	do k = 1, current_entry%count_nlo_entries ()
	if (k > 1) then
	current_entry => current_entry%get_next ()
	current_entry%particle_set => current_entry%first%particle_set
	current_entry%particle_set_is_valid &
	= current_entry%first%particle_set_is_valid
	end if
	do j = 1, simulation%n_max_tries
	if (.not. current_entry%valid) call msg_warning &
	("Process '" // char (current_entry%process_id) // "': " // &
	"matrix element vanishes, no events can be generated.")
	call current_entry%generate (simulation%i_mci, i_nlo = k)
	if (signal_is_pending ()) return
	call simulation%counter%record_mean_and_variance &
	(current_entry%weight_prc, k)
	if (current_entry%has_valid_particle_set ()) exit
	end do
	end do
	if (entry%is_nlo ()) call entry%reset_nlo_counter ()

	if (.not. entry%has_valid_particle_set ()) then
	write (msg_buffer, "(A,I0,A)") "Simulation: failed to &
	&generate valid event after ", &
	simulation%n_max_tries, " tries (sample_max_tries)"
	call msg_fatal ()
	end if

	current_entry => entry%get_first ()
	do k = 1, current_entry%count_nlo_entries ()
	if (k > 1) current_entry => current_entry%get_next ()
	call current_entry%set_index (simulation%get_event_index ())
	call current_entry%evaluate_expressions ()
	end do
	if (signal_is_pending ()) return

	simulation%n_dropped = entry%get_n_dropped ()
	if (entry%passed_selection ()) then
	simulation%weight = entry%get_weight_ref ()
	simulation%excess = entry%get_excess_prc ()
	end if
	call simulation%counter%record &
	(simulation%weight, simulation%excess, simulation%n_dropped)
	call entry%record (simulation%i_mci)

	end associate

	else

	associate (entry => simulation%entry(simulation%i_prc))

	call simulation%set_event_index (entry%get_index ())
	call entry%accept_sqme_ref ()
	call entry%accept_weight_ref ()
	call entry%check ()
	call entry%evaluate_expressions ()
	if (signal_is_pending ()) return

	simulation%n_dropped = entry%get_n_dropped ()
	if (entry%passed_selection ()) then
	simulation%weight = entry%get_weight_ref ()
	simulation%excess = entry%get_excess_prc ()
	end if
	call simulation%counter%record &
	(simulation%weight, simulation%excess, simulation%n_dropped, &
	from_file=.true.)
	call entry%record (simulation%i_mci, from_file=.true.)

	end associate

	end if

	call simulation%calculate_alt_entries ()
	if (simulation%pacify) call pacify (simulation)
	if (signal_is_pending ()) return

	if (simulation%respect_selection) then
	passed = simulation%entry(simulation%i_prc)%passed_selection ()
	else
	passed = .true.
	end if
	if (present (es_array)) then
	call simulation%write_event (es_array, passed, event_handle_out)
	end if

	end subroutine simulation_next_event

	@ %def simulation_next_event
	@ Cleanup after last event: compute and show summary information.
	<<Simulations: simulation: TBP>>=
	procedure :: after_last_event => simulation_after_last_event
	<<Simulations: procedures>>=
	subroutine simulation_after_last_event (simulation, begin_it, end_it)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: begin_it, end_it

	call msg_message (" ... event sample complete.")
	<<Simulations: simulation generate: extra finalize>>

	if (simulation%unweighted) call simulation%show_efficiency ()
	call simulation%counter%show_excess ()
	call simulation%counter%show_dropped ()
	call simulation%counter%show_mean_and_variance ()

	end subroutine simulation_after_last_event

	@ %def simulation_after_last_event
	@
	\subsubsection{MPI additions}
	Below, we define code chunks that differ between the serial and MPI versions.

	Extra logging for MPI only.
	<<Simulations: simulation: TBP>>=
	procedure :: activate_extra_logging => simulation_activate_extra_logging
	<<Simulations: procedures>>=
	subroutine simulation_activate_extra_logging (simulation)
	class(simulation_t), intent(in) :: simulation
	<<Simulations: activate extra logging>>
	end subroutine simulation_activate_extra_logging

	<<Simulations: activate extra logging>>=
	<<MPI: Simulations: activate extra logging>>=
	logical :: mpi_logging
	integer :: rank, n_size
	call mpi_get_comm_id (n_size, rank)
	mpi_logging = &
	(simulation%local%get_sval (var_str ("$integration_method")) == "vamp2" &
	.and. n_size > 1) &
	.or. simulation%local%get_lval (var_str ("?mpi_logging"))
	call mpi_set_logging (mpi_logging)
	@ %def simulation_activate_extra_logging
	@
	Extra subroutine to be called before the first event:
	<<Simulations: simulation generate: extra init>>=
	<<MPI: Simulations: simulation generate: extra init>>=
	call simulation%init_event_loop_mpi (n_evt_requested, begin_it, end_it)
	@
	Extra subroutine to be called after the last event:
	<<Simulations: simulation generate: extra finalize>>=
	<<MPI: Simulations: simulation generate: extra finalize>>=
	call simulation%final_event_loop_mpi (begin_it, end_it)
	@
	For MPI event generation, the event-loop interval (1\dots n) is split up
	into intervals of [[n_workers]].
	<<MPI: Simulations: simulation: TBP>>=
	procedure, private :: init_event_loop_mpi => simulation_init_event_loop_mpi
	<<MPI: Simulations: procedures>>=
	subroutine simulation_init_event_loop_mpi &
	(simulation, n_events, begin_it, end_it)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: n_events
	integer, intent(out) :: begin_it, end_it

	integer :: rank, n_workers

	call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
	if (n_workers < 2) then
	begin_it = 1; end_it = n_events
	return
	end if
	call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
	if (rank == 0) then
	call compute_and_scatter_intervals (n_events, begin_it, end_it)
	else
	call retrieve_intervals (begin_it, end_it)
	end if

	!! Event index starts by 0 (before incrementing when the first event gets generated/read in).
	!! Proof: event_index_offset in [0, N], start_it in [1, N].
	simulation%event_index_offset = simulation%event_index_offset + (begin_it - 1)
	call simulation%init_event_index ()
	write (msg_buffer, "(A,I0,A,I0,A)") &
	& "MPI: generate events [", begin_it, ":", end_it, "]"
	call msg_message ()

	contains

	subroutine compute_and_scatter_intervals (n_events, begin_it, end_it)
	integer, intent(in) :: n_events
	integer, intent(out) :: begin_it, end_it

	integer, dimension(:), allocatable :: all_begin_it, all_end_it
	integer :: rank, n_workers, n_events_per_worker

	call MPI_COMM_RANK (MPI_COMM_WORLD, rank)
	call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
	allocate (all_begin_it (n_workers), source = 1)
	allocate (all_end_it (n_workers), source = n_events)
	n_events_per_worker = floor (real (n_events, default) / n_workers)
	all_begin_it = [(1 + rank * n_events_per_worker, rank = 0, n_workers - 1)]
	all_end_it = [(rank * n_events_per_worker, rank = 1, n_workers)]
	all_end_it(n_workers) = n_events
	call MPI_SCATTER (all_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
	call MPI_SCATTER (all_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)

	end subroutine compute_and_scatter_intervals

	subroutine retrieve_intervals (begin_it, end_it)
	integer, intent(out) :: begin_it, end_it

	integer :: local_begin_it, local_end_it

	call MPI_SCATTER (local_begin_it, 1, MPI_INTEGER, begin_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)
	call MPI_SCATTER (local_end_it, 1, MPI_INTEGER, end_it, 1, MPI_INTEGER, 0, MPI_COMM_WORLD)

	end subroutine retrieve_intervals

	end subroutine simulation_init_event_loop_mpi

	@ %def simulation_init_event_loop_mpi
	@
	Synchronize, reduce and collect stuff after the event loop has completed.
	<<MPI: Simulations: simulation: TBP>>=
	procedure, private :: final_event_loop_mpi => simulation_final_event_loop_mpi
	<<MPI: Simulations: procedures>>=
	subroutine simulation_final_event_loop_mpi (simulation, begin_it, end_it)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: begin_it, end_it

	integer :: n_workers, n_events_local, n_events_global

	call MPI_Barrier (MPI_COMM_WORLD)
	call MPI_COMM_SIZE (MPI_COMM_WORLD, n_workers)
	if (n_workers < 2) return
	n_events_local = end_it - begin_it + 1
	call MPI_ALLREDUCE (n_events_local, n_events_global, 1, MPI_INTEGER, MPI_SUM,&
	& MPI_COMM_WORLD)
	write (msg_buffer, "(2(A,1X,I0))") &
	"MPI: Number of generated events locally", n_events_local, " and in world", n_events_global
	call msg_message ()
	call simulation%counter%allreduce_record ()

	end subroutine simulation_final_event_loop_mpi

	@ %def simulation_final_event_loop_mpi
	@
	\subsubsection{Alternate environments}
	Compute the event matrix element and weight for all alternative
	environments, given the current event and selected process. We first
	copy the particle set, then temporarily update the process core with
	local parameters, recalculate everything, and restore the process
	core.

	The event weight is obtained by rescaling the original event weight with the
	ratio of the new and old [[sqme]] values. (In particular, if the old
	value was zero, the weight will stay zero.)

	Note: this may turn out to be inefficient because we always replace
	all parameters and recalculate everything, once for each event and
	environment. However, a more fine-grained control requires more
	code. In any case, while we may keep multiple process cores (which
	stay constant for a simulation run), we still have to update the
	external matrix element parameters event by event. The matrix element
	``object'' is present only once.
	<<Simulations: simulation: TBP>>=
	procedure :: calculate_alt_entries => simulation_calculate_alt_entries
	<<Simulations: procedures>>=
	subroutine simulation_calculate_alt_entries (simulation)
	class(simulation_t), intent(inout) :: simulation
	real(default) :: sqme_prc, weight_prc, factor
	real(default), dimension(:), allocatable :: sqme_alt, weight_alt
	integer :: n_alt, i, j
	i = simulation%i_prc
	n_alt = simulation%n_alt
	if (n_alt == 0) return
	allocate (sqme_alt (n_alt), weight_alt (n_alt))
	associate (entry => simulation%entry(i))
	do j = 1, n_alt
	if (signal_is_pending ()) return
	if (simulation%update_weight) then
	factor = entry%get_kinematical_weight ()
	else
	sqme_prc = entry%get_sqme_prc ()
	weight_prc = entry%get_weight_prc ()
	if (sqme_prc /= 0) then
	factor = weight_prc / sqme_prc
	else
	factor = 0
	end if
	end if
	associate (alt_entry => simulation%alt_entry(i,j))
	call alt_entry%update_process (saved=.false.)
	call alt_entry%select &
	(entry%get_i_mci (), entry%get_i_term (), entry%get_channel ())
	call alt_entry%fill_particle_set (entry)
	call alt_entry%recalculate &
	(update_sqme = .true., &
	recover_beams = simulation%recover_beams, &
	weight_factor = factor)
	if (signal_is_pending ()) return
	call alt_entry%accept_sqme_prc ()
	call alt_entry%update_normalization ()
	call alt_entry%accept_weight_prc ()
	call alt_entry%check ()
	call alt_entry%set_index (simulation%get_event_index ())
	call alt_entry%evaluate_expressions ()
	if (signal_is_pending ()) return
	sqme_alt(j) = alt_entry%get_sqme_ref ()
	if (alt_entry%passed_selection ()) then
	weight_alt(j) = alt_entry%get_weight_ref ()
	end if
	end associate
	end do
	call entry%update_process (saved=.false.)
	call entry%set (sqme_alt = sqme_alt, weight_alt = weight_alt)
	call entry%check ()
	call entry%store_alt_values ()
	end associate
	end subroutine simulation_calculate_alt_entries

	@ %def simulation_calculate_alt_entries
	@
	These routines take care of temporary parameter redefinitions that
	we want to take effect while recalculating the matrix elements. We
	extract the core(s) of the processes that we are simulating, apply the
	changes, and make sure that the changes are actually used. This is
	the duty of [[dispatch_core_update]]. When done, we restore the
	original versions using [[dispatch_core_restore]].
	<<Simulations: simulation: TBP>>=
	procedure :: update_processes => simulation_update_processes
	procedure :: restore_processes => simulation_restore_processes
	<<Simulations: procedures>>=
	subroutine simulation_update_processes (simulation, &
	model, qcd, helicity_selection)
	class(simulation_t), intent(inout) :: simulation
	class(model_data_t), intent(in), optional, target :: model
	type(qcd_t), intent(in), optional :: qcd
	type(helicity_selection_t), intent(in), optional :: helicity_selection
	integer :: i
	do i = 1, simulation%n_prc
	call simulation%entry(i)%update_process &
	(model, qcd, helicity_selection)
	end do
	end subroutine simulation_update_processes

	subroutine simulation_restore_processes (simulation)
	class(simulation_t), intent(inout) :: simulation
	integer :: i
	do i = 1, simulation%n_prc
	call simulation%entry(i)%restore_process ()
	end do
	end subroutine simulation_restore_processes

	@ %def simulation_update_processes
	@ %def simulation_restore_processes
	@
	\subsubsection{Rescan-Events Loop}
	Rescan an undefined number of events.

	If [[update_event]] or [[update_sqme]] is set, we have to recalculate the
	event, starting from the particle set. If the latter is set, this includes
	the squared matrix element (i.e., the amplitude is evaluated). Otherwise,
	only kinematics and observables derived from it are recovered.

	If any of the update flags is set, we will come up with separate
	[[sqme_prc]] and [[weight_prc]] values. (The latter is only distinct
	if [[update_weight]] is set.) Otherwise, we accept the reference values.
	<<Simulations: simulation: TBP>>=
	procedure :: rescan => simulation_rescan
	<<Simulations: procedures>>=
	subroutine simulation_rescan (simulation, n, es_array, global)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: n
	type(event_stream_array_t), intent(inout) :: es_array
	type(rt_data_t), intent(inout) :: global
	type(qcd_t) :: qcd
	type(string_t) :: str1, str2, str3
	logical :: complete, check_match
	str1 = "Rescanning"
	if (simulation%entry(1)%config%unweighted) then
	str2 = "unweighted"
	else
	str2 = "weighted"
	end if
	simulation%n_evt_requested = n
	call simulation%entry%set_n (n)
	if (simulation%update_sqme .or. simulation%update_weight) then
	call dispatch_qcd (qcd, global%get_var_list_ptr (), global%os_data)
	call simulation%update_processes &
	(global%model, qcd, global%get_helicity_selection ())
	str3 = "(process parameters updated) "
	else
	str3 = ""
	end if
	write (msg_buffer, "(A,1x,A,1x,A,A,A)") char (str1), char (str2), &
	"events ", char (str3), "..."
	call msg_message ()
	call simulation%init_event_index ()
	check_match = .not. global%var_list%get_lval (var_str ("?rescan_force"))
	do
	call simulation%increment_event_index ()
	call simulation%read_event (es_array, .false., complete)
	if (complete) exit
	if (simulation%update_event &
	.or. simulation%update_sqme &
	.or. simulation%update_weight) then
	call simulation%recalculate (check_match = check_match)
	if (signal_is_pending ()) return
	associate (entry => simulation%entry(simulation%i_prc))
	call entry%update_normalization ()
	if (simulation%update_event) then
	call entry%evaluate_transforms ()
	end if
	call entry%check ()
	call entry%evaluate_expressions ()
	if (signal_is_pending ()) return
	simulation%n_dropped = entry%get_n_dropped ()
	simulation%weight = entry%get_weight_prc ()
	call simulation%counter%record &
	(simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
	call entry%record (simulation%i_mci, from_file=.true.)
	end associate
	else
	associate (entry => simulation%entry(simulation%i_prc))
	call entry%accept_sqme_ref ()
	call entry%accept_weight_ref ()
	call entry%check ()
	call entry%evaluate_expressions ()
	if (signal_is_pending ()) return
	simulation%n_dropped = entry%get_n_dropped ()
	simulation%weight = entry%get_weight_ref ()
	call simulation%counter%record &
	(simulation%weight, n_dropped=simulation%n_dropped, from_file=.true.)
	call entry%record (simulation%i_mci, from_file=.true.)
	end associate
	end if
	call simulation%calculate_alt_entries ()
	if (signal_is_pending ()) return
	call simulation%write_event (es_array)
	end do
	call simulation%counter%show_dropped ()
	if (simulation%update_sqme .or. simulation%update_weight) then
	call simulation%restore_processes ()
	end if
	end subroutine simulation_rescan

	@ %def simulation_rescan
	@
	\subsubsection{Event index}
	Here we handle the event index that is kept in the simulation record. The
	event index is valid for the current sample. When generating or reading
	events, we initialize the index with the offset that the user provides (if any)
	and increment it for each event that is generated or read from file. The event
	index is stored in the event-entry that is current for the event. If an
	event on file comes with its own index, that index overwrites the predefined
	one and also resets the index within the simulation record.

	The event index is not connected to the [[counter]] object. The counter is
	supposed to collect statistical information. The event index is a user-level
	object that is visible in event records and analysis expressions.
	<<Simulations: simulation: TBP>>=
	procedure :: init_event_index => simulation_init_event_index
	procedure :: increment_event_index => simulation_increment_event_index
	procedure :: set_event_index => simulation_set_event_index
	procedure :: get_event_index => simulation_get_event_index
	<<Simulations: procedures>>=
	subroutine simulation_init_event_index (simulation)
	class(simulation_t), intent(inout) :: simulation
	call simulation%set_event_index (simulation%event_index_offset)
	end subroutine simulation_init_event_index

	subroutine simulation_increment_event_index (simulation)
	class(simulation_t), intent(inout) :: simulation
	if (simulation%event_index_set) then
	simulation%event_index = simulation%event_index + 1
	end if
	end subroutine simulation_increment_event_index

	subroutine simulation_set_event_index (simulation, i)
	class(simulation_t), intent(inout) :: simulation
	integer, intent(in) :: i
	simulation%event_index = i
	simulation%event_index_set = .true.
	end subroutine simulation_set_event_index

	function simulation_get_event_index (simulation) result (i)
	class(simulation_t), intent(in) :: simulation
	integer :: i
	if (simulation%event_index_set) then
	i = simulation%event_index
	else
	i = 0
	end if
	end function simulation_get_event_index

	@ %def simulation_init_event_index
	@ %def simulation_increment_event_index
	@ %def simulation_set_event_index
	@ %def simulation_get_event_index
	@
	\subsection{Direct event access}
	If we want to retrieve event information, we should expose the currently
	selected event [[entry]] within the simulation object. We recall that this is
	an extension of the (generic) [[event]] type. Assuming that we will restrict
	this to read access, we return a pointer.
	<<Simulations: simulation: TBP>>=
	procedure :: get_process_index => simulation_get_process_index
	procedure :: get_event_ptr => simulation_get_event_ptr
	<<Simulations: procedures>>=
	function simulation_get_process_index (simulation) result (i_prc)
	class(simulation_t), intent(in), target :: simulation
	integer :: i_prc

	i_prc = simulation%i_prc

	end function simulation_get_process_index

	function simulation_get_event_ptr (simulation) result (event)
	class(simulation_t), intent(in), target :: simulation
	class(event_t), pointer :: event

	event => simulation%entry(simulation%i_prc)

	end function simulation_get_event_ptr

	@ %def simulation_get_process_index
	@ %def simulation_get_event_ptr
	@
	\subsection{Event Stream I/O}
	Write an event to a generic [[eio]] event stream. The process index
	must be selected, or the current index must be available.
	<<Simulations: simulation: TBP>>=
	generic :: write_event => write_event_eio
	procedure :: write_event_eio => simulation_write_event_eio
	<<Simulations: procedures>>=
	subroutine simulation_write_event_eio (object, eio, i_prc)
	class(simulation_t), intent(in) :: object
	class(eio_t), intent(inout) :: eio
	integer, intent(in), optional :: i_prc
	logical :: increased
	integer :: current
	if (present (i_prc)) then
	current = i_prc
	else
	current = object%i_prc
	end if
	if (current > 0) then
	if (object%split_n_evt > 0 .and. object%counter%total > 1) then
	if (mod (object%counter%total, object%split_n_evt) == 1) then
	call eio%split_out ()
	end if
	else if (object%split_n_kbytes > 0) then
	call eio%update_split_count (increased)
	if (increased) call eio%split_out ()
	end if
	call eio%output (object%entry(current)%event_t, current, pacify = object%pacify)
	else
	call msg_fatal ("Simulation: write event: no process selected")
	end if
	end subroutine simulation_write_event_eio

	@ %def simulation_write_event
	@
	Read an event from a generic [[eio]] event stream. The event stream element
	must specify the process within the sample ([[i_prc]]), the MC group for this
	process ([[i_mci]]), the selected term ([[i_term]]), the selected MC
	integration [[channel]], and the particle set of the event.

	We may encounter EOF, which we indicate by storing 0 for the process index
	[[i_prc]]. An I/O error will be reported, and we also abort reading.
	<<Simulations: simulation: TBP>>=
	generic :: read_event => read_event_eio
	procedure :: read_event_eio => simulation_read_event_eio
	<<Simulations: procedures>>=
	subroutine simulation_read_event_eio (object, eio)
	class(simulation_t), intent(inout) :: object
	class(eio_t), intent(inout) :: eio
	integer :: iostat, current
	call eio%input_i_prc (current, iostat)
	select case (iostat)
	case (0)
	object%i_prc = current
	call eio%input_event (object%entry(current)%event_t, iostat)
	end select
	select case (iostat)
	case (:-1)
	object%i_prc = 0
	object%i_mci = 0
	case (1:)
	call msg_error ("Reading events: I/O error, aborting read")
	object%i_prc = 0
	object%i_mci = 0
	case default
	object%i_mci = object%entry(current)%get_i_mci ()
	end select
	end subroutine simulation_read_event_eio

	@ %def simulation_read_event
	@
	\subsection{Event Stream Array}
	Write an event using an array of event I/O streams.
	The process index must be selected, or the current index must be
	available.
	<<Simulations: simulation: TBP>>=
	generic :: write_event => write_event_es_array
	procedure :: write_event_es_array => simulation_write_event_es_array
	<<Simulations: procedures>>=
	subroutine simulation_write_event_es_array &
	(object, es_array, passed, event_handle)
	class(simulation_t), intent(in), target :: object
	class(event_stream_array_t), intent(inout) :: es_array
	logical, intent(in), optional :: passed
	class(event_handle_t), intent(inout), optional :: event_handle
	integer :: i_prc, event_index
	integer :: i
	type(entry_t), pointer :: current_entry
	i_prc = object%i_prc
	if (i_prc > 0) then
	event_index = object%counter%total
	current_entry => object%entry(i_prc)%get_first ()
	do i = 1, current_entry%count_nlo_entries ()
	if (i > 1) current_entry => current_entry%get_next ()
	call es_array%output (current_entry%event_t, i_prc, &
	event_index, &
	passed = passed, &
	pacify = object%pacify, &
	event_handle = event_handle)
	end do
	else
	call msg_fatal ("Simulation: write event: no process selected")
	end if
	end subroutine simulation_write_event_es_array

	@ %def simulation_write_event
	@ Read an event using an array of event I/O streams. Reading is
	successful if there is an input stream within the array, and if a
	valid event can be read from that stream. If there is a stream, but
	EOF is passed when reading the first item, we switch the channel to
	output and return failure but no error message, such that new events
	can be appended to that stream.
	<<Simulations: simulation: TBP>>=
	generic :: read_event => read_event_es_array
	procedure :: read_event_es_array => simulation_read_event_es_array
	<<Simulations: procedures>>=
	subroutine simulation_read_event_es_array &
	(object, es_array, enable_switch, fail, event_handle)
	class(simulation_t), intent(inout), target :: object
	class(event_stream_array_t), intent(inout), target :: es_array
	logical, intent(in) :: enable_switch
	logical, intent(out) :: fail
	class(event_handle_t), intent(inout), optional :: event_handle
	integer :: iostat, i_prc
	type(entry_t), pointer :: current_entry => null ()
	integer :: i
	if (es_array%has_input ()) then
	fail = .false.
	call es_array%input_i_prc (i_prc, iostat)
	select case (iostat)
	case (0)
	object%i_prc = i_prc
	current_entry => object%entry(i_prc)
	do i = 1, current_entry%count_nlo_entries ()
	if (i > 1) then
	call es_array%skip_eio_entry (iostat)
	current_entry => current_entry%get_next ()
	end if
	call current_entry%set_index (object%get_event_index ())
	call es_array%input_event &
	(current_entry%event_t, iostat, event_handle)
	end do
	case (:-1)
	write (msg_buffer, "(A,1x,I0,1x,A)") &
	"... event file terminates after", &
	object%counter%read, "events."
	call msg_message ()
	if (enable_switch) then
	call es_array%switch_inout ()
	write (msg_buffer, "(A,1x,I0,1x,A)") &
	"Generating remaining ", &
	object%n_evt_requested - object%counter%read, "events ..."
	call msg_message ()
	end if
	fail = .true.
	return
	end select
	select case (iostat)
	case (0)
	object%i_mci = object%entry(i_prc)%get_i_mci ()
	case default
	write (msg_buffer, "(A,1x,I0,1x,A)") &
	"Reading events: I/O error, aborting read after", &
	object%counter%read, "events."
	call msg_error ()
	object%i_prc = 0
	object%i_mci = 0
	fail = .true.
	end select
	else
	fail = .true.
	end if
	end subroutine simulation_read_event_es_array

	@ %def simulation_read_event
	@
	\subsection{Recover event}
	Recalculate the process instance contents, given an event with known particle
	set. The indices for MC, term, and channel must be already set. The
	[[recalculate]] method of the selected entry will import the result
	into [[sqme_prc]] and [[weight_prc]].

	If [[recover_phs]] is set (and false), do not attempt any phase-space
	calculation. Useful if we need only matrix elements (esp. testing); this flag
	is not stored in the simulation record.
	<<Simulations: simulation: TBP>>=
	procedure :: recalculate => simulation_recalculate
	<<Simulations: procedures>>=
	subroutine simulation_recalculate (simulation, recover_phs, check_match)
	class(simulation_t), intent(inout) :: simulation
	logical, intent(in), optional :: recover_phs
	logical, intent(in), optional :: check_match
	integer :: i_prc, i_comp, i_term, k
	integer :: i_mci, i_mci0, i_mci1
	integer, dimension(:), allocatable :: i_terms
	logical :: success
	i_prc = simulation%i_prc
	associate (entry => simulation%entry(i_prc))
	if (entry%selected_i_mci /= 0) then
	i_mci0 = entry%selected_i_mci
	i_mci1 = i_mci0
	else
	i_mci0 = 1
	i_mci1 = entry%process%get_n_mci ()
	end if
	SCAN_COMP: do i_mci = i_mci0, i_mci1
	i_comp = entry%process%get_master_component (i_mci)
	call entry%process%reset_selected_cores ()
	call entry%process%select_components ([i_comp])
	i_terms = entry%process%get_component_i_terms (i_comp)
	SCAN_TERM: do k = 1, size (i_terms)
	i_term = i_terms(k)
	call entry%select (i_mci, i_term, entry%selected_channel)
	if (entry%selected_i_term /= 0 &
	.and. entry%selected_i_term /= i_term) cycle SCAN_TERM
	call entry%select (i_mci, i_term, entry%selected_channel)
	if (simulation%update_weight) then
	call entry%recalculate &
	(update_sqme = simulation%update_sqme, &
	recover_beams = simulation%recover_beams, &
	recover_phs = recover_phs, &
	weight_factor = entry%get_kinematical_weight (), &
	check_match = check_match, &
	success = success)
	else
	call entry%recalculate &
	(update_sqme = simulation%update_sqme, &
	recover_beams = simulation%recover_beams, &
	recover_phs = recover_phs, &
	check_match = check_match, &
	success = success)
	end if
	if (success) exit SCAN_COMP
	end do SCAN_TERM
	deallocate (i_terms)
	end do SCAN_COMP
	if (.not. success) then
	call entry%write ()
	call msg_fatal ("Simulation/recalculate: &
	&event could not be matched to the specified process")
	end if
	end associate
	end subroutine simulation_recalculate

	@ %def simulation_recalculate
	@
	\subsection{Extract contents of the simulation object}
	Return the MD5 sum that summarizes configuration and integration
	(but not the event file). Used for initializing the event streams.
	<<Simulations: simulation: TBP>>=
	procedure :: get_md5sum_prc => simulation_get_md5sum_prc
	procedure :: get_md5sum_cfg => simulation_get_md5sum_cfg
	procedure :: get_md5sum_alt => simulation_get_md5sum_alt
	<<Simulations: procedures>>=
	function simulation_get_md5sum_prc (simulation) result (md5sum)
	class(simulation_t), intent(in) :: simulation
	character(32) :: md5sum
	md5sum = simulation%md5sum_prc
	end function simulation_get_md5sum_prc

	function simulation_get_md5sum_cfg (simulation) result (md5sum)
	class(simulation_t), intent(in) :: simulation
	character(32) :: md5sum
	md5sum = simulation%md5sum_cfg
	end function simulation_get_md5sum_cfg

	function simulation_get_md5sum_alt (simulation, i) result (md5sum)
	class(simulation_t), intent(in) :: simulation
	integer, intent(in) :: i
	character(32) :: md5sum
	md5sum = simulation%md5sum_alt(i)
	end function simulation_get_md5sum_alt

	@ %def simulation_get_md5sum_prc
	@ %def simulation_get_md5sum_cfg
	@
	Return data that may be useful for writing event files.

	Usually we can refer to a previously integrated process, for which we
	can fetch a process pointer. Occasionally, we do not have this because
	we are just rescanning an externally generated file without
	calculation. For that situation, we generate our local beam data object
	using the current enviroment, or, in simple cases, just fetch the
	necessary data from the process definition and environment.
	<<Simulations: simulation: TBP>>=
	procedure :: get_data => simulation_get_data
	<<Simulations: procedures>>=
	function simulation_get_data (simulation, alt) result (sdata)
	class(simulation_t), intent(in) :: simulation
	logical, intent(in), optional :: alt
	type(event_sample_data_t) :: sdata
	type(process_t), pointer :: process
	type(beam_data_t), pointer :: beam_data
	type(beam_structure_t), pointer :: beam_structure
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: n, i
	logical :: enable_alt, construct_beam_data
	real(default) :: sqrts
	class(model_data_t), pointer :: model
	logical :: decay_rest_frame
	type(string_t) :: process_id
	enable_alt = .true.; if (present (alt)) enable_alt = alt
	if (debug_on) call msg_debug (D_CORE, "simulation_get_data")
	if (debug_on) call msg_debug (D_CORE, "alternative setup", enable_alt)
	if (enable_alt) then
	call sdata%init (simulation%n_prc, simulation%n_alt)
	do i = 1, simulation%n_alt
	sdata%md5sum_alt(i) = simulation%get_md5sum_alt (i)
	end do
	else
	call sdata%init (simulation%n_prc)
	end if
	sdata%unweighted = simulation%unweighted
	sdata%negative_weights = simulation%negative_weights
	sdata%norm_mode = simulation%norm_mode
	process => simulation%entry(1)%get_process_ptr ()
	if (associated (process)) then
	beam_data => process%get_beam_data_ptr ()
	construct_beam_data = .false.
	else
	n = simulation%entry(1)%n_in
	sqrts = simulation%local%get_sqrts ()
	beam_structure => simulation%local%beam_structure
	call beam_structure%check_against_n_in (n, construct_beam_data)
	if (construct_beam_data) then
	allocate (beam_data)
	model => simulation%local%model
	decay_rest_frame = &
	simulation%local%get_lval (var_str ("?decay_rest_frame"))
	call beam_data%init_structure (beam_structure, &
	sqrts, model, decay_rest_frame)
	else
	beam_data => null ()
	end if
	end if
	if (associated (beam_data)) then
	n = beam_data%get_n_in ()
	sdata%n_beam = n
	allocate (flv (n))
	flv = beam_data%get_flavor ()
	sdata%pdg_beam(:n) = flv%get_pdg ()
	sdata%energy_beam(:n) = beam_data%get_energy ()
	if (construct_beam_data) deallocate (beam_data)
	else
	n = simulation%entry(1)%n_in
	sdata%n_beam = n
	process_id = simulation%entry(1)%process_id
	call simulation%local%prclib%get_pdg_in_1 &
	(process_id, sdata%pdg_beam(:n))
	sdata%energy_beam(:n) = sqrts / n
	end if
	do i = 1, simulation%n_prc
	if (.not. simulation%entry(i)%valid) cycle
	process => simulation%entry(i)%get_process_ptr ()
	if (associated (process)) then
	sdata%proc_num_id(i) = process%get_num_id ()
	else
	process_id = simulation%entry(i)%process_id
	sdata%proc_num_id(i) = simulation%local%prclib%get_num_id (process_id)
	end if
	if (sdata%proc_num_id(i) == 0) sdata%proc_num_id(i) = i
	if (simulation%entry(i)%has_integral) then
	sdata%cross_section(i) = simulation%entry(i)%integral
	sdata%error(i) = simulation%entry(i)%error
	end if
	end do
	sdata%total_cross_section = sum (sdata%cross_section)
	sdata%md5sum_prc = simulation%get_md5sum_prc ()
	sdata%md5sum_cfg = simulation%get_md5sum_cfg ()
	if (simulation%split_n_evt > 0 .or. simulation%split_n_kbytes > 0) then
	sdata%split_n_evt = simulation%split_n_evt
	sdata%split_n_kbytes = simulation%split_n_kbytes
	sdata%split_index = simulation%split_index
	end if
	end function simulation_get_data

	@ %def simulation_get_data
	@ Return a default name for the current event sample. This is the
	process ID of the first process.
	<<Simulations: simulation: TBP>>=
	procedure :: get_default_sample_name => simulation_get_default_sample_name
	<<Simulations: procedures>>=
	function simulation_get_default_sample_name (simulation) result (sample)
	class(simulation_t), intent(in) :: simulation
	type(string_t) :: sample
	type(process_t), pointer :: process
	sample = "whizard"
	if (simulation%n_prc > 0) then
	process => simulation%entry(1)%get_process_ptr ()
	if (associated (process)) then
	sample = process%get_id ()
	end if
	end if
	end function simulation_get_default_sample_name

	@ %def simulation_get_default_sample_name
	@
	<<Simulations: simulation: TBP>>=
	procedure :: is_valid => simulation_is_valid
	<<Simulations: procedures>>=
	function simulation_is_valid (simulation) result (valid)
	class(simulation_t), intent(inout) :: simulation
	logical :: valid
	valid = simulation%valid
	end function simulation_is_valid

	@ %def simulation_is_valid
	@
	Return the hard-interaction particle set for event entry [[i_prc]].
	<<Simulations: simulation: TBP>>=
	procedure :: get_hard_particle_set => simulation_get_hard_particle_set
	<<Simulations: procedures>>=
	function simulation_get_hard_particle_set (simulation, i_prc) result (pset)
	class(simulation_t), intent(in) :: simulation
	integer, intent(in) :: i_prc
	type(particle_set_t) :: pset
	call simulation%entry(i_prc)%get_hard_particle_set (pset)
	end function simulation_get_hard_particle_set

	@ %def simulation_get_hard_particle_set
	@
	\subsection{Auxiliary}
	Call pacify: eliminate numerical noise.
	<<Simulations: public>>=
	public :: pacify
	<<Simulations: interfaces>>=
	interface pacify
	module procedure pacify_simulation
	end interface
	<<Simulations: procedures>>=
	subroutine pacify_simulation (simulation)
	class(simulation_t), intent(inout) :: simulation
	integer :: i, j
	i = simulation%i_prc
	if (i > 0) then
	call pacify (simulation%entry(i))
	do j = 1, simulation%n_alt
	call pacify (simulation%alt_entry(i,j))
	end do
	end if
	end subroutine pacify_simulation

	@ %def pacify_simulation
	@ Manually evaluate expressions for the currently selected process.
	This is used only in the unit tests.
	<<Simulations: simulation: TBP>>=
	procedure :: evaluate_expressions => simulation_evaluate_expressions
	<<Simulations: procedures>>=
	subroutine simulation_evaluate_expressions (simulation)
	class(simulation_t), intent(inout) :: simulation
	call simulation%entry(simulation%i_prc)%evaluate_expressions ()
	end subroutine simulation_evaluate_expressions

	@ %def simulation_evaluate_expressions
	@ Manually evaluate event transforms for the currently selected
	process. This is used only in the unit tests.
	<<Simulations: simulation: TBP>>=
	procedure :: evaluate_transforms => simulation_evaluate_transforms
	<<Simulations: procedures>>=
	subroutine simulation_evaluate_transforms (simulation)
	class(simulation_t), intent(inout) :: simulation
	associate (entry => simulation%entry(simulation%i_prc))
	call entry%evaluate_transforms ()
	end associate
	end subroutine simulation_evaluate_transforms

	@ %def simulation_evaluate_transforms
	@
	\subsection{Unit tests}
	Test module, followed by the stand-alone unit-test procedures.
	<<[[simulations_ut.f90]]>>=
	<<File header>>

	module simulations_ut
	use unit_tests
	use simulations_uti

	<<Standard module head>>

	<<Simulations: public test>>

	contains

	<<Simulations: test driver>>

	end module simulations_ut
	@ %def simulations_ut
	@
	<<[[simulations_uti.f90]]>>=
	<<File header>>

	module simulations_uti

	<<Use kinds>>
	use kinds, only: i64
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_10, FMT_12
	use ifiles
	use lexers
	use parser
	use lorentz
	use flavors
	use interactions, only: reset_interaction_counter
	use process_libraries, only: process_library_t
	use prclib_stacks
	use phs_forests
	use event_base, only: generic_event_t
	use event_base, only: event_callback_t
	use particles, only: particle_set_t
	use eio_data
	use eio_base
	use eio_direct, only: eio_direct_t
	use eio_raw
	use eio_ascii
	use eio_dump
	use eio_callback
	use eval_trees
	use model_data, only: model_data_t
	use models
	use rt_data
	use event_streams
	use decays_ut, only: prepare_testbed
	use process, only: process_t
	use process_stacks, only: process_entry_t
	use process_configurations_ut, only: prepare_test_library
	use compilations, only: compile_library
	use integrations, only: integrate_process

	use simulations

	use restricted_subprocesses_uti, only: prepare_resonance_test_library

	<<Standard module head>>

	<<Simulations: test declarations>>

	<<Simulations: test auxiliary types>>

	contains

	<<Simulations: tests>>

	<<Simulations: test auxiliary>>

	end module simulations_uti

	@ %def simulations_uti
	@ API: driver for the unit tests below.
	<<Simulations: public test>>=
	public :: simulations_test
	<<Simulations: test driver>>=
	subroutine simulations_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Simulations: execute tests>>
	end subroutine simulations_test

	@ %def simulations_test
	@
	\subsubsection{Initialization}
	Initialize a [[simulation_t]] object, including the embedded event records.
	<<Simulations: execute tests>>=
	call test (simulations_1, "simulations_1", &
	"initialization", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_1
	<<Simulations: tests>>=
	subroutine simulations_1 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, procname2
	type(rt_data_t), target :: global
	type(simulation_t), target :: simulation

	write (u, "(A)") "* Test output: simulations_1"
	write (u, "(A)") "* Purpose: initialize simulation"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_1a"
	procname1 = "simulation_1p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	procname2 = "sim_extra"

	call prepare_test_library (global, libname, 1, [procname2])
	call compile_library (libname, global)
	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations2"), is_known = .true.)


	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_string (var_str ("$sample"), &
	var_str ("sim1"), is_known = .true.)
	call integrate_process (procname2, global, local_stack=.true.)

	call simulation%init ([procname1, procname2], .false., .true., global)
	call simulation%init_process_selector ()
	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the first process"
	write (u, "(A)")

	call simulation%write_event (u, i_prc = 1)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_1

	@ %def simulations_1
	@
	\subsubsection{Weighted events}
	Generate events for a single process.
	<<Simulations: execute tests>>=
	call test (simulations_2, "simulations_2", &
	"weighted events", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_2
	<<Simulations: tests>>=
	subroutine simulations_2 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1
	type(rt_data_t), target :: global
	type(simulation_t), target :: simulation
	type(event_sample_data_t) :: data

	write (u, "(A)") "* Test output: simulations_2"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_2a"
	procname1 = "simulation_2p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	data = simulation%get_data ()
	call data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate three events"
	write (u, "(A)")

	call simulation%set_n_events_requested (3)
	call simulation%generate ()
	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the last event"
	write (u, "(A)")

	call simulation%write_event (u)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_2

	@ %def simulations_2
	@
	\subsubsection{Unweighted events}
	Generate events for a single process.
	<<Simulations: execute tests>>=
	call test (simulations_3, "simulations_3", &
	"unweighted events", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_3
	<<Simulations: tests>>=
	subroutine simulations_3 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1
	type(rt_data_t), target :: global
	type(simulation_t), target :: simulation
	type(event_sample_data_t) :: data

	write (u, "(A)") "* Test output: simulations_3"
	write (u, "(A)") "* Purpose: generate unweighted events &
	&for a single process"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_3a"
	procname1 = "simulation_3p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	data = simulation%get_data ()
	call data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate three events"
	write (u, "(A)")

	call simulation%set_n_events_requested (3)
	call simulation%generate ()
	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the last event"
	write (u, "(A)")

	call simulation%write_event (u)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_3

	@ %def simulations_3
	@
	\subsubsection{Simulating process with structure functions}
	Generate events for a single process.
	<<Simulations: execute tests>>=
	call test (simulations_4, "simulations_4", &
	"process with structure functions", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_4
	<<Simulations: tests>>=
	subroutine simulations_4 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1
	type(rt_data_t), target :: global
	type(flavor_t) :: flv
	type(string_t) :: name
	type(simulation_t), target :: simulation
	type(event_sample_data_t) :: data

	write (u, "(A)") "* Test output: simulations_4"
	write (u, "(A)") "* Purpose: generate events for a single process &
	&with structure functions"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_4a"
	procname1 = "simulation_4p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call reset_interaction_counter ()

	call flv%init (25, global%model)
	name = flv%get_name ()

	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

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

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	call global%set_string (var_str ("$sample"), &
	var_str ("simulations4"), is_known = .true.)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	data = simulation%get_data ()
	call data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate three events"
	write (u, "(A)")

	call simulation%set_n_events_requested (3)
	call simulation%generate ()
	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the last event"
	write (u, "(A)")

	call simulation%write_event (u)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_4

	@ %def simulations_4
	@
	\subsubsection{Event I/O}
	Generate event for a test process, write to file and reread.
	<<Simulations: execute tests>>=
	call test (simulations_5, "simulations_5", &
	"raw event I/O", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_5
	<<Simulations: tests>>=
	subroutine simulations_5 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	class(eio_t), allocatable :: eio
	type(simulation_t), allocatable, target :: simulation

	write (u, "(A)") "* Test output: simulations_5"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* write to file and reread"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_5a"
	procname1 = "simulation_5p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations5"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations5"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Initialize raw event file"
	write (u, "(A)")

	allocate (eio_raw_t :: eio)
	call eio%init_out (sample)

	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call simulation%write_event (u)
	call simulation%write_event (eio)

	call eio%final ()
	deallocate (eio)
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)")
	write (u, "(A)") "* Re-read the event from file"
	write (u, "(A)")

	call global%set_log (var_str ("?update_sqme"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_weight"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()
	allocate (eio_raw_t :: eio)
	call eio%init_in (sample)

	call simulation%read_event (eio)
	call simulation%write_event (u)

	write (u, "(A)")
	write (u, "(A)") "* Recalculate process instance"
	write (u, "(A)")

	call simulation%recalculate ()
	call simulation%evaluate_expressions ()
	call simulation%write_event (u)

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

	call eio%final ()
	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_5

	@ %def simulations_5
	@
	\subsubsection{Event I/O}
	Generate event for a real process with structure functions, write to file and
	reread.
	<<Simulations: execute tests>>=
	call test (simulations_6, "simulations_6", &
	"raw event I/O with structure functions", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_6
	<<Simulations: tests>>=
	subroutine simulations_6 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	class(eio_t), allocatable :: eio
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	type(string_t) :: name

	write (u, "(A)") "* Test output: simulations_6"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* write to file and reread"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_6"
	procname1 = "simulation_6p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)

	call flv%init (25, global%model)
	name = flv%get_name ()

	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations6"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Initialize raw event file"
	write (u, "(A)")

	allocate (eio_raw_t :: eio)
	call eio%init_out (sample)

	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call pacify (simulation)
	call simulation%write_event (u, verbose = .true., testflag = .true.)
	call simulation%write_event (eio)

	call eio%final ()
	deallocate (eio)
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)")
	write (u, "(A)") "* Re-read the event from file"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?update_sqme"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_weight"), &
	.true., is_known = .true.)

	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()
	allocate (eio_raw_t :: eio)
	call eio%init_in (sample)

	call simulation%read_event (eio)
	call simulation%write_event (u, verbose = .true., testflag = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Recalculate process instance"
	write (u, "(A)")

	call simulation%recalculate ()
	call simulation%evaluate_expressions ()
	call simulation%write_event (u, verbose = .true., testflag = .true.)

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

	call eio%final ()
	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_6

	@ %def simulations_6
	@
	\subsubsection{Automatic Event I/O}
	Generate events with raw-format event file as cache: generate, reread,
	append.
	<<Simulations: execute tests>>=
	call test (simulations_7, "simulations_7", &
	"automatic raw event I/O", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_7
	<<Simulations: tests>>=
	subroutine simulations_7 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: empty_string_array
	type(event_sample_data_t) :: data
	type(event_stream_array_t) :: es_array
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	type(string_t) :: name

	write (u, "(A)") "* Test output: simulations_7"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* write to file and reread"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_7"
	procname1 = "simulation_7p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)

	call flv%init (25, global%model)
	name = flv%get_name ()

	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations7"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Initialize raw event file"
	write (u, "(A)")

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = simulation%get_md5sum_cfg ()
	call es_array%init (sample, [var_str ("raw")], global, data)

	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate (es_array)

	call es_array%final ()
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)") "* Re-read the event from file and generate another one"
	write (u, "(A)")

	call global%set_log (&
	var_str ("?rebuild_events"), .false., is_known = .true.)

	call reset_interaction_counter ()

	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = simulation%get_md5sum_cfg ()
	call es_array%init (sample, empty_string_array, global, data, &
	input = var_str ("raw"))

	call simulation%set_n_events_requested (2)
	call simulation%generate (es_array)

	call pacify (simulation)
	call simulation%write_event (u, verbose = .true.)

	call es_array%final ()
	call simulation%final ()
	deallocate (simulation)


	write (u, "(A)")
	write (u, "(A)") "* Re-read both events from file"
	write (u, "(A)")

	call reset_interaction_counter ()

	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = simulation%get_md5sum_cfg ()
	call es_array%init (sample, empty_string_array, global, data, &
	input = var_str ("raw"))

	call simulation%set_n_events_requested (2)
	call simulation%generate (es_array)

	call pacify (simulation)
	call simulation%write_event (u, verbose = .true.)

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

	call es_array%final ()
	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_7

	@ %def simulations_7
	@
	\subsubsection{Rescanning Events}
	Generate events and rescan the resulting raw event file.
	<<Simulations: execute tests>>=
	call test (simulations_8, "simulations_8", &
	"rescan raw event file", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_8
	<<Simulations: tests>>=
	subroutine simulations_8 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: empty_string_array
	type(event_sample_data_t) :: data
	type(event_stream_array_t) :: es_array
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	type(string_t) :: name

	write (u, "(A)") "* Test output: simulations_8"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* write to file and rescan"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_8"
	procname1 = "simulation_8p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)

	call flv%init (25, global%model)
	name = flv%get_name ()

	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations8"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Initialize raw event file"
	write (u, "(A)")

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = simulation%get_md5sum_cfg ()
	write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
	call es_array%init (sample, [var_str ("raw")], global, &
	data)

	write (u, "(A)")
	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate (es_array)

	call pacify (simulation)
	call simulation%write_event (u, verbose = .true., testflag = .true.)

	call es_array%final ()
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)")
	write (u, "(A)") "* Re-read the event from file"
	write (u, "(A)")

	call reset_interaction_counter ()

	allocate (simulation)
	call simulation%init ([procname1], .false., .false., global)
	call simulation%init_process_selector ()

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = ""
	write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
	call es_array%init (sample, empty_string_array, global, data, &
	input = var_str ("raw"), input_sample = sample, allow_switch = .false.)

	call simulation%rescan (1, es_array, global = global)

	write (u, "(A)")

	call pacify (simulation)
	call simulation%write_event (u, verbose = .true., testflag = .true.)

	call es_array%final ()
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)")
	write (u, "(A)") "* Re-read again and recalculate"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?update_sqme"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_event"), &
	.true., is_known = .true.)

	allocate (simulation)
	call simulation%init ([procname1], .false., .false., global)
	call simulation%init_process_selector ()

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = ""
	write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
	call es_array%init (sample, empty_string_array, global, data, &
	input = var_str ("raw"), input_sample = sample, allow_switch = .false.)

	call simulation%rescan (1, es_array, global = global)

	write (u, "(A)")

	call pacify (simulation)
	call simulation%write_event (u, verbose = .true., testflag = .true.)

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

	call es_array%final ()
	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_8

	@ %def simulations_8
	@
	\subsubsection{Rescanning Check}
	Generate events and rescan with process mismatch.
	<<Simulations: execute tests>>=
	call test (simulations_9, "simulations_9", &
	"rescan mismatch", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_9
	<<Simulations: tests>>=
	subroutine simulations_9 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	type(string_t), dimension(0) :: empty_string_array
	type(event_sample_data_t) :: data
	type(event_stream_array_t) :: es_array
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	type(string_t) :: name
	logical :: error

	write (u, "(A)") "* Test output: simulations_9"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* write to file and rescan"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_9"
	procname1 = "simulation_9p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("wood"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("vamp"), is_known = .true.)
	call global%set_log (var_str ("?use_vamp_equivalences"),&
	.true., is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)

	call flv%init (25, global%model)
	name = flv%get_name ()

	call global%beam_structure%init_sf ([name, name], [1])
	call global%beam_structure%set_sf (1, 1, var_str ("sf_test_1"))

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call reset_interaction_counter ()

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations9"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize raw event file"
	write (u, "(A)")

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = simulation%get_md5sum_cfg ()
	write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
	call es_array%init (sample, [var_str ("raw")], global, &
	data)

	write (u, "(A)")
	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate (es_array)

	call es_array%final ()
	call simulation%final ()
	deallocate (simulation)

	write (u, "(A)") "* Initialize event generation for different parameters"
	write (u, "(A)")

	call reset_interaction_counter ()

	allocate (simulation)
	call simulation%init ([procname1, procname1], .false., .false., global)
	call simulation%init_process_selector ()

	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Attempt to re-read the events (should fail)"
	write (u, "(A)")

	data%md5sum_prc = simulation%get_md5sum_prc ()
	data%md5sum_cfg = ""
	write (u, "(1x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
	write (u, "(1x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
	call es_array%init (sample, empty_string_array, global, data, &
	input = var_str ("raw"), input_sample = sample, &
	allow_switch = .false., error = error)

	write (u, "(1x,A,L1)") "error = ", error

	call simulation%rescan (1, es_array, global = global)

	call es_array%final ()
	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_9

	@ %def simulations_9
	@
	\subsubsection{Alternative weights}
	Generate an event for a single process and reweight it in a
	simultaneous calculation.
	<<Simulations: execute tests>>=
	call test (simulations_10, "simulations_10", &
	"alternative weight", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_10
	<<Simulations: tests>>=
	subroutine simulations_10 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, expr_text
	type(rt_data_t), target :: global
	type(rt_data_t), dimension(1), target :: alt_env
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: pt_weight
	type(simulation_t), target :: simulation
	type(event_sample_data_t) :: data

	write (u, "(A)") "* Test output: simulations_10"
	write (u, "(A)") "* Purpose: reweight event"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_pexpr_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_10a"
	procname1 = "simulation_10p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("simulations1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize alternative environment with custom weight"
	write (u, "(A)")

	call alt_env(1)%local_init (global)
	call alt_env(1)%activate ()

	expr_text = "2"
	write (u, "(A,A)") "weight = ", char (expr_text)
	write (u, *)

	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_weight, stream, .true.)
	call stream_final (stream)
	alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr ()
	call alt_env(1)%write_expr (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	call simulation%init ([procname1], .true., .true., global, alt_env=alt_env)
	call simulation%init_process_selector ()

	data = simulation%get_data ()
	call data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate an event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the last event"
	write (u, "(A)")

	call simulation%write_event (u)

	write (u, "(A)")
	write (u, "(A)") "* Write the event record for the alternative setup"
	write (u, "(A)")

	call simulation%write_alt_event (u)

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

	call simulation%final ()
	call global%final ()

	call syntax_model_file_final ()
	call syntax_pexpr_final ()

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

	end subroutine simulations_10

	@ %def simulations_10
	@
	\subsubsection{Decays}
	Generate an event with subsequent partonic decays.
	<<Simulations: execute tests>>=
	call test (simulations_11, "simulations_11", &
	"decay", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_11
	<<Simulations: tests>>=
	subroutine simulations_11 (u)
	integer, intent(in) :: u
	type(rt_data_t), target :: global
	type(prclib_entry_t), pointer :: lib
	type(string_t) :: prefix, procname1, procname2
	type(simulation_t), target :: simulation

	write (u, "(A)") "* Test output: simulations_11"
	write (u, "(A)") "* Purpose: apply decay"
	write (u, "(A)")

	write (u, "(A)") "* Initialize processes"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	allocate (lib)
	call global%add_prclib (lib)

	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	prefix = "simulation_11"
	procname1 = prefix // "_p"
	procname2 = prefix // "_d"
	call prepare_testbed &
	(global%prclib, global%process_stack, &
	prefix, global%os_data, &
	scattering=.true., decay=.true.)

	call global%select_model (var_str ("Test"))
	call global%model%set_par (var_str ("ff"), 0.4_default)
	call global%model%set_par (var_str ("mf"), &
	global%model%get_real (var_str ("ff")) &
	* global%model%get_real (var_str ("ms")))
	call global%model%set_unstable (25, [procname2])

	write (u, "(A)") "* Initialize simulation object"
	write (u, "(A)")

	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Generate event"
	write (u, "(A)")

	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call simulation%write (u)

	write (u, *)

	call simulation%write_event (u)

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

	call simulation%final ()
	call global%final ()

	call syntax_model_file_final ()

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

	end subroutine simulations_11

	@ %def simulations_11
	@
	\subsubsection{Split Event Files}
	Generate event for a real process with structure functions and write to file,
	accepting a limit for the number of events per file.
	<<Simulations: execute tests>>=
	call test (simulations_12, "simulations_12", &
	"split event files", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_12
	<<Simulations: tests>>=
	subroutine simulations_12 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	class(eio_t), allocatable :: eio
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	integer :: i_evt

	write (u, "(A)") "* Test output: simulations_12"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* and write to split event files"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_12"
	procname1 = "simulation_12p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%model_set_real (var_str ("ms"), &
	0._default)

	call flv%init (25, global%model)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations_12"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)
	call global%set_int (var_str ("sample_split_n_evt"), &
	2, is_known = .true.)
	call global%set_int (var_str ("sample_split_index"), &
	42, is_known = .true.)
	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	call simulation%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize ASCII event file"
	write (u, "(A)")

	allocate (eio_ascii_short_t :: eio)
	select type (eio)
	class is (eio_ascii_t); call eio%set_parameters ()
	end select
	call eio%init_out (sample, data = simulation%get_data ())

	write (u, "(A)") "* Generate 5 events, distributed among three files"

	do i_evt = 1, 5
	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call simulation%write_event (eio)
	end do

	call eio%final ()
	deallocate (eio)
	call simulation%final ()
	deallocate (simulation)

	write (u, *)
	call display_file ("simulations_12.42.short.evt", u)
	write (u, *)
	call display_file ("simulations_12.43.short.evt", u)
	write (u, *)
	call display_file ("simulations_12.44.short.evt", u)

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

	call global%final ()

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

	end subroutine simulations_12

	@ %def simulations_12
	@ Auxiliary: display file contents.
	<<Simulations: public test auxiliary>>=
	public :: display_file
	<<Simulations: test auxiliary>>=
	subroutine display_file (file, u)
	use io_units, only: free_unit
	character(*), intent(in) :: file
	integer, intent(in) :: u
	character(256) :: buffer
	integer :: u_file
	write (u, "(3A)") "* Contents of file '", file, "':"
	write (u, *)
	u_file = free_unit ()
	open (u_file, file = file, action = "read", status = "old")
	do
	read (u_file, "(A)", end = 1) buffer
	write (u, "(A)") trim (buffer)
	end do
	1 continue
	end subroutine display_file

	@ %def display_file
	@
	\subsubsection{Callback}
	Generate events and execute a callback in place of event I/O.
	<<Simulations: execute tests>>=
	call test (simulations_13, "simulations_13", &
	"callback", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_13
	<<Simulations: tests>>=
	subroutine simulations_13 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, procname1, sample
	type(rt_data_t), target :: global
	class(eio_t), allocatable :: eio
	type(simulation_t), allocatable, target :: simulation
	type(flavor_t) :: flv
	integer :: i_evt
	type(simulations_13_callback_t) :: event_callback

	write (u, "(A)") "* Test output: simulations_13"
	write (u, "(A)") "* Purpose: generate events for a single process"
	write (u, "(A)") "* and execute callback"
	write (u, "(A)")

	write (u, "(A)") "* Initialize process and integrate"
	write (u, "(A)")

	call syntax_model_file_init ()

	call global%global_init ()
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)

	libname = "simulation_13"
	procname1 = "simulation_13p"

	call prepare_test_library (global, libname, 1, [procname1])
	call compile_library (libname, global)

	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)

	call global%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known = .true.)
	call global%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known = .true.)
	call global%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known = .true.)
	call global%set_log (var_str ("?vis_history"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)

	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)

	call flv%init (25, global%model)

	call global%it_list%init ([1], [1000])

	call global%set_string (var_str ("$run_id"), &
	var_str ("r1"), is_known = .true.)
	call integrate_process (procname1, global, local_stack=.true.)

	write (u, "(A)") "* Initialize event generation"
	write (u, "(A)")

	call global%set_log (var_str ("?unweighted"), &
	.false., is_known = .true.)
	sample = "simulations_13"
	call global%set_string (var_str ("$sample"), &
	sample, is_known = .true.)

	allocate (simulation)
	call simulation%init ([procname1], .true., .true., global)
	call simulation%init_process_selector ()

	write (u, "(A)") "* Prepare callback object"
	write (u, "(A)")

	event_callback%u = u
	call global%set_event_callback (event_callback)

	write (u, "(A)") "* Initialize callback I/O object"
	write (u, "(A)")

	allocate (eio_callback_t :: eio)
	select type (eio)
	class is (eio_callback_t)
	call eio%set_parameters (callback = event_callback, &
	count_interval = 3)
	end select
	call eio%init_out (sample, data = simulation%get_data ())

	write (u, "(A)") "* Generate 7 events, with callback every 3 events"
	write (u, "(A)")

	do i_evt = 1, 7
	call simulation%set_n_events_requested (1)
	call simulation%generate ()
	call simulation%write_event (eio)
	end do

	call eio%final ()
	deallocate (eio)
	call simulation%final ()
	deallocate (simulation)

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

	call global%final ()

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

	end subroutine simulations_13

	@ %def simulations_13
	@ The callback object and procedure. In the type extension, we can
	store the output channel [[u]] so we know where to write into.
	<<Simulations: test auxiliary types>>=
	type, extends (event_callback_t) :: simulations_13_callback_t
	integer :: u
	contains
	procedure :: write => simulations_13_callback_write
	procedure :: proc => simulations_13_callback
	end type simulations_13_callback_t

	@ %def simulations_13_callback_t
	<<Simulations: test auxiliary>>=
	subroutine simulations_13_callback_write (event_callback, unit)
	class(simulations_13_callback_t), intent(in) :: event_callback
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Hello"
	end subroutine simulations_13_callback_write

	subroutine simulations_13_callback (event_callback, i, event)
	class(simulations_13_callback_t), intent(in) :: event_callback
	integer(i64), intent(in) :: i
	class(generic_event_t), intent(in) :: event
	write (event_callback%u, "(A,I0)") "hello event #", i
	end subroutine simulations_13_callback

	@ %def simulations_13_callback_write
	@ %def simulations_13_callback
	@
	\subsubsection{Resonant subprocess setup}
	Prepare a process with resonances and enter resonant subprocesses in
	the simulation object. Select a kinematics configuration and compute
	probabilities for resonant subprocesses.

	The process and its initialization is taken from [[processes_18]], but
	we need a complete \oMega\ matrix element here.
	<<Simulations: execute tests>>=
	call test (simulations_14, "simulations_14", &
	"resonant subprocesses evaluation", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_14
	<<Simulations: tests>>=
	subroutine simulations_14 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, libname_generated
	type(string_t) :: procname
	type(string_t) :: model_name
	type(rt_data_t), target :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(simulation_t), target :: simulation
	type(particle_set_t) :: pset
	type(eio_direct_t) :: eio_in
	type(eio_dump_t) :: eio_out
	real(default) :: sqrts, mw, pp
	real(default), dimension(3) :: p3
	type(vector4_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: m
	integer :: u_verbose, i
	real(default) :: sqme_proc
	real(default), dimension(:), allocatable :: sqme
	real(default) :: on_shell_limit
	integer, dimension(:), allocatable :: i_array
	real(default), dimension(:), allocatable :: prob_array

	write (u, "(A)") "* Test output: simulations_14"
	write (u, "(A)") "* Purpose: construct resonant subprocesses &
	&in the simulation object"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	libname = "simulations_14_lib"
	procname = "simulations_14_p"

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)
	call global%set_log (var_str ("?update_sqme"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_weight"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_event"), &
	.true., is_known = .true.)

	model_name = "SM"
	call global%select_model (model_name)
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize simulation object &
	&with resonant subprocesses"
	write (u, "(A)")

	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)
	call global%set_real (var_str ("resonance_on_shell_limit"), &
	10._default, is_known = .true.)

	call simulation%init ([procname], &
	integrate=.false., generate=.false., local=global)

	call simulation%write_resonant_subprocess_data (u, 1)

	write (u, "(A)")
	write (u, "(A)") "* Resonant subprocesses: generated library"
	write (u, "(A)")

	libname_generated = procname // "_R"
	lib => global%prclib_stack%get_library_ptr (libname_generated)
	if (associated (lib)) call lib%write (u, libpath=.false.)

	write (u, "(A)")
	write (u, "(A)") "* Generated process stack"
	write (u, "(A)")

	call global%process_stack%show (u)

	write (u, "(A)")
	write (u, "(A)") "* Particle set"
	write (u, "(A)")

	pset = simulation%get_hard_particle_set (1)
	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize object for direct access"
	write (u, "(A)")

	call eio_in%init_direct &
	(n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, &
	pdg = [-11, 11, 1, -2, 24], model=global%model)
	call eio_in%set_selection_indices (1, 1, 1, 1)

	sqrts = global%get_rval (var_str ("sqrts"))
	mw = 80._default ! deliberately slightly different from true mw
	pp = sqrt (sqrts*2 - 4 mw**2) / 2

	allocate (p (5), m (5))
	p(1) = vector4_moving (sqrts/2, sqrts/2, 3)
	m(1) = 0
	p(2) = vector4_moving (sqrts/2,-sqrts/2, 3)
	m(2) = 0
	p3(1) = pp/2
	p3(2) = mw/2
	p3(3) = 0
	p(3) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(3) = 0
	p3(2) = -mw/2
	p(4) = vector4_moving (sqrts/4, vector3_moving (p3))
	m(4) = 0
	p(5) = vector4_moving (sqrts/2,-pp, 1)
	m(5) = mw
	call eio_in%set_momentum (p, m**2)

	call eio_in%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Transfer and show particle set"
	write (u, "(A)")

	call simulation%read_event (eio_in)
	pset = simulation%get_hard_particle_set (1)
	call pset%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (Re)calculate matrix element"
	write (u, "(A)")

	call simulation%recalculate (recover_phs = .false.)
	call simulation%evaluate_transforms ()

	write (u, "(A)") "* Show event with sqme"
	write (u, "(A)")

	call eio_out%set_parameters (unit = u, &
	weights = .true., pacify = .true., compressed = .true.)
	call eio_out%init_out (var_str (""))
	call simulation%write_event (eio_out)

	write (u, "(A)")
	write (u, "(A)") "* Write event to separate file &
	&'simulations_14_event_verbose.log'"

	u_verbose = free_unit ()
	open (unit = u_verbose, file = "simulations_14_event_verbose.log", &
	status = "replace", action = "write")
	call simulation%write (u_verbose)
	write (u_verbose, *)
	call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
	close (u_verbose)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_14

	@ %def simulations_14
	@
	\subsubsection{Resonant subprocess simulation}
	Prepare a process with resonances and enter resonant subprocesses in
	the simulation object. Simulate events with selection of resonance
	histories.

	The process and its initialization is taken from [[processes_18]], but
	we need a complete \oMega\ matrix element here.
	<<Simulations: execute tests>>=
	call test (simulations_15, "simulations_15", &
	"resonant subprocesses in simulation", &
	u, results)
	<<Simulations: test declarations>>=
	public :: simulations_15
	<<Simulations: tests>>=
	subroutine simulations_15 (u)
	integer, intent(in) :: u
	type(string_t) :: libname, libname_generated
	type(string_t) :: procname
	type(string_t) :: model_name
	type(rt_data_t), target :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	class(model_t), pointer :: model
	class(model_data_t), pointer :: model_data
	type(simulation_t), target :: simulation
	real(default) :: sqrts
	type(eio_dump_t) :: eio_out
	integer :: u_verbose

	write (u, "(A)") "* Test output: simulations_15"
	write (u, "(A)") "* Purpose: generate event with resonant subprocess"
	write (u, "(A)")

	write (u, "(A)") "* Build and load a test library with one process"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_phs_forest_init ()

	libname = "simulations_15_lib"
	procname = "simulations_15_p"

	call global%global_init ()
	call global%append_log (&
	var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_grids"), .true., intrinsic = .true.)
	call global%append_log (&
	var_str ("?rebuild_events"), .true., intrinsic = .true.)
	call global%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	call global%set_int (var_str ("seed"), &
	0, is_known = .true.)
	call global%set_real (var_str ("sqrts"),&
	1000._default, is_known = .true.)
	call global%set_log (var_str ("?recover_beams"), &
	.false., is_known = .true.)
	call global%set_log (var_str ("?update_sqme"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_weight"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?update_event"), &
	.true., is_known = .true.)
	call global%set_log (var_str ("?resonance_history"), &
	.true., is_known = .true.)
	call global%set_real (var_str ("resonance_on_shell_limit"), &
	10._default, is_known = .true.)

	model_name = "SM"
	call global%select_model (model_name)
	allocate (model)
	call model%init_instance (global%model)
	model_data => model

	write (u, "(A)") "* Initialize process library and process"
	write (u, "(A)")

	allocate (lib_entry)
	call lib_entry%init (libname)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)

	call prepare_resonance_test_library &
	(lib, libname, procname, model_data, global, u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize simulation object &
	&with resonant subprocesses"
	write (u, "(A)")

	call global%it_list%init ([1], [1000])
	call simulation%init ([procname], &
	integrate=.true., generate=.true., local=global)

	call simulation%write_resonant_subprocess_data (u, 1)

	write (u, "(A)")
	write (u, "(A)") "* Generate event"
	write (u, "(A)")

	call simulation%init_process_selector ()
	call simulation%set_n_events_requested (1)
	call simulation%generate ()

	call eio_out%set_parameters (unit = u, &
	weights = .true., pacify = .true., compressed = .true.)
	call eio_out%init_out (var_str (""))
	call simulation%write_event (eio_out)

	write (u, "(A)")
	write (u, "(A)") "* Write event to separate file &
	&'simulations_15_event_verbose.log'"

	u_verbose = free_unit ()
	open (unit = u_verbose, file = "simulations_15_event_verbose.log", &
	status = "replace", action = "write")
	call simulation%write (u_verbose)
	write (u_verbose, *)
	call simulation%write_event (u_verbose, verbose =.true., testflag = .true.)
	close (u_verbose)

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

	call simulation%final ()
	call global%final ()

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

	end subroutine simulations_15

	@ %def simulations_15
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{More Unit Tests}

	This chapter collects some procedures for testing that can't be
	provided at the point where the corresponding modules are defined,
	because they use other modules of a different level.

	(We should move them back, collecting the high-level functionality in
	init/final hooks that we can set at runtime.)


	\section{Expression Testing}

	Expression objects are part of process and event objects, but the
	process and event object modules should not depend on the
	implementation of expressions. Here, we collect unit tests that
	depend on expression implementation.
	<<[[expr_tests_ut.f90]]>>=
	<<File header>>
	module expr_tests_ut

	use unit_tests
	use expr_tests_uti

	<<Standard module head>>

	<<Expr tests: public test>>

	contains

	<<Expr tests: test driver>>

	end module expr_tests_ut
	@ %def expr_tests_ut
	@
	<<[[expr_tests_uti.f90]]>>=
	<<File header>>

	module expr_tests_uti

	<<Use kinds>>
	<<Use strings>>
	use format_defs, only: FMT_12
	use format_utils, only: write_separator
	use os_interface
	use sm_qcd
	use lorentz
	use ifiles
	use lexers
	use parser
	use model_data
	use interactions, only: reset_interaction_counter
	use process_libraries
	use subevents
	use subevt_expr
	use rng_base
	use mci_base
	use phs_base
	use variables, only: var_list_t
	use eval_trees
	use models
	use prc_core
	use prc_test
	use process, only: process_t
	use instances, only: process_instance_t
	use events

	use rng_base_ut, only: rng_test_factory_t
	use phs_base_ut, only: phs_test_config_t

	<<Standard module head>>

	<<Expr tests: test declarations>>

	contains

	<<Expr tests: tests>>

	<<Expr tests: test auxiliary>>

	end module expr_tests_uti

	@ %def expr_tests_uti
	@
	\subsection{Test}
	This is the master for calling self-test procedures.
	<<Expr tests: public test>>=
	public :: subevt_expr_test
	<<Expr tests: test driver>>=
	subroutine subevt_expr_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Expr tests: execute tests>>
	end subroutine subevt_expr_test

	@ %def subevt_expr_test
	@
	\subsubsection{Parton-event expressions}
	<<Expr tests: execute tests>>=
	call test (subevt_expr_1, "subevt_expr_1", &
	"parton-event expressions", &
	u, results)
	<<Expr tests: test declarations>>=
	public :: subevt_expr_1
	<<Expr tests: tests>>=
	subroutine subevt_expr_1 (u)
	integer, intent(in) :: u
	type(string_t) :: expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: pt_cuts, pt_scale, pt_fac_scale, pt_ren_scale
	type(parse_tree_t) :: pt_weight
	type(parse_node_t), pointer :: pn_cuts, pn_scale, pn_fac_scale, pn_ren_scale
	type(parse_node_t), pointer :: pn_weight
	type(eval_tree_factory_t) :: expr_factory
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(parton_expr_t), target :: expr
	real(default) :: E, Ex, m
	type(vector4_t), dimension(6) :: p
	integer :: i, pdg
	logical :: passed
	real(default) :: scale, weight
	real(default), allocatable :: fac_scale, ren_scale

	write (u, "(A)") "* Test output: subevt_expr_1"
	write (u, "(A)") "* Purpose: Set up a subevt and associated &
	&process-specific expressions"
	write (u, "(A)")

	call syntax_pexpr_init ()

	call syntax_model_file_init ()
	call os_data%init ()
	call model%read (var_str ("Test.mdl"), os_data)

	write (u, "(A)") "* Expression texts"
	write (u, "(A)")


	expr_text = "all Pt > 100 [s]"
	write (u, "(A,A)") "cuts = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (pt_cuts, stream, .true.)
	call stream_final (stream)
	pn_cuts => pt_cuts%get_root_ptr ()

	expr_text = "sqrts"
	write (u, "(A,A)") "scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_scale, stream, .true.)
	call stream_final (stream)
	pn_scale => pt_scale%get_root_ptr ()

	expr_text = "sqrts_hat"
	write (u, "(A,A)") "fac_scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_fac_scale, stream, .true.)
	call stream_final (stream)
	pn_fac_scale => pt_fac_scale%get_root_ptr ()

	expr_text = "100"
	write (u, "(A,A)") "ren_scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_ren_scale, stream, .true.)
	call stream_final (stream)
	pn_ren_scale => pt_ren_scale%get_root_ptr ()

	expr_text = "n_tot - n_in - n_out"
	write (u, "(A,A)") "weight = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_weight, stream, .true.)
	call stream_final (stream)
	pn_weight => pt_weight%get_root_ptr ()

	call ifile_final (ifile)

	write (u, "(A)")
	write (u, "(A)") "* Initialize process expr"
	write (u, "(A)")

	call expr%setup_vars (1000._default)
	call expr%var_list%append_real (var_str ("tolerance"), 0._default)
	call expr%link_var_list (model%get_var_list_ptr ())

	call expr_factory%init (pn_cuts)
	call expr%setup_selection (expr_factory)
	call expr_factory%init (pn_scale)
	call expr%setup_scale (expr_factory)
	call expr_factory%init (pn_fac_scale)
	call expr%setup_fac_scale (expr_factory)
	call expr_factory%init (pn_ren_scale)
	call expr%setup_ren_scale (expr_factory)
	call expr_factory%init (pn_weight)
	call expr%setup_weight (expr_factory)

	call write_separator (u)
	call expr%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill subevt and evaluate expressions"
	write (u, "(A)")

	call subevt_init (expr%subevt_t, 6)
	E = 500._default
	Ex = 400._default
	m = 125._default
	pdg = 25
	p(1) = vector4_moving (E, sqrt (E2 - m2), 3)
	p(2) = vector4_moving (E, -sqrt (E2 - m2), 3)
	p(3) = vector4_moving (Ex, sqrt (Ex2 - m2), 3)
	p(4) = vector4_moving (Ex, -sqrt (Ex2 - m2), 3)
	p(5) = vector4_moving (Ex, sqrt (Ex2 - m2), 1)
	p(6) = vector4_moving (Ex, -sqrt (Ex2 - m2), 1)

	call expr%reset_contents ()
	do i = 1, 2
	- call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_beam (i, pdg, p(i), m**2)
	end do
	do i = 3, 4
	- call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_incoming (i, pdg, p(i), m**2)
	end do
	do i = 5, 6
	- call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_outgoing (i, pdg, p(i), m**2)
	end do
	- expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
	+ expr%sqrts_hat = expr%get_sqrts_hat ()
	expr%n_in = 2
	expr%n_out = 2
	expr%n_tot = 4
	expr%subevt_filled = .true.

	call expr%evaluate (passed, scale, fac_scale, ren_scale, weight)

	write (u, "(A,L1)") "Event has passed = ", passed
	write (u, "(A," // FMT_12 // ")") "Scale = ", scale
	write (u, "(A," // FMT_12 // ")") "Factorization scale = ", fac_scale
	write (u, "(A," // FMT_12 // ")") "Renormalization scale = ", ren_scale
	write (u, "(A," // FMT_12 // ")") "Weight = ", weight
	write (u, "(A)")

	call write_separator (u)
	call expr%write (u)
	call write_separator (u)

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

	call expr%final ()

	call model%final ()
	call syntax_model_file_final ()

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

	end subroutine subevt_expr_1

	@ %def subevt_expr_1
	@
	\subsubsection{Parton-event expressions}
	<<Expr tests: execute tests>>=
	call test (subevt_expr_2, "subevt_expr_2", &
	"parton-event expressions", &
	u, results)
	<<Expr tests: test declarations>>=
	public :: subevt_expr_2
	<<Expr tests: tests>>=
	subroutine subevt_expr_2 (u)
	integer, intent(in) :: u
	type(string_t) :: expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: pt_selection
	type(parse_tree_t) :: pt_reweight, pt_analysis
	type(parse_node_t), pointer :: pn_selection
	type(parse_node_t), pointer :: pn_reweight, pn_analysis
	type(os_data_t) :: os_data
	type(model_t), target :: model
	type(eval_tree_factory_t) :: expr_factory
	type(event_expr_t), target :: expr
	real(default) :: E, Ex, m
	type(vector4_t), dimension(6) :: p
	integer :: i, pdg
	logical :: passed
	real(default) :: reweight
	logical :: analysis_flag

	write (u, "(A)") "* Test output: subevt_expr_2"
	write (u, "(A)") "* Purpose: Set up a subevt and associated &
	&process-specific expressions"
	write (u, "(A)")

	call syntax_pexpr_init ()

	call syntax_model_file_init ()
	call os_data%init ()
	call model%read (var_str ("Test.mdl"), os_data)

	write (u, "(A)") "* Expression texts"
	write (u, "(A)")


	expr_text = "all Pt > 100 [s]"
	write (u, "(A,A)") "selection = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (pt_selection, stream, .true.)
	call stream_final (stream)
	pn_selection => pt_selection%get_root_ptr ()

	expr_text = "n_tot - n_in - n_out"
	write (u, "(A,A)") "reweight = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_reweight, stream, .true.)
	call stream_final (stream)
	pn_reweight => pt_reweight%get_root_ptr ()

	expr_text = "true"
	write (u, "(A,A)") "analysis = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (pt_analysis, stream, .true.)
	call stream_final (stream)
	pn_analysis => pt_analysis%get_root_ptr ()

	call ifile_final (ifile)

	write (u, "(A)")
	write (u, "(A)") "* Initialize process expr"
	write (u, "(A)")

	call expr%setup_vars (1000._default)
	call expr%link_var_list (model%get_var_list_ptr ())
	call expr%var_list%append_real (var_str ("tolerance"), 0._default)

	call expr_factory%init (pn_selection)
	call expr%setup_selection (expr_factory)
	call expr_factory%init (pn_analysis)
	call expr%setup_analysis (expr_factory)
	call expr_factory%init (pn_reweight)
	call expr%setup_reweight (expr_factory)

	call write_separator (u)
	call expr%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Fill subevt and evaluate expressions"
	write (u, "(A)")

	call subevt_init (expr%subevt_t, 6)
	E = 500._default
	Ex = 400._default
	m = 125._default
	pdg = 25
	p(1) = vector4_moving (E, sqrt (E2 - m2), 3)
	p(2) = vector4_moving (E, -sqrt (E2 - m2), 3)
	p(3) = vector4_moving (Ex, sqrt (Ex2 - m2), 3)
	p(4) = vector4_moving (Ex, -sqrt (Ex2 - m2), 3)
	p(5) = vector4_moving (Ex, sqrt (Ex2 - m2), 1)
	p(6) = vector4_moving (Ex, -sqrt (Ex2 - m2), 1)

	call expr%reset_contents ()
	do i = 1, 2
	- call subevt_set_beam (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_beam (i, pdg, p(i), m**2)
	end do
	do i = 3, 4
	- call subevt_set_incoming (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_incoming (i, pdg, p(i), m**2)
	end do
	do i = 5, 6
	- call subevt_set_outgoing (expr%subevt_t, i, pdg, p(i), m**2)
	+ call expr%set_outgoing (i, pdg, p(i), m**2)
	end do
	- expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
	+ expr%sqrts_hat = expr%get_sqrts_hat ()
	expr%n_in = 2
	expr%n_out = 2
	expr%n_tot = 4
	expr%subevt_filled = .true.

	call expr%evaluate (passed, reweight, analysis_flag)

	write (u, "(A,L1)") "Event has passed = ", passed
	write (u, "(A," // FMT_12 // ")") "Reweighting factor = ", reweight
	write (u, "(A,L1)") "Analysis flag = ", analysis_flag
	write (u, "(A)")

	call write_separator (u)
	call expr%write (u)
	call write_separator (u)

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

	call expr%final ()

	call model%final ()
	call syntax_model_file_final ()

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

	end subroutine subevt_expr_2

	@ %def subevt_expr_2
	@
	\subsubsection{Processes: handle partonic cuts}
	Initialize a process and process instance, choose a sampling point and
	fill the process instance, evaluating a given cut configuration.

	We use the same trivial process as for the previous test. All
	momentum and state dependence is trivial, so we just test basic
	functionality.
	<<Expr tests: execute tests>>=
	call test (processes_5, "processes_5", &
	"handle cuts (partonic event)", &
	u, results)
	<<Expr tests: test declarations>>=
	public :: processes_5
	<<Expr tests: tests>>=
	subroutine processes_5 (u)
	integer, intent(in) :: u
	type(string_t) :: cut_expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: parse_tree
	type(eval_tree_factory_t) :: expr_factory
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), pointer :: model_tmp
	type(model_t), pointer :: model
	type(var_list_t), target :: var_list
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance

	write (u, "(A)") "* Test output: processes_5"
	write (u, "(A)") "* Purpose: create a process &
	&and fill a process instance"
	write (u, "(A)")

	write (u, "(A)") "* Prepare a cut expression"
	write (u, "(A)")

	call syntax_pexpr_init ()
	cut_expr_text = "all Pt > 100 [s]"
	call ifile_append (ifile, cut_expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (parse_tree, stream, .true.)

	write (u, "(A)") "* Build and initialize a test process"
	write (u, "(A)")

	libname = "processes5"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call syntax_model_file_init ()
	allocate (model_tmp)
	call model_tmp%read (var_str ("Test.mdl"), os_data)
	call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
	model => model_tmp

	call reset_interaction_counter ()

	call var_list%append_real (var_str ("tolerance"), 0._default)
	call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
	call var_list%append_int (var_str ("seed"), 0)

	allocate (process)
	call process%init (procname, lib, os_data, model, var_list)

	call var_list%final ()

	allocate (phs_test_config_t :: phs_config_template)
	call process%setup_test_cores ()
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_empty)

	write (u, "(A)") "* Complete process initialization and set cuts"
	write (u, "(A)")

	call process%setup_terms ()
	call expr_factory%init (parse_tree%get_root_ptr ())
	call process%set_cuts (expr_factory)
	call process%write (.false., u, &
	show_var_list=.true., show_expressions=.true., show_os_data=.false.)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)

	write (u, "(A)")
	write (u, "(A)") "* Inject a set of random numbers"
	write (u, "(A)")

	call process_instance%choose_mci (1)
	call process_instance%set_mcpar ([0._default, 0._default])

	write (u, "(A)")
	write (u, "(A)") "* Set up kinematics and subevt, check cuts (should fail)"
	write (u, "(A)")

	call process_instance%select_channel (1)
	call process_instance%compute_seed_kinematics ()
	call process_instance%compute_hard_kinematics ()
	call process_instance%compute_eff_kinematics ()
	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels ()

	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for another set (should succeed)"
	write (u, "(A)")

	call process_instance%reset ()
	call process_instance%set_mcpar ([0.5_default, 0.125_default])
	call process_instance%select_channel (1)
	call process_instance%compute_seed_kinematics ()
	call process_instance%compute_hard_kinematics ()
	call process_instance%compute_eff_kinematics ()
	call process_instance%evaluate_expressions ()
	call process_instance%compute_other_channels ()
	call process_instance%evaluate_trace ()

	call process_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for another set using convenience procedure &
	&(failure)"
	write (u, "(A)")

	call process_instance%evaluate_sqme (1, [0.0_default, 0.2_default])

	call process_instance%write_header (u)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for another set using convenience procedure &
	&(success)"
	write (u, "(A)")

	call process_instance%evaluate_sqme (1, [0.1_default, 0.2_default])

	call process_instance%write_header (u)

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

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call parse_tree_final (parse_tree)
	call stream_final (stream)
	call ifile_final (ifile)
	call syntax_pexpr_final ()

	call syntax_model_file_final ()

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

	end subroutine processes_5

	@ %def processes_5
	@ Trivial for testing: do not allocate the MCI record.
	<<Expr tests: test auxiliary>>=
	subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
	class(mci_t), allocatable, intent(out) :: mci
	type(var_list_t), intent(in) :: var_list
	type(string_t), intent(in) :: process_id
	logical, intent(in), optional :: is_nlo
	end subroutine dispatch_mci_empty

	@ %def dispatch_mci_empty
	@
	\subsubsection{Processes: scales and such}
	Initialize a process and process instance, choose a sampling point and
	fill the process instance, evaluating a given cut configuration.

	We use the same trivial process as for the previous test. All
	momentum and state dependence is trivial, so we just test basic
	functionality.
	<<Expr tests: execute tests>>=
	call test (processes_6, "processes_6", &
	"handle scales and weight (partonic event)", &
	u, results)
	<<Expr tests: test declarations>>=
	public :: processes_6
	<<Expr tests: tests>>=
	subroutine processes_6 (u)
	integer, intent(in) :: u
	type(string_t) :: expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: pt_scale, pt_fac_scale, pt_ren_scale, pt_weight
	type(process_library_t), target :: lib
	type(string_t) :: libname
	type(string_t) :: procname
	type(os_data_t) :: os_data
	type(model_t), pointer :: model_tmp
	type(model_t), pointer :: model
	type(var_list_t), target :: var_list
	type(process_t), allocatable, target :: process
	class(phs_config_t), allocatable :: phs_config_template
	real(default) :: sqrts
	type(process_instance_t), allocatable, target :: process_instance
	type(eval_tree_factory_t) :: expr_factory

	write (u, "(A)") "* Test output: processes_6"
	write (u, "(A)") "* Purpose: create a process &
	&and fill a process instance"
	write (u, "(A)")

	write (u, "(A)") "* Prepare expressions"
	write (u, "(A)")

	call syntax_pexpr_init ()

	expr_text = "sqrts - 100 GeV"
	write (u, "(A,A)") "scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_scale, stream, .true.)
	call stream_final (stream)

	expr_text = "sqrts_hat"
	write (u, "(A,A)") "fac_scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_fac_scale, stream, .true.)
	call stream_final (stream)

	expr_text = "eval sqrt (M2) [collect [s]]"
	write (u, "(A,A)") "ren_scale = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_ren_scale, stream, .true.)
	call stream_final (stream)

	expr_text = "n_tot * n_in * n_out * (eval Phi / pi [s])"
	write (u, "(A,A)") "weight = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_weight, stream, .true.)
	call stream_final (stream)

	call ifile_final (ifile)

	write (u, "(A)")
	write (u, "(A)") "* Build and initialize a test process"
	write (u, "(A)")

	libname = "processes4"
	procname = libname

	call os_data%init ()
	call prc_test_create_library (libname, lib)

	call syntax_model_file_init ()
	allocate (model_tmp)
	call model_tmp%read (var_str ("Test.mdl"), os_data)
	call var_list%init_snapshot (model_tmp%get_var_list_ptr ())
	model => model_tmp

	call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
	call var_list%append_int (var_str ("seed"), 0)

	call reset_interaction_counter ()

	allocate (process)
	call process%init (procname, lib, os_data, model, var_list)

	call var_list%final ()

	call process%setup_test_cores ()
	allocate (phs_test_config_t :: phs_config_template)
	call process%init_components (phs_config_template)

	write (u, "(A)") "* Prepare a trivial beam setup"
	write (u, "(A)")

	sqrts = 1000
	call process%setup_beams_sqrts (sqrts, i_core = 1)
	call process%configure_phs ()
	call process%setup_mci (dispatch_mci_empty)

	write (u, "(A)") "* Complete process initialization and set cuts"
	write (u, "(A)")

	call process%setup_terms ()
	call expr_factory%init (pt_scale%get_root_ptr ())
	call process%set_scale (expr_factory)
	call expr_factory%init (pt_fac_scale%get_root_ptr ())
	call process%set_fac_scale (expr_factory)
	call expr_factory%init (pt_ren_scale%get_root_ptr ())
	call process%set_ren_scale (expr_factory)
	call expr_factory%init (pt_weight%get_root_ptr ())
	call process%set_weight (expr_factory)
	call process%write (.false., u, show_expressions=.true.)

	write (u, "(A)")
	write (u, "(A)") "* Create a process instance and evaluate"
	write (u, "(A)")

	allocate (process_instance)
	call process_instance%init (process)
	call process_instance%choose_mci (1)
	call process_instance%evaluate_sqme (1, [0.5_default, 0.125_default])

	call process_instance%write (u)

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

	call process_instance%final ()
	deallocate (process_instance)

	call process%final ()
	deallocate (process)

	call parse_tree_final (pt_scale)
	call parse_tree_final (pt_fac_scale)
	call parse_tree_final (pt_ren_scale)
	call parse_tree_final (pt_weight)
	call syntax_pexpr_final ()

	call syntax_model_file_final ()

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

	end subroutine processes_6

	@ %def processes_6
	@
	\subsubsection{Event expressions}
	After generating an event, fill the [[subevt]] and evaluate expressions for
	selection, reweighting, and analysis.
	<<Expr tests: execute tests>>=
	call test (events_3, "events_3", &
	"expression evaluation", &
	u, results)
	<<Expr tests: test declarations>>=
	public :: events_3
	<<Expr tests: tests>>=
	subroutine events_3 (u)
	use processes_ut, only: prepare_test_process, cleanup_test_process
	integer, intent(in) :: u
	type(string_t) :: expr_text
	type(ifile_t) :: ifile
	type(stream_t) :: stream
	type(parse_tree_t) :: pt_selection, pt_reweight, pt_analysis
	type(eval_tree_factory_t) :: expr_factory
	type(event_t), allocatable, target :: event
	type(process_t), allocatable, target :: process
	type(process_instance_t), allocatable, target :: process_instance
	type(os_data_t) :: os_data
	type(model_t), pointer :: model
	type(var_list_t), target :: var_list

	write (u, "(A)") "* Test output: events_3"
	write (u, "(A)") "* Purpose: generate an event and evaluate expressions"
	write (u, "(A)")

	call syntax_pexpr_init ()

	write (u, "(A)") "* Expression texts"
	write (u, "(A)")

	expr_text = "all Pt > 100 [s]"
	write (u, "(A,A)") "selection = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (pt_selection, stream, .true.)
	call stream_final (stream)

	expr_text = "1 + sqrts_hat / sqrts"
	write (u, "(A,A)") "reweight = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_expr (pt_reweight, stream, .true.)
	call stream_final (stream)

	expr_text = "true"
	write (u, "(A,A)") "analysis = ", char (expr_text)
	call ifile_clear (ifile)
	call ifile_append (ifile, expr_text)
	call stream_init (stream, ifile)
	call parse_tree_init_lexpr (pt_analysis, stream, .true.)
	call stream_final (stream)

	call ifile_final (ifile)

	write (u, "(A)")
	write (u, "(A)") "* Initialize test process event"

	call os_data%init ()

	call syntax_model_file_init ()
	allocate (model)
	call model%read (var_str ("Test.mdl"), os_data)
	call var_list%init_snapshot (model%get_var_list_ptr ())

	call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
	call var_list%append_int (var_str ("seed"), 0)

	allocate (process)
	allocate (process_instance)
	call prepare_test_process (process, process_instance, model, var_list)

	call var_list%final ()

	call process_instance%setup_event_data ()

	write (u, "(A)")
	write (u, "(A)") "* Initialize event object and set expressions"

	allocate (event)
	call event%basic_init ()

	call expr_factory%init (pt_selection%get_root_ptr ())
	call event%set_selection (expr_factory)
	call expr_factory%init (pt_reweight%get_root_ptr ())
	call event%set_reweight (expr_factory)
	call expr_factory%init (pt_analysis%get_root_ptr ())
	call event%set_analysis (expr_factory)

	call event%connect (process_instance, process%get_model_ptr ())
	call event%expr%var_list%append_real (var_str ("tolerance"), 0._default)
	call event%setup_expressions ()

	write (u, "(A)")
	write (u, "(A)") "* Generate test process event"

	call process_instance%generate_weighted_event (1)

	write (u, "(A)")
	write (u, "(A)") "* Fill event object and evaluate expressions"
	write (u, "(A)")

	call event%generate (1, [0.4_default, 0.4_default])
	call event%set_index (42)
	call event%evaluate_expressions ()
	call event%write (u)

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

	call event%final ()
	deallocate (event)

	call cleanup_test_process (process, process_instance)
	deallocate (process_instance)
	deallocate (process)

	call syntax_model_file_final ()

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

	end subroutine events_3

	@ %def events_3
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Top Level}

	The top level consists of
	\begin{description}
	\item[commands]
	Defines generic command-list and command objects, and all specific
	implementations. Each command type provides a specific
	functionality. Together with the modules that provide expressions
	and variables, this module defines the Sindarin language.
	\item[whizard]
	This module interprets streams of various kind in terms of the
	command language. It also contains the unit-test feature. We also
	define the externally visible procedures here, for the \whizard\ as
	a library.
	\item[main]
	The driver for \whizard\ as a stand-alone program. Contains the
	command-line interpreter.
	\item[whizard\_c\_interface]
	Alternative top-level procedures, for use in the context of a
	C-compatible caller program.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Commands}
	This module defines the command language of the main input file.
	<<[[commands.f90]]>>=
	<<File header>>

	module commands

	<<Use kinds>>
	<<Use strings>>
	<<Use debug>>
	use io_units
	use string_utils, only: lower_case, split_string, str
	use format_utils, only: write_indent
	use format_defs, only: FMT_14, FMT_19
	use diagnostics

	use constants, only: one
	use physics_defs
	use sorting
	use sf_lhapdf, only: lhapdf_global_reset
	use os_interface
	use ifiles
	use lexers
	use syntax_rules
	use parser
	use analysis
	use pdg_arrays
	use variables, only: var_list_t, V_NONE, V_LOG, V_INT, V_REAL, V_CMPLX, V_STR, V_PDG
	use observables, only: var_list_check_observable
	use observables, only: var_list_check_result_var
	use eval_trees
	use models
	use auto_components
	use flavors
	use polarizations
	use particle_specifiers
	use process_libraries
	use process
	use instances
	use prclib_stacks
	use slha_interface
	use user_files
	use eio_data
	use rt_data

	use process_configurations
	use compilations, only: compile_library, compile_executable
	use integrations, only: integrate_process
	use restricted_subprocesses, only: get_libname_res
	use restricted_subprocesses, only: spawn_resonant_subprocess_libraries
	use event_streams
	use simulations

	use radiation_generator

	<<Use mpi f08>>

	<<Standard module head>>

	<<Commands: public>>

	<<Commands: types>>

	<<Commands: variables>>

	<<Commands: parameters>>

	<<Commands: interfaces>>

	contains

	<<Commands: procedures>>

	end module commands
	@ %def commands
	@
	\subsection{The command type}
	The command type is a generic type that holds any command, compiled
	for execution.

	Each command may come with its own local environment. The command list that
	determines this environment is allocated as [[options]], if necessary. (It
	has to be allocated as a pointer because the type definition is recursive.) The
	local environment is available as a pointer which either points to the global
	environment, or is explicitly allocated and initialized.
	<<Commands: types>>=
	type, abstract :: command_t
	type(parse_node_t), pointer :: pn => null ()
	class(command_t), pointer :: next => null ()
	type(parse_node_t), pointer :: pn_opt => null ()
	type(command_list_t), pointer :: options => null ()
	type(rt_data_t), pointer :: local => null ()
	contains
	<<Commands: command: TBP>>
	end type command_t

	@ %def command_t
	@ Finalizer: If there is an option list, finalize the option list and
	deallocate. If not, the local environment is just a pointer.
	<<Commands: command: TBP>>=
	procedure :: final => command_final
	<<Commands: procedures>>=
	recursive subroutine command_final (cmd)
	class(command_t), intent(inout) :: cmd
	if (associated (cmd%options)) then
	call cmd%options%final ()
	deallocate (cmd%options)
	call cmd%local%local_final ()
	deallocate (cmd%local)
	else
	cmd%local => null ()
	end if
	end subroutine command_final

	@ %def command_final
	@ Allocate a command with the appropriate concrete type. Store the
	parse node pointer in the command object, so we can reference to it
	when compiling.
	<<Commands: procedures>>=
	subroutine dispatch_command (command, pn)
	class(command_t), intent(inout), pointer :: command
	type(parse_node_t), intent(in), target :: pn
	select case (char (parse_node_get_rule_key (pn)))
	case ("cmd_model")
	allocate (cmd_model_t :: command)
	case ("cmd_library")
	allocate (cmd_library_t :: command)
	case ("cmd_process")
	allocate (cmd_process_t :: command)
	case ("cmd_nlo")
	allocate (cmd_nlo_t :: command)
	case ("cmd_compile")
	allocate (cmd_compile_t :: command)
	case ("cmd_exec")
	allocate (cmd_exec_t :: command)
	case ("cmd_num", "cmd_complex", "cmd_real", "cmd_int", &
	"cmd_log_decl", "cmd_log", "cmd_string", "cmd_string_decl", &
	"cmd_alias", "cmd_result")
	allocate (cmd_var_t :: command)
	case ("cmd_slha")
	allocate (cmd_slha_t :: command)
	case ("cmd_show")
	allocate (cmd_show_t :: command)
	case ("cmd_clear")
	allocate (cmd_clear_t :: command)
	case ("cmd_expect")
	allocate (cmd_expect_t :: command)
	case ("cmd_beams")
	allocate (cmd_beams_t :: command)
	case ("cmd_beams_pol_density")
	allocate (cmd_beams_pol_density_t :: command)
	case ("cmd_beams_pol_fraction")
	allocate (cmd_beams_pol_fraction_t :: command)
	case ("cmd_beams_momentum")
	allocate (cmd_beams_momentum_t :: command)
	case ("cmd_beams_theta")
	allocate (cmd_beams_theta_t :: command)
	case ("cmd_beams_phi")
	allocate (cmd_beams_phi_t :: command)
	case ("cmd_cuts")
	allocate (cmd_cuts_t :: command)
	case ("cmd_scale")
	allocate (cmd_scale_t :: command)
	case ("cmd_fac_scale")
	allocate (cmd_fac_scale_t :: command)
	case ("cmd_ren_scale")
	allocate (cmd_ren_scale_t :: command)
	case ("cmd_weight")
	allocate (cmd_weight_t :: command)
	case ("cmd_selection")
	allocate (cmd_selection_t :: command)
	case ("cmd_reweight")
	allocate (cmd_reweight_t :: command)
	case ("cmd_iterations")
	allocate (cmd_iterations_t :: command)
	case ("cmd_integrate")
	allocate (cmd_integrate_t :: command)
	case ("cmd_observable")
	allocate (cmd_observable_t :: command)
	case ("cmd_histogram")
	allocate (cmd_histogram_t :: command)
	case ("cmd_plot")
	allocate (cmd_plot_t :: command)
	case ("cmd_graph")
	allocate (cmd_graph_t :: command)
	case ("cmd_record")
	allocate (cmd_record_t :: command)
	case ("cmd_analysis")
	allocate (cmd_analysis_t :: command)
	case ("cmd_alt_setup")
	allocate (cmd_alt_setup_t :: command)
	case ("cmd_unstable")
	allocate (cmd_unstable_t :: command)
	case ("cmd_stable")
	allocate (cmd_stable_t :: command)
	case ("cmd_polarized")
	allocate (cmd_polarized_t :: command)
	case ("cmd_unpolarized")
	allocate (cmd_unpolarized_t :: command)
	case ("cmd_sample_format")
	allocate (cmd_sample_format_t :: command)
	case ("cmd_simulate")
	allocate (cmd_simulate_t :: command)
	case ("cmd_rescan")
	allocate (cmd_rescan_t :: command)
	case ("cmd_write_analysis")
	allocate (cmd_write_analysis_t :: command)
	case ("cmd_compile_analysis")
	allocate (cmd_compile_analysis_t :: command)
	case ("cmd_open_out")
	allocate (cmd_open_out_t :: command)
	case ("cmd_close_out")
	allocate (cmd_close_out_t :: command)
	case ("cmd_printf")
	allocate (cmd_printf_t :: command)
	case ("cmd_scan")
	allocate (cmd_scan_t :: command)
	case ("cmd_if")
	allocate (cmd_if_t :: command)
	case ("cmd_include")
	allocate (cmd_include_t :: command)
	case ("cmd_export")
	allocate (cmd_export_t :: command)
	case ("cmd_quit")
	allocate (cmd_quit_t :: command)
	case default
	print *, char (parse_node_get_rule_key (pn))
	call msg_bug ("Command not implemented")
	end select
	command%pn => pn
	end subroutine dispatch_command

	@ %def dispatch_command
	@ Output. We allow for indentation so we can display a command tree.
	<<Commands: command: TBP>>=
	procedure (command_write), deferred :: write
	<<Commands: interfaces>>=
	abstract interface
	subroutine command_write (cmd, unit, indent)
	import
	class(command_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	end subroutine command_write
	end interface

	@ %def command_write
	@ Compile a command. The command type is already fixed, so this is a
	deferred type-bound procedure.
	<<Commands: command: TBP>>=
	procedure (command_compile), deferred :: compile
	<<Commands: interfaces>>=
	abstract interface
	subroutine command_compile (cmd, global)
	import
	class(command_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	end subroutine command_compile
	end interface

	@ %def command_compile
	@ Execute a command. This will use and/or modify the runtime data
	set. If the [[quit]] flag is set, the caller should terminate command
	execution.
	<<Commands: command: TBP>>=
	procedure (command_execute), deferred :: execute
	<<Commands: interfaces>>=
	abstract interface
	subroutine command_execute (cmd, global)
	import
	class(command_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	end subroutine command_execute
	end interface

	@ %def command_execute
	@
	\subsection{Options}
	The [[options]] command list is allocated, initialized, and executed, if the
	command is associated with an option text in curly braces. If present, a
	separate local runtime data set [[local]] will be allocated and initialized;
	otherwise, [[local]] becomes a pointer to the global dataset.

	For output, we indent the options list.
	<<Commands: command: TBP>>=
	procedure :: write_options => command_write_options
	<<Commands: procedures>>=
	recursive subroutine command_write_options (cmd, unit, indent)
	class(command_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: ind
	ind = 1; if (present (indent)) ind = indent + 1
	if (associated (cmd%options)) call cmd%options%write (unit, ind)
	end subroutine command_write_options

	@ %def command_write_options
	@ Compile the options list, if any. This implies initialization of the local
	environment. Should be done once the [[pn_opt]] node has been assigned (if
	applicable), but before the actual command compilation.
	<<Commands: command: TBP>>=
	procedure :: compile_options => command_compile_options
	<<Commands: procedures>>=
	recursive subroutine command_compile_options (cmd, global)
	class(command_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (associated (cmd%pn_opt)) then
	allocate (cmd%local)
	call cmd%local%local_init (global)
	call global%copy_globals (cmd%local)
	allocate (cmd%options)
	call cmd%options%compile (cmd%pn_opt, cmd%local)
	call global%restore_globals (cmd%local)
	call cmd%local%deactivate ()
	else
	cmd%local => global
	end if
	end subroutine command_compile_options

	@ %def command_compile_options
	@ Execute options. First prepare the local environment, then execute the
	command list.
	<<Commands: command: TBP>>=
	procedure :: execute_options => cmd_execute_options
	<<Commands: procedures>>=
	recursive subroutine cmd_execute_options (cmd, global)
	class(command_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (associated (cmd%options)) then
	call cmd%local%activate ()
	call cmd%options%execute (cmd%local)
	end if
	end subroutine cmd_execute_options

	@ %def cmd_execute_options
	@ This must be called after the parent command has been executed, to undo
	temporary modifications to the environment. Note that some modifications to
	[[global]] can become permanent.
	<<Commands: command: TBP>>=
	procedure :: reset_options => cmd_reset_options
	<<Commands: procedures>>=
	subroutine cmd_reset_options (cmd, global)
	class(command_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (associated (cmd%options)) then
	call cmd%local%deactivate (global)
	end if
	end subroutine cmd_reset_options

	@ %def cmd_reset_options
	@
	\subsection{Specific command types}
	\subsubsection{Model configuration}
	The command declares a model, looks for the specified file and loads
	it.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_model_t
	private
	type(string_t) :: name
	type(string_t) :: scheme
	logical :: ufo_model = .false.
	logical :: ufo_path_set = .false.
	type(string_t) :: ufo_path
	contains
	<<Commands: cmd model: TBP>>
	end type cmd_model_t

	@ %def cmd_model_t
	@ Output
	<<Commands: cmd model: TBP>>=
	procedure :: write => cmd_model_write
	<<Commands: procedures>>=
	subroutine cmd_model_write (cmd, unit, indent)
	class(cmd_model_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,'""',A,'""')", advance="no") "model =", char (cmd%name)
	if (cmd%ufo_model) then
	if (cmd%ufo_path_set) then
	write (u, "(1x,A,A,A)") "(ufo (", char (cmd%ufo_path), "))"
	else
	write (u, "(1x,A)") "(ufo)"
	end if
	else if (cmd%scheme /= "") then
	write (u, "(1x,'(',A,')')") char (cmd%scheme)
	else
	write (u, *)
	end if
	end subroutine cmd_model_write

	@ %def cmd_model_write
	@ Compile. Get the model name and read the model from file, so it is
	readily available when the command list is executed. If the model has a
	scheme argument, take this into account.

	Assign the model pointer in the [[global]] record, so it can be used for
	(read-only) variable lookup while compiling further commands.
	<<Commands: cmd model: TBP>>=
	procedure :: compile => cmd_model_compile
	<<Commands: procedures>>=
	subroutine cmd_model_compile (cmd, global)
	class(cmd_model_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_name, pn_arg, pn_scheme
	type(parse_node_t), pointer :: pn_ufo_arg, pn_path
	type(model_t), pointer :: model
	type(string_t) :: scheme
	pn_name => cmd%pn%get_sub_ptr (3)
	pn_arg => pn_name%get_next_ptr ()
	if (associated (pn_arg)) then
	pn_scheme => pn_arg%get_sub_ptr ()
	else
	pn_scheme => null ()
	end if
	cmd%name = pn_name%get_string ()
	if (associated (pn_scheme)) then
	select case (char (pn_scheme%get_rule_key ()))
	case ("ufo_spec")
	cmd%ufo_model = .true.
	pn_ufo_arg => pn_scheme%get_sub_ptr (2)
	if (associated (pn_ufo_arg)) then
	pn_path => pn_ufo_arg%get_sub_ptr ()
	cmd%ufo_path_set = .true.
	cmd%ufo_path = pn_path%get_string ()
	end if
	case default
	scheme = pn_scheme%get_string ()
	select case (char (lower_case (scheme)))
	case ("ufo"); cmd%ufo_model = .true.
	case default; cmd%scheme = scheme
	end select
	end select
	if (cmd%ufo_model) then
	if (cmd%ufo_path_set) then
	call preload_ufo_model (model, cmd%name, cmd%ufo_path)
	else
	call preload_ufo_model (model, cmd%name)
	end if
	else
	call preload_model (model, cmd%name, cmd%scheme)
	end if
	else
	cmd%scheme = ""
	call preload_model (model, cmd%name)
	end if
	global%model => model
	if (associated (global%model)) then
	call global%model%link_var_list (global%var_list)
	end if
	contains
	subroutine preload_model (model, name, scheme)
	type(model_t), pointer, intent(out) :: model
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: scheme
	model => null ()
	if (associated (global%model)) then
	if (global%model%matches (name, scheme)) then
	model => global%model
	end if
	end if
	if (.not. associated (model)) then
	if (global%model_list%model_exists (name, scheme)) then
	model => global%model_list%get_model_ptr (name, scheme)
	else
	call global%read_model (name, model, scheme)
	end if
	end if
	end subroutine preload_model
	subroutine preload_ufo_model (model, name, ufo_path)
	type(model_t), pointer, intent(out) :: model
	type(string_t), intent(in) :: name
	type(string_t), intent(in), optional :: ufo_path
	model => null ()
	if (associated (global%model)) then
	if (global%model%matches (name, ufo=.true., ufo_path=ufo_path)) then
	model => global%model
	end if
	end if
	if (.not. associated (model)) then
	if (global%model_list%model_exists (name, &
	ufo=.true., ufo_path=ufo_path)) then
	model => global%model_list%get_model_ptr (name, &
	ufo=.true., ufo_path=ufo_path)
	else
	call global%read_ufo_model (name, model, ufo_path=ufo_path)
	end if
	end if
	end subroutine preload_ufo_model
	end subroutine cmd_model_compile

	@ %def cmd_model_compile
	@ Execute: Insert a pointer into the global data record and reassign
	the variable list.
	<<Commands: cmd model: TBP>>=
	procedure :: execute => cmd_model_execute
	<<Commands: procedures>>=
	subroutine cmd_model_execute (cmd, global)
	class(cmd_model_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (cmd%ufo_model) then
	if (cmd%ufo_path_set) then
	call global%select_model (cmd%name, ufo=.true., ufo_path=cmd%ufo_path)
	else
	call global%select_model (cmd%name, ufo=.true.)
	end if
	else if (cmd%scheme /= "") then
	call global%select_model (cmd%name, cmd%scheme)
	else
	call global%select_model (cmd%name)
	end if
	if (.not. associated (global%model)) &
	call msg_fatal ("Switching to model '" &
	// char (cmd%name) // "': model not found")
	end subroutine cmd_model_execute

	@ %def cmd_model_execute
	@
	\subsubsection{Library configuration}
	We configure a process library that should hold the subsequently
	defined processes. If the referenced library exists already, just
	make it the currently active one.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_library_t
	private
	type(string_t) :: name
	contains
	<<Commands: cmd library: TBP>>
	end type cmd_library_t

	@ %def cmd_library_t
	@ Output.
	<<Commands: cmd library: TBP>>=
	procedure :: write => cmd_library_write
	<<Commands: procedures>>=
	subroutine cmd_library_write (cmd, unit, indent)
	class(cmd_library_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit)
	call write_indent (u, indent)
	write (u, "(1x,A,1x,'""',A,'""')") "library =", char (cmd%name)
	end subroutine cmd_library_write

	@ %def cmd_library_write
	@ Compile. Get the library name.
	<<Commands: cmd library: TBP>>=
	procedure :: compile => cmd_library_compile
	<<Commands: procedures>>=
	subroutine cmd_library_compile (cmd, global)
	class(cmd_library_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_name
	pn_name => parse_node_get_sub_ptr (cmd%pn, 3)
	cmd%name = parse_node_get_string (pn_name)
	end subroutine cmd_library_compile

	@ %def cmd_library_compile
	@ Execute: Initialize a new library and push it on the library stack
	(if it does not yet exist). Insert a pointer to the library into the
	global data record. Then, try to load the library unless the
	[[rebuild]] flag is set.
	<<Commands: cmd library: TBP>>=
	procedure :: execute => cmd_library_execute
	<<Commands: procedures>>=
	subroutine cmd_library_execute (cmd, global)
	class(cmd_library_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	logical :: rebuild_library
	lib => global%prclib_stack%get_library_ptr (cmd%name)
	rebuild_library = &
	global%var_list%get_lval (var_str ("?rebuild_library"))
	if (.not. (associated (lib))) then
	allocate (lib_entry)
	call lib_entry%init (cmd%name)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)
	else
	call global%update_prclib (lib)
	end if
	if (associated (lib) .and. .not. rebuild_library) then
	call lib%update_status (global%os_data)
	end if
	end subroutine cmd_library_execute

	@ %def cmd_library_execute
	@
	\subsubsection{Process configuration}
	We define a process-configuration command as a specific type. The
	incoming and outgoing particles are given evaluation-trees which we
	transform to PDG-code arrays. For transferring to \oMega, they are
	reconverted to strings.

	For the incoming particles, we store parse nodes individually. We do
	not yet resolve the outgoing state, so we store just a single parse
	node.

	This also includes the choice of method for the corresponding process:
	[[omega]] for \oMega\ matrix elements as Fortran code, [[ovm]] for
	\oMega\ matrix elements as a bytecode virtual machine, [[test]] for
	special processes, [[unit_test]] for internal test matrix elements
	generated by \whizard, [[template]] and [[template_unity]] for test
	matrix elements generated by \whizard\ as Fortran code similar to the
	\oMega\ code. If the one-loop program (OLP) \gosam\ is linked, also
	matrix elements from there (at leading and next-to-leading order) can
	be generated via [[gosam]].
	<<Commands: types>>=
	type, extends (command_t) :: cmd_process_t
	private
	type(string_t) :: id
	integer :: n_in = 0
	type(parse_node_p), dimension(:), allocatable :: pn_pdg_in
	type(parse_node_t), pointer :: pn_out => null ()
	contains
	<<Commands: cmd process: TBP>>
	end type cmd_process_t

	@ %def cmd_process_t
	@ Output. The particle expressions are not resolved, so we just list the
	number of incoming particles.
	<<Commands: cmd process: TBP>>=
	procedure :: write => cmd_process_write
	<<Commands: procedures>>=
	subroutine cmd_process_write (cmd, unit, indent)
	class(cmd_process_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A,A,I0,A)") "process: ", char (cmd%id), " (", &
	size (cmd%pn_pdg_in), " -> X)"
	call cmd%write_options (u, indent)
	end subroutine cmd_process_write

	@ %def cmd_process_write
	@ Compile. Find and assign the parse nodes.
	<<Commands: cmd process: TBP>>=
	procedure :: compile => cmd_process_compile
	<<Commands: procedures>>=
	subroutine cmd_process_compile (cmd, global)
	class(cmd_process_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_id, pn_in, pn_codes
	integer :: i
	pn_id => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_in => parse_node_get_next_ptr (pn_id, 2)
	cmd%pn_out => parse_node_get_next_ptr (pn_in, 2)
	cmd%pn_opt => parse_node_get_next_ptr (cmd%pn_out)
	call cmd%compile_options (global)
	cmd%id = parse_node_get_string (pn_id)
	cmd%n_in = parse_node_get_n_sub (pn_in)
	pn_codes => parse_node_get_sub_ptr (pn_in)
	allocate (cmd%pn_pdg_in (cmd%n_in))
	do i = 1, cmd%n_in
	cmd%pn_pdg_in(i)%ptr => pn_codes
	pn_codes => parse_node_get_next_ptr (pn_codes)
	end do
	end subroutine cmd_process_compile

	@ %def cmd_process_compile
	@ Command execution. Evaluate the subevents, transform PDG codes
	into strings, and add the current process configuration to the
	process library.

	The initial state will be unique (one or two particles). For the final state,
	we allow for expressions. The expressions will be expanded until we have a
	sum of final states. Each distinct final state will get its own process
	component.

	To identify equivalent final states, we transform the final state into
	an array of PDG codes, which we sort and compare. If a particle entry
	is actually a PDG array, only the first entry in the array is used for
	the comparison. The user should make sure that there is no overlap
	between different particles or arrays which would make the expansion
	ambiguous.

	There are two possibilities that a process contains more than one
	component: by an explicit component statement by the user for
	inclusive processes, or by having one process at NLO level. The first
	option is determined in the chunk [[scan components]], and
	determines [[n_components]].
	<<Commands: cmd process: TBP>>=
	procedure :: execute => cmd_process_execute
	<<Commands: procedures>>=
	subroutine cmd_process_execute (cmd, global)
	class(cmd_process_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(pdg_array_t) :: pdg_in, pdg_out
	type(pdg_array_t), dimension(:), allocatable :: pdg_out_tab
	type(string_t), dimension(:), allocatable :: prt_in
	type(string_t) :: prt_out, prt_out1
	type(process_configuration_t) :: prc_config
	type(prt_expr_t) :: prt_expr_out
	type(prt_spec_t), dimension(:), allocatable :: prt_spec_in
	type(prt_spec_t), dimension(:), allocatable :: prt_spec_out
	type(var_list_t), pointer :: var_list
	integer, dimension(:), allocatable :: ipdg
	integer, dimension(:), allocatable :: i_term
	integer, dimension(:), allocatable :: nlo_comp
	integer :: i, j, n_in, n_out, n_terms, n_components
	logical :: nlo_fixed_order
	logical :: qcd_corr, qed_corr
	type(string_t), dimension(:), allocatable :: prt_in_nlo, prt_out_nlo
	type(radiation_generator_t) :: radiation_generator
	type(pdg_list_t) :: pl_in, pl_out, pl_excluded_gauge_splittings
	type(string_t) :: method, born_me_method, loop_me_method, &
	correlation_me_method, real_tree_me_method, dglap_me_method
	integer, dimension(:), allocatable :: i_list
	logical :: use_real_finite
	logical :: gks_active
	logical :: initial_state_colored
	logical :: neg_sf
	integer :: comp_mult
	integer :: gks_multiplicity
	integer :: n_components_init
	integer :: alpha_power, alphas_power
	logical :: requires_soft_mismatch, requires_dglap_remnants
	type(string_t) :: nlo_correction_type
	type(pdg_array_t), dimension(:), allocatable :: pdg
	if (debug_on) call msg_debug (D_CORE, "cmd_process_execute")
	var_list => cmd%local%get_var_list_ptr ()

	n_in = size (cmd%pn_pdg_in)
	allocate (prt_in (n_in), prt_spec_in (n_in))
	do i = 1, n_in
	pdg_in = &
	eval_pdg_array (cmd%pn_pdg_in(i)%ptr, var_list)
	prt_in(i) = make_flavor_string (pdg_in, cmd%local%model)
	prt_spec_in(i) = new_prt_spec (prt_in(i))
	end do
	call compile_prt_expr &
	(prt_expr_out, cmd%pn_out, var_list, cmd%local%model)
	call prt_expr_out%expand ()
	<<Commands: cmd process execute: scan components>>
	allocate (nlo_comp (n_components))

	nlo_fixed_order = cmd%local%nlo_fixed_order
	gks_multiplicity = var_list%get_ival (var_str ("gks_multiplicity"))
	gks_active = gks_multiplicity > 2
	neg_sf = .false.
	select case (char (var_list%get_sval (var_str ("$negative_sf"))))
	case ("default")
	neg_sf = nlo_fixed_order
	case ("negative")
	neg_sf = .true.
	case ("positive")
	neg_sf = .false.
	case default
	call msg_fatal ("Negative PDF handling can only be " // &
	"default, negative or positive.")
	end select
	<<Commands: cmd process execute: check for nlo corrections>>

	method = var_list%get_sval (var_str ("$method"))
	born_me_method = var_list%get_sval (var_str ("$born_me_method"))
	if (born_me_method == var_str ("")) born_me_method = method
	select case (char (var_list%get_sval (var_str ("$real_partition_mode"))))
	case ("default", "off", "singular")
	use_real_finite = .false.
	case ("all", "on", "finite")
	use_real_finite = .true.
	case default
	call msg_fatal ("The real partition mode can only be " // &
	"default, off, all, on, singular or finite.")
	end select
	if (nlo_fixed_order) then
	real_tree_me_method = &
	var_list%get_sval (var_str ("$real_tree_me_method"))
	if (real_tree_me_method == var_str ("")) &
	real_tree_me_method = method
	loop_me_method = var_list%get_sval (var_str ("$loop_me_method"))
	if (loop_me_method == var_str ("")) &
	loop_me_method = method
	correlation_me_method = &
	var_list%get_sval (var_str ("$correlation_me_method"))
	if (correlation_me_method == var_str ("")) &
	correlation_me_method = method
	dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method"))
	if (dglap_me_method == var_str ("")) &
	dglap_me_method = method
	call check_nlo_options (cmd%local)
	end if

	call determine_needed_components ()
	call prc_config%init (cmd%id, n_in, n_components_init, &
	cmd%local%model, cmd%local%var_list, &
	nlo_process = nlo_fixed_order, &
	negative_sf = neg_sf)

	alpha_power = var_list%get_ival (var_str ("alpha_power"))
	alphas_power = var_list%get_ival (var_str ("alphas_power"))
	call prc_config%set_coupling_powers (alpha_power, alphas_power)

	call setup_components ()
	call prc_config%record (cmd%local)

	contains

	<<Commands: cmd process execute procedures>>

	end subroutine cmd_process_execute

	@ %def cmd_process_execute
	@
	<<Commands: cmd process execute procedures>>=
	elemental function is_threshold (method)
	logical :: is_threshold
	type(string_t), intent(in) :: method
	is_threshold = method == var_str ("threshold")
	end function is_threshold

	subroutine check_threshold_consistency ()
	if (nlo_fixed_order .and. is_threshold (born_me_method)) then
	if (.not. (is_threshold (real_tree_me_method) .and. is_threshold (loop_me_method) &
	.and. is_threshold (correlation_me_method))) then
	print *, 'born: ', char (born_me_method)
	print *, 'real: ', char (real_tree_me_method)
	print *, 'loop: ', char (loop_me_method)
	print *, 'correlation: ', char (correlation_me_method)
	call msg_fatal ("Inconsistent methods: All components need to be threshold")
	end if
	end if
	end subroutine check_threshold_consistency

	@ %def check_threshold_consistency
	<<Commands: cmd process execute: check for nlo corrections>>=
	if (nlo_fixed_order .or. gks_active) then
	nlo_correction_type = &
	var_list%get_sval (var_str ('$nlo_correction_type'))
	select case (char (nlo_correction_type))
	case ("QCD")
	qcd_corr = .true.; qed_corr = .false.
	case ("EW")
	qcd_corr = .false.; qed_corr = .true.
	case ("Full")
	qcd_corr =.true.; qed_corr = .true.
	case default
	call msg_fatal ("Invalid NLO correction type. " // &
	"Valid inputs are: QCD, EW, Full (default: QCD)")
	end select
	call check_for_excluded_gauge_boson_splitting_partners ()
	call setup_radiation_generator ()
	end if
	if (nlo_fixed_order) then
	call radiation_generator%find_splittings ()
	if (debug2_active (D_CORE)) then
	print *, ''
	print *, 'Found (pdg) splittings: '
	do i = 1, radiation_generator%if_table%get_length ()
	call radiation_generator%if_table%get_pdg_out (i, pdg)
	call pdg_array_write_set (pdg)
	print *, '----------------'
	end do
	end if

	nlo_fixed_order = radiation_generator%contains_emissions ()
	if (.not. nlo_fixed_order) call msg_warning &
	(arr = [var_str ("No NLO corrections found for process ") // &
	cmd%id // var_str("."), var_str ("Proceed with usual " // &
	"leading-order integration and simulation")])
	end if

	@ %def check_for_nlo_corrections
	@
	<<Commands: cmd process execute procedures>>=
	subroutine check_for_excluded_gauge_boson_splitting_partners ()
	type(string_t) :: str_excluded_partners
	type(string_t), dimension(:), allocatable :: excluded_partners
	type(pdg_list_t) :: pl_tmp, pl_anti
	integer :: i, n_anti
	str_excluded_partners = var_list%get_sval &
	(var_str ("$exclude_gauge_splittings"))
	if (str_excluded_partners == "") then
	return
	else
	call split_string (str_excluded_partners, &
	var_str (":"), excluded_partners)
	call pl_tmp%init (size (excluded_partners))
	do i = 1, size (excluded_partners)
	call pl_tmp%set (i, &
	cmd%local%model%get_pdg (excluded_partners(i), .true.))
	end do
	call pl_tmp%create_antiparticles (pl_anti, n_anti)
	call pl_excluded_gauge_splittings%init (pl_tmp%get_size () + n_anti)
	do i = 1, pl_tmp%get_size ()
	call pl_excluded_gauge_splittings%set (i, pl_tmp%get(i))
	end do
	do i = 1, n_anti
	j = i + pl_tmp%get_size ()
	call pl_excluded_gauge_splittings%set (j, pl_anti%get(i))
	end do
	end if
	end subroutine check_for_excluded_gauge_boson_splitting_partners

	@ %def check_for_excluded_gauge_boson_splitting_partners
	@
	<<Commands: cmd process execute procedures>>=
	subroutine determine_needed_components ()
	type(string_t) :: fks_method
	comp_mult = 1
	if (nlo_fixed_order) then
	fks_method = var_list%get_sval (var_str ('$fks_mapping_type'))
	call check_threshold_consistency ()
	requires_soft_mismatch = fks_method == var_str ('resonances')
	comp_mult = needed_extra_components (requires_dglap_remnants, &
	use_real_finite, requires_soft_mismatch)
	allocate (i_list (comp_mult))
	else if (gks_active) then
	call radiation_generator%generate_multiple &
	(gks_multiplicity, cmd%local%model)
	comp_mult = radiation_generator%get_n_gks_states () + 1
	end if
	n_components_init = n_components * comp_mult
	end subroutine determine_needed_components

	@ %def determine_needed_components
	@
	<<Commands: cmd process execute procedures>>=
	subroutine setup_radiation_generator ()
	call split_prt (prt_spec_in, n_in, pl_in)
	call split_prt (prt_spec_out, n_out, pl_out)
	call radiation_generator%init (pl_in, pl_out, &
	pl_excluded_gauge_splittings, qcd = qcd_corr, qed = qed_corr)
	call radiation_generator%set_n (n_in, n_out, 0)
	initial_state_colored = pdg_in%has_colored_particles ()
	if ((n_in == 2 .and. initial_state_colored) .or. qed_corr) then
	requires_dglap_remnants = n_in == 2 .and. initial_state_colored
	call radiation_generator%set_initial_state_emissions ()
	else
	requires_dglap_remnants = .false.
	end if
	call radiation_generator%set_constraints (.false., .false., .true., .true.)
	call radiation_generator%setup_if_table (cmd%local%model)
	end subroutine setup_radiation_generator

	@ %def setup_radiation_generator
	@
	<<Commands: cmd process execute: scan components>>=
	n_terms = prt_expr_out%get_n_terms ()
	allocate (pdg_out_tab (n_terms))
	allocate (i_term (n_terms), source = 0)
	n_components = 0
	SCAN: do i = 1, n_terms
	if (allocated (ipdg)) deallocate (ipdg)
	call prt_expr_out%term_to_array (prt_spec_out, i)
	n_out = size (prt_spec_out)
	allocate (ipdg (n_out))
	do j = 1, n_out
	prt_out = prt_spec_out(j)%to_string ()
	call split (prt_out, prt_out1, ":")
	ipdg(j) = cmd%local%model%get_pdg (prt_out1)
	end do
	pdg_out = sort (ipdg)
	do j = 1, n_components
	if (pdg_out == pdg_out_tab(j)) cycle SCAN
	end do
	n_components = n_components + 1
	i_term(n_components) = i
	pdg_out_tab(n_components) = pdg_out
	end do SCAN

	@
	<<Commands: cmd process execute procedures>>=
	subroutine split_prt (prt, n_out, pl)
	type(prt_spec_t), intent(in), dimension(:), allocatable :: prt
	integer, intent(in) :: n_out
	type(pdg_list_t), intent(out) :: pl
	type(pdg_array_t) :: pdg
	type(string_t) :: prt_string, prt_tmp
	integer, parameter :: max_particle_number = 25
	integer, dimension(max_particle_number) :: i_particle
	integer :: i, j, n
	i_particle = 0
	call pl%init (n_out)
	do i = 1, n_out
	n = 1
	prt_string = prt(i)%to_string ()
	do
	call split (prt_string, prt_tmp, ":")
	if (prt_tmp /= "") then
	i_particle(n) = cmd%local%model%get_pdg (prt_tmp)
	n = n + 1
	else
	exit
	end if
	end do
	- call pdg_array_init (pdg, n - 1)
	+ call pdg%init (n - 1)
	do j = 1, n - 1
	call pdg%set (j, i_particle(j))
	end do
	call pl%set (i, pdg)
	- call pdg_array_delete (pdg)
	+ call pdg%delete ()
	end do
	end subroutine split_prt

	@ %def split_prt
	@
	<<Commands: cmd process execute procedures>>=
	subroutine setup_components()
	integer :: k, i_comp, add_index
	i_comp = 0
	add_index = 0
	if (debug_on) call msg_debug (D_CORE, "setup_components")
	do i = 1, n_components
	call prt_expr_out%term_to_array (prt_spec_out, i_term(i))
	if (nlo_fixed_order) then
	associate (selected_nlo_parts => cmd%local%selected_nlo_parts)
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 1)
	call prc_config%setup_component (i_comp + 1, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, BORN, &
	can_be_integrated = selected_nlo_parts (BORN))
	call radiation_generator%generate_real_particle_strings &
	(prt_in_nlo, prt_out_nlo)
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 2)
	call prc_config%setup_component (i_comp + 2, &
	new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
	cmd%local%model, var_list, NLO_REAL, &
	can_be_integrated = selected_nlo_parts (NLO_REAL))
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 3)
	call prc_config%setup_component (i_comp + 3, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, NLO_VIRTUAL, &
	can_be_integrated = selected_nlo_parts (NLO_VIRTUAL))
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 4)
	call prc_config%setup_component (i_comp + 4, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, NLO_SUBTRACTION, &
	can_be_integrated = selected_nlo_parts (NLO_SUBTRACTION))
	do k = 1, 4
	i_list(k) = i_comp + k
	end do
	if (requires_dglap_remnants) then
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 5)
	call prc_config%setup_component (i_comp + 5, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, NLO_DGLAP, &
	can_be_integrated = selected_nlo_parts (NLO_DGLAP))
	i_list(5) = i_comp + 5
	add_index = add_index + 1
	end if
	if (use_real_finite) then
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 5 + add_index)
	call prc_config%setup_component (i_comp + 5 + add_index, &
	new_prt_spec (prt_in_nlo), new_prt_spec (prt_out_nlo), &
	cmd%local%model, var_list, NLO_REAL, &
	can_be_integrated = selected_nlo_parts (NLO_REAL))
	i_list(5 + add_index) = i_comp + 5 + add_index
	add_index = add_index + 1
	end if
	if (requires_soft_mismatch) then
	if (debug_on) call msg_debug (D_CORE, "Setting up this NLO component:", &
	i_comp + 5 + add_index)
	call prc_config%setup_component (i_comp + 5 + add_index, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, NLO_MISMATCH, &
	can_be_integrated = selected_nlo_parts (NLO_MISMATCH))
	i_list(5 + add_index) = i_comp + 5 + add_index
	end if
	call prc_config%set_component_associations (i_list, &
	requires_dglap_remnants, use_real_finite, &
	requires_soft_mismatch)
	end associate
	else if (gks_active) then
	call prc_config%setup_component (i_comp + 1, prt_spec_in, &
	prt_spec_out, cmd%local%model, var_list, BORN, &
	can_be_integrated = .true.)
	call radiation_generator%reset_queue ()
	do j = 1, comp_mult
	prt_out_nlo = radiation_generator%get_next_state ()
	call prc_config%setup_component (i_comp + 1 + j, &
	new_prt_spec (prt_in), new_prt_spec (prt_out_nlo), &
	cmd%local%model, var_list, GKS, can_be_integrated = .false.)
	end do
	else
	call prc_config%setup_component (i, &
	prt_spec_in, prt_spec_out, &
	cmd%local%model, var_list, can_be_integrated = .true.)
	end if
	i_comp = i_comp + comp_mult
	end do
	end subroutine setup_components

	@
	@ These three functions should be bundled with the logicals they depend
	on into an object (the pcm?).
	<<Commands: procedures>>=
	subroutine check_nlo_options (local)
	type(rt_data_t), intent(in) :: local
	type(var_list_t), pointer :: var_list => null ()
	real :: mult_real, mult_virt, mult_dglap
	logical :: combined, powheg
	logical :: case_lo_but_any_other
	logical :: fixed_order_nlo_events
	logical :: real_finite_only
	var_list => local%get_var_list_ptr ()
	combined = var_list%get_lval (var_str ('?combined_nlo_integration'))
	powheg = var_list%get_lval (var_str ('?powheg_matching'))
	if (powheg .and. .not. combined) then
	call msg_fatal ("POWHEG matching requires the 'combined_nlo_integration' &
	&-option to be set to true.")
	end if
	fixed_order_nlo_events = &
	var_list%get_lval (var_str ('?fixed_order_nlo_events'))
	if (fixed_order_nlo_events .and. .not. combined .and. &
	count (local%selected_nlo_parts) > 1) &
	call msg_fatal ("Option mismatch: Fixed order NLO events of multiple ", &
	[var_str ("components are requested, but ?combined_nlo_integration "), &
	var_str ("is false. You can either switch to the combined NLO "), &
	var_str ("integration mode for the full process or choose one "), &
	var_str ("individual NLO component to generate events with.")])
	real_finite_only = local%var_list%get_sval (var_str ("$real_partition_mode")) == "finite"
	associate (nlo_parts => local%selected_nlo_parts)
	! TODO (PS-2020-03-26): This technically leaves the possibility to skip this
	! message by deactivating the dglap component for a proton collider process.
	! To circumvent this, the selected_nlo_parts should be refactored.
	if (combined .and. .not. (nlo_parts(BORN) &
	.and. nlo_parts(NLO_VIRTUAL) .and. nlo_parts(NLO_REAL))) then
	call msg_fatal ("A combined integration of anything else than", &
	[var_str ("all NLO components together is not supported.")])
	end if
	if (real_finite_only .and. combined) then
	call msg_fatal ("You cannot do a combined integration without", &
	[var_str ("the real singular component.")])
	end if
	if (real_finite_only .and. count(nlo_parts([BORN,NLO_VIRTUAL,NLO_DGLAP])) > 1) then
	call msg_fatal ("You cannot do a full NLO integration without", &
	[var_str ("the real singular component.")])
	end if
	end associate
	mult_real = local%var_list%get_rval (var_str ("mult_call_real"))
	mult_virt = local%var_list%get_rval (var_str ("mult_call_virt"))
	mult_dglap = local%var_list%get_rval (var_str ("mult_call_dglap"))
	if (combined .and. (mult_real /= one .or. mult_virt /= one .or. mult_dglap /= one)) then
	call msg_warning ("mult_call_real, mult_call_virt and mult_call_dglap", &
	[var_str (" will be ignored because of ?combined_nlo_integration = true. ")])
	end if
	end subroutine check_nlo_options

	@ %def check_nlo_options
	@ There are four components for a general NLO process, namely Born,
	real, virtual and subtraction. There will be additional components for
	DGLAP remnant, in case real contributions are split into singular and
	finite pieces, and for resonance-aware FKS subtraction for the needed
	soft mismatch component.
	<<Commands: procedures>>=
	pure function needed_extra_components (requires_dglap_remnant, &
	use_real_finite, requires_soft_mismatch) result (n)
	integer :: n
	logical, intent(in) :: requires_dglap_remnant, &
	use_real_finite, requires_soft_mismatch
	n = 4
	if (requires_dglap_remnant) n = n + 1
	if (use_real_finite) n = n + 1
	if (requires_soft_mismatch) n = n + 1
	end function needed_extra_components

	@ %def needed_extra_components
	@ This is a method of the eval tree, but cannot be coded inside the
	[[expressions]] module since it uses the [[model]] and [[flv]] types
	which are not available there.
	<<Commands: procedures>>=
	function make_flavor_string (aval, model) result (prt)
	type(string_t) :: prt
	type(pdg_array_t), intent(in) :: aval
	type(model_t), intent(in), target :: model
	integer, dimension(:), allocatable :: pdg
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	pdg = aval
	allocate (flv (size (pdg)))
	call flv%init (pdg, model)
	if (size (pdg) /= 0) then
	prt = flv(1)%get_name ()
	do i = 2, size (flv)
	prt = prt // ":" // flv(i)%get_name ()
	end do
	else
	prt = "?"
	end if
	end function make_flavor_string

	@ %def make_flavor_string
	@ Create a pdg array from a particle-specification array
	<<Commands: procedures>>=
	function make_pdg_array (prt, model) result (pdg_array)
	type(prt_spec_t), intent(in), dimension(:) :: prt
	type(model_t), intent(in) :: model
	integer, dimension(:), allocatable :: aval
	type(pdg_array_t) :: pdg_array
	type(flavor_t) :: flv
	integer :: k
	allocate (aval (size (prt)))
	do k = 1, size (prt)
	call flv%init (prt(k)%to_string (), model)
	aval (k) = flv%get_pdg ()
	end do
	pdg_array = aval
	end function make_pdg_array

	@ %def make_pdg_array
	@ Compile a (possible nested) expression, to obtain a
	particle-specifier expression which we can process further.
	<<Commands: procedures>>=
	recursive subroutine compile_prt_expr (prt_expr, pn, var_list, model)
	type(prt_expr_t), intent(out) :: prt_expr
	type(parse_node_t), intent(in), target :: pn
	type(var_list_t), intent(in), target :: var_list
	type(model_t), intent(in), target :: model
	type(parse_node_t), pointer :: pn_entry, pn_term, pn_addition
	type(pdg_array_t) :: pdg
	type(string_t) :: prt_string
	integer :: n_entry, n_term, i
	select case (char (parse_node_get_rule_key (pn)))
	case ("prt_state_list")
	n_entry = parse_node_get_n_sub (pn)
	pn_entry => parse_node_get_sub_ptr (pn)
	if (n_entry == 1) then
	call compile_prt_expr (prt_expr, pn_entry, var_list, model)
	else
	call prt_expr%init_list (n_entry)
	select type (x => prt_expr%x)
	type is (prt_spec_list_t)
	do i = 1, n_entry
	call compile_prt_expr (x%expr(i), pn_entry, var_list, model)
	pn_entry => parse_node_get_next_ptr (pn_entry)
	end do
	end select
	end if
	case ("prt_state_sum")
	n_term = parse_node_get_n_sub (pn)
	pn_term => parse_node_get_sub_ptr (pn)
	pn_addition => pn_term
	if (n_term == 1) then
	call compile_prt_expr (prt_expr, pn_term, var_list, model)
	else
	call prt_expr%init_sum (n_term)
	select type (x => prt_expr%x)
	type is (prt_spec_sum_t)
	do i = 1, n_term
	call compile_prt_expr (x%expr(i), pn_term, var_list, model)
	pn_addition => parse_node_get_next_ptr (pn_addition)
	if (associated (pn_addition)) &
	pn_term => parse_node_get_sub_ptr (pn_addition, 2)
	end do
	end select
	end if
	case ("cexpr")
	pdg = eval_pdg_array (pn, var_list)
	prt_string = make_flavor_string (pdg, model)
	call prt_expr%init_spec (new_prt_spec (prt_string))
	case default
	call parse_node_write_rec (pn)
	call msg_bug ("compile prt expr: impossible syntax rule")
	end select
	end subroutine compile_prt_expr

	@ %def compile_prt_expr
	@
	\subsubsection{Initiating a NLO calculation}
	<<Commands: types>>=
	type, extends (command_t) :: cmd_nlo_t
	private
	integer, dimension(:), allocatable :: nlo_component
	contains
	<<Commands: cmd nlo: TBP>>
	end type cmd_nlo_t

	@ %def cmd_nlo_t
	@
	<<Commands: cmd nlo: TBP>>=
	procedure :: write => cmd_nlo_write
	<<Commands: procedures>>=
	subroutine cmd_nlo_write (cmd, unit, indent)
	class(cmd_nlo_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	end subroutine cmd_nlo_write

	@ %def cmd_nlo_write
	@ As it is, the NLO calculation is switched on by putting {nlo} behind the process definition. This should be made nicer in the future.
	<<Commands: cmd nlo: TBP>>=
	procedure :: compile => cmd_nlo_compile
	<<Commands: procedures>>=
	subroutine cmd_nlo_compile (cmd, global)
	class(cmd_nlo_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_comp
	integer :: i, n_comp
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
	if (associated (pn_arg)) then
	n_comp = parse_node_get_n_sub (pn_arg)
	allocate (cmd%nlo_component (n_comp))
	pn_comp => parse_node_get_sub_ptr (pn_arg)
	i = 0
	do while (associated (pn_comp))
	i = i + 1
	cmd%nlo_component(i) = component_status &
	(parse_node_get_rule_key (pn_comp))
	pn_comp => parse_node_get_next_ptr (pn_comp)
	end do
	else
	allocate (cmd%nlo_component (0))
	end if
	end subroutine cmd_nlo_compile

	@ %def cmd_nlo_compile
	@ % TODO (PS-2020-03-26): This routine still needs to be adopted
	% to cope with more than 5 components.
	<<Commands: cmd nlo: TBP>>=
	procedure :: execute => cmd_nlo_execute
	<<Commands: procedures>>=
	subroutine cmd_nlo_execute (cmd, global)
	class(cmd_nlo_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(string_t) :: string
	integer :: n, i, j
	logical, dimension(0:5) :: selected_nlo_parts
	if (debug_on) call msg_debug (D_CORE, "cmd_nlo_execute")
	selected_nlo_parts = .false.
	if (allocated (cmd%nlo_component)) then
	n = size (cmd%nlo_component)
	else
	n = 0
	end if
	do i = 1, n
	select case (cmd%nlo_component (i))
	case (BORN, NLO_VIRTUAL, NLO_MISMATCH, NLO_DGLAP, NLO_REAL)
	selected_nlo_parts(cmd%nlo_component (i)) = .true.
	case (NLO_FULL)
	selected_nlo_parts = .true.
	selected_nlo_parts (NLO_SUBTRACTION) = .false.
	case default
	string = var_str ("")
	do j = BORN, NLO_DGLAP
	string = string // component_status (j) // ", "
	end do
	string = string // component_status (NLO_FULL)
	call msg_fatal ("Invalid NLO mode. Valid modes are: " // &
	char (string))
	end select
	end do
	global%nlo_fixed_order = any (selected_nlo_parts)
	global%selected_nlo_parts = selected_nlo_parts
	allocate (global%nlo_component (size (cmd%nlo_component)))
	global%nlo_component = cmd%nlo_component
	end subroutine cmd_nlo_execute

	@ %def cmd_nlo_execute
	@
	\subsubsection{Process compilation}
	<<Commands: types>>=
	type, extends (command_t) :: cmd_compile_t
	private
	type(string_t), dimension(:), allocatable :: libname
	logical :: make_executable = .false.
	type(string_t) :: exec_name
	contains
	<<Commands: cmd compile: TBP>>
	end type cmd_compile_t

	@ %def cmd_compile_t
	@ Output: list all libraries to be compiled.
	<<Commands: cmd compile: TBP>>=
	procedure :: write => cmd_compile_write
	<<Commands: procedures>>=
	subroutine cmd_compile_write (cmd, unit, indent)
	class(cmd_compile_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "compile ("
	if (allocated (cmd%libname)) then
	do i = 1, size (cmd%libname)
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "('""',A,'""')", advance="no") char (cmd%libname(i))
	end do
	end if
	write (u, "(A)") ")"
	end subroutine cmd_compile_write

	@ %def cmd_compile_write
	@ Compile the libraries specified in the argument. If the argument is
	empty, compile all libraries which can be found in the process library stack.
	<<Commands: cmd compile: TBP>>=
	procedure :: compile => cmd_compile_compile
	<<Commands: procedures>>=
	subroutine cmd_compile_compile (cmd, global)
	class(cmd_compile_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_arg, pn_lib
	type(parse_node_t), pointer :: pn_exec_name_spec, pn_exec_name
	integer :: n_lib, i
	pn_cmd => parse_node_get_sub_ptr (cmd%pn)
	pn_clause => parse_node_get_sub_ptr (pn_cmd)
	pn_exec_name_spec => parse_node_get_sub_ptr (pn_clause, 2)
	if (associated (pn_exec_name_spec)) then
	pn_exec_name => parse_node_get_sub_ptr (pn_exec_name_spec, 2)
	else
	pn_exec_name => null ()
	end if
	pn_arg => parse_node_get_next_ptr (pn_clause)
	cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
	call cmd%compile_options (global)
	if (associated (pn_arg)) then
	n_lib = parse_node_get_n_sub (pn_arg)
	else
	n_lib = 0
	end if
	if (n_lib > 0) then
	allocate (cmd%libname (n_lib))
	pn_lib => parse_node_get_sub_ptr (pn_arg)
	do i = 1, n_lib
	cmd%libname(i) = parse_node_get_string (pn_lib)
	pn_lib => parse_node_get_next_ptr (pn_lib)
	end do
	end if
	if (associated (pn_exec_name)) then
	cmd%make_executable = .true.
	cmd%exec_name = parse_node_get_string (pn_exec_name)
	end if
	end subroutine cmd_compile_compile

	@ %def cmd_compile_compile
	@ Command execution. Generate code, write driver, compile and link.
	Do this for all libraries in the list.

	If no library names have been given and stored while compiling this
	command, we collect all libraries from the current stack and compile
	those.

	As a bonus, a compiled library may be able to spawn new process
	libraries. For instance, a processes may ask for a set of resonant
	subprocesses which go into their own library, but this can be
	determined only after the process is available as a compiled object.
	Therefore, the compilation loop is implemented as a recursive internal
	subroutine.

	We can compile static libraries (which actually just loads them). However, we
	can't incorporate in a generated executable.
	<<Commands: cmd compile: TBP>>=
	procedure :: execute => cmd_compile_execute
	<<Commands: procedures>>=
	subroutine cmd_compile_execute (cmd, global)
	class(cmd_compile_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(string_t), dimension(:), allocatable :: libname, libname_static
	integer :: i, n_lib
	<<Commands: cmd compile execute: extra variables>>
	<<Commands: cmd compile execute: extra init>>
	if (allocated (cmd%libname)) then
	allocate (libname (size (cmd%libname)))
	libname = cmd%libname
	else
	call cmd%local%prclib_stack%get_names (libname)
	end if
	n_lib = size (libname)
	if (cmd%make_executable) then
	call get_prclib_static (libname_static)
	do i = 1, n_lib
	if (any (libname_static == libname(i))) then
	call msg_fatal ("Compile: can't include static library '" &
	// char (libname(i)) // "'")
	end if
	end do
	call compile_executable (cmd%exec_name, libname, cmd%local)
	else
	call compile_libraries (libname)
	call global%update_prclib &
	(global%prclib_stack%get_library_ptr (libname(n_lib)))
	end if
	<<Commands: cmd compile execute: extra end init>>
	contains
	recursive subroutine compile_libraries (libname)
	type(string_t), dimension(:), intent(in) :: libname
	integer :: i
	type(string_t), dimension(:), allocatable :: libname_extra
	type(process_library_t), pointer :: lib_saved
	do i = 1, size (libname)
	call compile_library (libname(i), cmd%local)
	lib_saved => global%prclib
	call spawn_extra_libraries &
	(libname(i), cmd%local, global, libname_extra)
	call compile_libraries (libname_extra)
	call global%update_prclib (lib_saved)
	end do
	end subroutine compile_libraries
	end subroutine cmd_compile_execute

	@ %def cmd_compile_execute
	<<Commands: cmd compile execute: extra variables>>=
	<<Commands: cmd compile execute: extra init>>=
	<<Commands: cmd compile execute: extra end init>>=
	@ The parallelization leads to undefined behavior while writing simultaneously to one file.
	The master worker has to initialize single-handed the corresponding library files.
	The slave worker will wait with a blocking [[MPI_BCAST]] until they receive a logical flag.
	<<MPI: Commands: cmd compile execute: extra variables>>=
	logical :: compile_init
	integer :: rank, n_size
	<<MPI: Commands: cmd compile execute: extra init>>=
	if (debug_on) call msg_debug (D_MPI, "cmd_compile_execute")
	compile_init = .false.
	call mpi_get_comm_id (n_size, rank)
	if (debug_on) call msg_debug (D_MPI, "n_size", rank)
	if (debug_on) call msg_debug (D_MPI, "rank", rank)
	if (rank /= 0) then
	if (debug_on) call msg_debug (D_MPI, "wait for master")
	call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
	else
	compile_init = .true.
	end if

	if (compile_init) then
	<<MPI: Commands: cmd compile execute: extra end init>>=
	if (rank == 0) then
	if (debug_on) call msg_debug (D_MPI, "load slaves")
	call MPI_bcast (compile_init, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD)
	end if
	end if
	call MPI_barrier (MPI_COMM_WORLD)
	@ %def cmd_compile_execute_mpi
	@
	This is the interface to the external procedure which returns the
	names of all static libraries which are part of the executable. (The
	default is none.) The routine must allocate the array.
	<<Commands: public>>=
	public :: get_prclib_static
	<<Commands: interfaces>>=
	interface
	subroutine get_prclib_static (libname)
	import
	type(string_t), dimension(:), intent(inout), allocatable :: libname
	end subroutine get_prclib_static
	end interface

	@ %def get_prclib_static
	@
	Spawn extra libraries. We can ask the processes within a compiled
	library, which we have available at this point, whether they need additional
	processes which should go into their own libraries.

	The current implementation only concerns resonant subprocesses.

	Note that the libraries should be created (source code), but not be
	compiled here. This is done afterwards.
	<<Commands: procedures>>=
	subroutine spawn_extra_libraries (libname, local, global, libname_extra)
	type(string_t), intent(in) :: libname
	type(rt_data_t), intent(inout), target :: local
	type(rt_data_t), intent(inout), target :: global
	type(string_t), dimension(:), allocatable, intent(out) :: libname_extra
	type(string_t), dimension(:), allocatable :: libname_res
	allocate (libname_extra (0))
	call spawn_resonant_subprocess_libraries &
	(libname, local, global, libname_res)
	if (allocated (libname_res)) libname_extra = [libname_extra, libname_res]
	end subroutine spawn_extra_libraries

	@ %def spawn_extra_libraries
	@
	\subsubsection{Execute a shell command}
	The argument is a string expression.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_exec_t
	private
	type(parse_node_t), pointer :: pn_command => null ()
	contains
	<<Commands: cmd exec: TBP>>
	end type cmd_exec_t

	@ %def cmd_exec_t
	@ Simply tell the status.
	<<Commands: cmd exec: TBP>>=
	procedure :: write => cmd_exec_write
	<<Commands: procedures>>=
	subroutine cmd_exec_write (cmd, unit, indent)
	class(cmd_exec_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	if (associated (cmd%pn_command)) then
	write (u, "(1x,A)") "exec: [command associated]"
	else
	write (u, "(1x,A)") "exec: [undefined]"
	end if
	end subroutine cmd_exec_write

	@ %def cmd_exec_write
	@ Compile the exec command.
	<<Commands: cmd exec: TBP>>=
	procedure :: compile => cmd_exec_compile
	<<Commands: procedures>>=
	subroutine cmd_exec_compile (cmd, global)
	class(cmd_exec_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_command
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_command => parse_node_get_sub_ptr (pn_arg)
	cmd%pn_command => pn_command
	end subroutine cmd_exec_compile

	@ %def cmd_exec_compile
	@ Execute the specified shell command.
	<<Commands: cmd exec: TBP>>=
	procedure :: execute => cmd_exec_execute
	<<Commands: procedures>>=
	subroutine cmd_exec_execute (cmd, global)
	class(cmd_exec_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(string_t) :: command
	logical :: is_known
	integer :: status
	command = eval_string (cmd%pn_command, global%var_list, is_known=is_known)
	if (is_known) then
	if (command /= "") then
	call os_system_call (command, status, verbose=.true.)
	if (status /= 0) then
	write (msg_buffer, "(A,I0)") "Return code = ", status
	call msg_message ()
	call msg_error ("System command returned with nonzero status code")
	end if
	end if
	end if
	end subroutine cmd_exec_execute

	@ %def cmd_exec_execute
	@
	\subsubsection{Variable declaration}
	A variable can have various types. Hold the definition as an eval
	tree.

	There are intrinsic variables, user variables, and model variables.
	The latter are further divided in independent variables and dependent
	variables.

	Regarding model variables: When dealing with them, we always look at
	two variable lists in parallel. The global (or local) variable list
	contains the user-visible values. It includes variables that
	correspond to variables in the current model's list. These, in turn,
	are pointers to the model's parameter list, so the model is always in
	sync, internally. To keep the global variable list in sync with the
	model, the global variables carry the [[is_copy]] property and contain
	a separate pointer to the model variable. (The pointer is reassigned
	whenever the model changes.) Modifying the global variable changes
	two values simultaneously: the visible value and the model variable,
	via this extra pointer. After each modification, we update dependent
	parameters in the model variable list and re-synchronize the global
	variable list (again, using these pointers) with the model variable
	this. In the last step, modifications in the derived parameters
	become visible.

	When we integrate a process, we capture the current variable list of
	the current model in a separate model instance, which is stored in the
	process object. Thus, the model parameters associated to this process
	at this time are preserved for the lifetime of the process object.

	When we generate or rescan events, we can again capture a local model
	variable list in a model instance. This allows us to reweight event
	by event with different parameter sets simultaneously.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_var_t
	private
	type(string_t) :: name
	integer :: type = V_NONE
	type(parse_node_t), pointer :: pn_value => null ()
	logical :: is_intrinsic = .false.
	logical :: is_model_var = .false.
	contains
	<<Commands: cmd var: TBP>>
	end type cmd_var_t

	@ %def cmd_var_t
	@ Output. We know name, type, and properties, but not the value.
	<<Commands: cmd var: TBP>>=
	procedure :: write => cmd_var_write
	<<Commands: procedures>>=
	subroutine cmd_var_write (cmd, unit, indent)
	class(cmd_var_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A,A)", advance="no") "var: ", char (cmd%name), " ("
	select case (cmd%type)
	case (V_NONE)
	write (u, "(A)", advance="no") "[unknown]"
	case (V_LOG)
	write (u, "(A)", advance="no") "logical"
	case (V_INT)
	write (u, "(A)", advance="no") "int"
	case (V_REAL)
	write (u, "(A)", advance="no") "real"
	case (V_CMPLX)
	write (u, "(A)", advance="no") "complex"
	case (V_STR)
	write (u, "(A)", advance="no") "string"
	case (V_PDG)
	write (u, "(A)", advance="no") "alias"
	end select
	if (cmd%is_intrinsic) then
	write (u, "(A)", advance="no") ", intrinsic"
	end if
	if (cmd%is_model_var) then
	write (u, "(A)", advance="no") ", model"
	end if
	write (u, "(A)") ")"
	end subroutine cmd_var_write

	@ %def cmd_var_write
	@ Compile the lhs and determine the variable name and type. Check whether
	this variable can be created or modified as requested, and append the value to
	the variable list, if appropriate. The value is initially undefined.
	The rhs is assigned to a pointer, to be compiled and evaluated when the
	command is executed.
	<<Commands: cmd var: TBP>>=
	procedure :: compile => cmd_var_compile
	<<Commands: procedures>>=
	subroutine cmd_var_compile (cmd, global)
	class(cmd_var_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_var, pn_name
	type(parse_node_t), pointer :: pn_result, pn_proc
	type(string_t) :: var_name
	type(var_list_t), pointer :: model_vars
	integer :: type
	logical :: new
	pn_result => null ()
	new = .false.
	select case (char (parse_node_get_rule_key (cmd%pn)))
	case ("cmd_log_decl"); type = V_LOG
	pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
	if (.not. associated (pn_var)) then ! handle masked syntax error
	cmd%type = V_NONE; return
	end if
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	new = .true.
	case ("cmd_log"); type = V_LOG
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	case ("cmd_int"); type = V_INT
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	new = .true.
	case ("cmd_real"); type = V_REAL
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	new = .true.
	case ("cmd_complex"); type = V_CMPLX
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	new = .true.
	case ("cmd_num"); type = V_NONE
	pn_name => parse_node_get_sub_ptr (cmd%pn)
	case ("cmd_string_decl"); type = V_STR
	pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
	if (.not. associated (pn_var)) then ! handle masked syntax error
	cmd%type = V_NONE; return
	end if
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	new = .true.
	case ("cmd_string"); type = V_STR
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	case ("cmd_alias"); type = V_PDG
	pn_name => parse_node_get_sub_ptr (cmd%pn, 2)
	new = .true.
	case ("cmd_result"); type = V_REAL
	pn_name => parse_node_get_sub_ptr (cmd%pn)
	pn_result => parse_node_get_sub_ptr (pn_name)
	pn_proc => parse_node_get_next_ptr (pn_result)
	case default
	call parse_node_mismatch &
	("logical\|int\|real\|complex\|?\|$\|alias\|var_name", cmd%pn) ! $
	end select
	if (.not. associated (pn_name)) then ! handle masked syntax error
	cmd%type = V_NONE; return
	end if
	if (.not. associated (pn_result)) then
	var_name = parse_node_get_string (pn_name)
	else
	var_name = parse_node_get_key (pn_result) &
	// "(" // parse_node_get_string (pn_proc) // ")"
	end if
	select case (type)
	case (V_LOG); var_name = "?" // var_name
	case (V_STR); var_name = "$" // var_name ! $
	end select
	if (associated (global%model)) then
	model_vars => global%model%get_var_list_ptr ()
	else
	model_vars => null ()
	end if
	call var_list_check_observable (global%var_list, var_name, type)
	call var_list_check_result_var (global%var_list, var_name, type)
	call global%var_list%check_user_var (var_name, type, new)
	cmd%name = var_name
	cmd%pn_value => parse_node_get_next_ptr (pn_name, 2)
	if (global%var_list%contains (cmd%name, follow_link = .false.)) then
	! local variable
	cmd%is_intrinsic = &
	global%var_list%is_intrinsic (cmd%name, follow_link = .false.)
	cmd%type = &
	global%var_list%get_type (cmd%name, follow_link = .false.)
	else
	if (new) cmd%type = type
	if (global%var_list%contains (cmd%name, follow_link = .true.)) then
	! global variable
	cmd%is_intrinsic = &
	global%var_list%is_intrinsic (cmd%name, follow_link = .true.)
	if (cmd%type == V_NONE) then
	cmd%type = &
	global%var_list%get_type (cmd%name, follow_link = .true.)
	end if
	else if (associated (model_vars)) then ! check model variable
	cmd%is_model_var = &
	model_vars%contains (cmd%name)
	if (cmd%type == V_NONE) then
	cmd%type = &
	model_vars%get_type (cmd%name)
	end if
	end if
	if (cmd%type == V_NONE) then
	call msg_fatal ("Variable '" // char (cmd%name) // "' " &
	// "set without declaration")
	cmd%type = V_NONE; return
	end if
	if (cmd%is_model_var) then
	if (new) then
	call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
	// "redeclared")
	else if (model_vars%is_locked (cmd%name)) then
	call msg_fatal ("Model variable '" // char (cmd%name) // "' " &
	// "is locked")
	end if
	else
	select case (cmd%type)
	case (V_LOG)
	call global%var_list%append_log (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	case (V_INT)
	call global%var_list%append_int (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	case (V_REAL)
	call global%var_list%append_real (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	case (V_CMPLX)
	call global%var_list%append_cmplx (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	case (V_PDG)
	call global%var_list%append_pdg_array (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	case (V_STR)
	call global%var_list%append_string (cmd%name, &
	intrinsic=cmd%is_intrinsic, user=.true.)
	end select
	end if
	end if
	end subroutine cmd_var_compile

	@ %def cmd_var_compile
	@ Execute. Evaluate the definition and assign the variable value.
	If the variable is a model variable, take a snapshot of the model if necessary
	and set the variable in the local model.
	<<Commands: cmd var: TBP>>=
	procedure :: execute => cmd_var_execute
	<<Commands: procedures>>=
	subroutine cmd_var_execute (cmd, global)
	class(cmd_var_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default) :: rval
	logical :: is_known, pacified
	var_list => global%get_var_list_ptr ()
	if (cmd%is_model_var) then
	pacified = var_list%get_lval (var_str ("?pacify"))
	rval = eval_real (cmd%pn_value, var_list, is_known=is_known)
	call global%model_set_real &
	(cmd%name, rval, verbose=.true., pacified=pacified)
	else if (cmd%type /= V_NONE) then
	call cmd%set_value (var_list, verbose=.true.)
	end if
	end subroutine cmd_var_execute

	@ %def cmd_var_execute
	@ Copy the value to the variable list, where the variable should already exist.
	<<Commands: cmd var: TBP>>=
	procedure :: set_value => cmd_var_set_value
	<<Commands: procedures>>=
	subroutine cmd_var_set_value (var, var_list, verbose, model_name)
	class(cmd_var_t), intent(inout) :: var
	type(var_list_t), intent(inout), target :: var_list
	logical, intent(in), optional :: verbose
	type(string_t), intent(in), optional :: model_name
	logical :: lval, pacified
	integer :: ival
	real(default) :: rval
	complex(default) :: cval
	type(pdg_array_t) :: aval
	type(string_t) :: sval
	logical :: is_known
	pacified = var_list%get_lval (var_str ("?pacify"))
	select case (var%type)
	case (V_LOG)
	lval = eval_log (var%pn_value, var_list, is_known=is_known)
	call var_list%set_log (var%name, &
	lval, is_known, verbose=verbose, model_name=model_name)
	case (V_INT)
	ival = eval_int (var%pn_value, var_list, is_known=is_known)
	call var_list%set_int (var%name, &
	ival, is_known, verbose=verbose, model_name=model_name)
	case (V_REAL)
	rval = eval_real (var%pn_value, var_list, is_known=is_known)
	call var_list%set_real (var%name, &
	rval, is_known, verbose=verbose, &
	model_name=model_name, pacified = pacified)
	case (V_CMPLX)
	cval = eval_cmplx (var%pn_value, var_list, is_known=is_known)
	call var_list%set_cmplx (var%name, &
	cval, is_known, verbose=verbose, &
	model_name=model_name, pacified = pacified)
	case (V_PDG)
	aval = eval_pdg_array (var%pn_value, var_list, is_known=is_known)
	call var_list%set_pdg_array (var%name, &
	aval, is_known, verbose=verbose, model_name=model_name)
	case (V_STR)
	sval = eval_string (var%pn_value, var_list, is_known=is_known)
	call var_list%set_string (var%name, &
	sval, is_known, verbose=verbose, model_name=model_name)
	end select
	end subroutine cmd_var_set_value

	@ %def cmd_var_set_value
	@
	\subsubsection{SLHA}
	Read a SLHA (SUSY Les Houches Accord) file to fill the appropriate
	model parameters. We do not access the current variable record, but
	directly work on the appropriate SUSY model, which is loaded if
	necessary.

	We may be in read or write mode. In the latter case, we may write
	just input parameters, or the complete spectrum, or the spectrum with
	all decays.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_slha_t
	private
	type(string_t) :: file
	logical :: write_mode = .false.
	contains
	<<Commands: cmd slha: TBP>>
	end type cmd_slha_t

	@ %def cmd_slha_t
	@ Output.
	<<Commands: cmd slha: TBP>>=
	procedure :: write => cmd_slha_write
	<<Commands: procedures>>=
	subroutine cmd_slha_write (cmd, unit, indent)
	class(cmd_slha_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A)") "slha: file name = ", char (cmd%file)
	write (u, "(1x,A,L1)") "slha: write mode = ", cmd%write_mode
	end subroutine cmd_slha_write

	@ %def cmd_slha_write
	@ Compile. Read the filename and store it.
	<<Commands: cmd slha: TBP>>=
	procedure :: compile => cmd_slha_compile
	<<Commands: procedures>>=
	subroutine cmd_slha_compile (cmd, global)
	class(cmd_slha_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_key, pn_arg, pn_file
	pn_key => parse_node_get_sub_ptr (cmd%pn)
	pn_arg => parse_node_get_next_ptr (pn_key)
	pn_file => parse_node_get_sub_ptr (pn_arg)
	call cmd%compile_options (global)
	cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
	select case (char (parse_node_get_key (pn_key)))
	case ("read_slha")
	cmd%write_mode = .false.
	case ("write_slha")
	cmd%write_mode = .true.
	case default
	call parse_node_mismatch ("read_slha\|write_slha", cmd%pn)
	end select
	cmd%file = parse_node_get_string (pn_file)
	end subroutine cmd_slha_compile

	@ %def cmd_slha_compile
	@ Execute. Read or write the specified SLHA file. Behind the scenes,
	this will first read the WHIZARD model file, then read the SLHA file
	and assign the SLHA parameters as far as determined by
	[[dispatch_slha]]. Finally, the global variables are synchronized
	with the model. This is similar to executing [[cmd_model]].
	<<Commands: cmd slha: TBP>>=
	procedure :: execute => cmd_slha_execute
	<<Commands: procedures>>=
	subroutine cmd_slha_execute (cmd, global)
	class(cmd_slha_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	logical :: input, spectrum, decays
	if (cmd%write_mode) then
	input = .true.
	spectrum = .false.
	decays = .false.
	if (.not. associated (cmd%local%model)) then
	call msg_fatal ("SLHA: local model not associated")
	return
	end if
	call slha_write_file &
	(cmd%file, cmd%local%model, &
	input = input, spectrum = spectrum, decays = decays)
	else
	if (.not. associated (global%model)) then
	call msg_fatal ("SLHA: global model not associated")
	return
	end if
	call dispatch_slha (cmd%local%var_list, &
	input = input, spectrum = spectrum, decays = decays)
	call global%ensure_model_copy ()
	call slha_read_file &
	(cmd%file, cmd%local%os_data, global%model, &
	input = input, spectrum = spectrum, decays = decays)
	end if
	end subroutine cmd_slha_execute

	@ %def cmd_slha_execute
	@
	\subsubsection{Show values}
	This command shows the current values of variables or other objects,
	in a suitably condensed form.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_show_t
	private
	type(string_t), dimension(:), allocatable :: name
	contains
	<<Commands: cmd show: TBP>>
	end type cmd_show_t

	@ %def cmd_show_t
	@ Output: list the object names, not values.
	<<Commands: cmd show: TBP>>=
	procedure :: write => cmd_show_write
	<<Commands: procedures>>=
	subroutine cmd_show_write (cmd, unit, indent)
	class(cmd_show_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "show: "
	if (allocated (cmd%name)) then
	do i = 1, size (cmd%name)
	write (u, "(1x,A)", advance="no") char (cmd%name(i))
	end do
	write (u, *)
	else
	write (u, "(5x,A)") "[undefined]"
	end if
	end subroutine cmd_show_write

	@ %def cmd_show_write
	@ Compile. Allocate an array which is filled with the names of the
	variables to show.
	<<Commands: cmd show: TBP>>=
	procedure :: compile => cmd_show_compile
	<<Commands: procedures>>=
	subroutine cmd_show_compile (cmd, global)
	class(cmd_show_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
	type(string_t) :: key
	integer :: i, n_args
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (pn_arg)) then
	select case (char (parse_node_get_rule_key (pn_arg)))
	case ("show_arg")
	cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
	case default
	cmd%pn_opt => pn_arg
	pn_arg => null ()
	end select
	end if
	call cmd%compile_options (global)
	if (associated (pn_arg)) then
	n_args = parse_node_get_n_sub (pn_arg)
	allocate (cmd%name (n_args))
	pn_var => parse_node_get_sub_ptr (pn_arg)
	i = 0
	do while (associated (pn_var))
	i = i + 1
	select case (char (parse_node_get_rule_key (pn_var)))
	case ("model", "library", "beams", "iterations", &
	"cuts", "weight", "int", "real", "complex", &
	"scale", "factorization_scale", "renormalization_scale", &
	"selection", "reweight", "analysis", "pdg", &
	"stable", "unstable", "polarized", "unpolarized", &
	"results", "expect", "intrinsic", "string", "logical")
	cmd%name(i) = parse_node_get_key (pn_var)
	case ("result_var")
	pn_prefix => parse_node_get_sub_ptr (pn_var)
	pn_name => parse_node_get_next_ptr (pn_prefix)
	if (associated (pn_name)) then
	cmd%name(i) = parse_node_get_key (pn_prefix) &
	// "(" // parse_node_get_string (pn_name) // ")"
	else
	cmd%name(i) = parse_node_get_key (pn_prefix)
	end if
	case ("log_var", "string_var", "alias_var")
	pn_prefix => parse_node_get_sub_ptr (pn_var)
	pn_name => parse_node_get_next_ptr (pn_prefix)
	key = parse_node_get_key (pn_prefix)
	if (associated (pn_name)) then
	select case (char (parse_node_get_rule_key (pn_name)))
	case ("var_name")
	select case (char (key))
	case ("?", "$") ! $ sign
	cmd%name(i) = key // parse_node_get_string (pn_name)
	case ("alias")
	cmd%name(i) = parse_node_get_string (pn_name)
	end select
	case default
	call parse_node_mismatch &
	("var_name", pn_name)
	end select
	else
	cmd%name(i) = key
	end if
	case default
	cmd%name(i) = parse_node_get_string (pn_var)
	end select
	pn_var => parse_node_get_next_ptr (pn_var)
	end do
	else
	allocate (cmd%name (0))
	end if
	end subroutine cmd_show_compile

	@ %def cmd_show_compile
	@ Execute. Scan the list of objects to show.
	<<Commands: parameters>>=
	integer, parameter, public :: SHOW_BUFFER_SIZE = 4096
	<<Commands: cmd show: TBP>>=
	procedure :: execute => cmd_show_execute
	<<Commands: procedures>>=
	subroutine cmd_show_execute (cmd, global)
	class(cmd_show_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list, model_vars
	type(model_t), pointer :: model
	type(string_t) :: name
	integer :: n, pdg
	type(flavor_t) :: flv
	type(process_library_t), pointer :: prc_lib
	type(process_t), pointer :: process
	logical :: pacified
	character(SHOW_BUFFER_SIZE) :: buffer
	type(string_t) :: out_file
	integer :: i, j, u, u_log, u_out, u_ext
	u = free_unit ()
	var_list => cmd%local%var_list
	if (associated (cmd%local%model)) then
	model_vars => cmd%local%model%get_var_list_ptr ()
	else
	model_vars => null ()
	end if
	pacified = var_list%get_lval (var_str ("?pacify"))
	out_file = var_list%get_sval (var_str ("$out_file"))
	if (file_list_is_open (global%out_files, out_file, action="write")) then
	call msg_message ("show: copying output to file '" &
	// char (out_file) // "'")
	u_ext = file_list_get_unit (global%out_files, out_file)
	else
	u_ext = -1
	end if
	open (u, status = "scratch", action = "readwrite")
	if (associated (cmd%local%model)) then
	name = cmd%local%model%get_name ()
	end if
	if (size (cmd%name) == 0) then
	if (associated (model_vars)) then
	call model_vars%write (model_name = name, &
	unit = u, pacified = pacified, follow_link = .false.)
	end if
	call var_list%write (unit = u, pacified = pacified)
	else
	do i = 1, size (cmd%name)
	select case (char (cmd%name(i)))
	case ("model")
	if (associated (cmd%local%model)) then
	call cmd%local%model%show (u)
	else
	write (u, "(A)") "Model: [undefined]"
	end if
	case ("library")
	if (associated (cmd%local%prclib)) then
	call cmd%local%prclib%show (u)
	else
	write (u, "(A)") "Process library: [undefined]"
	end if
	case ("beams")
	call cmd%local%show_beams (u)
	case ("iterations")
	call cmd%local%it_list%write (u)
	case ("results")
	call cmd%local%process_stack%show (u, fifo=.true.)
	case ("stable")
	call cmd%local%model%show_stable (u)
	case ("polarized")
	call cmd%local%model%show_polarized (u)
	case ("unpolarized")
	call cmd%local%model%show_unpolarized (u)
	case ("unstable")
	model => cmd%local%model
	call model%show_unstable (u)
	n = model%get_n_field ()
	do j = 1, n
	pdg = model%get_pdg (j)
	call flv%init (pdg, model)
	if (.not. flv%is_stable ()) &
	call show_unstable (cmd%local, pdg, u)
	if (flv%has_antiparticle ()) then
	associate (anti => flv%anti ())
	if (.not. anti%is_stable ()) &
	call show_unstable (cmd%local, -pdg, u)
	end associate
	end if
	end do
	case ("cuts", "weight", "scale", &
	"factorization_scale", "renormalization_scale", &
	"selection", "reweight", "analysis")
	call cmd%local%pn%show (cmd%name(i), u)
	case ("expect")
	call expect_summary (force = .true.)
	case ("intrinsic")
	call var_list%write (intrinsic=.true., unit=u, &
	pacified = pacified)
	case ("logical")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_LOG, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (&
	only_type=V_LOG, unit=u, pacified = pacified)
	case ("int")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_INT, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (only_type=V_INT, &
	unit=u, pacified = pacified)
	case ("real")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_REAL, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (only_type=V_REAL, &
	unit=u, pacified = pacified)
	case ("complex")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_CMPLX, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (only_type=V_CMPLX, &
	unit=u, pacified = pacified)
	case ("pdg")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_PDG, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (only_type=V_PDG, &
	unit=u, pacified = pacified)
	case ("string")
	if (associated (model_vars)) then
	call model_vars%write (only_type=V_STR, &
	model_name = name, unit=u, pacified = pacified, &
	follow_link=.false.)
	end if
	call var_list%write (only_type=V_STR, &
	unit=u, pacified = pacified)
	case default
	if (analysis_exists (cmd%name(i))) then
	call analysis_write (cmd%name(i), u)
	else if (cmd%local%process_stack%exists (cmd%name(i))) then
	process => cmd%local%process_stack%get_process_ptr (cmd%name(i))
	call process%show (u)
	else if (associated (cmd%local%prclib_stack%get_library_ptr &
	(cmd%name(i)))) then
	prc_lib => cmd%local%prclib_stack%get_library_ptr (cmd%name(i))
	call prc_lib%show (u)
	else if (associated (model_vars)) then
	if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
	call model_vars%write_var (cmd%name(i), &
	unit = u, model_name = name, pacified = pacified)
	else if (var_list%contains (cmd%name(i))) then
	call var_list%write_var (cmd%name(i), &
	unit = u, pacified = pacified)
	else
	call msg_error ("show: object '" // char (cmd%name(i)) &
	// "' not found")
	end if
	else if (var_list%contains (cmd%name(i))) then
	call var_list%write_var (cmd%name(i), &
	unit = u, pacified = pacified)
	else
	call msg_error ("show: object '" // char (cmd%name(i)) &
	// "' not found")
	end if
	end select
	end do
	end if
	rewind (u)
	u_log = logfile_unit ()
	u_out = given_output_unit ()
	do
	read (u, "(A)", end = 1) buffer
	if (u_log > 0) write (u_log, "(A)") trim (buffer)
	if (u_out > 0) write (u_out, "(A)") trim (buffer)
	if (u_ext > 0) write (u_ext, "(A)") trim (buffer)
	end do
	1 close (u)
	if (u_log > 0) flush (u_log)
	if (u_out > 0) flush (u_out)
	if (u_ext > 0) flush (u_ext)
	end subroutine cmd_show_execute

	@ %def cmd_show_execute
	@
	\subsubsection{Clear values}
	This command clears the current values of variables or other objects,
	where this makes sense. It parallels the [[show]] command. The
	objects are cleared, but not deleted.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_clear_t
	private
	type(string_t), dimension(:), allocatable :: name
	contains
	<<Commands: cmd clear: TBP>>
	end type cmd_clear_t

	@ %def cmd_clear_t
	@ Output: list the names of the objects to be cleared.
	<<Commands: cmd clear: TBP>>=
	procedure :: write => cmd_clear_write
	<<Commands: procedures>>=
	subroutine cmd_clear_write (cmd, unit, indent)
	class(cmd_clear_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "clear: "
	if (allocated (cmd%name)) then
	do i = 1, size (cmd%name)
	write (u, "(1x,A)", advance="no") char (cmd%name(i))
	end do
	write (u, *)
	else
	write (u, "(5x,A)") "[undefined]"
	end if
	end subroutine cmd_clear_write

	@ %def cmd_clear_write
	@ Compile. Allocate an array which is filled with the names of the
	objects to be cleared.

	Note: there is currently no need to account for options, but we
	prepare for that possibility.
	<<Commands: cmd clear: TBP>>=
	procedure :: compile => cmd_clear_compile
	<<Commands: procedures>>=
	subroutine cmd_clear_compile (cmd, global)
	class(cmd_clear_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
	type(string_t) :: key
	integer :: i, n_args
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (pn_arg)) then
	select case (char (parse_node_get_rule_key (pn_arg)))
	case ("clear_arg")
	cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
	case default
	cmd%pn_opt => pn_arg
	pn_arg => null ()
	end select
	end if
	call cmd%compile_options (global)
	if (associated (pn_arg)) then
	n_args = parse_node_get_n_sub (pn_arg)
	allocate (cmd%name (n_args))
	pn_var => parse_node_get_sub_ptr (pn_arg)
	i = 0
	do while (associated (pn_var))
	i = i + 1
	select case (char (parse_node_get_rule_key (pn_var)))
	case ("beams", "iterations", &
	"cuts", "weight", &
	"scale", "factorization_scale", "renormalization_scale", &
	"selection", "reweight", "analysis", &
	"unstable", "polarized", &
	"expect")
	cmd%name(i) = parse_node_get_key (pn_var)
	case ("log_var", "string_var")
	pn_prefix => parse_node_get_sub_ptr (pn_var)
	pn_name => parse_node_get_next_ptr (pn_prefix)
	key = parse_node_get_key (pn_prefix)
	if (associated (pn_name)) then
	select case (char (parse_node_get_rule_key (pn_name)))
	case ("var_name")
	select case (char (key))
	case ("?", "$") ! $ sign
	cmd%name(i) = key // parse_node_get_string (pn_name)
	end select
	case default
	call parse_node_mismatch &
	("var_name", pn_name)
	end select
	else
	cmd%name(i) = key
	end if
	case default
	cmd%name(i) = parse_node_get_string (pn_var)
	end select
	pn_var => parse_node_get_next_ptr (pn_var)
	end do
	else
	allocate (cmd%name (0))
	end if
	end subroutine cmd_clear_compile

	@ %def cmd_clear_compile
	@ Execute. Scan the list of objects to clear.

	Objects that can be shown but not cleared: model, library, results
	<<Commands: cmd clear: TBP>>=
	procedure :: execute => cmd_clear_execute
	<<Commands: procedures>>=
	subroutine cmd_clear_execute (cmd, global)
	class(cmd_clear_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	integer :: i
	logical :: success
	type(var_list_t), pointer :: model_vars
	if (size (cmd%name) == 0) then
	call msg_warning ("clear: no object specified")
	else
	do i = 1, size (cmd%name)
	success = .true.
	select case (char (cmd%name(i)))
	case ("beams")
	call cmd%local%clear_beams ()
	case ("iterations")
	call cmd%local%it_list%clear ()
	case ("polarized")
	call cmd%local%model%clear_polarized ()
	case ("unstable")
	call cmd%local%model%clear_unstable ()
	case ("cuts", "weight", "scale", &
	"factorization_scale", "renormalization_scale", &
	"selection", "reweight", "analysis")
	call cmd%local%pn%clear (cmd%name(i))
	case ("expect")
	call expect_clear ()
	case default
	if (analysis_exists (cmd%name(i))) then
	call analysis_clear (cmd%name(i))
	else if (cmd%local%var_list%contains (cmd%name(i))) then
	if (.not. cmd%local%var_list%is_locked (cmd%name(i))) then
	call cmd%local%var_list%unset (cmd%name(i))
	else
	call msg_error ("clear: variable '" // char (cmd%name(i)) &
	// "' is locked and can't be cleared")
	success = .false.
	end if
	else if (associated (cmd%local%model)) then
	model_vars => cmd%local%model%get_var_list_ptr ()
	if (model_vars%contains (cmd%name(i), follow_link=.false.)) then
	call msg_error ("clear: variable '" // char (cmd%name(i)) &
	// "' is a model variable and can't be cleared")
	else
	call msg_error ("clear: object '" // char (cmd%name(i)) &
	// "' not found")
	end if
	success = .false.
	else
	call msg_error ("clear: object '" // char (cmd%name(i)) &
	// "' not found")
	success = .false.
	end if
	end select
	if (success) call msg_message ("cleared: " // char (cmd%name(i)))
	end do
	end if
	end subroutine cmd_clear_execute

	@ %def cmd_clear_execute
	@
	\subsubsection{Compare values of variables to expectation}
	The implementation is similar to the [[show]] command. There are just
	two arguments: two values that should be compared. For providing
	local values for the numerical tolerance, the command has a local
	argument list.

	If the expectation fails, an error condition is recorded.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_expect_t
	private
	type(parse_node_t), pointer :: pn_lexpr => null ()
	contains
	<<Commands: cmd expect: TBP>>
	end type cmd_expect_t

	@ %def cmd_expect_t
	@ Simply tell the status.
	<<Commands: cmd expect: TBP>>=
	procedure :: write => cmd_expect_write
	<<Commands: procedures>>=
	subroutine cmd_expect_write (cmd, unit, indent)
	class(cmd_expect_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	if (associated (cmd%pn_lexpr)) then
	write (u, "(1x,A)") "expect: [expression associated]"
	else
	write (u, "(1x,A)") "expect: [undefined]"
	end if
	end subroutine cmd_expect_write

	@ %def cmd_expect_write
	@ Compile. This merely assigns the parse node, the actual compilation is done
	at execution. This is necessary because the origin of variables
	(local/global) may change during execution.
	<<Commands: cmd expect: TBP>>=
	procedure :: compile => cmd_expect_compile
	<<Commands: procedures>>=
	subroutine cmd_expect_compile (cmd, global)
	class(cmd_expect_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
	cmd%pn_lexpr => parse_node_get_sub_ptr (pn_arg)
	call cmd%compile_options (global)
	end subroutine cmd_expect_compile

	@ %def cmd_expect_compile
	@ Execute. Evaluate both arguments, print them and their difference
	(if numerical), and whether they agree. Record the result.
	<<Commands: cmd expect: TBP>>=
	procedure :: execute => cmd_expect_execute
	<<Commands: procedures>>=
	subroutine cmd_expect_execute (cmd, global)
	class(cmd_expect_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	logical :: success, is_known
	var_list => cmd%local%get_var_list_ptr ()
	success = eval_log (cmd%pn_lexpr, var_list, is_known=is_known)
	if (is_known) then
	if (success) then
	call msg_message ("expect: success")
	else
	call msg_error ("expect: failure")
	end if
	else
	call msg_error ("expect: undefined result")
	success = .false.
	end if
	call expect_record (success)
	end subroutine cmd_expect_execute

	@ %def cmd_expect_execute
	@
	\subsubsection{Beams}
	The beam command includes both beam and structure-function
	definition.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_beams_t
	private
	integer :: n_in = 0
	type(parse_node_p), dimension(:), allocatable :: pn_pdg
	integer :: n_sf_record = 0
	integer, dimension(:), allocatable :: n_entry
	type(parse_node_p), dimension(:,:), allocatable :: pn_sf_entry
	contains
	<<Commands: cmd beams: TBP>>
	end type cmd_beams_t

	@ %def cmd_beams_t
	@ Output. The particle expressions are not resolved.
	<<Commands: cmd beams: TBP>>=
	procedure :: write => cmd_beams_write
	<<Commands: procedures>>=
	subroutine cmd_beams_write (cmd, unit, indent)
	class(cmd_beams_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams: [undefined]"
	end select
	if (allocated (cmd%n_entry)) then
	if (cmd%n_sf_record > 0) then
	write (u, "(1x,A,99(1x,I0))") "structure function entries:", &
	cmd%n_entry
	end if
	end if
	end subroutine cmd_beams_write

	@ %def cmd_beams_write
	@ Compile. Find and assign the parse nodes.

	Note: local environments are not yet supported.
	<<Commands: cmd beams: TBP>>=
	procedure :: compile => cmd_beams_compile
	<<Commands: procedures>>=
	subroutine cmd_beams_compile (cmd, global)
	class(cmd_beams_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_beam_def, pn_beam_spec
	type(parse_node_t), pointer :: pn_beam_list
	type(parse_node_t), pointer :: pn_codes
	type(parse_node_t), pointer :: pn_strfun_seq, pn_strfun_pair
	type(parse_node_t), pointer :: pn_strfun_def
	integer :: i
	pn_beam_def => parse_node_get_sub_ptr (cmd%pn, 3)
	pn_beam_spec => parse_node_get_sub_ptr (pn_beam_def)
	pn_strfun_seq => parse_node_get_next_ptr (pn_beam_spec)
	pn_beam_list => parse_node_get_sub_ptr (pn_beam_spec)
	call cmd%compile_options (global)
	cmd%n_in = parse_node_get_n_sub (pn_beam_list)
	allocate (cmd%pn_pdg (cmd%n_in))
	pn_codes => parse_node_get_sub_ptr (pn_beam_list)
	do i = 1, cmd%n_in
	cmd%pn_pdg(i)%ptr => pn_codes
	pn_codes => parse_node_get_next_ptr (pn_codes)
	end do
	if (associated (pn_strfun_seq)) then
	cmd%n_sf_record = parse_node_get_n_sub (pn_beam_def) - 1
	allocate (cmd%n_entry (cmd%n_sf_record), source = 1)
	allocate (cmd%pn_sf_entry (2, cmd%n_sf_record))
	do i = 1, cmd%n_sf_record
	pn_strfun_pair => parse_node_get_sub_ptr (pn_strfun_seq, 2)
	pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair)
	cmd%pn_sf_entry(1,i)%ptr => pn_strfun_def
	pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def)
	cmd%pn_sf_entry(2,i)%ptr => pn_strfun_def
	if (associated (pn_strfun_def)) cmd%n_entry(i) = 2
	pn_strfun_seq => parse_node_get_next_ptr (pn_strfun_seq)
	end do
	else
	allocate (cmd%n_entry (0))
	allocate (cmd%pn_sf_entry (0, 0))
	end if
	end subroutine cmd_beams_compile

	@ %def cmd_beams_compile
	@ Command execution: Determine beam particles and structure-function
	names, if any. The results are stored in the [[beam_structure]]
	component of the [[global]] data block.
	<<Commands: cmd beams: TBP>>=
	procedure :: execute => cmd_beams_execute
	<<Commands: procedures>>=
	subroutine cmd_beams_execute (cmd, global)
	class(cmd_beams_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(pdg_array_t) :: pdg_array
	integer, dimension(:), allocatable :: pdg
	type(flavor_t), dimension(:), allocatable :: flv
	type(parse_node_t), pointer :: pn_key
	type(string_t) :: sf_name
	integer :: i, j
	call lhapdf_global_reset ()
	var_list => cmd%local%get_var_list_ptr ()
	allocate (flv (cmd%n_in))
	do i = 1, cmd%n_in
	pdg_array = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
	pdg = pdg_array
	select case (size (pdg))
	case (1)
	call flv(i)%init ( pdg(1), cmd%local%model)
	case default
	call msg_fatal ("Beams: beam particles must be unique")
	end select
	end do
	select case (cmd%n_in)
	case (1)
	if (cmd%n_sf_record > 0) then
	call msg_fatal ("Beam setup: no structure functions allowed &
	&for decay")
	end if
	call global%beam_structure%init_sf (flv%get_name ())
	case (2)
	call global%beam_structure%init_sf (flv%get_name (), cmd%n_entry)
	do i = 1, cmd%n_sf_record
	do j = 1, cmd%n_entry(i)
	pn_key => parse_node_get_sub_ptr (cmd%pn_sf_entry(j,i)%ptr)
	sf_name = parse_node_get_key (pn_key)
	call global%beam_structure%set_sf (i, j, sf_name)
	end do
	end do
	end select
	end subroutine cmd_beams_execute

	@ %def cmd_beams_execute
	@
	\subsubsection{Density matrices for beam polarization}
	For holding beam polarization, we define a notation and a data
	structure for sparse matrices. The entries (and the index
	expressions) are numerical expressions, so we use evaluation trees.

	Each entry in the sparse matrix is an n-tuple of expressions. The first
	tuple elements represent index values, the last one is an arbitrary
	(complex) number. Absent expressions are replaced by default-value rules.

	Note: Here, and in some other commands, we would like to store an evaluation
	tree, not just a parse node pointer. However, the current expression handler
	wants all variables defined, so the evaluation tree can only be built by
	[[evaluate]], i.e., compiled just-in-time and evaluated immediately.
	<<Commands: types>>=
	type :: sentry_expr_t
	type(parse_node_p), dimension(:), allocatable :: expr
	contains
	<<Commands: sentry expr: TBP>>
	end type sentry_expr_t

	@ %def sentry_expr_t
	@ Compile parse nodes into evaluation trees.
	<<Commands: sentry expr: TBP>>=
	procedure :: compile => sentry_expr_compile
	<<Commands: procedures>>=
	subroutine sentry_expr_compile (sentry, pn)
	class(sentry_expr_t), intent(out) :: sentry
	type(parse_node_t), intent(in), target :: pn
	type(parse_node_t), pointer :: pn_expr, pn_extra
	integer :: n_expr, i
	n_expr = parse_node_get_n_sub (pn)
	allocate (sentry%expr (n_expr))
	if (n_expr > 0) then
	i = 0
	pn_expr => parse_node_get_sub_ptr (pn)
	pn_extra => parse_node_get_next_ptr (pn_expr)
	do i = 1, n_expr
	sentry%expr(i)%ptr => pn_expr
	if (associated (pn_extra)) then
	pn_expr => parse_node_get_sub_ptr (pn_extra, 2)
	pn_extra => parse_node_get_next_ptr (pn_extra)
	end if
	end do
	end if
	end subroutine sentry_expr_compile

	@ %def sentry_expr_compile
	@ Evaluate the expressions and return an index array of predefined
	length together with a complex value. If the value (as the last expression)
	is undefined, set it to unity. If index values are undefined, repeat
	the previous index value.
	<<Commands: sentry expr: TBP>>=
	procedure :: evaluate => sentry_expr_evaluate
	<<Commands: procedures>>=
	subroutine sentry_expr_evaluate (sentry, index, value, global)
	class(sentry_expr_t), intent(inout) :: sentry
	integer, dimension(:), intent(out) :: index
	complex(default), intent(out) :: value
	type(rt_data_t), intent(in), target :: global
	type(var_list_t), pointer :: var_list
	integer :: i, n_expr, n_index
	type(eval_tree_t) :: eval_tree
	var_list => global%get_var_list_ptr ()
	n_expr = size (sentry%expr)
	n_index = size (index)
	if (n_expr <= n_index + 1) then
	do i = 1, min (n_expr, n_index)
	associate (expr => sentry%expr(i))
	call eval_tree%init_expr (expr%ptr, var_list)
	call eval_tree%evaluate ()
	if (eval_tree%is_known ()) then
	index(i) = eval_tree%get_int ()
	else
	call msg_fatal ("Evaluating density matrix: undefined index")
	end if
	end associate
	end do
	do i = n_expr + 1, n_index
	index(i) = index(n_expr)
	end do
	if (n_expr == n_index + 1) then
	associate (expr => sentry%expr(n_expr))
	call eval_tree%init_expr (expr%ptr, var_list)
	call eval_tree%evaluate ()
	if (eval_tree%is_known ()) then
	value = eval_tree%get_cmplx ()
	else
	call msg_fatal ("Evaluating density matrix: undefined index")
	end if
	call eval_tree%final ()
	end associate
	else
	value = 1
	end if
	else
	call msg_fatal ("Evaluating density matrix: index expression too long")
	end if
	end subroutine sentry_expr_evaluate

	@ %def sentry_expr_evaluate
	@ The sparse matrix itself consists of an arbitrary number of entries.
	<<Commands: types>>=
	type :: smatrix_expr_t
	type(sentry_expr_t), dimension(:), allocatable :: entry
	contains
	<<Commands: smatrix expr: TBP>>
	end type smatrix_expr_t

	@ %def smatrix_expr_t
	@ Compile: assign sub-nodes to sentry-expressions and compile those.
	<<Commands: smatrix expr: TBP>>=
	procedure :: compile => smatrix_expr_compile
	<<Commands: procedures>>=
	subroutine smatrix_expr_compile (smatrix_expr, pn)
	class(smatrix_expr_t), intent(out) :: smatrix_expr
	type(parse_node_t), intent(in), target :: pn
	type(parse_node_t), pointer :: pn_arg, pn_entry
	integer :: n_entry, i
	pn_arg => parse_node_get_sub_ptr (pn, 2)
	if (associated (pn_arg)) then
	n_entry = parse_node_get_n_sub (pn_arg)
	allocate (smatrix_expr%entry (n_entry))
	pn_entry => parse_node_get_sub_ptr (pn_arg)
	do i = 1, n_entry
	call smatrix_expr%entry(i)%compile (pn_entry)
	pn_entry => parse_node_get_next_ptr (pn_entry)
	end do
	else
	allocate (smatrix_expr%entry (0))
	end if
	end subroutine smatrix_expr_compile

	@ %def smatrix_expr_compile
	@ Evaluate the entries and build a new [[smatrix]] object, which
	contains just the numerical results.
	<<Commands: smatrix expr: TBP>>=
	procedure :: evaluate => smatrix_expr_evaluate
	<<Commands: procedures>>=
	subroutine smatrix_expr_evaluate (smatrix_expr, smatrix, global)
	class(smatrix_expr_t), intent(inout) :: smatrix_expr
	type(smatrix_t), intent(out) :: smatrix
	type(rt_data_t), intent(in), target :: global
	integer, dimension(2) :: idx
	complex(default) :: value
	integer :: i, n_entry
	n_entry = size (smatrix_expr%entry)
	call smatrix%init (2, n_entry)
	do i = 1, n_entry
	call smatrix_expr%entry(i)%evaluate (idx, value, global)
	call smatrix%set_entry (i, idx, value)
	end do
	end subroutine smatrix_expr_evaluate

	@ %def smatrix_expr_evaluate
	@
	\subsubsection{Beam polarization density}

	The beam polarization command defines spin density matrix for one or
	two beams (scattering or decay).
	<<Commands: types>>=
	type, extends (command_t) :: cmd_beams_pol_density_t
	private
	integer :: n_in = 0
	type(smatrix_expr_t), dimension(:), allocatable :: smatrix
	contains
	<<Commands: cmd beams pol density: TBP>>
	end type cmd_beams_pol_density_t

	@ %def cmd_beams_pol_density_t
	@ Output.
	<<Commands: cmd beams pol density: TBP>>=
	procedure :: write => cmd_beams_pol_density_write
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_density_write (cmd, unit, indent)
	class(cmd_beams_pol_density_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams polarization setup: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams polarization setup: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams polarization setup: [undefined]"
	end select
	end subroutine cmd_beams_pol_density_write

	@ %def cmd_beams_pol_density_write
	@ Compile. Find and assign the parse nodes.

	Note: local environments are not yet supported.
	<<Commands: cmd beams pol density: TBP>>=
	procedure :: compile => cmd_beams_pol_density_compile
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_density_compile (cmd, global)
	class(cmd_beams_pol_density_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_pol_spec, pn_smatrix
	integer :: i
	pn_pol_spec => parse_node_get_sub_ptr (cmd%pn, 3)
	call cmd%compile_options (global)
	cmd%n_in = parse_node_get_n_sub (pn_pol_spec)
	allocate (cmd%smatrix (cmd%n_in))
	pn_smatrix => parse_node_get_sub_ptr (pn_pol_spec)
	do i = 1, cmd%n_in
	call cmd%smatrix(i)%compile (pn_smatrix)
	pn_smatrix => parse_node_get_next_ptr (pn_smatrix)
	end do
	end subroutine cmd_beams_pol_density_compile

	@ %def cmd_beams_pol_density_compile
	@ Command execution: Fill polarization density matrices. No check
	yet, the matrices are checked and normalized when the actual beam
	object is created, just before integration. For intermediate storage,
	we use the [[beam_structure]] object in the [[global]] data set.
	<<Commands: cmd beams pol density: TBP>>=
	procedure :: execute => cmd_beams_pol_density_execute
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_density_execute (cmd, global)
	class(cmd_beams_pol_density_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(smatrix_t) :: smatrix
	integer :: i
	call global%beam_structure%init_pol (cmd%n_in)
	do i = 1, cmd%n_in
	call cmd%smatrix(i)%evaluate (smatrix, global)
	call global%beam_structure%set_smatrix (i, smatrix)
	end do
	end subroutine cmd_beams_pol_density_execute

	@ %def cmd_beams_pol_density_execute
	@
	\subsubsection{Beam polarization fraction}
	In addition to the polarization density matrix, we can independently
	specify the polarization fraction for one or both beams.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_beams_pol_fraction_t
	private
	integer :: n_in = 0
	type(parse_node_p), dimension(:), allocatable :: expr
	contains
	<<Commands: cmd beams pol fraction: TBP>>
	end type cmd_beams_pol_fraction_t

	@ %def cmd_beams_pol_fraction_t
	@ Output.
	<<Commands: cmd beams pol fraction: TBP>>=
	procedure :: write => cmd_beams_pol_fraction_write
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_fraction_write (cmd, unit, indent)
	class(cmd_beams_pol_fraction_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams polarization fraction: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams polarization fraction: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams polarization fraction: [undefined]"
	end select
	end subroutine cmd_beams_pol_fraction_write

	@ %def cmd_beams_pol_fraction_write
	@ Compile. Find and assign the parse nodes.

	Note: local environments are not yet supported.
	<<Commands: cmd beams pol fraction: TBP>>=
	procedure :: compile => cmd_beams_pol_fraction_compile
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_fraction_compile (cmd, global)
	class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_frac_spec, pn_expr
	integer :: i
	pn_frac_spec => parse_node_get_sub_ptr (cmd%pn, 3)
	call cmd%compile_options (global)
	cmd%n_in = parse_node_get_n_sub (pn_frac_spec)
	allocate (cmd%expr (cmd%n_in))
	pn_expr => parse_node_get_sub_ptr (pn_frac_spec)
	do i = 1, cmd%n_in
	cmd%expr(i)%ptr => pn_expr
	pn_expr => parse_node_get_next_ptr (pn_expr)
	end do
	end subroutine cmd_beams_pol_fraction_compile

	@ %def cmd_beams_pol_fraction_compile
	@ Command execution: Retrieve the numerical values of the beam
	polarization fractions. The results are stored in the
	[[beam_structure]] component of the [[global]] data block.
	<<Commands: cmd beams pol fraction: TBP>>=
	procedure :: execute => cmd_beams_pol_fraction_execute
	<<Commands: procedures>>=
	subroutine cmd_beams_pol_fraction_execute (cmd, global)
	class(cmd_beams_pol_fraction_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default), dimension(:), allocatable :: pol_f
	type(eval_tree_t) :: expr
	integer :: i
	var_list => global%get_var_list_ptr ()
	allocate (pol_f (cmd%n_in))
	do i = 1, cmd%n_in
	call expr%init_expr (cmd%expr(i)%ptr, var_list)
	call expr%evaluate ()
	if (expr%is_known ()) then
	pol_f(i) = expr%get_real ()
	else
	call msg_fatal ("beams polarization fraction: undefined value")
	end if
	call expr%final ()
	end do
	call global%beam_structure%set_pol_f (pol_f)
	end subroutine cmd_beams_pol_fraction_execute

	@ %def cmd_beams_pol_fraction_execute
	@
	\subsubsection{Beam momentum}
	This is completely analogous to the previous command, hence we can use
	inheritance.
	<<Commands: types>>=
	type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_momentum_t
	contains
	<<Commands: cmd beams momentum: TBP>>
	end type cmd_beams_momentum_t

	@ %def cmd_beams_momentum_t
	@ Output.
	<<Commands: cmd beams momentum: TBP>>=
	procedure :: write => cmd_beams_momentum_write
	<<Commands: procedures>>=
	subroutine cmd_beams_momentum_write (cmd, unit, indent)
	class(cmd_beams_momentum_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams momentum: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams momentum: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams momentum: [undefined]"
	end select
	end subroutine cmd_beams_momentum_write

	@ %def cmd_beams_momentum_write
	@ Compile: inherited.

	Command execution: Not inherited, but just the error string and the final
	command are changed.
	<<Commands: cmd beams momentum: TBP>>=
	procedure :: execute => cmd_beams_momentum_execute
	<<Commands: procedures>>=
	subroutine cmd_beams_momentum_execute (cmd, global)
	class(cmd_beams_momentum_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default), dimension(:), allocatable :: p
	type(eval_tree_t) :: expr
	integer :: i
	var_list => global%get_var_list_ptr ()
	allocate (p (cmd%n_in))
	do i = 1, cmd%n_in
	call expr%init_expr (cmd%expr(i)%ptr, var_list)
	call expr%evaluate ()
	if (expr%is_known ()) then
	p(i) = expr%get_real ()
	else
	call msg_fatal ("beams momentum: undefined value")
	end if
	call expr%final ()
	end do
	call global%beam_structure%set_momentum (p)
	end subroutine cmd_beams_momentum_execute

	@ %def cmd_beams_momentum_execute
	@
	\subsubsection{Beam angles}
	Again, this is analogous. There are two angles, polar angle $\theta$
	and azimuthal angle $\phi$, which can be set independently for both beams.
	<<Commands: types>>=
	type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_theta_t
	contains
	<<Commands: cmd beams theta: TBP>>
	end type cmd_beams_theta_t

	type, extends (cmd_beams_pol_fraction_t) :: cmd_beams_phi_t
	contains
	<<Commands: cmd beams phi: TBP>>
	end type cmd_beams_phi_t

	@ %def cmd_beams_theta_t
	@ %def cmd_beams_phi_t
	@ Output.
	<<Commands: cmd beams theta: TBP>>=
	procedure :: write => cmd_beams_theta_write
	<<Commands: cmd beams phi: TBP>>=
	procedure :: write => cmd_beams_phi_write
	<<Commands: procedures>>=
	subroutine cmd_beams_theta_write (cmd, unit, indent)
	class(cmd_beams_theta_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams theta: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams theta: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams theta: [undefined]"
	end select
	end subroutine cmd_beams_theta_write

	subroutine cmd_beams_phi_write (cmd, unit, indent)
	class(cmd_beams_phi_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_in)
	case (1)
	write (u, "(1x,A)") "beams phi: 1 [decay]"
	case (2)
	write (u, "(1x,A)") "beams phi: 2 [scattering]"
	case default
	write (u, "(1x,A)") "beams phi: [undefined]"
	end select
	end subroutine cmd_beams_phi_write

	@ %def cmd_beams_theta_write
	@ %def cmd_beams_phi_write
	@ Compile: inherited.

	Command execution: Not inherited, but just the error string and the final
	command are changed.
	<<Commands: cmd beams theta: TBP>>=
	procedure :: execute => cmd_beams_theta_execute
	<<Commands: cmd beams phi: TBP>>=
	procedure :: execute => cmd_beams_phi_execute
	<<Commands: procedures>>=
	subroutine cmd_beams_theta_execute (cmd, global)
	class(cmd_beams_theta_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default), dimension(:), allocatable :: theta
	type(eval_tree_t) :: expr
	integer :: i
	var_list => global%get_var_list_ptr ()
	allocate (theta (cmd%n_in))
	do i = 1, cmd%n_in
	call expr%init_expr (cmd%expr(i)%ptr, var_list)
	call expr%evaluate ()
	if (expr%is_known ()) then
	theta(i) = expr%get_real ()
	else
	call msg_fatal ("beams theta: undefined value")
	end if
	call expr%final ()
	end do
	call global%beam_structure%set_theta (theta)
	end subroutine cmd_beams_theta_execute

	subroutine cmd_beams_phi_execute (cmd, global)
	class(cmd_beams_phi_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default), dimension(:), allocatable :: phi
	type(eval_tree_t) :: expr
	integer :: i
	var_list => global%get_var_list_ptr ()
	allocate (phi (cmd%n_in))
	do i = 1, cmd%n_in
	call expr%init_expr (cmd%expr(i)%ptr, var_list)
	call expr%evaluate ()
	if (expr%is_known ()) then
	phi(i) = expr%get_real ()
	else
	call msg_fatal ("beams phi: undefined value")
	end if
	call expr%final ()
	end do
	call global%beam_structure%set_phi (phi)
	end subroutine cmd_beams_phi_execute

	@ %def cmd_beams_theta_execute
	@ %def cmd_beams_phi_execute
	@
	\subsubsection{Cuts}
	Define a cut expression. We store the parse tree for the right-hand
	side instead of compiling it. Compilation is deferred to the process
	environment where the cut expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_cuts_t
	private
	type(parse_node_t), pointer :: pn_lexpr => null ()
	contains
	<<Commands: cmd cuts: TBP>>
	end type cmd_cuts_t

	@ %def cmd_cuts_t
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that cuts have been defined.
	<<Commands: cmd cuts: TBP>>=
	procedure :: write => cmd_cuts_write
	<<Commands: procedures>>=
	subroutine cmd_cuts_write (cmd, unit, indent)
	class(cmd_cuts_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "cuts: [defined]"
	end subroutine cmd_cuts_write

	@ %def cmd_cuts_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd cuts: TBP>>=
	procedure :: compile => cmd_cuts_compile
	<<Commands: procedures>>=
	subroutine cmd_cuts_compile (cmd, global)
	class(cmd_cuts_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_cuts_compile

	@ %def cmd_cuts_compile
	@ Instead of evaluating the cut expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd cuts: TBP>>=
	procedure :: execute => cmd_cuts_execute
	<<Commands: procedures>>=
	subroutine cmd_cuts_execute (cmd, global)
	class(cmd_cuts_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%cuts_lexpr => cmd%pn_lexpr
	end subroutine cmd_cuts_execute

	@ %def cmd_cuts_execute
	@
	\subsubsection{General, Factorization and Renormalization Scales}
	Define a scale expression for either the renormalization or the
	factorization scale. We store the parse tree for the right-hand
	side instead of compiling it. Compilation is deferred to the process
	environment where the expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_scale_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd scale: TBP>>
	end type cmd_scale_t

	@ %def cmd_scale_t
	<<Commands: types>>=
	type, extends (command_t) :: cmd_fac_scale_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd fac scale: TBP>>
	end type cmd_fac_scale_t

	@ %def cmd_fac_scale_t
	<<Commands: types>>=
	type, extends (command_t) :: cmd_ren_scale_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd ren scale: TBP>>
	end type cmd_ren_scale_t

	@ %def cmd_ren_scale_t
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that scale, renormalization and factorization have been
	defined, respectively.
	<<Commands: cmd scale: TBP>>=
	procedure :: write => cmd_scale_write
	<<Commands: procedures>>=
	subroutine cmd_scale_write (cmd, unit, indent)
	class(cmd_scale_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "scale: [defined]"
	end subroutine cmd_scale_write

	@ %def cmd_scale_write
	@
	<<Commands: cmd fac scale: TBP>>=
	procedure :: write => cmd_fac_scale_write
	<<Commands: procedures>>=
	subroutine cmd_fac_scale_write (cmd, unit, indent)
	class(cmd_fac_scale_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "factorization scale: [defined]"
	end subroutine cmd_fac_scale_write

	@ %def cmd_fac_scale_write
	@
	<<Commands: cmd ren scale: TBP>>=
	procedure :: write => cmd_ren_scale_write
	<<Commands: procedures>>=
	subroutine cmd_ren_scale_write (cmd, unit, indent)
	class(cmd_ren_scale_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "renormalization scale: [defined]"
	end subroutine cmd_ren_scale_write

	@ %def cmd_ren_scale_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd scale: TBP>>=
	procedure :: compile => cmd_scale_compile
	<<Commands: procedures>>=
	subroutine cmd_scale_compile (cmd, global)
	class(cmd_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_scale_compile

	@ %def cmd_scale_compile
	@
	<<Commands: cmd fac scale: TBP>>=
	procedure :: compile => cmd_fac_scale_compile
	<<Commands: procedures>>=
	subroutine cmd_fac_scale_compile (cmd, global)
	class(cmd_fac_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_fac_scale_compile

	@ %def cmd_fac_scale_compile
	@
	<<Commands: cmd ren scale: TBP>>=
	procedure :: compile => cmd_ren_scale_compile
	<<Commands: procedures>>=
	subroutine cmd_ren_scale_compile (cmd, global)
	class(cmd_ren_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_ren_scale_compile

	@ %def cmd_ren_scale_compile
	@ Instead of evaluating the scale expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd scale: TBP>>=
	procedure :: execute => cmd_scale_execute
	<<Commands: procedures>>=
	subroutine cmd_scale_execute (cmd, global)
	class(cmd_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%scale_expr => cmd%pn_expr
	end subroutine cmd_scale_execute

	@ %def cmd_scale_execute
	@
	<<Commands: cmd fac scale: TBP>>=
	procedure :: execute => cmd_fac_scale_execute
	<<Commands: procedures>>=
	subroutine cmd_fac_scale_execute (cmd, global)
	class(cmd_fac_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%fac_scale_expr => cmd%pn_expr
	end subroutine cmd_fac_scale_execute

	@ %def cmd_fac_scale_execute
	@
	<<Commands: cmd ren scale: TBP>>=
	procedure :: execute => cmd_ren_scale_execute
	<<Commands: procedures>>=
	subroutine cmd_ren_scale_execute (cmd, global)
	class(cmd_ren_scale_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%ren_scale_expr => cmd%pn_expr
	end subroutine cmd_ren_scale_execute

	@ %def cmd_ren_scale_execute
	@
	\subsubsection{Weight}
	Define a weight expression. The weight is applied to a process to be
	integrated, event by event. We store the parse tree for the right-hand
	side instead of compiling it. Compilation is deferred to the process
	environment where the expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_weight_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd weight: TBP>>
	end type cmd_weight_t

	@ %def cmd_weight_t
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that scale, renormalization and factorization have been
	defined, respectively.
	<<Commands: cmd weight: TBP>>=
	procedure :: write => cmd_weight_write
	<<Commands: procedures>>=
	subroutine cmd_weight_write (cmd, unit, indent)
	class(cmd_weight_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "weight expression: [defined]"
	end subroutine cmd_weight_write

	@ %def cmd_weight_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd weight: TBP>>=
	procedure :: compile => cmd_weight_compile
	<<Commands: procedures>>=
	subroutine cmd_weight_compile (cmd, global)
	class(cmd_weight_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_weight_compile

	@ %def cmd_weight_compile
	@ Instead of evaluating the expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd weight: TBP>>=
	procedure :: execute => cmd_weight_execute
	<<Commands: procedures>>=
	subroutine cmd_weight_execute (cmd, global)
	class(cmd_weight_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%weight_expr => cmd%pn_expr
	end subroutine cmd_weight_execute

	@ %def cmd_weight_execute
	@
	\subsubsection{Selection}
	Define a selection expression. This is to be applied upon simulation or
	event-file rescanning, event by event. We store the parse tree for the
	right-hand side instead of compiling it. Compilation is deferred to the
	environment where the expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_selection_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd selection: TBP>>
	end type cmd_selection_t

	@ %def cmd_selection_t
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that scale, renormalization and factorization have been
	defined, respectively.
	<<Commands: cmd selection: TBP>>=
	procedure :: write => cmd_selection_write
	<<Commands: procedures>>=
	subroutine cmd_selection_write (cmd, unit, indent)
	class(cmd_selection_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "selection expression: [defined]"
	end subroutine cmd_selection_write

	@ %def cmd_selection_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd selection: TBP>>=
	procedure :: compile => cmd_selection_compile
	<<Commands: procedures>>=
	subroutine cmd_selection_compile (cmd, global)
	class(cmd_selection_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_selection_compile

	@ %def cmd_selection_compile
	@ Instead of evaluating the expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd selection: TBP>>=
	procedure :: execute => cmd_selection_execute
	<<Commands: procedures>>=
	subroutine cmd_selection_execute (cmd, global)
	class(cmd_selection_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%selection_lexpr => cmd%pn_expr
	end subroutine cmd_selection_execute

	@ %def cmd_selection_execute
	@
	\subsubsection{Reweight}
	Define a reweight expression. This is to be applied upon simulation or
	event-file rescanning, event by event. We store the parse tree for the
	right-hand side instead of compiling it. Compilation is deferred to the
	environment where the expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_reweight_t
	private
	type(parse_node_t), pointer :: pn_expr => null ()
	contains
	<<Commands: cmd reweight: TBP>>
	end type cmd_reweight_t

	@ %def cmd_reweight_t
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that scale, renormalization and factorization have been
	defined, respectively.
	<<Commands: cmd reweight: TBP>>=
	procedure :: write => cmd_reweight_write
	<<Commands: procedures>>=
	subroutine cmd_reweight_write (cmd, unit, indent)
	class(cmd_reweight_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "reweight expression: [defined]"
	end subroutine cmd_reweight_write

	@ %def cmd_reweight_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd reweight: TBP>>=
	procedure :: compile => cmd_reweight_compile
	<<Commands: procedures>>=
	subroutine cmd_reweight_compile (cmd, global)
	class(cmd_reweight_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_expr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_reweight_compile

	@ %def cmd_reweight_compile
	@ Instead of evaluating the expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd reweight: TBP>>=
	procedure :: execute => cmd_reweight_execute
	<<Commands: procedures>>=
	subroutine cmd_reweight_execute (cmd, global)
	class(cmd_reweight_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%reweight_expr => cmd%pn_expr
	end subroutine cmd_reweight_execute

	@ %def cmd_reweight_execute
	@
	\subsubsection{Alternative Simulation Setups}
	Together with simulation, we can re-evaluate event weights in the context of
	alternative setups. The [[cmd_alt_setup_t]] object is designed to hold these
	setups, which are brace-enclosed command lists. Compilation is deferred to
	the simulation environment where the setup expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_alt_setup_t
	private
	type(parse_node_p), dimension(:), allocatable :: setup
	contains
	<<Commands: cmd alt setup: TBP>>
	end type cmd_alt_setup_t

	@ %def cmd_alt_setup_t
	@ Output. Print just a message that the alternative setup list has been
	defined.
	<<Commands: cmd alt setup: TBP>>=
	procedure :: write => cmd_alt_setup_write
	<<Commands: procedures>>=
	subroutine cmd_alt_setup_write (cmd, unit, indent)
	class(cmd_alt_setup_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,I0,A)") "alt_setup: ", size (cmd%setup), " entries"
	end subroutine cmd_alt_setup_write

	@ %def cmd_alt_setup_write
	@ Compile. Store the parse sub-trees in an array.
	<<Commands: cmd alt setup: TBP>>=
	procedure :: compile => cmd_alt_setup_compile
	<<Commands: procedures>>=
	subroutine cmd_alt_setup_compile (cmd, global)
	class(cmd_alt_setup_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_list, pn_setup
	integer :: i
	pn_list => parse_node_get_sub_ptr (cmd%pn, 3)
	if (associated (pn_list)) then
	allocate (cmd%setup (parse_node_get_n_sub (pn_list)))
	i = 1
	pn_setup => parse_node_get_sub_ptr (pn_list)
	do while (associated (pn_setup))
	cmd%setup(i)%ptr => pn_setup
	i = i + 1
	pn_setup => parse_node_get_next_ptr (pn_setup)
	end do
	else
	allocate (cmd%setup (0))
	end if
	end subroutine cmd_alt_setup_compile

	@ %def cmd_alt_setup_compile
	@ Execute. Transfer the array of command lists to the global environment.
	<<Commands: cmd alt setup: TBP>>=
	procedure :: execute => cmd_alt_setup_execute
	<<Commands: procedures>>=
	subroutine cmd_alt_setup_execute (cmd, global)
	class(cmd_alt_setup_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (allocated (global%pn%alt_setup)) deallocate (global%pn%alt_setup)
	allocate (global%pn%alt_setup (size (cmd%setup)))
	global%pn%alt_setup = cmd%setup
	end subroutine cmd_alt_setup_execute

	@ %def cmd_alt_setup_execute
	@
	\subsubsection{Integration}
	Integrate several processes, consecutively with identical parameters.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_integrate_t
	private
	integer :: n_proc = 0
	type(string_t), dimension(:), allocatable :: process_id
	contains
	<<Commands: cmd integrate: TBP>>
	end type cmd_integrate_t

	@ %def cmd_integrate_t
	@ Output: we know the process IDs.
	<<Commands: cmd integrate: TBP>>=
	procedure :: write => cmd_integrate_write
	<<Commands: procedures>>=
	subroutine cmd_integrate_write (cmd, unit, indent)
	class(cmd_integrate_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "integrate ("
	do i = 1, cmd%n_proc
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (cmd%process_id(i))
	end do
	write (u, "(A)") ")"
	end subroutine cmd_integrate_write

	@ %def cmd_integrate_write
	@ Compile.
	<<Commands: cmd integrate: TBP>>=
	procedure :: compile => cmd_integrate_compile
	<<Commands: procedures>>=
	subroutine cmd_integrate_compile (cmd, global)
	class(cmd_integrate_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_proclist, pn_proc
	integer :: i
	pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
	call cmd%compile_options (global)
	cmd%n_proc = parse_node_get_n_sub (pn_proclist)
	allocate (cmd%process_id (cmd%n_proc))
	pn_proc => parse_node_get_sub_ptr (pn_proclist)
	do i = 1, cmd%n_proc
	cmd%process_id(i) = parse_node_get_string (pn_proc)
	call global%process_stack%init_result_vars (cmd%process_id(i))
	pn_proc => parse_node_get_next_ptr (pn_proc)
	end do
	end subroutine cmd_integrate_compile

	@ %def cmd_integrate_compile
	@ Command execution. Integrate the process(es) with the predefined number
	of passes, iterations and calls. For structure functions, cuts,
	weight and scale, use local definitions if present; by default, the local
	definitions are initialized with the global ones.

	The [[integrate]] procedure should take its input from the currently
	active local environment, but produce a process record in the stack of
	the global environment.

	Since the process acquires a snapshot of the variable list, so if the global
	list (or the local one) is deleted, this does no harm. This implies that
	later changes of the variable list do not affect the stored process.
	<<Commands: cmd integrate: TBP>>=
	procedure :: execute => cmd_integrate_execute
	<<Commands: procedures>>=
	subroutine cmd_integrate_execute (cmd, global)
	class(cmd_integrate_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	integer :: i
	if (debug_on) call msg_debug (D_CORE, "cmd_integrate_execute")
	do i = 1, cmd%n_proc
	if (debug_on) call msg_debug (D_CORE, "cmd%process_id(i) ", cmd%process_id(i))
	call integrate_process (cmd%process_id(i), cmd%local, global)
	call global%process_stack%fill_result_vars (cmd%process_id(i))
	call global%process_stack%update_result_vars &
	(cmd%process_id(i), global%var_list)
	if (signal_is_pending ()) return
	end do
	end subroutine cmd_integrate_execute

	@ %def cmd_integrate_execute
	@
	\subsubsection{Observables}
	Declare an observable. After the declaration, it can be used to
	record data, and at the end one can retrieve average and error.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_observable_t
	private
	type(string_t) :: id
	contains
	<<Commands: cmd observable: TBP>>
	end type cmd_observable_t

	@ %def cmd_observable_t
	@ Output. We know the ID.
	<<Commands: cmd observable: TBP>>=
	procedure :: write => cmd_observable_write
	<<Commands: procedures>>=
	subroutine cmd_observable_write (cmd, unit, indent)
	class(cmd_observable_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A)") "observable: ", char (cmd%id)
	end subroutine cmd_observable_write

	@ %def cmd_observable_write
	@ Compile. Just record the observable ID.
	<<Commands: cmd observable: TBP>>=
	procedure :: compile => cmd_observable_compile
	<<Commands: procedures>>=
	subroutine cmd_observable_compile (cmd, global)
	class(cmd_observable_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_tag
	pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (pn_tag)) then
	cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
	end if
	call cmd%compile_options (global)
	select case (char (parse_node_get_rule_key (pn_tag)))
	case ("analysis_id")
	cmd%id = parse_node_get_string (pn_tag)
	case default
	call msg_bug ("observable: name expression not implemented (yet)")
	end select
	end subroutine cmd_observable_compile

	@ %def cmd_observable_compile
	@ Command execution. This declares the observable and allocates it in
	the analysis store.
	<<Commands: cmd observable: TBP>>=
	procedure :: execute => cmd_observable_execute
	<<Commands: procedures>>=
	subroutine cmd_observable_execute (cmd, global)
	class(cmd_observable_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(graph_options_t) :: graph_options
	type(string_t) :: label, unit
	var_list => cmd%local%get_var_list_ptr ()
	label = var_list%get_sval (var_str ("$obs_label"))
	unit = var_list%get_sval (var_str ("$obs_unit"))
	- call graph_options_init (graph_options)
	+ call graph_options%init ()
	call set_graph_options (graph_options, var_list)
	call analysis_init_observable (cmd%id, label, unit, graph_options)
	end subroutine cmd_observable_execute

	@ %def cmd_observable_execute
	@
	\subsubsection{Histograms}
	Declare a histogram. At minimum, we have to set lower and upper bound
	and bin width.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_histogram_t
	private
	type(string_t) :: id
	type(parse_node_t), pointer :: pn_lower_bound => null ()
	type(parse_node_t), pointer :: pn_upper_bound => null ()
	type(parse_node_t), pointer :: pn_bin_width => null ()
	contains
	<<Commands: cmd histogram: TBP>>
	end type cmd_histogram_t

	@ %def cmd_histogram_t
	@ Output. Just print the ID.
	<<Commands: cmd histogram: TBP>>=
	procedure :: write => cmd_histogram_write
	<<Commands: procedures>>=
	subroutine cmd_histogram_write (cmd, unit, indent)
	class(cmd_histogram_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A)") "histogram: ", char (cmd%id)
	end subroutine cmd_histogram_write

	@ %def cmd_histogram_write
	@ Compile. Record the histogram ID and initialize lower, upper bound
	and bin width.
	<<Commands: cmd histogram: TBP>>=
	procedure :: compile => cmd_histogram_compile
	<<Commands: procedures>>=
	subroutine cmd_histogram_compile (cmd, global)
	class(cmd_histogram_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_tag, pn_args, pn_arg1, pn_arg2, pn_arg3
	character(*), parameter :: e_illegal_use = &
	"illegal usage of 'histogram': insufficient number of arguments"
	pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_args => parse_node_get_next_ptr (pn_tag)
	if (associated (pn_args)) then
	pn_arg1 => parse_node_get_sub_ptr (pn_args)
	if (.not. associated (pn_arg1)) call msg_fatal (e_illegal_use)
	pn_arg2 => parse_node_get_next_ptr (pn_arg1)
	if (.not. associated (pn_arg2)) call msg_fatal (e_illegal_use)
	pn_arg3 => parse_node_get_next_ptr (pn_arg2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_args)
	end if
	call cmd%compile_options (global)
	select case (char (parse_node_get_rule_key (pn_tag)))
	case ("analysis_id")
	cmd%id = parse_node_get_string (pn_tag)
	case default
	call msg_bug ("histogram: name expression not implemented (yet)")
	end select
	cmd%pn_lower_bound => pn_arg1
	cmd%pn_upper_bound => pn_arg2
	cmd%pn_bin_width => pn_arg3
	end subroutine cmd_histogram_compile

	@ %def cmd_histogram_compile
	@ Command execution. This declares the histogram and allocates it in
	the analysis store.
	<<Commands: cmd histogram: TBP>>=
	procedure :: execute => cmd_histogram_execute
	<<Commands: procedures>>=
	subroutine cmd_histogram_execute (cmd, global)
	class(cmd_histogram_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	real(default) :: lower_bound, upper_bound, bin_width
	integer :: bin_number
	logical :: bin_width_is_used, normalize_bins
	type(string_t) :: obs_label, obs_unit
	type(graph_options_t) :: graph_options
	type(drawing_options_t) :: drawing_options

	var_list => cmd%local%get_var_list_ptr ()
	lower_bound = eval_real (cmd%pn_lower_bound, var_list)
	upper_bound = eval_real (cmd%pn_upper_bound, var_list)
	if (associated (cmd%pn_bin_width)) then
	bin_width = eval_real (cmd%pn_bin_width, var_list)
	bin_width_is_used = .true.
	else if (var_list%is_known (var_str ("n_bins"))) then
	bin_number = &
	var_list%get_ival (var_str ("n_bins"))
	bin_width_is_used = .false.
	else
	call msg_error ("Cmd '" // char (cmd%id) // &
	"': neither bin width nor number is defined")
	end if
	normalize_bins = &
	var_list%get_lval (var_str ("?normalize_bins"))
	obs_label = &
	var_list%get_sval (var_str ("$obs_label"))
	obs_unit = &
	var_list%get_sval (var_str ("$obs_unit"))

	- call graph_options_init (graph_options)
	+ call graph_options%init ()
	call set_graph_options (graph_options, var_list)
	- call drawing_options_init_histogram (drawing_options)
	+ call drawing_options%init_histogram ()
	call set_drawing_options (drawing_options, var_list)

	if (bin_width_is_used) then
	call analysis_init_histogram &
	(cmd%id, lower_bound, upper_bound, bin_width, &
	normalize_bins, &
	obs_label, obs_unit, &
	graph_options, drawing_options)
	else
	call analysis_init_histogram &
	(cmd%id, lower_bound, upper_bound, bin_number, &
	normalize_bins, &
	obs_label, obs_unit, &
	graph_options, drawing_options)
	end if
	end subroutine cmd_histogram_execute

	@ %def cmd_histogram_execute
	@ Set the graph options from a variable list.
	<<Commands: procedures>>=
	subroutine set_graph_options (gro, var_list)
	type(graph_options_t), intent(inout) :: gro
	type(var_list_t), intent(in) :: var_list
	- call graph_options_set (gro, title = &
	- var_list%get_sval (var_str ("$title")))
	- call graph_options_set (gro, description = &
	- var_list%get_sval (var_str ("$description")))
	- call graph_options_set (gro, x_label = &
	- var_list%get_sval (var_str ("$x_label")))
	- call graph_options_set (gro, y_label = &
	- var_list%get_sval (var_str ("$y_label")))
	- call graph_options_set (gro, width_mm = &
	- var_list%get_ival (var_str ("graph_width_mm")))
	- call graph_options_set (gro, height_mm = &
	- var_list%get_ival (var_str ("graph_height_mm")))
	- call graph_options_set (gro, x_log = &
	- var_list%get_lval (var_str ("?x_log")))
	- call graph_options_set (gro, y_log = &
	- var_list%get_lval (var_str ("?y_log")))
	+ call gro%set (title = var_list%get_sval (var_str ("$title")))
	+ call gro%set (description = var_list%get_sval (var_str ("$description")))
	+ call gro%set (x_label = var_list%get_sval (var_str ("$x_label")))
	+ call gro%set (y_label = var_list%get_sval (var_str ("$y_label")))
	+ call gro%set (width_mm = var_list%get_ival (var_str ("graph_width_mm")))
	+ call gro%set (height_mm = var_list%get_ival (var_str ("graph_height_mm")))
	+ call gro%set (x_log = var_list%get_lval (var_str ("?x_log")))
	+ call gro%set (y_log = var_list%get_lval (var_str ("?y_log")))
	if (var_list%is_known (var_str ("x_min"))) &
	- call graph_options_set (gro, x_min = &
	- var_list%get_rval (var_str ("x_min")))
	+ call gro%set (x_min = var_list%get_rval (var_str ("x_min")))
	if (var_list%is_known (var_str ("x_max"))) &
	- call graph_options_set (gro, x_max = &
	- var_list%get_rval (var_str ("x_max")))
	+ call gro%set (x_max = var_list%get_rval (var_str ("x_max")))
	if (var_list%is_known (var_str ("y_min"))) &
	- call graph_options_set (gro, y_min = &
	- var_list%get_rval (var_str ("y_min")))
	+ call gro%set (y_min = var_list%get_rval (var_str ("y_min")))
	if (var_list%is_known (var_str ("y_max"))) &
	- call graph_options_set (gro, y_max = &
	- var_list%get_rval (var_str ("y_max")))
	- call graph_options_set (gro, gmlcode_bg = &
	- var_list%get_sval (var_str ("$gmlcode_bg")))
	- call graph_options_set (gro, gmlcode_fg = &
	- var_list%get_sval (var_str ("$gmlcode_fg")))
	+ call gro%set (y_max = var_list%get_rval (var_str ("y_max")))
	+ call gro%set (gmlcode_bg = var_list%get_sval (var_str ("$gmlcode_bg")))
	+ call gro%set (gmlcode_fg = var_list%get_sval (var_str ("$gmlcode_fg")))
	end subroutine set_graph_options

	@ %def set_graph_options
	@ Set the drawing options from a variable list.
	<<Commands: procedures>>=
	subroutine set_drawing_options (dro, var_list)
	type(drawing_options_t), intent(inout) :: dro
	type(var_list_t), intent(in) :: var_list
	if (var_list%is_known (var_str ("?draw_histogram"))) then
	if (var_list%get_lval (var_str ("?draw_histogram"))) then
	- call drawing_options_set (dro, with_hbars = .true.)
	+ call dro%set (with_hbars = .true.)
	else
	- call drawing_options_set (dro, with_hbars = .false., &
	+ call dro%set (with_hbars = .false., &
	with_base = .false., fill = .false., piecewise = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?draw_base"))) then
	if (var_list%get_lval (var_str ("?draw_base"))) then
	- call drawing_options_set (dro, with_base = .true.)
	+ call dro%set (with_base = .true.)
	else
	- call drawing_options_set (dro, with_base = .false., fill = .false.)
	+ call dro%set (with_base = .false., fill = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?draw_piecewise"))) then
	if (var_list%get_lval (var_str ("?draw_piecewise"))) then
	- call drawing_options_set (dro, piecewise = .true.)
	+ call dro%set (piecewise = .true.)
	else
	- call drawing_options_set (dro, piecewise = .false.)
	+ call dro%set (piecewise = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?fill_curve"))) then
	if (var_list%get_lval (var_str ("?fill_curve"))) then
	- call drawing_options_set (dro, fill = .true., with_base = .true.)
	+ call dro%set (fill = .true., with_base = .true.)
	else
	- call drawing_options_set (dro, fill = .false.)
	+ call dro%set (fill = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?draw_curve"))) then
	if (var_list%get_lval (var_str ("?draw_curve"))) then
	- call drawing_options_set (dro, draw = .true.)
	+ call dro%set (draw = .true.)
	else
	- call drawing_options_set (dro, draw = .false.)
	+ call dro%set (draw = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?draw_errors"))) then
	if (var_list%get_lval (var_str ("?draw_errors"))) then
	- call drawing_options_set (dro, err = .true.)
	+ call dro%set (err = .true.)
	else
	- call drawing_options_set (dro, err = .false.)
	+ call dro%set (err = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("?draw_symbols"))) then
	if (var_list%get_lval (var_str ("?draw_symbols"))) then
	- call drawing_options_set (dro, symbols = .true.)
	+ call dro%set (symbols = .true.)
	else
	- call drawing_options_set (dro, symbols = .false.)
	+ call dro%set (symbols = .false.)
	end if
	end if
	if (var_list%is_known (var_str ("$fill_options"))) then
	- call drawing_options_set (dro, fill_options = &
	+ call dro%set (fill_options = &
	var_list%get_sval (var_str ("$fill_options")))
	end if
	if (var_list%is_known (var_str ("$draw_options"))) then
	- call drawing_options_set (dro, draw_options = &
	+ call dro%set (draw_options = &
	var_list%get_sval (var_str ("$draw_options")))
	end if
	if (var_list%is_known (var_str ("$err_options"))) then
	- call drawing_options_set (dro, err_options = &
	+ call dro%set (err_options = &
	var_list%get_sval (var_str ("$err_options")))
	end if
	if (var_list%is_known (var_str ("$symbol"))) then
	- call drawing_options_set (dro, symbol = &
	+ call dro%set (symbol = &
	var_list%get_sval (var_str ("$symbol")))
	end if
	if (var_list%is_known (var_str ("$gmlcode_bg"))) then
	- call drawing_options_set (dro, gmlcode_bg = &
	+ call dro%set (gmlcode_bg = &
	var_list%get_sval (var_str ("$gmlcode_bg")))
	end if
	if (var_list%is_known (var_str ("$gmlcode_fg"))) then
	- call drawing_options_set (dro, gmlcode_fg = &
	+ call dro%set (gmlcode_fg = &
	var_list%get_sval (var_str ("$gmlcode_fg")))
	end if
	end subroutine set_drawing_options

	@ %def set_drawing_options
	@
	\subsubsection{Plots}
	Declare a plot. No mandatory arguments, just options.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_plot_t
	private
	type(string_t) :: id
	contains
	<<Commands: cmd plot: TBP>>
	end type cmd_plot_t

	@ %def cmd_plot_t
	@ Output. Just print the ID.
	<<Commands: cmd plot: TBP>>=
	procedure :: write => cmd_plot_write
	<<Commands: procedures>>=
	subroutine cmd_plot_write (cmd, unit, indent)
	class(cmd_plot_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A)") "plot: ", char (cmd%id)
	end subroutine cmd_plot_write

	@ %def cmd_plot_write
	@ Compile. Record the plot ID and initialize lower, upper bound
	and bin width.
	<<Commands: cmd plot: TBP>>=
	procedure :: compile => cmd_plot_compile
	<<Commands: procedures>>=
	subroutine cmd_plot_compile (cmd, global)
	class(cmd_plot_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_tag
	pn_tag => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
	call cmd%init (pn_tag, global)
	end subroutine cmd_plot_compile

	@ %def cmd_plot_compile
	@ This init routine is separated because it is reused below for graph
	initialization.
	<<Commands: cmd plot: TBP>>=
	procedure :: init => cmd_plot_init
	<<Commands: procedures>>=
	subroutine cmd_plot_init (plot, pn_tag, global)
	class(cmd_plot_t), intent(inout) :: plot
	type(parse_node_t), intent(in), pointer :: pn_tag
	type(rt_data_t), intent(inout), target :: global
	call plot%compile_options (global)
	select case (char (parse_node_get_rule_key (pn_tag)))
	case ("analysis_id")
	plot%id = parse_node_get_string (pn_tag)
	case default
	call msg_bug ("plot: name expression not implemented (yet)")
	end select
	end subroutine cmd_plot_init

	@ %def cmd_plot_init
	@ Command execution. This declares the plot and allocates it in
	the analysis store.
	<<Commands: cmd plot: TBP>>=
	procedure :: execute => cmd_plot_execute
	<<Commands: procedures>>=
	subroutine cmd_plot_execute (cmd, global)
	class(cmd_plot_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(graph_options_t) :: graph_options
	type(drawing_options_t) :: drawing_options

	var_list => cmd%local%get_var_list_ptr ()
	- call graph_options_init (graph_options)
	+ call graph_options%init ()
	call set_graph_options (graph_options, var_list)
	- call drawing_options_init_plot (drawing_options)
	+ call drawing_options%init_plot ()
	call set_drawing_options (drawing_options, var_list)

	call analysis_init_plot (cmd%id, graph_options, drawing_options)
	end subroutine cmd_plot_execute

	@ %def cmd_plot_execute
	@
	\subsubsection{Graphs}
	Declare a graph. The graph is defined in terms of its contents. Both the
	graph and its contents may carry options.

	The graph object contains its own ID as well as the IDs of its elements. For
	the elements, we reuse the [[cmd_plot_t]] defined above.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_graph_t
	private
	type(string_t) :: id
	integer :: n_elements = 0
	type(cmd_plot_t), dimension(:), allocatable :: el
	type(string_t), dimension(:), allocatable :: element_id
	contains
	<<Commands: cmd graph: TBP>>
	end type cmd_graph_t

	@ %def cmd_graph_t
	@ Output. Just print the ID.
	<<Commands: cmd graph: TBP>>=
	procedure :: write => cmd_graph_write
	<<Commands: procedures>>=
	subroutine cmd_graph_write (cmd, unit, indent)
	class(cmd_graph_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,A,A,I0,A)") "graph: ", char (cmd%id), &
	" (", cmd%n_elements, " entries)"
	end subroutine cmd_graph_write

	@ %def cmd_graph_write
	@ Compile. Record the graph ID and initialize lower, upper bound
	and bin width. For compiling the graph element syntax, we use part of the
	[[cmd_plot_t]] compiler.

	Note: currently, we do not respect options, therefore just IDs on the RHS.
	<<Commands: cmd graph: TBP>>=
	procedure :: compile => cmd_graph_compile
	<<Commands: procedures>>=
	subroutine cmd_graph_compile (cmd, global)
	class(cmd_graph_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_term, pn_tag, pn_def, pn_app
	integer :: i

	pn_term => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_tag => parse_node_get_sub_ptr (pn_term)
	cmd%pn_opt => parse_node_get_next_ptr (pn_tag)
	call cmd%compile_options (global)
	select case (char (parse_node_get_rule_key (pn_tag)))
	case ("analysis_id")
	cmd%id = parse_node_get_string (pn_tag)
	case default
	call msg_bug ("graph: name expression not implemented (yet)")
	end select
	pn_def => parse_node_get_next_ptr (pn_term, 2)
	cmd%n_elements = parse_node_get_n_sub (pn_def)
	allocate (cmd%element_id (cmd%n_elements))
	allocate (cmd%el (cmd%n_elements))
	pn_term => parse_node_get_sub_ptr (pn_def)
	pn_tag => parse_node_get_sub_ptr (pn_term)
	cmd%el(1)%pn_opt => parse_node_get_next_ptr (pn_tag)
	call cmd%el(1)%init (pn_tag, global)
	cmd%element_id(1) = parse_node_get_string (pn_tag)
	pn_app => parse_node_get_next_ptr (pn_term)
	do i = 2, cmd%n_elements
	pn_term => parse_node_get_sub_ptr (pn_app, 2)
	pn_tag => parse_node_get_sub_ptr (pn_term)
	cmd%el(i)%pn_opt => parse_node_get_next_ptr (pn_tag)
	call cmd%el(i)%init (pn_tag, global)
	cmd%element_id(i) = parse_node_get_string (pn_tag)
	pn_app => parse_node_get_next_ptr (pn_app)
	end do

	end subroutine cmd_graph_compile

	@ %def cmd_graph_compile
	@ Command execution. This declares the graph, allocates it in
	the analysis store, and copies the graph elements.

	For the graph, we set graph and default drawing options. For the elements, we
	reset individual drawing options.

	This accesses internals of the contained elements of type [[cmd_plot_t]], see
	above. We might disentangle such an interdependency when this code is
	rewritten using proper type extension.
	<<Commands: cmd graph: TBP>>=
	procedure :: execute => cmd_graph_execute
	<<Commands: procedures>>=
	subroutine cmd_graph_execute (cmd, global)
	class(cmd_graph_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(graph_options_t) :: graph_options
	type(drawing_options_t) :: drawing_options
	integer :: i, type

	var_list => cmd%local%get_var_list_ptr ()
	- call graph_options_init (graph_options)
	+ call graph_options%init ()
	call set_graph_options (graph_options, var_list)
	call analysis_init_graph (cmd%id, cmd%n_elements, graph_options)

	do i = 1, cmd%n_elements
	if (associated (cmd%el(i)%options)) then
	call cmd%el(i)%options%execute (cmd%el(i)%local)
	end if
	type = analysis_store_get_object_type (cmd%element_id(i))
	select case (type)
	case (AN_HISTOGRAM)
	- call drawing_options_init_histogram (drawing_options)
	+ call drawing_options%init_histogram ()
	case (AN_PLOT)
	- call drawing_options_init_plot (drawing_options)
	+ call drawing_options%init_plot ()
	end select
	call set_drawing_options (drawing_options, var_list)
	if (associated (cmd%el(i)%options)) then
	call set_drawing_options (drawing_options, cmd%el(i)%local%var_list)
	end if
	call analysis_fill_graph (cmd%id, i, cmd%element_id(i), drawing_options)
	end do
	end subroutine cmd_graph_execute

	@ %def cmd_graph_execute
	@
	\subsubsection{Analysis}
	Hold the analysis ID either as a string or as an expression:
	<<Commands: types>>=
	type :: analysis_id_t
	type(string_t) :: tag
	type(parse_node_t), pointer :: pn_sexpr => null ()
	end type analysis_id_t

	@ %def analysis_id_t
	@ Define the analysis expression. We store the parse tree for the
	right-hand side instead of compiling it. Compilation is deferred to
	the process environment where the analysis expression is used.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_analysis_t
	private
	type(parse_node_t), pointer :: pn_lexpr => null ()
	contains
	<<Commands: cmd analysis: TBP>>
	end type cmd_analysis_t

	@ %def cmd_analysis_t
	@ Output. Print just a message that analysis has been defined.
	<<Commands: cmd analysis: TBP>>=
	procedure :: write => cmd_analysis_write
	<<Commands: procedures>>=
	subroutine cmd_analysis_write (cmd, unit, indent)
	class(cmd_analysis_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "analysis: [defined]"
	end subroutine cmd_analysis_write

	@ %def cmd_analysis_write
	@ Compile. Simply store the parse (sub)tree.
	<<Commands: cmd analysis: TBP>>=
	procedure :: compile => cmd_analysis_compile
	<<Commands: procedures>>=
	subroutine cmd_analysis_compile (cmd, global)
	class(cmd_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 3)
	end subroutine cmd_analysis_compile

	@ %def cmd_analysis_compile
	@ Instead of evaluating the cut expression, link the parse tree to the
	global data set, such that it is compiled and executed in the
	appropriate process context.
	<<Commands: cmd analysis: TBP>>=
	procedure :: execute => cmd_analysis_execute
	<<Commands: procedures>>=
	subroutine cmd_analysis_execute (cmd, global)
	class(cmd_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	global%pn%analysis_lexpr => cmd%pn_lexpr
	end subroutine cmd_analysis_execute

	@ %def cmd_analysis_execute
	@
	\subsubsection{Write histograms and plots}
	The data type encapsulating the command:
	<<Commands: types>>=
	type, extends (command_t) :: cmd_write_analysis_t
	private
	type(analysis_id_t), dimension(:), allocatable :: id
	type(string_t), dimension(:), allocatable :: tag
	contains
	<<Commands: cmd write analysis: TBP>>
	end type cmd_write_analysis_t

	@ %def analysis_id_t
	@ %def cmd_write_analysis_t
	@ Output. Just the keyword.
	<<Commands: cmd write analysis: TBP>>=
	procedure :: write => cmd_write_analysis_write
	<<Commands: procedures>>=
	subroutine cmd_write_analysis_write (cmd, unit, indent)
	class(cmd_write_analysis_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "write_analysis"
	end subroutine cmd_write_analysis_write

	@ %def cmd_write_analysis_write
	@ Compile.
	<<Commands: cmd write analysis: TBP>>=
	procedure :: compile => cmd_write_analysis_compile
	<<Commands: procedures>>=
	subroutine cmd_write_analysis_compile (cmd, global)
	class(cmd_write_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
	integer :: n, i
	pn_clause => parse_node_get_sub_ptr (cmd%pn)
	pn_args => parse_node_get_sub_ptr (pn_clause, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
	call cmd%compile_options (global)
	if (associated (pn_args)) then
	n = parse_node_get_n_sub (pn_args)
	allocate (cmd%id (n))
	do i = 1, n
	pn_id => parse_node_get_sub_ptr (pn_args, i)
	if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
	cmd%id(i)%tag = parse_node_get_string (pn_id)
	else
	cmd%id(i)%pn_sexpr => pn_id
	end if
	end do
	else
	allocate (cmd%id (0))
	end if
	end subroutine cmd_write_analysis_compile

	@ %def cmd_write_analysis_compile
	@ The output format for real data values:
	<<Commands: parameters>>=
	character(*), parameter, public :: &
	DEFAULT_ANALYSIS_FILENAME = "whizard_analysis.dat"
	character(len=1), dimension(2), parameter, public :: &
	FORBIDDEN_ENDINGS1 = [ "o", "a" ]
	character(len=2), dimension(6), parameter, public :: &
	FORBIDDEN_ENDINGS2 = [ "mp", "ps", "vg", "pg", "lo", "la" ]
	character(len=3), dimension(18), parameter, public :: &
	FORBIDDEN_ENDINGS3 = [ "aux", "dvi", "evt", "evx", "f03", "f90", &
	"f95", "log", "ltp", "mpx", "olc", "olp", "pdf", "phs", "sin", &
	"tex", "vg2", "vgx" ]

	@ %def DEFAULT_ANALYSIS_FILENAME
	@ %def FORBIDDEN_ENDINGS1
	@ %def FORBIDDEN_ENDINGS2
	@ %def FORBIDDEN_ENDINGS3
	@ As this contains a lot of similar code to [[cmd_compile_analysis_execute]]
	we outsource the main code to a subroutine.
	<<Commands: cmd write analysis: TBP>>=
	procedure :: execute => cmd_write_analysis_execute
	<<Commands: procedures>>=
	subroutine cmd_write_analysis_execute (cmd, global)
	class(cmd_write_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	var_list => cmd%local%get_var_list_ptr ()
	call write_analysis_wrap (var_list, global%out_files, &
	cmd%id, tag = cmd%tag)
	end subroutine cmd_write_analysis_execute

	@ %def cmd_write_analysis_execute
	@ If the [[data_file]] optional argument is present, this is
	called from [[cmd_compile_analysis_execute]], which needs the file name for
	further processing, and requires the default format. For the moment,
	parameters and macros for custom data processing are disabled.
	<<Commands: procedures>>=
	subroutine write_analysis_wrap (var_list, out_files, id, tag, data_file)
	type(var_list_t), intent(inout), target :: var_list
	type(file_list_t), intent(inout), target :: out_files
	type(analysis_id_t), dimension(:), intent(in), target :: id
	type(string_t), dimension(:), allocatable, intent(out) :: tag
	type(string_t), intent(out), optional :: data_file
	type(string_t) :: defaultfile, file
	integer :: i
	logical :: keep_open
	type(string_t) :: extension
	logical :: one_file
	defaultfile = var_list%get_sval (var_str ("$out_file"))
	if (present (data_file)) then
	if (defaultfile == "" .or. defaultfile == ".") then
	defaultfile = DEFAULT_ANALYSIS_FILENAME
	else
	if (scan (".", defaultfile) > 0) then
	call split (defaultfile, extension, ".", back=.true.)
	if (any (lower_case (char(extension)) == FORBIDDEN_ENDINGS1) .or. &
	any (lower_case (char(extension)) == FORBIDDEN_ENDINGS2) .or. &
	any (lower_case (char(extension)) == FORBIDDEN_ENDINGS3)) &
	call msg_fatal ("The ending " // char(extension) // &
	" is internal and not allowed as data file.")
	if (extension /= "") then
	if (defaultfile /= "") then
	defaultfile = defaultfile // "." // extension
	else
	defaultfile = "whizard_analysis." // extension
	end if
	else
	defaultfile = defaultfile // ".dat"
	endif
	else
	defaultfile = defaultfile // ".dat"
	end if
	end if
	data_file = defaultfile
	end if
	one_file = defaultfile /= ""
	if (one_file) then
	file = defaultfile
	keep_open = file_list_is_open (out_files, file, &
	action = "write")
	if (keep_open) then
	if (present (data_file)) then
	call msg_fatal ("Compiling analysis: File '" &
	// char (data_file) &
	// "' can't be used, it is already open.")
	else
	call msg_message ("Appending analysis data to file '" &
	// char (file) // "'")
	end if
	else
	call file_list_open (out_files, file, &
	action = "write", status = "replace", position = "asis")
	call msg_message ("Writing analysis data to file '" &
	// char (file) // "'")
	end if
	end if

	call get_analysis_tags (tag, id, var_list)
	do i = 1, size (tag)
	call file_list_write_analysis &
	(out_files, file, tag(i))
	end do
	if (one_file .and. .not. keep_open) then
	call file_list_close (out_files, file)
	end if

	contains

	subroutine get_analysis_tags (analysis_tag, id, var_list)
	type(string_t), dimension(:), intent(out), allocatable :: analysis_tag
	type(analysis_id_t), dimension(:), intent(in) :: id
	type(var_list_t), intent(in), target :: var_list
	if (size (id) /= 0) then
	allocate (analysis_tag (size (id)))
	do i = 1, size (id)
	if (associated (id(i)%pn_sexpr)) then
	analysis_tag(i) = eval_string (id(i)%pn_sexpr, var_list)
	else
	analysis_tag(i) = id(i)%tag
	end if
	end do
	else
	call analysis_store_get_ids (tag)
	end if
	end subroutine get_analysis_tags

	end subroutine write_analysis_wrap

	@ %def write_analysis_wrap
	\subsubsection{Compile analysis results}
	This command writes files in a form suitable for GAMELAN and executes the
	appropriate commands to compile them. The first part is identical to
	[[cmd_write_analysis]].
	<<Commands: types>>=
	type, extends (command_t) :: cmd_compile_analysis_t
	private
	type(analysis_id_t), dimension(:), allocatable :: id
	type(string_t), dimension(:), allocatable :: tag
	contains
	<<Commands: cmd compile analysis: TBP>>
	end type cmd_compile_analysis_t

	@ %def cmd_compile_analysis_t
	@ Output. Just the keyword.
	<<Commands: cmd compile analysis: TBP>>=
	procedure :: write => cmd_compile_analysis_write
	<<Commands: procedures>>=
	subroutine cmd_compile_analysis_write (cmd, unit, indent)
	class(cmd_compile_analysis_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "compile_analysis"
	end subroutine cmd_compile_analysis_write

	@ %def cmd_compile_analysis_write
	@ Compile.
	<<Commands: cmd compile analysis: TBP>>=
	procedure :: compile => cmd_compile_analysis_compile
	<<Commands: procedures>>=
	subroutine cmd_compile_analysis_compile (cmd, global)
	class(cmd_compile_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_clause, pn_args, pn_id
	integer :: n, i
	pn_clause => parse_node_get_sub_ptr (cmd%pn)
	pn_args => parse_node_get_sub_ptr (pn_clause, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_clause)
	call cmd%compile_options (global)
	if (associated (pn_args)) then
	n = parse_node_get_n_sub (pn_args)
	allocate (cmd%id (n))
	do i = 1, n
	pn_id => parse_node_get_sub_ptr (pn_args, i)
	if (char (parse_node_get_rule_key (pn_id)) == "analysis_id") then
	cmd%id(i)%tag = parse_node_get_string (pn_id)
	else
	cmd%id(i)%pn_sexpr => pn_id
	end if
	end do
	else
	allocate (cmd%id (0))
	end if
	end subroutine cmd_compile_analysis_compile

	@ %def cmd_compile_analysis_compile
	@ First write the analysis data to file, then write a GAMELAN driver and
	produce MetaPost and \TeX\ output.
	<<Commands: cmd compile analysis: TBP>>=
	procedure :: execute => cmd_compile_analysis_execute
	<<Commands: procedures>>=
	subroutine cmd_compile_analysis_execute (cmd, global)
	class(cmd_compile_analysis_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(string_t) :: file, basename, extension, driver_file, &
	makefile
	integer :: u_driver, u_makefile
	logical :: has_gmlcode, only_file
	var_list => cmd%local%get_var_list_ptr ()
	call write_analysis_wrap (var_list, &
	global%out_files, cmd%id, tag = cmd%tag, &
	data_file = file)
	basename = file
	if (scan (".", basename) > 0) then
	call split (basename, extension, ".", back=.true.)
	else
	extension = ""
	end if
	driver_file = basename // ".tex"
	makefile = basename // "_ana.makefile"
	u_driver = free_unit ()
	open (unit=u_driver, file=char(driver_file), &
	action="write", status="replace")
	if (allocated (cmd%tag)) then
	call analysis_write_driver (file, cmd%tag, unit=u_driver)
	has_gmlcode = analysis_has_plots (cmd%tag)
	else
	call analysis_write_driver (file, unit=u_driver)
	has_gmlcode = analysis_has_plots ()
	end if
	close (u_driver)
	u_makefile = free_unit ()
	open (unit=u_makefile, file=char(makefile), &
	action="write", status="replace")
	call analysis_write_makefile (basename, u_makefile, &
	has_gmlcode, global%os_data)
	close (u_makefile)
	call msg_message ("Compiling analysis results display in '" &
	// char (driver_file) // "'")
	call msg_message ("Providing analysis steering makefile '" &
	// char (makefile) // "'")
	only_file = global%var_list%get_lval &
	(var_str ("?analysis_file_only"))
	if (.not. only_file) call analysis_compile_tex &
	(basename, has_gmlcode, global%os_data)
	end subroutine cmd_compile_analysis_execute

	@ %def cmd_compile_analysis_execute
	@
	\subsection{User-controlled output to data files}

	\subsubsection{Open file (output)}
	Open a file for output.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_open_out_t
	private
	type(parse_node_t), pointer :: file_expr => null ()
	contains
	<<Commands: cmd open out: TBP>>
	end type cmd_open_out_t

	@ %def cmd_open_out
	@ Finalizer for the embedded eval tree.
	<<Commands: procedures>>=
	subroutine cmd_open_out_final (object)
	class(cmd_open_out_t), intent(inout) :: object
	end subroutine cmd_open_out_final

	@ %def cmd_open_out_final
	@ Output (trivial here).
	<<Commands: cmd open out: TBP>>=
	procedure :: write => cmd_open_out_write
	<<Commands: procedures>>=
	subroutine cmd_open_out_write (cmd, unit, indent)
	class(cmd_open_out_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "open_out: <filename>"
	end subroutine cmd_open_out_write

	@ %def cmd_open_out_write
	@ Compile: create an eval tree for the filename expression.
	<<Commands: cmd open out: TBP>>=
	procedure :: compile => cmd_open_out_compile
	<<Commands: procedures>>=
	subroutine cmd_open_out_compile (cmd, global)
	class(cmd_open_out_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	cmd%file_expr => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (cmd%file_expr)) then
	cmd%pn_opt => parse_node_get_next_ptr (cmd%file_expr)
	end if
	call cmd%compile_options (global)
	end subroutine cmd_open_out_compile

	@ %def cmd_open_out_compile
	@ Execute: append the file to the global list of open files.
	<<Commands: cmd open out: TBP>>=
	procedure :: execute => cmd_open_out_execute
	<<Commands: procedures>>=
	subroutine cmd_open_out_execute (cmd, global)
	class(cmd_open_out_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(eval_tree_t) :: file_expr
	type(string_t) :: file
	var_list => cmd%local%get_var_list_ptr ()
	call file_expr%init_sexpr (cmd%file_expr, var_list)
	call file_expr%evaluate ()
	if (file_expr%is_known ()) then
	file = file_expr%get_string ()
	call file_list_open (global%out_files, file, &
	action = "write", status = "replace", position = "asis")
	else
	call msg_fatal ("open_out: file name argument evaluates to unknown")
	end if
	call file_expr%final ()
	end subroutine cmd_open_out_execute

	@ %def cmd_open_out_execute

	\subsubsection{Open file (output)}
	Close an output file. Except for the [[execute]] method, everything is
	analogous to the open command, so we can just inherit.
	<<Commands: types>>=
	type, extends (cmd_open_out_t) :: cmd_close_out_t
	private
	contains
	<<Commands: cmd close out: TBP>>
	end type cmd_close_out_t

	@ %def cmd_close_out
	@ Execute: remove the file from the global list of output files.
	<<Commands: cmd close out: TBP>>=
	procedure :: execute => cmd_close_out_execute
	<<Commands: procedures>>=
	subroutine cmd_close_out_execute (cmd, global)
	class(cmd_close_out_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(eval_tree_t) :: file_expr
	type(string_t) :: file
	var_list => cmd%local%var_list
	call file_expr%init_sexpr (cmd%file_expr, var_list)
	call file_expr%evaluate ()
	if (file_expr%is_known ()) then
	file = file_expr%get_string ()
	call file_list_close (global%out_files, file)
	else
	call msg_fatal ("close_out: file name argument evaluates to unknown")
	end if
	call file_expr%final ()
	end subroutine cmd_close_out_execute

	@ %def cmd_close_out_execute
	@
	\subsection{Print custom-formatted values}
	<<Commands: types>>=
	type, extends (command_t) :: cmd_printf_t
	private
	type(parse_node_t), pointer :: sexpr => null ()
	type(parse_node_t), pointer :: sprintf_fun => null ()
	type(parse_node_t), pointer :: sprintf_clause => null ()
	type(parse_node_t), pointer :: sprintf => null ()
	contains
	<<Commands: cmd printf: TBP>>
	end type cmd_printf_t

	@ %def cmd_printf_t
	@ Finalize.
	<<Commands: cmd printf: TBP>>=
	procedure :: final => cmd_printf_final
	<<Commands: procedures>>=
	subroutine cmd_printf_final (cmd)
	class(cmd_printf_t), intent(inout) :: cmd
	call parse_node_final (cmd%sexpr, recursive = .false.)
	deallocate (cmd%sexpr)
	call parse_node_final (cmd%sprintf_fun, recursive = .false.)
	deallocate (cmd%sprintf_fun)
	call parse_node_final (cmd%sprintf_clause, recursive = .false.)
	deallocate (cmd%sprintf_clause)
	call parse_node_final (cmd%sprintf, recursive = .false.)
	deallocate (cmd%sprintf)
	end subroutine cmd_printf_final

	@ %def cmd_printf_final
	@ Output. Do not print the parse tree, since this may get cluttered.
	Just a message that cuts have been defined.
	<<Commands: cmd printf: TBP>>=
	procedure :: write => cmd_printf_write
	<<Commands: procedures>>=
	subroutine cmd_printf_write (cmd, unit, indent)
	class(cmd_printf_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "printf:"
	end subroutine cmd_printf_write

	@ %def cmd_printf_write
	@ Compile. We create a fake parse node (subtree) with a [[sprintf]] command
	with identical arguments which can then be handled by the corresponding
	evaluation procedure.
	<<Commands: cmd printf: TBP>>=
	procedure :: compile => cmd_printf_compile
	<<Commands: procedures>>=
	subroutine cmd_printf_compile (cmd, global)
	class(cmd_printf_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_cmd, pn_clause, pn_args, pn_format
	pn_cmd => parse_node_get_sub_ptr (cmd%pn)
	pn_clause => parse_node_get_sub_ptr (pn_cmd)
	pn_format => parse_node_get_sub_ptr (pn_clause, 2)
	pn_args => parse_node_get_next_ptr (pn_clause)
	cmd%pn_opt => parse_node_get_next_ptr (pn_cmd)
	call cmd%compile_options (global)
	allocate (cmd%sexpr)
	call parse_node_create_branch (cmd%sexpr, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("sexpr")))
	allocate (cmd%sprintf_fun)
	call parse_node_create_branch (cmd%sprintf_fun, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_fun")))
	allocate (cmd%sprintf_clause)
	call parse_node_create_branch (cmd%sprintf_clause, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf_clause")))
	allocate (cmd%sprintf)
	call parse_node_create_key (cmd%sprintf, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("sprintf")))
	call parse_node_append_sub (cmd%sprintf_clause, cmd%sprintf)
	call parse_node_append_sub (cmd%sprintf_clause, pn_format)
	call parse_node_freeze_branch (cmd%sprintf_clause)
	call parse_node_append_sub (cmd%sprintf_fun, cmd%sprintf_clause)
	if (associated (pn_args)) then
	call parse_node_append_sub (cmd%sprintf_fun, pn_args)
	end if
	call parse_node_freeze_branch (cmd%sprintf_fun)
	call parse_node_append_sub (cmd%sexpr, cmd%sprintf_fun)
	call parse_node_freeze_branch (cmd%sexpr)
	end subroutine cmd_printf_compile

	@ %def cmd_printf_compile
	@ Execute. Evaluate the string (pretending this is a [[sprintf]] expression)
	and print it.
	<<Commands: cmd printf: TBP>>=
	procedure :: execute => cmd_printf_execute
	<<Commands: procedures>>=
	subroutine cmd_printf_execute (cmd, global)
	class(cmd_printf_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(string_t) :: string, file
	type(eval_tree_t) :: sprintf_expr
	logical :: advance
	var_list => cmd%local%get_var_list_ptr ()
	advance = var_list%get_lval (&
	var_str ("?out_advance"))
	file = var_list%get_sval (&
	var_str ("$out_file"))
	call sprintf_expr%init_sexpr (cmd%sexpr, var_list)
	call sprintf_expr%evaluate ()
	if (sprintf_expr%is_known ()) then
	string = sprintf_expr%get_string ()
	if (len (file) == 0) then
	call msg_result (char (string))
	else
	call file_list_write (global%out_files, file, string, advance)
	end if
	end if
	end subroutine cmd_printf_execute

	@ %def cmd_printf_execute
	@
	\subsubsection{Record data}
	The expression syntax already contains a [[record]] keyword; this evaluates to
	a logical which is always true, but it has the side-effect of recording data
	into analysis objects. Here we define a command as an interface to this
	construct.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_record_t
	private
	type(parse_node_t), pointer :: pn_lexpr => null ()
	contains
	<<Commands: cmd record: TBP>>
	end type cmd_record_t

	@ %def cmd_record_t
	@ Output. With the compile hack below, there is nothing of interest
	to print here.
	<<Commands: cmd record: TBP>>=
	procedure :: write => cmd_record_write
	<<Commands: procedures>>=
	subroutine cmd_record_write (cmd, unit, indent)
	class(cmd_record_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)") "record"
	end subroutine cmd_record_write

	@ %def cmd_record_write
	@ Compile. This is a hack which transforms the [[record]] command
	into a [[record]] expression, which we handle in the [[expressions]]
	module.
	<<Commands: cmd record: TBP>>=
	procedure :: compile => cmd_record_compile
	<<Commands: procedures>>=
	subroutine cmd_record_compile (cmd, global)
	class(cmd_record_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_lexpr, pn_lsinglet, pn_lterm, pn_record
	call parse_node_create_branch (pn_lexpr, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("lexpr")))
	call parse_node_create_branch (pn_lsinglet, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("lsinglet")))
	call parse_node_append_sub (pn_lexpr, pn_lsinglet)
	call parse_node_create_branch (pn_lterm, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("lterm")))
	call parse_node_append_sub (pn_lsinglet, pn_lterm)
	pn_record => parse_node_get_sub_ptr (cmd%pn)
	call parse_node_append_sub (pn_lterm, pn_record)
	cmd%pn_lexpr => pn_lexpr
	end subroutine cmd_record_compile

	@ %def cmd_record_compile
	@ Command execution. Again, transfer this to the embedded expression
	and just forget the logical result.
	<<Commands: cmd record: TBP>>=
	procedure :: execute => cmd_record_execute
	<<Commands: procedures>>=
	subroutine cmd_record_execute (cmd, global)
	class(cmd_record_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	logical :: lval
	var_list => global%get_var_list_ptr ()
	lval = eval_log (cmd%pn_lexpr, var_list)
	end subroutine cmd_record_execute

	@ %def cmd_record_execute
	@
	\subsubsection{Unstable particles}
	Mark a particle as unstable. For each unstable particle, we store a
	number of decay channels and compute their respective BRs.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_unstable_t
	private
	integer :: n_proc = 0
	type(string_t), dimension(:), allocatable :: process_id
	type(parse_node_t), pointer :: pn_prt_in => null ()
	contains
	<<Commands: cmd unstable: TBP>>
	end type cmd_unstable_t

	@ %def cmd_unstable_t
	@ Output: we know the process IDs.
	<<Commands: cmd unstable: TBP>>=
	procedure :: write => cmd_unstable_write
	<<Commands: procedures>>=
	subroutine cmd_unstable_write (cmd, unit, indent)
	class(cmd_unstable_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,I0,1x,A)", advance="no") &
	"unstable:", 1, "("
	do i = 1, cmd%n_proc
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (cmd%process_id(i))
	end do
	write (u, "(A)") ")"
	end subroutine cmd_unstable_write

	@ %def cmd_unstable_write
	@ Compile. Initiate an eval tree for the decaying particle and
	determine the decay channel process IDs.
	<<Commands: cmd unstable: TBP>>=
	procedure :: compile => cmd_unstable_compile
	<<Commands: procedures>>=
	subroutine cmd_unstable_compile (cmd, global)
	class(cmd_unstable_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_list, pn_proc
	integer :: i
	cmd%pn_prt_in => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_list => parse_node_get_next_ptr (cmd%pn_prt_in)
	if (associated (pn_list)) then
	select case (char (parse_node_get_rule_key (pn_list)))
	case ("unstable_arg")
	cmd%n_proc = parse_node_get_n_sub (pn_list)
	cmd%pn_opt => parse_node_get_next_ptr (pn_list)
	case default
	cmd%n_proc = 0
	cmd%pn_opt => pn_list
	pn_list => null ()
	end select
	end if
	call cmd%compile_options (global)
	if (associated (pn_list)) then
	allocate (cmd%process_id (cmd%n_proc))
	pn_proc => parse_node_get_sub_ptr (pn_list)
	do i = 1, cmd%n_proc
	cmd%process_id(i) = parse_node_get_string (pn_proc)
	call cmd%local%process_stack%init_result_vars (cmd%process_id(i))
	pn_proc => parse_node_get_next_ptr (pn_proc)
	end do
	else
	allocate (cmd%process_id (0))
	end if
	end subroutine cmd_unstable_compile

	@ %def cmd_unstable_compile
	@ Command execution. Evaluate the decaying particle and mark the decays in
	the current model object.
	<<Commands: cmd unstable: TBP>>=
	procedure :: execute => cmd_unstable_execute
	<<Commands: procedures>>=
	subroutine cmd_unstable_execute (cmd, global)
	class(cmd_unstable_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	logical :: auto_decays, auto_decays_radiative
	integer :: auto_decays_multiplicity
	logical :: isotropic_decay, diagonal_decay, polarized_decay
	integer :: decay_helicity
	type(pdg_array_t) :: pa_in
	integer :: pdg_in
	type(string_t) :: libname_cur, libname_dec
	type(string_t), dimension(:), allocatable :: auto_id, tmp_id
	integer :: n_proc_user
	integer :: i, u_tmp
	character(80) :: buffer
	var_list => cmd%local%get_var_list_ptr ()
	auto_decays = &
	var_list%get_lval (var_str ("?auto_decays"))
	if (auto_decays) then
	auto_decays_multiplicity = &
	var_list%get_ival (var_str ("auto_decays_multiplicity"))
	auto_decays_radiative = &
	var_list%get_lval (var_str ("?auto_decays_radiative"))
	end if
	isotropic_decay = &
	var_list%get_lval (var_str ("?isotropic_decay"))
	if (isotropic_decay) then
	diagonal_decay = .false.
	polarized_decay = .false.
	else
	diagonal_decay = &
	var_list%get_lval (var_str ("?diagonal_decay"))
	if (diagonal_decay) then
	polarized_decay = .false.
	else
	polarized_decay = &
	var_list%is_known (var_str ("decay_helicity"))
	if (polarized_decay) then
	decay_helicity = var_list%get_ival (var_str ("decay_helicity"))
	end if
	end if
	end if
	pa_in = eval_pdg_array (cmd%pn_prt_in, var_list)
	- if (pdg_array_get_length (pa_in) /= 1) &
	+ if (pa_in%get_length () /= 1) &
	call msg_fatal ("Unstable: decaying particle must be unique")
	- pdg_in = pdg_array_get (pa_in, 1)
	+ pdg_in = pa_in%get (1)
	n_proc_user = cmd%n_proc
	if (auto_decays) then
	call create_auto_decays (pdg_in, &
	auto_decays_multiplicity, auto_decays_radiative, &
	libname_dec, auto_id, cmd%local)
	allocate (tmp_id (cmd%n_proc + size (auto_id)))
	tmp_id(:cmd%n_proc) = cmd%process_id
	tmp_id(cmd%n_proc+1:) = auto_id
	call move_alloc (from = tmp_id, to = cmd%process_id)
	cmd%n_proc = size (cmd%process_id)
	end if
	libname_cur = cmd%local%prclib%get_name ()
	do i = 1, cmd%n_proc
	if (i == n_proc_user + 1) then
	call cmd%local%update_prclib &
	(cmd%local%prclib_stack%get_library_ptr (libname_dec))
	end if
	if (.not. global%process_stack%exists (cmd%process_id(i))) then
	call var_list%set_log &
	(var_str ("?decay_rest_frame"), .false., is_known = .true.)
	call integrate_process (cmd%process_id(i), cmd%local, global)
	call global%process_stack%fill_result_vars (cmd%process_id(i))
	end if
	end do
	call cmd%local%update_prclib &
	(cmd%local%prclib_stack%get_library_ptr (libname_cur))
	if (cmd%n_proc > 0) then
	if (polarized_decay) then
	call global%modify_particle (pdg_in, stable = .false., &
	decay = cmd%process_id, &
	isotropic_decay = .false., &
	diagonal_decay = .false., &
	decay_helicity = decay_helicity, &
	polarized = .false.)
	else
	call global%modify_particle (pdg_in, stable = .false., &
	decay = cmd%process_id, &
	isotropic_decay = isotropic_decay, &
	diagonal_decay = diagonal_decay, &
	polarized = .false.)
	end if
	u_tmp = free_unit ()
	open (u_tmp, status = "scratch", action = "readwrite")
	call show_unstable (global, pdg_in, u_tmp)
	rewind (u_tmp)
	do
	read (u_tmp, "(A)", end = 1) buffer
	write (msg_buffer, "(A)") trim (buffer)
	call msg_message ()
	end do
	1 continue
	close (u_tmp)
	else
	call err_unstable (global, pdg_in)
	end if
	end subroutine cmd_unstable_execute

	@ %def cmd_unstable_execute
	@ Show data for the current unstable particle. This is called both by
	the [[unstable]] and by the [[show]] command.

	To determine decay branching rations, we look at the decay process IDs
	and inspect the corresponding [[integral()]] result variables.
	<<Commands: procedures>>=
	subroutine show_unstable (global, pdg, u)
	type(rt_data_t), intent(in), target :: global
	integer, intent(in) :: pdg, u
	type(flavor_t) :: flv
	type(string_t), dimension(:), allocatable :: decay
	real(default), dimension(:), allocatable :: br
	real(default) :: width
	type(process_t), pointer :: process
	type(process_component_def_t), pointer :: prc_def
	type(string_t), dimension(:), allocatable :: prt_out, prt_out_str
	integer :: i, j
	logical :: opened
	call flv%init (pdg, global%model)
	call flv%get_decays (decay)
	if (.not. allocated (decay)) return
	allocate (prt_out_str (size (decay)))
	allocate (br (size (decay)))
	do i = 1, size (br)
	process => global%process_stack%get_process_ptr (decay(i))
	prc_def => process%get_component_def_ptr (1)
	call prc_def%get_prt_out (prt_out)
	prt_out_str(i) = prt_out(1)
	do j = 2, size (prt_out)
	prt_out_str(i) = prt_out_str(i) // ", " // prt_out(j)
	end do
	br(i) = global%get_rval ("integral(" // decay(i) // ")")
	end do
	if (all (br >= 0)) then
	if (any (br > 0)) then
	width = sum (br)
	br = br / sum (br)
	write (u, "(A)") "Unstable particle " &
	// char (flv%get_name ()) &
	// ": computed branching ratios:"
	do i = 1, size (br)
	write (u, "(2x,A,':'," // FMT_14 // ",3x,A)") &
	char (decay(i)), br(i), char (prt_out_str(i))
	end do
	write (u, "(2x,'Total width ='," // FMT_14 // ",' GeV (computed)')") width
	write (u, "(2x,' ='," // FMT_14 // ",' GeV (preset)')") &
	flv%get_width ()
	if (flv%decays_isotropically ()) then
	write (u, "(2x,A)") "Decay options: isotropic"
	else if (flv%decays_diagonal ()) then
	write (u, "(2x,A)") "Decay options: &
	&projection on diagonal helicity states"
	else if (flv%has_decay_helicity ()) then
	write (u, "(2x,A,1x,I0)") "Decay options: projection onto helicity =", &
	flv%get_decay_helicity ()
	else
	write (u, "(2x,A)") "Decay options: helicity treated exactly"
	end if
	else
	inquire (unit = u, opened = opened)
	if (opened .and. .not. mask_fatal_errors) close (u)
	call msg_fatal ("Unstable particle " &
	// char (flv%get_name ()) &
	// ": partial width vanishes for all decay channels")
	end if
	else
	inquire (unit = u, opened = opened)
	if (opened .and. .not. mask_fatal_errors) close (u)
	call msg_fatal ("Unstable particle " &
	// char (flv%get_name ()) &
	// ": partial width is negative")
	end if
	end subroutine show_unstable

	@ %def show_unstable
	@ If no decays have been found, issue a non-fatal error.
	<<Commands: procedures>>=
	subroutine err_unstable (global, pdg)
	type(rt_data_t), intent(in), target :: global
	integer, intent(in) :: pdg
	type(flavor_t) :: flv
	call flv%init (pdg, global%model)
	call msg_error ("Unstable: no allowed decays found for particle " &
	// char (flv%get_name ()) // ", keeping as stable")
	end subroutine err_unstable

	@ %def err_unstable
	@ Auto decays: create process IDs and make up process
	configurations, using the PDG codes generated by the [[ds_table]] make
	method.

	We allocate and use a self-contained process library that contains only the
	decay processes of the current particle. When done, we revert the global
	library pointer to the original library but return the name of the new one.
	The new library becomes part of the global library stack and can thus be
	referred to at any time.
	<<Commands: procedures>>=
	subroutine create_auto_decays &
	(pdg_in, mult, rad, libname_dec, process_id, global)
	integer, intent(in) :: pdg_in
	integer, intent(in) :: mult
	logical, intent(in) :: rad
	type(string_t), intent(out) :: libname_dec
	type(string_t), dimension(:), allocatable, intent(out) :: process_id
	type(rt_data_t), intent(inout) :: global
	type(prclib_entry_t), pointer :: lib_entry
	type(process_library_t), pointer :: lib
	type(ds_table_t) :: ds_table
	type(split_constraints_t) :: constraints
	type(pdg_array_t), dimension(:), allocatable :: pa_out
	character(80) :: buffer
	character :: p_or_a
	type(string_t) :: process_string, libname_cur
	type(flavor_t) :: flv_in, flv_out
	type(string_t) :: prt_in
	type(string_t), dimension(:), allocatable :: prt_out
	type(process_configuration_t) :: prc_config
	integer :: i, j, k
	call flv_in%init (pdg_in, global%model)
	if (rad) then
	call constraints%init (2)
	else
	call constraints%init (3)
	call constraints%set (3, constrain_radiation ())
	end if
	call constraints%set (1, constrain_n_tot (mult))
	call constraints%set (2, &
	constrain_mass_sum (flv_in%get_mass (), margin = 0._default))
	call ds_table%make (global%model, pdg_in, constraints)
	prt_in = flv_in%get_name ()
	if (pdg_in > 0) then
	p_or_a = "p"
	else
	p_or_a = "a"
	end if
	if (ds_table%get_length () == 0) then
	call msg_warning ("Auto-decays: Particle " // char (prt_in) // ": " &
	// "no decays found")
	libname_dec = ""
	allocate (process_id (0))
	else
	call msg_message ("Creating decay process library for particle " &
	// char (prt_in))
	libname_cur = global%prclib%get_name ()
	write (buffer, "(A,A,I0)") "_d", p_or_a, abs (pdg_in)
	libname_dec = libname_cur // trim (buffer)
	lib => global%prclib_stack%get_library_ptr (libname_dec)
	if (.not. (associated (lib))) then
	allocate (lib_entry)
	call lib_entry%init (libname_dec)
	lib => lib_entry%process_library_t
	call global%add_prclib (lib_entry)
	else
	call global%update_prclib (lib)
	end if
	allocate (process_id (ds_table%get_length ()))
	do i = 1, size (process_id)
	write (buffer, "(A,'_',A,I0,'_',I0)") &
	"decay", p_or_a, abs (pdg_in), i
	process_id(i) = trim (buffer)
	process_string = process_id(i) // ": " // prt_in // " =>"
	call ds_table%get_pdg_out (i, pa_out)
	allocate (prt_out (size (pa_out)))
	do j = 1, size (pa_out)
	do k = 1, pa_out(j)%get_length ()
	call flv_out%init (pa_out(j)%get (k), global%model)
	if (k == 1) then
	prt_out(j) = flv_out%get_name ()
	else
	prt_out(j) = prt_out(j) // ":" // flv_out%get_name ()
	end if
	end do
	process_string = process_string // " " // prt_out(j)
	end do
	call msg_message (char (process_string))
	call prc_config%init (process_id(i), 1, 1, &
	global%model, global%var_list, &
	nlo_process = global%nlo_fixed_order)
	call prc_config%setup_component (1, new_prt_spec ([prt_in]), &
	new_prt_spec (prt_out), global%model, global%var_list)
	call prc_config%record (global)
	deallocate (prt_out)
	deallocate (pa_out)
	end do
	lib => global%prclib_stack%get_library_ptr (libname_cur)
	call global%update_prclib (lib)
	end if
	call ds_table%final ()
	end subroutine create_auto_decays

	@ %def create_auto_decays
	@
	\subsubsection{(Stable particles}
	Revert the unstable declaration for a list of particles.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_stable_t
	private
	type(parse_node_p), dimension(:), allocatable :: pn_pdg
	contains
	<<Commands: cmd stable: TBP>>
	end type cmd_stable_t

	@ %def cmd_stable_t
	@ Output: we know only the number of particles.
	<<Commands: cmd stable: TBP>>=
	procedure :: write => cmd_stable_write
	<<Commands: procedures>>=
	subroutine cmd_stable_write (cmd, unit, indent)
	class(cmd_stable_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,I0)") "stable:", size (cmd%pn_pdg)
	end subroutine cmd_stable_write

	@ %def cmd_stable_write
	@ Compile. Assign parse nodes for the particle IDs.
	<<Commands: cmd stable: TBP>>=
	procedure :: compile => cmd_stable_compile
	<<Commands: procedures>>=
	subroutine cmd_stable_compile (cmd, global)
	class(cmd_stable_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_list, pn_prt
	integer :: n, i
	pn_list => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_list)
	call cmd%compile_options (global)
	n = parse_node_get_n_sub (pn_list)
	allocate (cmd%pn_pdg (n))
	pn_prt => parse_node_get_sub_ptr (pn_list)
	i = 1
	do while (associated (pn_prt))
	cmd%pn_pdg(i)%ptr => pn_prt
	pn_prt => parse_node_get_next_ptr (pn_prt)
	i = i + 1
	end do
	end subroutine cmd_stable_compile

	@ %def cmd_stable_compile
	@ Execute: apply the modifications to the current model.
	<<Commands: cmd stable: TBP>>=
	procedure :: execute => cmd_stable_execute
	<<Commands: procedures>>=
	subroutine cmd_stable_execute (cmd, global)
	class(cmd_stable_t), intent(inout) :: cmd
	type(rt_data_t), target, intent(inout) :: global
	type(var_list_t), pointer :: var_list
	type(pdg_array_t) :: pa
	integer :: pdg
	type(flavor_t) :: flv
	integer :: i
	var_list => cmd%local%get_var_list_ptr ()
	do i = 1, size (cmd%pn_pdg)
	pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
	- if (pdg_array_get_length (pa) /= 1) &
	+ if (pa%get_length () /= 1) &
	call msg_fatal ("Stable: listed particles must be unique")
	- pdg = pdg_array_get (pa, 1)
	+ pdg = pa%get (1)
	call global%modify_particle (pdg, stable = .true., &
	isotropic_decay = .false., &
	diagonal_decay = .false., &
	polarized = .false.)
	call flv%init (pdg, cmd%local%model)
	call msg_message ("Particle " &
	// char (flv%get_name ()) &
	// " declared as stable")
	end do
	end subroutine cmd_stable_execute

	@ %def cmd_stable_execute
	@
	\subsubsection{Polarized particles}
	These commands mark particles as (un)polarized, to be applied in
	subsequent simulation passes. Since this is technically the same as
	the [[stable]] command, we take a shortcut and make this an extension,
	just overriding methods.
	<<Commands: types>>=
	type, extends (cmd_stable_t) :: cmd_polarized_t
	contains
	<<Commands: cmd polarized: TBP>>
	end type cmd_polarized_t

	type, extends (cmd_stable_t) :: cmd_unpolarized_t
	contains
	<<Commands: cmd unpolarized: TBP>>
	end type cmd_unpolarized_t

	@ %def cmd_polarized_t cmd_unpolarized_t
	@ Output: we know only the number of particles.
	<<Commands: cmd polarized: TBP>>=
	procedure :: write => cmd_polarized_write
	<<Commands: cmd unpolarized: TBP>>=
	procedure :: write => cmd_unpolarized_write
	<<Commands: procedures>>=
	subroutine cmd_polarized_write (cmd, unit, indent)
	class(cmd_polarized_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,I0)") "polarized:", size (cmd%pn_pdg)
	end subroutine cmd_polarized_write

	subroutine cmd_unpolarized_write (cmd, unit, indent)
	class(cmd_unpolarized_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,I0)") "unpolarized:", size (cmd%pn_pdg)
	end subroutine cmd_unpolarized_write

	@ %def cmd_polarized_write
	@ %def cmd_unpolarized_write
	@ Compile: accounted for by the base command.

	Execute: apply the modifications to the current model.
	<<Commands: cmd polarized: TBP>>=
	procedure :: execute => cmd_polarized_execute
	<<Commands: cmd unpolarized: TBP>>=
	procedure :: execute => cmd_unpolarized_execute
	<<Commands: procedures>>=
	subroutine cmd_polarized_execute (cmd, global)
	class(cmd_polarized_t), intent(inout) :: cmd
	type(rt_data_t), target, intent(inout) :: global
	type(var_list_t), pointer :: var_list
	type(pdg_array_t) :: pa
	integer :: pdg
	type(flavor_t) :: flv
	integer :: i
	var_list => cmd%local%get_var_list_ptr ()
	do i = 1, size (cmd%pn_pdg)
	pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
	- if (pdg_array_get_length (pa) /= 1) &
	+ if (pa%get_length () /= 1) &
	call msg_fatal ("Polarized: listed particles must be unique")
	- pdg = pdg_array_get (pa, 1)
	+ pdg = pa%get (1)
	call global%modify_particle (pdg, polarized = .true., &
	stable = .true., &
	isotropic_decay = .false., &
	diagonal_decay = .false.)
	call flv%init (pdg, cmd%local%model)
	call msg_message ("Particle " &
	// char (flv%get_name ()) &
	// " declared as polarized")
	end do
	end subroutine cmd_polarized_execute

	subroutine cmd_unpolarized_execute (cmd, global)
	class(cmd_unpolarized_t), intent(inout) :: cmd
	type(rt_data_t), target, intent(inout) :: global
	type(var_list_t), pointer :: var_list
	type(pdg_array_t) :: pa
	integer :: pdg
	type(flavor_t) :: flv
	integer :: i
	var_list => cmd%local%get_var_list_ptr ()
	do i = 1, size (cmd%pn_pdg)
	pa = eval_pdg_array (cmd%pn_pdg(i)%ptr, var_list)
	- if (pdg_array_get_length (pa) /= 1) &
	+ if (pa%get_length () /= 1) &
	call msg_fatal ("Unpolarized: listed particles must be unique")
	- pdg = pdg_array_get (pa, 1)
	+ pdg = pa%get (1)
	call global%modify_particle (pdg, polarized = .false., &
	stable = .true., &
	isotropic_decay = .false., &
	diagonal_decay = .false.)
	call flv%init (pdg, cmd%local%model)
	call msg_message ("Particle " &
	// char (flv%get_name ()) &
	// " declared as unpolarized")
	end do
	end subroutine cmd_unpolarized_execute

	@ %def cmd_polarized_execute
	@ %def cmd_unpolarized_execute
	@
	\subsubsection{Parameters: formats for event-sample output}
	Specify all event formats that are to be used for output files in the
	subsequent simulation run. (The raw format is on by default and can be turned
	off here.)
	<<Commands: types>>=
	type, extends (command_t) :: cmd_sample_format_t
	private
	type(string_t), dimension(:), allocatable :: format
	contains
	<<Commands: cmd sample format: TBP>>
	end type cmd_sample_format_t

	@ %def cmd_sample_format_t
	@ Output: here, everything is known.
	<<Commands: cmd sample format: TBP>>=
	procedure :: write => cmd_sample_format_write
	<<Commands: procedures>>=
	subroutine cmd_sample_format_write (cmd, unit, indent)
	class(cmd_sample_format_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "sample_format = "
	do i = 1, size (cmd%format)
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (cmd%format(i))
	end do
	write (u, "(A)")
	end subroutine cmd_sample_format_write

	@ %def cmd_sample_format_write
	@ Compile. Initialize evaluation trees.
	<<Commands: cmd sample format: TBP>>=
	procedure :: compile => cmd_sample_format_compile
	<<Commands: procedures>>=
	subroutine cmd_sample_format_compile (cmd, global)
	class(cmd_sample_format_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg
	type(parse_node_t), pointer :: pn_format
	integer :: i, n_format
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
	if (associated (pn_arg)) then
	n_format = parse_node_get_n_sub (pn_arg)
	allocate (cmd%format (n_format))
	pn_format => parse_node_get_sub_ptr (pn_arg)
	i = 0
	do while (associated (pn_format))
	i = i + 1
	cmd%format(i) = parse_node_get_string (pn_format)
	pn_format => parse_node_get_next_ptr (pn_format)
	end do
	else
	allocate (cmd%format (0))
	end if
	end subroutine cmd_sample_format_compile

	@ %def cmd_sample_format_compile
	@ Execute. Transfer the list of format specifications to the
	corresponding array in the runtime data set.
	<<Commands: cmd sample format: TBP>>=
	procedure :: execute => cmd_sample_format_execute
	<<Commands: procedures>>=
	subroutine cmd_sample_format_execute (cmd, global)
	class(cmd_sample_format_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (allocated (global%sample_fmt)) deallocate (global%sample_fmt)
	allocate (global%sample_fmt (size (cmd%format)), source = cmd%format)
	end subroutine cmd_sample_format_execute

	@ %def cmd_sample_format_execute
	@
	\subsubsection{The simulate command}
	This is the actual SINDARIN command.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_simulate_t
	! not private anymore as required by the whizard-c-interface
	integer :: n_proc = 0
	type(string_t), dimension(:), allocatable :: process_id
	contains
	<<Commands: cmd simulate: TBP>>
	end type cmd_simulate_t

	@ %def cmd_simulate_t
	@ Output: we know the process IDs.
	<<Commands: cmd simulate: TBP>>=
	procedure :: write => cmd_simulate_write
	<<Commands: procedures>>=
	subroutine cmd_simulate_write (cmd, unit, indent)
	class(cmd_simulate_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "simulate ("
	do i = 1, cmd%n_proc
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (cmd%process_id(i))
	end do
	write (u, "(A)") ")"
	end subroutine cmd_simulate_write

	@ %def cmd_simulate_write
	@ Compile. In contrast to WHIZARD 1 the confusing option to give the
	number of unweighted events for weighted events as if unweighting were
	to take place has been abandoned. (We both use [[n_events]] for
	weighted and unweighted events, the variable [[n_calls]] from WHIZARD
	1 has been discarded.
	<<Commands: cmd simulate: TBP>>=
	procedure :: compile => cmd_simulate_compile
	<<Commands: procedures>>=
	subroutine cmd_simulate_compile (cmd, global)
	class(cmd_simulate_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_proclist, pn_proc
	integer :: i
	pn_proclist => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
	call cmd%compile_options (global)
	cmd%n_proc = parse_node_get_n_sub (pn_proclist)
	allocate (cmd%process_id (cmd%n_proc))
	pn_proc => parse_node_get_sub_ptr (pn_proclist)
	do i = 1, cmd%n_proc
	cmd%process_id(i) = parse_node_get_string (pn_proc)
	call global%process_stack%init_result_vars (cmd%process_id(i))
	pn_proc => parse_node_get_next_ptr (pn_proc)
	end do
	end subroutine cmd_simulate_compile

	@ %def cmd_simulate_compile
	@ Execute command: Simulate events. This is done via a [[simulation_t]]
	object and its associated methods.

	Signal handling: the [[generate]] method may exit abnormally if there is a
	pending signal. The current logic ensures that the [[es_array]] output
	channels are closed before the [[execute]] routine returns. The program will
	terminate then in [[command_list_execute]].
	<<Commands: cmd simulate: TBP>>=
	procedure :: execute => cmd_simulate_execute
	<<Commands: procedures>>=
	subroutine cmd_simulate_execute (cmd, global)
	class(cmd_simulate_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(rt_data_t), dimension(:), allocatable, target :: alt_env
	integer :: n_events
	type(simulation_t), target :: sim
	type(event_stream_array_t) :: es_array
	integer :: i, checkpoint, callback
	var_list => cmd%local%var_list
	if (cmd%local%nlo_fixed_order) then
	call check_nlo_options (cmd%local)
	end if
	if (allocated (cmd%local%pn%alt_setup)) then
	allocate (alt_env (size (cmd%local%pn%alt_setup)))
	do i = 1, size (alt_env)
	call build_alt_setup (alt_env(i), cmd%local, &
	cmd%local%pn%alt_setup(i)%ptr)
	end do
	call sim%init (cmd%process_id, .true., .true., cmd%local, global, &
	alt_env)
	else
	call sim%init (cmd%process_id, .true., .true., cmd%local, global)
	end if
	if (signal_is_pending ()) return
	if (sim%is_valid ()) then
	call sim%init_process_selector ()
	call sim%setup_openmp ()
	call sim%compute_n_events (n_events)
	call sim%set_n_events_requested (n_events)
	call sim%activate_extra_logging ()
	call sim%prepare_event_streams (es_array)
	if (es_array%is_valid ()) then
	call sim%generate (es_array)
	else
	call sim%generate ()
	end if
	call es_array%final ()
	if (allocated (alt_env)) then
	do i = 1, size (alt_env)
	call alt_env(i)%local_final ()
	end do
	end if
	end if
	call sim%final ()
	end subroutine cmd_simulate_execute

	@ %def cmd_simulate_execute
	@ Build an alternative setup: the parse tree is stored in the global
	environment. We create a temporary command list to compile and execute this;
	the result is an alternative local environment [[alt_env]] which we can hand
	over to the [[simulate]] command.
	<<Commands: procedures>>=
	recursive subroutine build_alt_setup (alt_env, global, pn)
	type(rt_data_t), intent(inout), target :: alt_env
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), intent(in), target :: pn
	type(command_list_t), allocatable :: alt_options
	allocate (alt_options)
	call alt_env%local_init (global)
	call alt_env%activate ()
	call alt_options%compile (pn, alt_env)
	call alt_options%execute (alt_env)
	call alt_env%deactivate (global, keep_local = .true.)
	call alt_options%final ()
	end subroutine build_alt_setup

	@ %def build_alt_setup
	@
	\subsubsection{The rescan command}
	This is the actual SINDARIN command.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_rescan_t
	! private
	type(parse_node_t), pointer :: pn_filename => null ()
	integer :: n_proc = 0
	type(string_t), dimension(:), allocatable :: process_id
	contains
	<<Commands: cmd rescan: TBP>>
	end type cmd_rescan_t

	@ %def cmd_rescan_t
	@ Output: we know the process IDs.
	<<Commands: cmd rescan: TBP>>=
	procedure :: write => cmd_rescan_write
	<<Commands: procedures>>=
	subroutine cmd_rescan_write (cmd, unit, indent)
	class(cmd_rescan_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "rescan ("
	do i = 1, cmd%n_proc
	if (i > 1) write (u, "(A,1x)", advance="no") ","
	write (u, "(A)", advance="no") char (cmd%process_id(i))
	end do
	write (u, "(A)") ")"
	end subroutine cmd_rescan_write

	@ %def cmd_rescan_write
	@ Compile. The command takes a suffix argument, namely the file name
	of requested event file.
	<<Commands: cmd rescan: TBP>>=
	procedure :: compile => cmd_rescan_compile
	<<Commands: procedures>>=
	subroutine cmd_rescan_compile (cmd, global)
	class(cmd_rescan_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_filename, pn_proclist, pn_proc
	integer :: i
	pn_filename => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_proclist => parse_node_get_next_ptr (pn_filename)
	cmd%pn_opt => parse_node_get_next_ptr (pn_proclist)
	call cmd%compile_options (global)
	cmd%pn_filename => pn_filename
	cmd%n_proc = parse_node_get_n_sub (pn_proclist)
	allocate (cmd%process_id (cmd%n_proc))
	pn_proc => parse_node_get_sub_ptr (pn_proclist)
	do i = 1, cmd%n_proc
	cmd%process_id(i) = parse_node_get_string (pn_proc)
	pn_proc => parse_node_get_next_ptr (pn_proc)
	end do
	end subroutine cmd_rescan_compile

	@ %def cmd_rescan_compile
	@ Execute command: Rescan events. This is done via a [[simulation_t]]
	object and its associated methods.
	<<Commands: cmd rescan: TBP>>=
	procedure :: execute => cmd_rescan_execute
	<<Commands: procedures>>=
	subroutine cmd_rescan_execute (cmd, global)
	class(cmd_rescan_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(rt_data_t), dimension(:), allocatable, target :: alt_env
	type(string_t) :: sample, sample_suffix
	logical :: exist, write_raw, update_event, update_sqme
	type(simulation_t), target :: sim
	type(event_sample_data_t) :: input_data, data
	type(string_t) :: input_sample
	integer :: n_fmt
	type(string_t), dimension(:), allocatable :: sample_fmt
	type(string_t) :: input_format, input_ext, input_file
	type(string_t) :: lhef_extension, extension_hepmc, extension_lcio
	type(event_stream_array_t) :: es_array
	integer :: i, n_events
	<<Commands: cmd rescan execute: extra variables>>
	var_list => cmd%local%var_list
	if (allocated (cmd%local%pn%alt_setup)) then
	allocate (alt_env (size (cmd%local%pn%alt_setup)))
	do i = 1, size (alt_env)
	call build_alt_setup (alt_env(i), cmd%local, &
	cmd%local%pn%alt_setup(i)%ptr)
	end do
	call sim%init (cmd%process_id, .false., .false., cmd%local, global, &
	alt_env)
	else
	call sim%init (cmd%process_id, .false., .false., cmd%local, global)
	end if
	call sim%compute_n_events (n_events)
	input_sample = eval_string (cmd%pn_filename, var_list)
	input_format = var_list%get_sval (&
	var_str ("$rescan_input_format"))
	sample_suffix = ""
	<<Commands: cmd rescan execute: extra init>>
	sample = var_list%get_sval (var_str ("$sample"))
	if (sample == "") then
	sample = sim%get_default_sample_name () // sample_suffix
	else
	sample = var_list%get_sval (var_str ("$sample")) // sample_suffix
	end if
	write_raw = var_list%get_lval (var_str ("?write_raw"))
	if (allocated (cmd%local%sample_fmt)) then
	n_fmt = size (cmd%local%sample_fmt)
	else
	n_fmt = 0
	end if
	if (write_raw) then
	if (sample == input_sample) then
	call msg_error ("Rescan: ?write_raw = true: " &
	// "suppressing raw event output (filename clashes with input)")
	allocate (sample_fmt (n_fmt))
	if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt
	else
	allocate (sample_fmt (n_fmt + 1))
	if (n_fmt > 0) sample_fmt(:n_fmt) = cmd%local%sample_fmt
	sample_fmt(n_fmt+1) = var_str ("raw")
	end if
	else
	allocate (sample_fmt (n_fmt))
	if (n_fmt > 0) sample_fmt = cmd%local%sample_fmt
	end if
	update_event = &
	var_list%get_lval (var_str ("?update_event"))
	update_sqme = &
	var_list%get_lval (var_str ("?update_sqme"))
	if (update_event .or. update_sqme) then
	call msg_message ("Recalculating observables")
	if (update_sqme) then
	call msg_message ("Recalculating squared matrix elements")
	end if
	end if
	lhef_extension = &
	var_list%get_sval (var_str ("$lhef_extension"))
	extension_hepmc = &
	var_list%get_sval (var_str ("$extension_hepmc"))
	extension_lcio = &
	var_list%get_sval (var_str ("$extension_lcio"))
	select case (char (input_format))
	case ("raw"); input_ext = "evx"
	call cmd%local%set_log &
	(var_str ("?recover_beams"), .false., is_known=.true.)
	case ("lhef"); input_ext = lhef_extension
	case ("hepmc"); input_ext = extension_hepmc
	case ("lcio"); input_ext = extension_lcio
	case default
	call msg_fatal ("rescan: input sample format '" // char (input_format) &
	// "' not supported")
	end select
	input_file = input_sample // "." // input_ext
	inquire (file = char (input_file), exist = exist)
	if (exist) then
	input_data = sim%get_data (alt = .false.)
	input_data%n_evt = n_events
	data = sim%get_data ()
	data%n_evt = n_events
	input_data%md5sum_cfg = ""
	call es_array%init (sample, &
	sample_fmt, cmd%local, data, &
	input = input_format, input_sample = input_sample, &
	input_data = input_data, &
	allow_switch = .false.)
	call sim%rescan (n_events, es_array, global = cmd%local)
	call es_array%final ()
	else
	call msg_fatal ("Rescan: event file '" &
	// char (input_file) // "' not found")
	end if
	if (allocated (alt_env)) then
	do i = 1, size (alt_env)
	call alt_env(i)%local_final ()
	end do
	end if
	call sim%final ()
	end subroutine cmd_rescan_execute

	@ %def cmd_rescan_execute
	@ MPI: Append rank id to sample name.
	<<Commands: cmd rescan execute: extra variables>>=
	<<MPI: Commands: cmd rescan execute: extra variables>>=
	logical :: mpi_logging
	integer :: rank, n_size
	<<Commands: cmd rescan execute: extra init>>=
	<<MPI: Commands: cmd rescan execute: extra init>>=
	call mpi_get_comm_id (n_size, rank)
	if (n_size > 1) then
	sample_suffix = var_str ("_") // str (rank)
	end if
	mpi_logging = (("vamp2" == char (var_list%get_sval (var_str ("$integration_method"))) &
	& .and. (n_size > 1)) &
	& .or. var_list%get_lval (var_str ("?mpi_logging")))
	call mpi_set_logging (mpi_logging)
	@
	\subsubsection{Parameters: number of iterations}
	Specify number of iterations and number of calls for one integration pass.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_iterations_t
	private
	integer :: n_pass = 0
	type(parse_node_p), dimension(:), allocatable :: pn_expr_n_it
	type(parse_node_p), dimension(:), allocatable :: pn_expr_n_calls
	type(parse_node_p), dimension(:), allocatable :: pn_sexpr_adapt
	contains
	<<Commands: cmd iterations: TBP>>
	end type cmd_iterations_t

	@ %def cmd_iterations_t
	@ Output. Display the number of passes, which is known after compilation.
	<<Commands: cmd iterations: TBP>>=
	procedure :: write => cmd_iterations_write
	<<Commands: procedures>>=
	subroutine cmd_iterations_write (cmd, unit, indent)
	class(cmd_iterations_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	select case (cmd%n_pass)
	case (0)
	write (u, "(1x,A)") "iterations: [empty]"
	case (1)
	write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " pass"
	case default
	write (u, "(1x,A,I0,A)") "iterations: ", cmd%n_pass, " passes"
	end select
	end subroutine cmd_iterations_write

	@ %def cmd_iterations_write
	@ Compile. Initialize evaluation trees.
	<<Commands: cmd iterations: TBP>>=
	procedure :: compile => cmd_iterations_compile
	<<Commands: procedures>>=
	subroutine cmd_iterations_compile (cmd, global)
	class(cmd_iterations_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_n_it, pn_n_calls, pn_adapt
	type(parse_node_t), pointer :: pn_it_spec, pn_calls_spec, pn_adapt_spec
	integer :: i
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 3)
	if (associated (pn_arg)) then
	cmd%n_pass = parse_node_get_n_sub (pn_arg)
	allocate (cmd%pn_expr_n_it (cmd%n_pass))
	allocate (cmd%pn_expr_n_calls (cmd%n_pass))
	allocate (cmd%pn_sexpr_adapt (cmd%n_pass))
	pn_it_spec => parse_node_get_sub_ptr (pn_arg)
	i = 1
	do while (associated (pn_it_spec))
	pn_n_it => parse_node_get_sub_ptr (pn_it_spec)
	pn_calls_spec => parse_node_get_next_ptr (pn_n_it)
	pn_n_calls => parse_node_get_sub_ptr (pn_calls_spec, 2)
	pn_adapt_spec => parse_node_get_next_ptr (pn_calls_spec)
	if (associated (pn_adapt_spec)) then
	pn_adapt => parse_node_get_sub_ptr (pn_adapt_spec, 2)
	else
	pn_adapt => null ()
	end if
	cmd%pn_expr_n_it(i)%ptr => pn_n_it
	cmd%pn_expr_n_calls(i)%ptr => pn_n_calls
	cmd%pn_sexpr_adapt(i)%ptr => pn_adapt
	i = i + 1
	pn_it_spec => parse_node_get_next_ptr (pn_it_spec)
	end do
	else
	allocate (cmd%pn_expr_n_it (0))
	allocate (cmd%pn_expr_n_calls (0))
	end if
	end subroutine cmd_iterations_compile

	@ %def cmd_iterations_compile
	@ Execute. Evaluate the trees and transfer the results to the iteration
	list in the runtime data set.
	<<Commands: cmd iterations: TBP>>=
	procedure :: execute => cmd_iterations_execute
	<<Commands: procedures>>=
	subroutine cmd_iterations_execute (cmd, global)
	class(cmd_iterations_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	integer, dimension(cmd%n_pass) :: n_it, n_calls
	logical, dimension(cmd%n_pass) :: custom_adapt
	type(string_t), dimension(cmd%n_pass) :: adapt_code
	integer :: i
	var_list => global%get_var_list_ptr ()
	do i = 1, cmd%n_pass
	n_it(i) = eval_int (cmd%pn_expr_n_it(i)%ptr, var_list)
	n_calls(i) = &
	eval_int (cmd%pn_expr_n_calls(i)%ptr, var_list)
	if (associated (cmd%pn_sexpr_adapt(i)%ptr)) then
	adapt_code(i) = &
	eval_string (cmd%pn_sexpr_adapt(i)%ptr, &
	var_list, is_known = custom_adapt(i))
	else
	custom_adapt(i) = .false.
	end if
	end do
	call global%it_list%init (n_it, n_calls, custom_adapt, adapt_code)
	end subroutine cmd_iterations_execute

	@ %def cmd_iterations_execute
	@
	\subsubsection{Range expressions}
	We need a special type for storing and evaluating range expressions.
	<<Commands: parameters>>=
	integer, parameter :: STEP_NONE = 0
	integer, parameter :: STEP_ADD = 1
	integer, parameter :: STEP_SUB = 2
	integer, parameter :: STEP_MUL = 3
	integer, parameter :: STEP_DIV = 4
	integer, parameter :: STEP_COMP_ADD = 11
	integer, parameter :: STEP_COMP_MUL = 13
	@
	There is an abstract base type and two implementations: scan over integers and
	scan over reals.
	<<Commands: types>>=
	type, abstract :: range_t
	type(parse_node_t), pointer :: pn_expr => null ()
	type(parse_node_t), pointer :: pn_term => null ()
	type(parse_node_t), pointer :: pn_factor => null ()
	type(parse_node_t), pointer :: pn_value => null ()
	type(parse_node_t), pointer :: pn_literal => null ()
	type(parse_node_t), pointer :: pn_beg => null ()
	type(parse_node_t), pointer :: pn_end => null ()
	type(parse_node_t), pointer :: pn_step => null ()
	type(eval_tree_t) :: expr_beg
	type(eval_tree_t) :: expr_end
	type(eval_tree_t) :: expr_step
	integer :: step_mode = 0
	integer :: n_step = 0
	contains
	<<Commands: range: TBP>>
	end type range_t

	@ %def range_t
	@ These are the implementations:
	<<Commands: types>>=
	type, extends (range_t) :: range_int_t
	integer :: i_beg = 0
	integer :: i_end = 0
	integer :: i_step = 0
	contains
	<<Commands: range int: TBP>>
	end type range_int_t

	type, extends (range_t) :: range_real_t
	real(default) :: r_beg = 0
	real(default) :: r_end = 0
	real(default) :: r_step = 0
	real(default) :: lr_beg = 0
	real(default) :: lr_end = 0
	real(default) :: lr_step = 0
	contains
	<<Commands: range real: TBP>>
	end type range_real_t

	@ %def range_int_t range_real_t
	@ Finalize the allocated dummy node. The other nodes are just pointers.
	<<Commands: range: TBP>>=
	procedure :: final => range_final
	<<Commands: procedures>>=
	subroutine range_final (object)
	class(range_t), intent(inout) :: object
	if (associated (object%pn_expr)) then
	call parse_node_final (object%pn_expr, recursive = .false.)
	call parse_node_final (object%pn_term, recursive = .false.)
	call parse_node_final (object%pn_factor, recursive = .false.)
	call parse_node_final (object%pn_value, recursive = .false.)
	call parse_node_final (object%pn_literal, recursive = .false.)
	deallocate (object%pn_expr)
	deallocate (object%pn_term)
	deallocate (object%pn_factor)
	deallocate (object%pn_value)
	deallocate (object%pn_literal)
	end if
	end subroutine range_final

	@ %def range_final
	@ Output.
	<<Commands: range: TBP>>=
	procedure (range_write), deferred :: write
	procedure :: base_write => range_write
	<<Commands: range int: TBP>>=
	procedure :: write => range_int_write
	<<Commands: range real: TBP>>=
	procedure :: write => range_real_write
	<<Commands: procedures>>=
	subroutine range_write (object, unit)
	class(range_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Range specification:"
	if (associated (object%pn_expr)) then
	write (u, "(1x,A)") "Dummy value:"
	call parse_node_write_rec (object%pn_expr, u)
	end if
	if (associated (object%pn_beg)) then
	write (u, "(1x,A)") "Initial value:"
	call parse_node_write_rec (object%pn_beg, u)
	call object%expr_beg%write (u)
	if (associated (object%pn_end)) then
	write (u, "(1x,A)") "Final value:"
	call parse_node_write_rec (object%pn_end, u)
	call object%expr_end%write (u)
	if (associated (object%pn_step)) then
	write (u, "(1x,A)") "Step value:"
	call parse_node_write_rec (object%pn_step, u)
	select case (object%step_mode)
	case (STEP_ADD); write (u, "(1x,A)") "Step mode: +"
	case (STEP_SUB); write (u, "(1x,A)") "Step mode: -"
	case (STEP_MUL); write (u, "(1x,A)") "Step mode: *"
	case (STEP_DIV); write (u, "(1x,A)") "Step mode: /"
	case (STEP_COMP_ADD); write (u, "(1x,A)") "Division mode: +"
	case (STEP_COMP_MUL); write (u, "(1x,A)") "Division mode: *"
	end select
	end if
	end if
	else
	write (u, "(1x,A)") "Expressions: [undefined]"
	end if
	end subroutine range_write

	subroutine range_int_write (object, unit)
	class(range_int_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (unit)
	write (u, "(1x,A)") "Range parameters:"
	write (u, "(3x,A,I0)") "i_beg = ", object%i_beg
	write (u, "(3x,A,I0)") "i_end = ", object%i_end
	write (u, "(3x,A,I0)") "i_step = ", object%i_step
	write (u, "(3x,A,I0)") "n_step = ", object%n_step
	end subroutine range_int_write

	subroutine range_real_write (object, unit)
	class(range_real_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	call object%base_write (unit)
	write (u, "(1x,A)") "Range parameters:"
	write (u, "(3x,A," // FMT_19 // ")") "r_beg = ", object%r_beg
	write (u, "(3x,A," // FMT_19 // ")") "r_end = ", object%r_end
	write (u, "(3x,A," // FMT_19 // ")") "r_step = ", object%r_end
	write (u, "(3x,A,I0)") "n_step = ", object%n_step
	end subroutine range_real_write

	@ %def range_write
	@ Initialize, given a range expression parse node. This is common to the
	implementations.
	<<Commands: range: TBP>>=
	procedure :: init => range_init
	<<Commands: procedures>>=
	subroutine range_init (range, pn)
	class(range_t), intent(out) :: range
	type(parse_node_t), intent(in), target :: pn
	type(parse_node_t), pointer :: pn_spec, pn_end, pn_step_spec, pn_op
	select case (char (parse_node_get_rule_key (pn)))
	case ("expr")
	case ("range_expr")
	range%pn_beg => parse_node_get_sub_ptr (pn)
	pn_spec => parse_node_get_next_ptr (range%pn_beg)
	if (associated (pn_spec)) then
	pn_end => parse_node_get_sub_ptr (pn_spec, 2)
	range%pn_end => pn_end
	pn_step_spec => parse_node_get_next_ptr (pn_end)
	if (associated (pn_step_spec)) then
	pn_op => parse_node_get_sub_ptr (pn_step_spec)
	range%pn_step => parse_node_get_next_ptr (pn_op)
	select case (char (parse_node_get_rule_key (pn_op)))
	case ("/+"); range%step_mode = STEP_ADD
	case ("/-"); range%step_mode = STEP_SUB
	case ("/*"); range%step_mode = STEP_MUL
	case ("//"); range%step_mode = STEP_DIV
	case ("/+/"); range%step_mode = STEP_COMP_ADD
	case ("/*/"); range%step_mode = STEP_COMP_MUL
	case default
	call range%write ()
	call msg_bug ("Range: step mode not implemented")
	end select
	else
	range%step_mode = STEP_ADD
	end if
	else
	range%step_mode = STEP_NONE
	end if
	call range%create_value_node ()
	case default
	call msg_bug ("range expression: node type '" &
	// char (parse_node_get_rule_key (pn)) &
	// "' not implemented")
	end select
	end subroutine range_init

	@ %def range_init
	@ This method manually creates a parse node (actually, a cascade of parse
	nodes) that hold a constant value as a literal. The idea is that this node is
	inserted as the right-hand side of a fake variable assignment, which is
	prepended to each scan iteration. Before the variable
	assignment is compiled and executed, we can manually reset the value of the
	literal and thus pretend that the loop variable is assigned this value.
	<<Commands: range: TBP>>=
	procedure :: create_value_node => range_create_value_node
	<<Commands: procedures>>=
	subroutine range_create_value_node (range)
	class(range_t), intent(inout) :: range
	allocate (range%pn_literal)
	allocate (range%pn_value)
	select type (range)
	type is (range_int_t)
	call parse_node_create_value (range%pn_literal, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_literal")),&
	ival = 0)
	call parse_node_create_branch (range%pn_value, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("integer_value")))
	type is (range_real_t)
	call parse_node_create_value (range%pn_literal, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_literal")),&
	rval = 0._default)
	call parse_node_create_branch (range%pn_value, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("real_value")))
	class default
	call msg_bug ("range: create value node: type not implemented")
	end select
	call parse_node_append_sub (range%pn_value, range%pn_literal)
	call parse_node_freeze_branch (range%pn_value)
	allocate (range%pn_factor)
	call parse_node_create_branch (range%pn_factor, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("factor")))
	call parse_node_append_sub (range%pn_factor, range%pn_value)
	call parse_node_freeze_branch (range%pn_factor)
	allocate (range%pn_term)
	call parse_node_create_branch (range%pn_term, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("term")))
	call parse_node_append_sub (range%pn_term, range%pn_factor)
	call parse_node_freeze_branch (range%pn_term)
	allocate (range%pn_expr)
	call parse_node_create_branch (range%pn_expr, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("expr")))
	call parse_node_append_sub (range%pn_expr, range%pn_term)
	call parse_node_freeze_branch (range%pn_expr)
	end subroutine range_create_value_node

	@ %def range_create_value_node
	@ Compile, given an environment.
	<<Commands: range: TBP>>=
	procedure :: compile => range_compile
	<<Commands: procedures>>=
	subroutine range_compile (range, global)
	class(range_t), intent(inout) :: range
	type(rt_data_t), intent(in), target :: global
	type(var_list_t), pointer :: var_list
	var_list => global%get_var_list_ptr ()
	if (associated (range%pn_beg)) then
	call range%expr_beg%init_expr (range%pn_beg, var_list)
	if (associated (range%pn_end)) then
	call range%expr_end%init_expr (range%pn_end, var_list)
	if (associated (range%pn_step)) then
	call range%expr_step%init_expr (range%pn_step, var_list)
	end if
	end if
	end if
	end subroutine range_compile

	@ %def range_compile
	@ Evaluate: compute the actual bounds and parameters that determine the values
	that we can iterate.

	This is implementation-specific.
	<<Commands: range: TBP>>=
	procedure (range_evaluate), deferred :: evaluate
	<<Commands: interfaces>>=
	abstract interface
	subroutine range_evaluate (range)
	import
	class(range_t), intent(inout) :: range
	end subroutine range_evaluate
	end interface

	@ %def range_evaluate
	@ The version for an integer variable. If the step is subtractive, we invert
	the sign and treat it as an additive step. For a multiplicative step, the
	step must be greater than one, and the initial and final values must be of
	same sign and strictly ordered. Analogously for a division step.
	<<Commands: range int: TBP>>=
	procedure :: evaluate => range_int_evaluate
	<<Commands: procedures>>=
	subroutine range_int_evaluate (range)
	class(range_int_t), intent(inout) :: range
	integer :: ival
	if (associated (range%pn_beg)) then
	call range%expr_beg%evaluate ()
	if (range%expr_beg%is_known ()) then
	range%i_beg = range%expr_beg%get_int ()
	else
	call range%write ()
	call msg_fatal &
	("Range expression: initial value evaluates to unknown")
	end if
	if (associated (range%pn_end)) then
	call range%expr_end%evaluate ()
	if (range%expr_end%is_known ()) then
	range%i_end = range%expr_end%get_int ()
	if (associated (range%pn_step)) then
	call range%expr_step%evaluate ()
	if (range%expr_step%is_known ()) then
	range%i_step = range%expr_step%get_int ()
	select case (range%step_mode)
	case (STEP_SUB); range%i_step = - range%i_step
	end select
	else
	call range%write ()
	call msg_fatal &
	("Range expression: step value evaluates to unknown")
	end if
	else
	range%i_step = 1
	end if
	else
	call range%write ()
	call msg_fatal &
	("Range expression: final value evaluates to unknown")
	end if
	else
	range%i_end = range%i_beg
	range%i_step = 1
	end if
	select case (range%step_mode)
	case (STEP_NONE)
	range%n_step = 1
	case (STEP_ADD, STEP_SUB)
	if (range%i_step /= 0) then
	if (range%i_beg == range%i_end) then
	range%n_step = 1
	else if (sign (1, range%i_end - range%i_beg) &
	== sign (1, range%i_step)) then
	range%n_step = (range%i_end - range%i_beg) / range%i_step + 1
	else
	range%n_step = 0
	end if
	else
	call msg_fatal ("range evaluation (add): step value is zero")
	end if
	case (STEP_MUL)
	if (range%i_step > 1) then
	if (range%i_beg == range%i_end) then
	range%n_step = 1
	else if (range%i_beg == 0) then
	call msg_fatal ("range evaluation (mul): initial value is zero")
	else if (sign (1, range%i_beg) == sign (1, range%i_end) &
	.and. abs (range%i_beg) < abs (range%i_end)) then
	range%n_step = 0
	ival = range%i_beg
	do while (abs (ival) <= abs (range%i_end))
	range%n_step = range%n_step + 1
	ival = ival * range%i_step
	end do
	else
	range%n_step = 0
	end if
	else
	call msg_fatal &
	("range evaluation (mult): step value is one or less")
	end if
	case (STEP_DIV)
	if (range%i_step > 1) then
	if (range%i_beg == range%i_end) then
	range%n_step = 1
	else if (sign (1, range%i_beg) == sign (1, range%i_end) &
	.and. abs (range%i_beg) > abs (range%i_end)) then
	range%n_step = 0
	ival = range%i_beg
	do while (abs (ival) >= abs (range%i_end))
	range%n_step = range%n_step + 1
	if (ival == 0) exit
	ival = ival / range%i_step
	end do
	else
	range%n_step = 0
	end if
	else
	call msg_fatal &
	("range evaluation (div): step value is one or less")
	end if
	case (STEP_COMP_ADD)
	call msg_fatal ("range evaluation: &
	&step mode /+/ not allowed for integer variable")
	case (STEP_COMP_MUL)
	call msg_fatal ("range evaluation: &
	&step mode /*/ not allowed for integer variable")
	case default
	call range%write ()
	call msg_bug ("range evaluation: step mode not implemented")
	end select
	end if
	end subroutine range_int_evaluate

	@ %def range_int_evaluate
	@ The version for a real variable.
	<<Commands: range real: TBP>>=
	procedure :: evaluate => range_real_evaluate
	<<Commands: procedures>>=
	subroutine range_real_evaluate (range)
	class(range_real_t), intent(inout) :: range
	if (associated (range%pn_beg)) then
	call range%expr_beg%evaluate ()
	if (range%expr_beg%is_known ()) then
	range%r_beg = range%expr_beg%get_real ()
	else
	call range%write ()
	call msg_fatal &
	("Range expression: initial value evaluates to unknown")
	end if
	if (associated (range%pn_end)) then
	call range%expr_end%evaluate ()
	if (range%expr_end%is_known ()) then
	range%r_end = range%expr_end%get_real ()
	if (associated (range%pn_step)) then
	if (range%expr_step%is_known ()) then
	select case (range%step_mode)
	case (STEP_ADD, STEP_SUB, STEP_MUL, STEP_DIV)
	call range%expr_step%evaluate ()
	range%r_step = range%expr_step%get_real ()
	select case (range%step_mode)
	case (STEP_SUB); range%r_step = - range%r_step
	end select
	case (STEP_COMP_ADD, STEP_COMP_MUL)
	range%n_step = &
	max (range%expr_step%get_int (), 0)
	end select
	else
	call range%write ()
	call msg_fatal &
	("Range expression: step value evaluates to unknown")
	end if
	else
	call range%write ()
	call msg_fatal &
	("Range expression (real): step value must be provided")
	end if
	else
	call range%write ()
	call msg_fatal &
	("Range expression: final value evaluates to unknown")
	end if
	else
	range%r_end = range%r_beg
	range%r_step = 1
	end if
	select case (range%step_mode)
	case (STEP_NONE)
	range%n_step = 1
	case (STEP_ADD, STEP_SUB)
	if (range%r_step /= 0) then
	if (sign (1._default, range%r_end - range%r_beg) &
	== sign (1._default, range%r_step)) then
	range%n_step = &
	nint ((range%r_end - range%r_beg) / range%r_step + 1)
	else
	range%n_step = 0
	end if
	else
	call msg_fatal ("range evaluation (add): step value is zero")
	end if
	case (STEP_MUL)
	if (range%r_step > 1) then
	if (range%r_beg == 0 .or. range%r_end == 0) then
	call msg_fatal ("range evaluation (mul): bound is zero")
	else if (sign (1._default, range%r_beg) &
	== sign (1._default, range%r_end) &
	.and. abs (range%r_beg) <= abs (range%r_end)) then
	range%lr_beg = log (abs (range%r_beg))
	range%lr_end = log (abs (range%r_end))
	range%lr_step = log (range%r_step)
	range%n_step = nint &
	(abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
	else
	range%n_step = 0
	end if
	else
	call msg_fatal &
	("range evaluation (mult): step value is one or less")
	end if
	case (STEP_DIV)
	if (range%r_step > 1) then
	if (range%r_beg == 0 .or. range%r_end == 0) then
	call msg_fatal ("range evaluation (div): bound is zero")
	else if (sign (1._default, range%r_beg) &
	== sign (1._default, range%r_end) &
	.and. abs (range%r_beg) >= abs (range%r_end)) then
	range%lr_beg = log (abs (range%r_beg))
	range%lr_end = log (abs (range%r_end))
	range%lr_step = -log (range%r_step)
	range%n_step = nint &
	(abs ((range%lr_end - range%lr_beg) / range%lr_step) + 1)
	else
	range%n_step = 0
	end if
	else
	call msg_fatal &
	("range evaluation (mult): step value is one or less")
	end if
	case (STEP_COMP_ADD)
	! Number of steps already known
	case (STEP_COMP_MUL)
	! Number of steps already known
	if (range%r_beg == 0 .or. range%r_end == 0) then
	call msg_fatal ("range evaluation (mul): bound is zero")
	else if (sign (1._default, range%r_beg) &
	== sign (1._default, range%r_end)) then
	range%lr_beg = log (abs (range%r_beg))
	range%lr_end = log (abs (range%r_end))
	else
	range%n_step = 0
	end if
	case default
	call range%write ()
	call msg_bug ("range evaluation: step mode not implemented")
	end select
	end if
	end subroutine range_real_evaluate

	@ %def range_real_evaluate
	@ Return the number of iterations:
	<<Commands: range: TBP>>=
	procedure :: get_n_iterations => range_get_n_iterations
	<<Commands: procedures>>=
	function range_get_n_iterations (range) result (n)
	class(range_t), intent(in) :: range
	integer :: n
	n = range%n_step
	end function range_get_n_iterations

	@ %def range_get_n_iterations
	@ Compute the value for iteration [[i]] and store it in the embedded token.
	<<Commands: range: TBP>>=
	procedure (range_set_value), deferred :: set_value
	<<Commands: interfaces>>=
	abstract interface
	subroutine range_set_value (range, i)
	import
	class(range_t), intent(inout) :: range
	integer, intent(in) :: i
	end subroutine range_set_value
	end interface

	@ %def range_set_value
	@ In the integer case, we compute the value directly for additive step. For
	multiplicative step, we perform a loop in the same way as above, where the
	number of iteration was determined.
	<<Commands: range int: TBP>>=
	procedure :: set_value => range_int_set_value
	<<Commands: procedures>>=
	subroutine range_int_set_value (range, i)
	class(range_int_t), intent(inout) :: range
	integer, intent(in) :: i
	integer :: k, ival
	select case (range%step_mode)
	case (STEP_NONE)
	ival = range%i_beg
	case (STEP_ADD, STEP_SUB)
	ival = range%i_beg + (i - 1) * range%i_step
	case (STEP_MUL)
	ival = range%i_beg
	do k = 1, i - 1
	ival = ival * range%i_step
	end do
	case (STEP_DIV)
	ival = range%i_beg
	do k = 1, i - 1
	ival = ival / range%i_step
	end do
	case default
	call range%write ()
	call msg_bug ("range iteration: step mode not implemented")
	end select
	call parse_node_set_value (range%pn_literal, ival = ival)
	end subroutine range_int_set_value

	@ %def range_int_set_value
	@ In the integer case, we compute the value directly for additive step. For
	multiplicative step, we perform a loop in the same way as above, where the
	number of iteration was determined.
	<<Commands: range real: TBP>>=
	procedure :: set_value => range_real_set_value
	<<Commands: procedures>>=
	subroutine range_real_set_value (range, i)
	class(range_real_t), intent(inout) :: range
	integer, intent(in) :: i
	real(default) :: rval, x
	select case (range%step_mode)
	case (STEP_NONE)
	rval = range%r_beg
	case (STEP_ADD, STEP_SUB, STEP_COMP_ADD)
	if (range%n_step > 1) then
	x = real (i - 1, default) / (range%n_step - 1)
	else
	x = 1._default / 2
	end if
	rval = x * range%r_end + (1 - x) * range%r_beg
	case (STEP_MUL, STEP_DIV, STEP_COMP_MUL)
	if (range%n_step > 1) then
	x = real (i - 1, default) / (range%n_step - 1)
	else
	x = 1._default / 2
	end if
	rval = sign &
	(exp (x * range%lr_end + (1 - x) * range%lr_beg), range%r_beg)
	case default
	call range%write ()
	call msg_bug ("range iteration: step mode not implemented")
	end select
	call parse_node_set_value (range%pn_literal, rval = rval)
	end subroutine range_real_set_value

	@ %def range_real_set_value
	@
	\subsubsection{Scan over parameters and other objects}
	The scan command allocates a new parse node for the variable
	assignment (the lhs). The rhs of this parse node is assigned from the
	available rhs expressions in the scan list, one at a time, so the
	compiled parse node can be prepended to the scan body.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_scan_t
	private
	type(string_t) :: name
	integer :: n_values = 0
	type(parse_node_p), dimension(:), allocatable :: scan_cmd
	class(range_t), dimension(:), allocatable :: range
	contains
	<<Commands: cmd scan: TBP>>
	end type cmd_scan_t

	@ %def cmd_scan_t
	@ Finalizer.

	The auxiliary parse nodes that we have constructed have to be treated
	carefully: the embedded pointers all point to persistent objects
	somewhere else and should not be finalized, so we should not call the
	finalizer recursively.
	<<Commands: cmd scan: TBP>>=
	procedure :: final => cmd_scan_final
	<<Commands: procedures>>=
	recursive subroutine cmd_scan_final (cmd)
	class(cmd_scan_t), intent(inout) :: cmd
	type(parse_node_t), pointer :: pn_var_single, pn_decl_single
	type(string_t) :: key
	integer :: i
	if (allocated (cmd%scan_cmd)) then
	do i = 1, size (cmd%scan_cmd)
	pn_var_single => parse_node_get_sub_ptr (cmd%scan_cmd(i)%ptr)
	key = parse_node_get_rule_key (pn_var_single)
	select case (char (key))
	case ("scan_string_decl", "scan_log_decl")
	pn_decl_single => parse_node_get_sub_ptr (pn_var_single, 2)
	call parse_node_final (pn_decl_single, recursive=.false.)
	deallocate (pn_decl_single)
	end select
	call parse_node_final (pn_var_single, recursive=.false.)
	deallocate (pn_var_single)
	end do
	deallocate (cmd%scan_cmd)
	end if
	if (allocated (cmd%range)) then
	do i = 1, size (cmd%range)
	call cmd%range(i)%final ()
	end do
	end if
	end subroutine cmd_scan_final

	@ %def cmd_scan_final
	@ Output.
	<<Commands: cmd scan: TBP>>=
	procedure :: write => cmd_scan_write
	<<Commands: procedures>>=
	subroutine cmd_scan_write (cmd, unit, indent)
	class(cmd_scan_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,1x,A,1x,'(',I0,')')") "scan:", char (cmd%name), &
	cmd%n_values
	end subroutine cmd_scan_write

	@ %def cmd_scan_write
	@ Compile the scan command. We construct a new parse node that
	implements the variable assignment for a single element on the rhs,
	instead of the whole list that we get from the original parse tree.
	By simply copying the node, we copy all pointers and inherit the
	targets from the original. During execution, we should replace the
	rhs by the stored rhs pointers (the list elements), one by one, then
	(re)compile the redefined node.
	<<Commands: cmd scan: TBP>>=
	procedure :: compile => cmd_scan_compile
	<<Commands: procedures>>=
	recursive subroutine cmd_scan_compile (cmd, global)
	class(cmd_scan_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	type(parse_node_t), pointer :: pn_var, pn_body, pn_body_first
	type(parse_node_t), pointer :: pn_decl, pn_name
	type(parse_node_t), pointer :: pn_arg, pn_scan_cmd, pn_rhs
	type(parse_node_t), pointer :: pn_decl_single, pn_var_single
	type(syntax_rule_t), pointer :: var_rule_decl, var_rule
	type(string_t) :: key
	integer :: var_type
	integer :: i
	if (debug_on) call msg_debug (D_CORE, "cmd_scan_compile")
	if (debug_active (D_CORE)) call parse_node_write_rec (cmd%pn)
	pn_var => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_body => parse_node_get_next_ptr (pn_var)
	if (associated (pn_body)) then
	pn_body_first => parse_node_get_sub_ptr (pn_body)
	else
	pn_body_first => null ()
	end if
	key = parse_node_get_rule_key (pn_var)
	select case (char (key))
	case ("scan_num")
	pn_name => parse_node_get_sub_ptr (pn_var)
	cmd%name = parse_node_get_string (pn_name)
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_num"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_int")
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_int"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_real")
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_real"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_complex")
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str("cmd_complex"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_alias")
	pn_name => parse_node_get_sub_ptr (pn_var, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, var_str ("cmd_alias"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_string_decl")
	pn_decl => parse_node_get_sub_ptr (pn_var, 2)
	pn_name => parse_node_get_sub_ptr (pn_decl, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_string"))
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_string_decl"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_log_decl")
	pn_decl => parse_node_get_sub_ptr (pn_var, 2)
	pn_name => parse_node_get_sub_ptr (pn_decl, 2)
	cmd%name = parse_node_get_string (pn_name)
	var_rule_decl => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_log"))
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_log_decl"))
	pn_arg => parse_node_get_next_ptr (pn_name, 2)
	case ("scan_cuts")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_cuts"))
	cmd%name = "cuts"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_weight")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_weight"))
	cmd%name = "weight"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_scale")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_scale"))
	cmd%name = "scale"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_ren_scale")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_ren_scale"))
	cmd%name = "renormalization_scale"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_fac_scale")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_fac_scale"))
	cmd%name = "factorization_scale"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_selection")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_selection"))
	cmd%name = "selection"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_reweight")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_reweight"))
	cmd%name = "reweight"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_analysis")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_analysis"))
	cmd%name = "analysis"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_model")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_model"))
	cmd%name = "model"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case ("scan_library")
	var_rule => syntax_get_rule_ptr (syntax_cmd_list, &
	var_str ("cmd_library"))
	cmd%name = "library"
	pn_arg => parse_node_get_sub_ptr (pn_var, 3)
	case default
	call msg_bug ("scan: case '" // char (key) // "' not implemented")
	end select
	if (associated (pn_arg)) then
	cmd%n_values = parse_node_get_n_sub (pn_arg)
	end if
	var_list => global%get_var_list_ptr ()
	allocate (cmd%scan_cmd (cmd%n_values))
	select case (char (key))
	case ("scan_num")
	var_type = &
	var_list%get_type (cmd%name)
	select case (var_type)
	case (V_INT)
	allocate (range_int_t :: cmd%range (cmd%n_values))
	case (V_REAL)
	allocate (range_real_t :: cmd%range (cmd%n_values))
	case (V_CMPLX)
	call msg_fatal ("scan over complex variable not implemented")
	case (V_NONE)
	call msg_fatal ("scan: variable '" // char (cmd%name) //"' undefined")
	case default
	call msg_bug ("scan: impossible variable type")
	end select
	case ("scan_int")
	allocate (range_int_t :: cmd%range (cmd%n_values))
	case ("scan_real")
	allocate (range_real_t :: cmd%range (cmd%n_values))
	case ("scan_complex")
	call msg_fatal ("scan over complex variable not implemented")
	end select
	i = 1
	if (associated (pn_arg)) then
	pn_rhs => parse_node_get_sub_ptr (pn_arg)
	else
	pn_rhs => null ()
	end if
	do while (associated (pn_rhs))
	allocate (pn_scan_cmd)
	call parse_node_create_branch (pn_scan_cmd, &
	syntax_get_rule_ptr (syntax_cmd_list, var_str ("command_list")))
	allocate (pn_var_single)
	pn_var_single = pn_var
	call parse_node_replace_rule (pn_var_single, var_rule)
	select case (char (key))
	case ("scan_num", "scan_int", "scan_real", &
	"scan_complex", "scan_alias", &
	"scan_cuts", "scan_weight", &
	"scan_scale", "scan_ren_scale", "scan_fac_scale", &
	"scan_selection", "scan_reweight", "scan_analysis", &
	"scan_model", "scan_library")
	if (allocated (cmd%range)) then
	call cmd%range(i)%init (pn_rhs)
	call parse_node_replace_last_sub &
	(pn_var_single, cmd%range(i)%pn_expr)
	else
	call parse_node_replace_last_sub (pn_var_single, pn_rhs)
	end if
	case ("scan_string_decl", "scan_log_decl")
	allocate (pn_decl_single)
	pn_decl_single = pn_decl
	call parse_node_replace_rule (pn_decl_single, var_rule_decl)
	call parse_node_replace_last_sub (pn_decl_single, pn_rhs)
	call parse_node_freeze_branch (pn_decl_single)
	call parse_node_replace_last_sub (pn_var_single, pn_decl_single)
	case default
	call msg_bug ("scan: case '" // char (key) &
	// "' broken")
	end select
	call parse_node_freeze_branch (pn_var_single)
	call parse_node_append_sub (pn_scan_cmd, pn_var_single)
	call parse_node_append_sub (pn_scan_cmd, pn_body_first)
	call parse_node_freeze_branch (pn_scan_cmd)
	cmd%scan_cmd(i)%ptr => pn_scan_cmd
	i = i + 1
	pn_rhs => parse_node_get_next_ptr (pn_rhs)
	end do
	if (debug_active (D_CORE)) then
	do i = 1, cmd%n_values
	print *, "scan command ", i
	call parse_node_write_rec (cmd%scan_cmd(i)%ptr)
	if (allocated (cmd%range)) call cmd%range(i)%write ()
	end do
	print *, "original"
	call parse_node_write_rec (cmd%pn)
	end if
	end subroutine cmd_scan_compile

	@ %def cmd_scan_compile
	@ Execute the loop for all values in the step list. We use the
	parse trees with single variable assignment that we have stored, to
	iteratively create a local environment, execute the stored commands, and
	destroy it again. When we encounter a range object, we execute the commands
	for each value that this object provides. Computing this value has the side
	effect of modifying the rhs of the variable assignment that heads the local
	command list, directly in the local parse tree.
	<<Commands: cmd scan: TBP>>=
	procedure :: execute => cmd_scan_execute
	<<Commands: procedures>>=
	recursive subroutine cmd_scan_execute (cmd, global)
	class(cmd_scan_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(rt_data_t), allocatable :: local
	integer :: i, j
	do i = 1, cmd%n_values
	if (allocated (cmd%range)) then
	call cmd%range(i)%compile (global)
	call cmd%range(i)%evaluate ()
	do j = 1, cmd%range(i)%get_n_iterations ()
	call cmd%range(i)%set_value (j)
	allocate (local)
	call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
	call local%local_final ()
	deallocate (local)
	end do
	else
	allocate (local)
	call build_alt_setup (local, global, cmd%scan_cmd(i)%ptr)
	call local%local_final ()
	deallocate (local)
	end if
	end do
	end subroutine cmd_scan_execute

	@ %def cmd_scan_execute
	@
	\subsubsection{Conditionals}
	Conditionals are implemented as a list that is compiled and evaluated
	recursively; this allows for a straightforward representation of
	[[else if]] constructs. A [[cmd_if_t]] object can hold either an
	[[else_if]] clause which is another object of this type, or an
	[[else_body]], but not both.

	If- or else-bodies are no scoping units, so all data remain global and
	no copy-in copy-out is needed.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_if_t
	private
	type(parse_node_t), pointer :: pn_if_lexpr => null ()
	type(command_list_t), pointer :: if_body => null ()
	type(cmd_if_t), dimension(:), pointer :: elsif_cmd => null ()
	type(command_list_t), pointer :: else_body => null ()
	contains
	<<Commands: cmd if: TBP>>
	end type cmd_if_t

	@ %def cmd_if_t
	@ Finalizer. There are no local options, therefore we can simply override
	the default finalizer.
	<<Commands: cmd if: TBP>>=
	procedure :: final => cmd_if_final
	<<Commands: procedures>>=
	recursive subroutine cmd_if_final (cmd)
	class(cmd_if_t), intent(inout) :: cmd
	integer :: i
	if (associated (cmd%if_body)) then
	call command_list_final (cmd%if_body)
	deallocate (cmd%if_body)
	end if
	if (associated (cmd%elsif_cmd)) then
	do i = 1, size (cmd%elsif_cmd)
	call cmd_if_final (cmd%elsif_cmd(i))
	end do
	deallocate (cmd%elsif_cmd)
	end if
	if (associated (cmd%else_body)) then
	call command_list_final (cmd%else_body)
	deallocate (cmd%else_body)
	end if
	end subroutine cmd_if_final

	@ %def cmd_if_final
	@ Output. Recursively write the command lists.
	<<Commands: cmd if: TBP>>=
	procedure :: write => cmd_if_write
	<<Commands: procedures>>=
	subroutine cmd_if_write (cmd, unit, indent)
	class(cmd_if_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, ind, i
	u = given_output_unit (unit); if (u < 0) return
	ind = 0; if (present (indent)) ind = indent
	call write_indent (u, indent)
	write (u, "(A)") "if <expr> then"
	if (associated (cmd%if_body)) then
	call cmd%if_body%write (unit, ind + 1)
	end if
	if (associated (cmd%elsif_cmd)) then
	do i = 1, size (cmd%elsif_cmd)
	call write_indent (u, indent)
	write (u, "(A)") "elsif <expr> then"
	if (associated (cmd%elsif_cmd(i)%if_body)) then
	call cmd%elsif_cmd(i)%if_body%write (unit, ind + 1)
	end if
	end do
	end if
	if (associated (cmd%else_body)) then
	call write_indent (u, indent)
	write (u, "(A)") "else"
	call cmd%else_body%write (unit, ind + 1)
	end if
	end subroutine cmd_if_write

	@ %def cmd_if_write
	@ Compile the conditional.
	<<Commands: cmd if: TBP>>=
	procedure :: compile => cmd_if_compile
	<<Commands: procedures>>=
	recursive subroutine cmd_if_compile (cmd, global)
	class(cmd_if_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_lexpr, pn_body
	type(parse_node_t), pointer :: pn_elsif_clauses, pn_cmd_elsif
	type(parse_node_t), pointer :: pn_else_clause, pn_cmd_else
	integer :: i, n_elsif
	pn_lexpr => parse_node_get_sub_ptr (cmd%pn, 2)
	cmd%pn_if_lexpr => pn_lexpr
	pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
	select case (char (parse_node_get_rule_key (pn_body)))
	case ("command_list")
	allocate (cmd%if_body)
	call cmd%if_body%compile (pn_body, global)
	pn_elsif_clauses => parse_node_get_next_ptr (pn_body)
	case default
	pn_elsif_clauses => pn_body
	end select
	select case (char (parse_node_get_rule_key (pn_elsif_clauses)))
	case ("elsif_clauses")
	n_elsif = parse_node_get_n_sub (pn_elsif_clauses)
	allocate (cmd%elsif_cmd (n_elsif))
	pn_cmd_elsif => parse_node_get_sub_ptr (pn_elsif_clauses)
	do i = 1, n_elsif
	pn_lexpr => parse_node_get_sub_ptr (pn_cmd_elsif, 2)
	cmd%elsif_cmd(i)%pn_if_lexpr => pn_lexpr
	pn_body => parse_node_get_next_ptr (pn_lexpr, 2)
	if (associated (pn_body)) then
	allocate (cmd%elsif_cmd(i)%if_body)
	call cmd%elsif_cmd(i)%if_body%compile (pn_body, global)
	end if
	pn_cmd_elsif => parse_node_get_next_ptr (pn_cmd_elsif)
	end do
	pn_else_clause => parse_node_get_next_ptr (pn_elsif_clauses)
	case default
	pn_else_clause => pn_elsif_clauses
	end select
	select case (char (parse_node_get_rule_key (pn_else_clause)))
	case ("else_clause")
	pn_cmd_else => parse_node_get_sub_ptr (pn_else_clause)
	pn_body => parse_node_get_sub_ptr (pn_cmd_else, 2)
	if (associated (pn_body)) then
	allocate (cmd%else_body)
	call cmd%else_body%compile (pn_body, global)
	end if
	end select
	end subroutine cmd_if_compile

	@ %def global
	@ (Recursively) execute the condition. Context remains global in all cases.
	<<Commands: cmd if: TBP>>=
	procedure :: execute => cmd_if_execute
	<<Commands: procedures>>=
	recursive subroutine cmd_if_execute (cmd, global)
	class(cmd_if_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	logical :: lval, is_known
	integer :: i
	var_list => global%get_var_list_ptr ()
	lval = eval_log (cmd%pn_if_lexpr, var_list, is_known=is_known)
	if (is_known) then
	if (lval) then
	if (associated (cmd%if_body)) then
	call cmd%if_body%execute (global)
	end if
	return
	end if
	else
	call error_undecided ()
	return
	end if
	if (associated (cmd%elsif_cmd)) then
	SCAN_ELSIF: do i = 1, size (cmd%elsif_cmd)
	lval = eval_log (cmd%elsif_cmd(i)%pn_if_lexpr, var_list, &
	is_known=is_known)
	if (is_known) then
	if (lval) then
	if (associated (cmd%elsif_cmd(i)%if_body)) then
	call cmd%elsif_cmd(i)%if_body%execute (global)
	end if
	return
	end if
	else
	call error_undecided ()
	return
	end if
	end do SCAN_ELSIF
	end if
	if (associated (cmd%else_body)) then
	call cmd%else_body%execute (global)
	end if
	contains
	subroutine error_undecided ()
	call msg_error ("Undefined result of cmditional expression: " &
	// "neither branch will be executed")
	end subroutine error_undecided
	end subroutine cmd_if_execute

	@ %def cmd_if_execute
	@
	\subsubsection{Include another command-list file}
	The include command allocates a local parse tree. This must not be
	deleted before the command object itself is deleted, since pointers
	may point to subobjects of it.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_include_t
	private
	type(string_t) :: file
	type(command_list_t), pointer :: command_list => null ()
	type(parse_tree_t) :: parse_tree
	contains
	<<Commands: cmd include: TBP>>
	end type cmd_include_t

	@ %def cmd_include_t
	@ Finalizer: delete the command list. No options, so we can simply override
	the default finalizer.
	<<Commands: cmd include: TBP>>=
	procedure :: final => cmd_include_final
	<<Commands: procedures>>=
	subroutine cmd_include_final (cmd)
	class(cmd_include_t), intent(inout) :: cmd
	call parse_tree_final (cmd%parse_tree)
	if (associated (cmd%command_list)) then
	call cmd%command_list%final ()
	deallocate (cmd%command_list)
	end if
	end subroutine cmd_include_final

	@ %def cmd_include_final
	@ Write: display the command list as-is, if allocated.
	<<Commands: cmd include: TBP>>=
	procedure :: write => cmd_include_write
	<<Commands: procedures>>=
	subroutine cmd_include_write (cmd, unit, indent)
	class(cmd_include_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, ind
	u = given_output_unit (unit)
	ind = 0; if (present (indent)) ind = indent
	call write_indent (u, indent)
	write (u, "(A,A,A,A)") "include ", '"', char (cmd%file), '"'
	if (associated (cmd%command_list)) then
	call cmd%command_list%write (u, ind + 1)
	end if
	end subroutine cmd_include_write

	@ %def cmd_include_write
	@ Compile file contents: First parse the file, then immediately
	compile its contents. Use the global data set.
	<<Commands: cmd include: TBP>>=
	procedure :: compile => cmd_include_compile
	<<Commands: procedures>>=
	subroutine cmd_include_compile (cmd, global)
	class(cmd_include_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_file
	type(string_t) :: file
	logical :: exist
	integer :: u
	type(stream_t), target :: stream
	type(lexer_t) :: lexer
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	pn_file => parse_node_get_sub_ptr (pn_arg)
	file = parse_node_get_string (pn_file)
	inquire (file=char(file), exist=exist)
	if (exist) then
	cmd%file = file
	else
	cmd%file = global%os_data%whizard_cutspath // "/" // file
	inquire (file=char(cmd%file), exist=exist)
	if (.not. exist) then
	call msg_error ("Include file '" // char (file) // "' not found")
	return
	end if
	end if
	u = free_unit ()
	call lexer_init_cmd_list (lexer, global%lexer)
	call stream_init (stream, char (cmd%file))
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init (cmd%parse_tree, syntax_cmd_list, lexer)
	call stream_final (stream)
	call lexer_final (lexer)
	close (u)
	allocate (cmd%command_list)
	call cmd%command_list%compile (cmd%parse_tree%get_root_ptr (), &
	global)
	end subroutine cmd_include_compile

	@ %def cmd_include_compile
	@ Execute file contents in the global context.
	<<Commands: cmd include: TBP>>=
	procedure :: execute => cmd_include_execute
	<<Commands: procedures>>=
	subroutine cmd_include_execute (cmd, global)
	class(cmd_include_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	if (associated (cmd%command_list)) then
	call msg_message &
	("Including Sindarin from '" // char (cmd%file) // "'")
	call cmd%command_list%execute (global)
	call msg_message &
	("End of included '" // char (cmd%file) // "'")
	end if
	end subroutine cmd_include_execute

	@ %def cmd_include_execute
	@
	\subsubsection{Export values}
	This command exports the current values of variables or other objects to the
	surrounding scope. By default, a scope enclosed by braces keeps all objects
	local to it. The [[export]] command exports the values that are generated
	within the scope to the corresponding object in the outer scope.

	The allowed set of exportable objects is, in principle, the same as the set of
	objects that the [[show]] command supports. This includes some convenience
	abbreviations.

	TODO: The initial implementation inherits syntax from [[show]], but supports
	only the [[results]] pseudo-object. The results (i.e., the process stack) is
	appended to the outer process stack instead of being discarded. The behavior
	of the [[export]] command for other object kinds is to be defined on a
	case-by-case basis. It may involve replacing the outer value or, instead,
	doing some sort of appending or reduction.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_export_t
	private
	type(string_t), dimension(:), allocatable :: name
	contains
	<<Commands: cmd export: TBP>>
	end type cmd_export_t

	@ %def cmd_export_t
	@ Output: list the object names, not values.
	<<Commands: cmd export: TBP>>=
	procedure :: write => cmd_export_write
	<<Commands: procedures>>=
	subroutine cmd_export_write (cmd, unit, indent)
	class(cmd_export_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A)", advance="no") "export: "
	if (allocated (cmd%name)) then
	do i = 1, size (cmd%name)
	write (u, "(1x,A)", advance="no") char (cmd%name(i))
	end do
	write (u, *)
	else
	write (u, "(5x,A)") "[undefined]"
	end if
	end subroutine cmd_export_write

	@ %def cmd_export_write
	@ Compile. Allocate an array which is filled with the names of the
	variables to export.
	<<Commands: cmd export: TBP>>=
	procedure :: compile => cmd_export_compile
	<<Commands: procedures>>=
	subroutine cmd_export_compile (cmd, global)
	class(cmd_export_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg, pn_var, pn_prefix, pn_name
	type(string_t) :: key
	integer :: i, n_args
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (pn_arg)) then
	select case (char (parse_node_get_rule_key (pn_arg)))
	case ("show_arg")
	cmd%pn_opt => parse_node_get_next_ptr (pn_arg)
	case default
	cmd%pn_opt => pn_arg
	pn_arg => null ()
	end select
	end if
	call cmd%compile_options (global)
	if (associated (pn_arg)) then
	n_args = parse_node_get_n_sub (pn_arg)
	allocate (cmd%name (n_args))
	pn_var => parse_node_get_sub_ptr (pn_arg)
	i = 0
	do while (associated (pn_var))
	i = i + 1
	select case (char (parse_node_get_rule_key (pn_var)))
	case ("model", "library", "beams", "iterations", &
	"cuts", "weight", "int", "real", "complex", &
	"scale", "factorization_scale", "renormalization_scale", &
	"selection", "reweight", "analysis", "pdg", &
	"stable", "unstable", "polarized", "unpolarized", &
	"results", "expect", "intrinsic", "string", "logical")
	cmd%name(i) = parse_node_get_key (pn_var)
	case ("result_var")
	pn_prefix => parse_node_get_sub_ptr (pn_var)
	pn_name => parse_node_get_next_ptr (pn_prefix)
	if (associated (pn_name)) then
	cmd%name(i) = parse_node_get_key (pn_prefix) &
	// "(" // parse_node_get_string (pn_name) // ")"
	else
	cmd%name(i) = parse_node_get_key (pn_prefix)
	end if
	case ("log_var", "string_var", "alias_var")
	pn_prefix => parse_node_get_sub_ptr (pn_var)
	pn_name => parse_node_get_next_ptr (pn_prefix)
	key = parse_node_get_key (pn_prefix)
	if (associated (pn_name)) then
	select case (char (parse_node_get_rule_key (pn_name)))
	case ("var_name")
	select case (char (key))
	case ("?", "$") ! $ sign
	cmd%name(i) = key // parse_node_get_string (pn_name)
	case ("alias")
	cmd%name(i) = parse_node_get_string (pn_name)
	end select
	case default
	call parse_node_mismatch &
	("var_name", pn_name)
	end select
	else
	cmd%name(i) = key
	end if
	case default
	cmd%name(i) = parse_node_get_string (pn_var)
	end select
	!!! restriction imposed by current lack of implementation
	select case (char (parse_node_get_rule_key (pn_var)))
	case ("results")
	case default
	call msg_fatal ("export: object (type) '" &
	// char (parse_node_get_rule_key (pn_var)) &
	// "' not supported yet")
	end select
	pn_var => parse_node_get_next_ptr (pn_var)
	end do
	else
	allocate (cmd%name (0))
	end if
	end subroutine cmd_export_compile

	@ %def cmd_export_compile
	@ Execute. Scan the list of objects to export.
	<<Commands: cmd export: TBP>>=
	procedure :: execute => cmd_export_execute
	<<Commands: procedures>>=
	subroutine cmd_export_execute (cmd, global)
	class(cmd_export_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	call global%append_exports (cmd%name)
	end subroutine cmd_export_execute

	@ %def cmd_export_execute
	@
	\subsubsection{Quit command execution}
	The code is the return code of the whole program if it is terminated
	by this command.
	<<Commands: types>>=
	type, extends (command_t) :: cmd_quit_t
	private
	logical :: has_code = .false.
	type(parse_node_t), pointer :: pn_code_expr => null ()
	contains
	<<Commands: cmd quit: TBP>>
	end type cmd_quit_t

	@ %def cmd_quit_t
	@ Output.
	<<Commands: cmd quit: TBP>>=
	procedure :: write => cmd_quit_write
	<<Commands: procedures>>=
	subroutine cmd_quit_write (cmd, unit, indent)
	class(cmd_quit_t), intent(in) :: cmd
	integer, intent(in), optional :: unit, indent
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call write_indent (u, indent)
	write (u, "(1x,A,L1)") "quit: has_code = ", cmd%has_code
	end subroutine cmd_quit_write

	@ %def cmd_quit_write
	@ Compile: allocate a [[quit]] object which serves as a placeholder.
	<<Commands: cmd quit: TBP>>=
	procedure :: compile => cmd_quit_compile
	<<Commands: procedures>>=
	subroutine cmd_quit_compile (cmd, global)
	class(cmd_quit_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_arg
	pn_arg => parse_node_get_sub_ptr (cmd%pn, 2)
	if (associated (pn_arg)) then
	cmd%pn_code_expr => parse_node_get_sub_ptr (pn_arg)
	cmd%has_code = .true.
	end if
	end subroutine cmd_quit_compile

	@ %def cmd_quit_compile
	@ Execute: The quit command does not execute anything, it just stops
	command execution. This is achieved by setting quit flag and quit
	code in the global variable list. However, the return code, if
	present, is an expression which has to be evaluated.
	<<Commands: cmd quit: TBP>>=
	procedure :: execute => cmd_quit_execute
	<<Commands: procedures>>=
	subroutine cmd_quit_execute (cmd, global)
	class(cmd_quit_t), intent(inout) :: cmd
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), pointer :: var_list
	logical :: is_known
	var_list => global%get_var_list_ptr ()
	if (cmd%has_code) then
	global%quit_code = eval_int (cmd%pn_code_expr, var_list, &
	is_known=is_known)
	if (.not. is_known) then
	call msg_error ("Undefined return code of quit/exit command")
	end if
	end if
	global%quit = .true.
	end subroutine cmd_quit_execute

	@ %def cmd_quit_execute
	@
	\subsection{The command list}
	The command list holds a list of commands and relevant global data.
	<<Commands: public>>=
	public :: command_list_t
	<<Commands: types>>=
	type :: command_list_t
	! not private anymore as required by the whizard-c-interface
	class(command_t), pointer :: first => null ()
	class(command_t), pointer :: last => null ()
	contains
	<<Commands: command list: TBP>>
	end type command_list_t

	@ %def command_list_t
	@ Output.
	<<Commands: command list: TBP>>=
	procedure :: write => command_list_write
	<<Commands: procedures>>=
	recursive subroutine command_list_write (cmd_list, unit, indent)
	class(command_list_t), intent(in) :: cmd_list
	integer, intent(in), optional :: unit, indent
	class(command_t), pointer :: cmd
	cmd => cmd_list%first
	do while (associated (cmd))
	call cmd%write (unit, indent)
	cmd => cmd%next
	end do
	end subroutine command_list_write

	@ %def command_list_write
	@ Append a new command to the list and free the original pointer.
	<<Commands: command list: TBP>>=
	procedure :: append => command_list_append
	<<Commands: procedures>>=
	subroutine command_list_append (cmd_list, command)
	class(command_list_t), intent(inout) :: cmd_list
	class(command_t), intent(inout), pointer :: command
	if (associated (cmd_list%last)) then
	cmd_list%last%next => command
	else
	cmd_list%first => command
	end if
	cmd_list%last => command
	command => null ()
	end subroutine command_list_append

	@ %def command_list_append
	@ Finalize.
	<<Commands: command list: TBP>>=
	procedure :: final => command_list_final
	<<Commands: procedures>>=
	recursive subroutine command_list_final (cmd_list)
	class(command_list_t), intent(inout) :: cmd_list
	class(command_t), pointer :: command
	do while (associated (cmd_list%first))
	command => cmd_list%first
	cmd_list%first => cmd_list%first%next
	call command%final ()
	deallocate (command)
	end do
	cmd_list%last => null ()
	end subroutine command_list_final

	@ %def command_list_final
	@
	\subsection{Compiling the parse tree}
	Transform a parse tree into a command list. Initialization is assumed
	to be done.

	After each command, we set a breakpoint.
	<<Commands: command list: TBP>>=
	procedure :: compile => command_list_compile
	<<Commands: procedures>>=
	recursive subroutine command_list_compile (cmd_list, pn, global)
	class(command_list_t), intent(inout), target :: cmd_list
	type(parse_node_t), intent(in), target :: pn
	type(rt_data_t), intent(inout), target :: global
	type(parse_node_t), pointer :: pn_cmd
	class(command_t), pointer :: command
	integer :: i
	pn_cmd => parse_node_get_sub_ptr (pn)
	do i = 1, parse_node_get_n_sub (pn)
	call dispatch_command (command, pn_cmd)
	call command%compile (global)
	call cmd_list%append (command)
	call terminate_now_if_signal ()
	pn_cmd => parse_node_get_next_ptr (pn_cmd)
	end do
	end subroutine command_list_compile

	@ %def command_list_compile
	@
	\subsection{Executing the command list}
	Before executing a command we should execute its options (if any). After
	that, reset the options, i.e., remove temporary effects from the global
	state.

	Also here, after each command we set a breakpoint.
	<<Commands: command list: TBP>>=
	procedure :: execute => command_list_execute
	<<Commands: procedures>>=
	recursive subroutine command_list_execute (cmd_list, global)
	class(command_list_t), intent(in) :: cmd_list
	type(rt_data_t), intent(inout), target :: global
	class(command_t), pointer :: command
	command => cmd_list%first
	COMMAND_COND: do while (associated (command))
	call command%execute_options (global)
	call command%execute (global)
	call command%reset_options (global)
	call terminate_now_if_signal ()
	if (global%quit) exit COMMAND_COND
	command => command%next
	end do COMMAND_COND
	end subroutine command_list_execute

	@ %def command_list_execute
	@
	\subsection{Command list syntax}
	<<Commands: public>>=
	public :: syntax_cmd_list
	<<Commands: variables>>=
	type(syntax_t), target, save :: syntax_cmd_list

	@ %def syntax_cmd_list
	<<Commands: public>>=
	public :: syntax_cmd_list_init
	<<Commands: procedures>>=
	subroutine syntax_cmd_list_init ()
	type(ifile_t) :: ifile
	call define_cmd_list_syntax (ifile)
	call syntax_init (syntax_cmd_list, ifile)
	call ifile_final (ifile)
	end subroutine syntax_cmd_list_init

	@ %def syntax_cmd_list_init
	<<Commands: public>>=
	public :: syntax_cmd_list_final
	<<Commands: procedures>>=
	subroutine syntax_cmd_list_final ()
	call syntax_final (syntax_cmd_list)
	end subroutine syntax_cmd_list_final

	@ %def syntax_cmd_list_final
	<<Commands: public>>=
	public :: syntax_cmd_list_write
	<<Commands: procedures>>=
	subroutine syntax_cmd_list_write (unit)
	integer, intent(in), optional :: unit
	call syntax_write (syntax_cmd_list, unit)
	end subroutine syntax_cmd_list_write

	@ %def syntax_cmd_list_write
	<<Commands: procedures>>=
	subroutine define_cmd_list_syntax (ifile)
	type(ifile_t), intent(inout) :: ifile
	call ifile_append (ifile, "SEQ command_list = command*")
	call ifile_append (ifile, "ALT command = " &
	// "cmd_model \| cmd_library \| cmd_iterations \| cmd_sample_format \| " &
	// "cmd_var \| cmd_slha \| " &
	// "cmd_show \| cmd_clear \| " &
	// "cmd_expect \| " &
	// "cmd_cuts \| cmd_scale \| cmd_fac_scale \| cmd_ren_scale \| " &
	// "cmd_weight \| cmd_selection \| cmd_reweight \| " &
	// "cmd_beams \| cmd_beams_pol_density \| cmd_beams_pol_fraction \| " &
	// "cmd_beams_momentum \| cmd_beams_theta \| cmd_beams_phi \| " &
	// "cmd_integrate \| " &
	// "cmd_observable \| cmd_histogram \| cmd_plot \| cmd_graph \| " &
	// "cmd_record \| " &
	// "cmd_analysis \| cmd_alt_setup \| " &
	// "cmd_unstable \| cmd_stable \| cmd_simulate \| cmd_rescan \| " &
	// "cmd_process \| cmd_compile \| cmd_exec \| " &
	// "cmd_scan \| cmd_if \| cmd_include \| cmd_quit \| " &
	// "cmd_export \| " &
	// "cmd_polarized \| cmd_unpolarized \| " &
	// "cmd_open_out \| cmd_close_out \| cmd_printf \| " &
	// "cmd_write_analysis \| cmd_compile_analysis \| cmd_nlo \| cmd_components")
	call ifile_append (ifile, "GRO options = '{' local_command_list '}'")
	call ifile_append (ifile, "SEQ local_command_list = local_command*")
	call ifile_append (ifile, "ALT local_command = " &
	// "cmd_model \| cmd_library \| cmd_iterations \| cmd_sample_format \| " &
	// "cmd_var \| cmd_slha \| " &
	// "cmd_show \| " &
	// "cmd_expect \| " &
	// "cmd_cuts \| cmd_scale \| cmd_fac_scale \| cmd_ren_scale \| " &
	// "cmd_weight \| cmd_selection \| cmd_reweight \| " &
	// "cmd_beams \| cmd_beams_pol_density \| cmd_beams_pol_fraction \| " &
	// "cmd_beams_momentum \| cmd_beams_theta \| cmd_beams_phi \| " &
	// "cmd_observable \| cmd_histogram \| cmd_plot \| cmd_graph \| " &
	// "cmd_clear \| cmd_record \| " &
	// "cmd_analysis \| cmd_alt_setup \| " &
	// "cmd_open_out \| cmd_close_out \| cmd_printf \| " &
	// "cmd_write_analysis \| cmd_compile_analysis \| cmd_nlo \| cmd_components")
	call ifile_append (ifile, "SEQ cmd_model = model '=' model_name model_arg?")
	call ifile_append (ifile, "KEY model")
	call ifile_append (ifile, "ALT model_name = model_id \| string_literal")
	call ifile_append (ifile, "IDE model_id")
	call ifile_append (ifile, "ARG model_arg = ( model_scheme? )")
	call ifile_append (ifile, "ALT model_scheme = " &
	// "ufo_spec \| scheme_id \| string_literal")
	call ifile_append (ifile, "SEQ ufo_spec = ufo ufo_arg?")
	call ifile_append (ifile, "KEY ufo")
	call ifile_append (ifile, "ARG ufo_arg = ( string_literal )")
	call ifile_append (ifile, "IDE scheme_id")
	call ifile_append (ifile, "SEQ cmd_library = library '=' lib_name")
	call ifile_append (ifile, "KEY library")
	call ifile_append (ifile, "ALT lib_name = lib_id \| string_literal")
	call ifile_append (ifile, "IDE lib_id")
	call ifile_append (ifile, "ALT cmd_var = " &
	// "cmd_log_decl \| cmd_log \| " &
	// "cmd_int \| cmd_real \| cmd_complex \| cmd_num \| " &
	// "cmd_string_decl \| cmd_string \| cmd_alias \| " &
	// "cmd_result")
	call ifile_append (ifile, "SEQ cmd_log_decl = logical cmd_log")
	call ifile_append (ifile, "SEQ cmd_log = '?' var_name '=' lexpr")
	call ifile_append (ifile, "SEQ cmd_int = int var_name '=' expr")
	call ifile_append (ifile, "SEQ cmd_real = real var_name '=' expr")
	call ifile_append (ifile, "SEQ cmd_complex = complex var_name '=' expr")
	call ifile_append (ifile, "SEQ cmd_num = var_name '=' expr")
	call ifile_append (ifile, "SEQ cmd_string_decl = string cmd_string")
	call ifile_append (ifile, "SEQ cmd_string = " &
	// "'$' var_name '=' sexpr") ! $
	call ifile_append (ifile, "SEQ cmd_alias = alias var_name '=' cexpr")
	call ifile_append (ifile, "SEQ cmd_result = result '=' expr")
	call ifile_append (ifile, "SEQ cmd_slha = slha_action slha_arg options?")
	call ifile_append (ifile, "ALT slha_action = " &
	// "read_slha \| write_slha")
	call ifile_append (ifile, "KEY read_slha")
	call ifile_append (ifile, "KEY write_slha")
	call ifile_append (ifile, "ARG slha_arg = ( string_literal )")
	call ifile_append (ifile, "SEQ cmd_show = show show_arg options?")
	call ifile_append (ifile, "KEY show")
	call ifile_append (ifile, "ARG show_arg = ( showable* )")
	call ifile_append (ifile, "ALT showable = " &
	// "model \| library \| beams \| iterations \| " &
	// "cuts \| weight \| logical \| string \| pdg \| " &
	// "scale \| factorization_scale \| renormalization_scale \| " &
	// "selection \| reweight \| analysis \| " &
	// "stable \| unstable \| polarized \| unpolarized \| " &
	// "expect \| intrinsic \| int \| real \| complex \| " &
	// "alias_var \| string \| results \| result_var \| " &
	// "log_var \| string_var \| var_name")
	call ifile_append (ifile, "KEY results")
	call ifile_append (ifile, "KEY intrinsic")
	call ifile_append (ifile, "SEQ alias_var = alias var_name")
	call ifile_append (ifile, "SEQ result_var = result_key result_arg?")
	call ifile_append (ifile, "SEQ log_var = '?' var_name")
	call ifile_append (ifile, "SEQ string_var = '$' var_name") ! $
	call ifile_append (ifile, "SEQ cmd_clear = clear clear_arg options?")
	call ifile_append (ifile, "KEY clear")
	call ifile_append (ifile, "ARG clear_arg = ( clearable* )")
	call ifile_append (ifile, "ALT clearable = " &
	// "beams \| iterations \| " &
	// "cuts \| weight \| " &
	// "scale \| factorization_scale \| renormalization_scale \| " &
	// "selection \| reweight \| analysis \| " &
	// "unstable \| polarized \| " &
	// "expect \| " &
	// "log_var \| string_var \| var_name")
	call ifile_append (ifile, "SEQ cmd_expect = expect expect_arg options?")
	call ifile_append (ifile, "KEY expect")
	call ifile_append (ifile, "ARG expect_arg = ( lexpr )")
	call ifile_append (ifile, "SEQ cmd_cuts = cuts '=' lexpr")
	call ifile_append (ifile, "SEQ cmd_scale = scale '=' expr")
	call ifile_append (ifile, "SEQ cmd_fac_scale = " &
	// "factorization_scale '=' expr")
	call ifile_append (ifile, "SEQ cmd_ren_scale = " &
	// "renormalization_scale '=' expr")
	call ifile_append (ifile, "SEQ cmd_weight = weight '=' expr")
	call ifile_append (ifile, "SEQ cmd_selection = selection '=' lexpr")
	call ifile_append (ifile, "SEQ cmd_reweight = reweight '=' expr")
	call ifile_append (ifile, "KEY cuts")
	call ifile_append (ifile, "KEY scale")
	call ifile_append (ifile, "KEY factorization_scale")
	call ifile_append (ifile, "KEY renormalization_scale")
	call ifile_append (ifile, "KEY weight")
	call ifile_append (ifile, "KEY selection")
	call ifile_append (ifile, "KEY reweight")
	call ifile_append (ifile, "SEQ cmd_process = process process_id '=' " &
	// "process_prt '=>' prt_state_list options?")
	call ifile_append (ifile, "KEY process")
	call ifile_append (ifile, "KEY '=>'")
	call ifile_append (ifile, "LIS process_prt = cexpr+")
	call ifile_append (ifile, "LIS prt_state_list = prt_state_sum+")
	call ifile_append (ifile, "SEQ prt_state_sum = " &
	// "prt_state prt_state_addition*")
	call ifile_append (ifile, "SEQ prt_state_addition = '+' prt_state")
	call ifile_append (ifile, "ALT prt_state = grouped_prt_state_list \| cexpr")
	call ifile_append (ifile, "GRO grouped_prt_state_list = " &
	// "( prt_state_list )")
	call ifile_append (ifile, "SEQ cmd_compile = compile_cmd options?")
	call ifile_append (ifile, "SEQ compile_cmd = compile_clause compile_arg?")
	call ifile_append (ifile, "SEQ compile_clause = compile exec_name_spec?")
	call ifile_append (ifile, "KEY compile")
	call ifile_append (ifile, "SEQ exec_name_spec = as exec_name")
	call ifile_append (ifile, "KEY as")
	call ifile_append (ifile, "ALT exec_name = exec_id \| string_literal")
	call ifile_append (ifile, "IDE exec_id")
	call ifile_append (ifile, "ARG compile_arg = ( lib_name* )")
	call ifile_append (ifile, "SEQ cmd_exec = exec exec_arg")
	call ifile_append (ifile, "KEY exec")
	call ifile_append (ifile, "ARG exec_arg = ( sexpr )")
	call ifile_append (ifile, "SEQ cmd_beams = beams '=' beam_def")
	call ifile_append (ifile, "KEY beams")
	call ifile_append (ifile, "SEQ beam_def = beam_spec strfun_seq*")
	call ifile_append (ifile, "SEQ beam_spec = beam_list")
	call ifile_append (ifile, "LIS beam_list = cexpr, cexpr?")
	call ifile_append (ifile, "SEQ cmd_beams_pol_density = " &
	// "beams_pol_density '=' beams_pol_spec")
	call ifile_append (ifile, "KEY beams_pol_density")
	call ifile_append (ifile, "LIS beams_pol_spec = smatrix, smatrix?")
	call ifile_append (ifile, "SEQ smatrix = '@' smatrix_arg")
	! call ifile_append (ifile, "KEY '@'") !!! Key already exists
	call ifile_append (ifile, "ARG smatrix_arg = ( sentry* )")
	call ifile_append (ifile, "SEQ sentry = expr extra_sentry*")
	call ifile_append (ifile, "SEQ extra_sentry = ':' expr")
	call ifile_append (ifile, "SEQ cmd_beams_pol_fraction = " &
	// "beams_pol_fraction '=' beams_par_spec")
	call ifile_append (ifile, "KEY beams_pol_fraction")
	call ifile_append (ifile, "SEQ cmd_beams_momentum = " &
	// "beams_momentum '=' beams_par_spec")
	call ifile_append (ifile, "KEY beams_momentum")
	call ifile_append (ifile, "SEQ cmd_beams_theta = " &
	// "beams_theta '=' beams_par_spec")
	call ifile_append (ifile, "KEY beams_theta")
	call ifile_append (ifile, "SEQ cmd_beams_phi = " &
	// "beams_phi '=' beams_par_spec")
	call ifile_append (ifile, "KEY beams_phi")
	call ifile_append (ifile, "LIS beams_par_spec = expr, expr?")
	call ifile_append (ifile, "SEQ strfun_seq = '=>' strfun_pair")
	call ifile_append (ifile, "LIS strfun_pair = strfun_def, strfun_def?")
	call ifile_append (ifile, "SEQ strfun_def = strfun_id")
	call ifile_append (ifile, "ALT strfun_id = " &
	// "none \| lhapdf \| lhapdf_photon \| pdf_builtin \| pdf_builtin_photon \| " &
	// "isr \| epa \| ewa \| circe1 \| circe2 \| energy_scan \| " &
	// "gaussian \| beam_events")
	call ifile_append (ifile, "KEY none")
	call ifile_append (ifile, "KEY lhapdf")
	call ifile_append (ifile, "KEY lhapdf_photon")
	call ifile_append (ifile, "KEY pdf_builtin")
	call ifile_append (ifile, "KEY pdf_builtin_photon")
	call ifile_append (ifile, "KEY isr")
	call ifile_append (ifile, "KEY epa")
	call ifile_append (ifile, "KEY ewa")
	call ifile_append (ifile, "KEY circe1")
	call ifile_append (ifile, "KEY circe2")
	call ifile_append (ifile, "KEY energy_scan")
	call ifile_append (ifile, "KEY gaussian")
	call ifile_append (ifile, "KEY beam_events")
	call ifile_append (ifile, "SEQ cmd_integrate = " &
	// "integrate proc_arg options?")
	call ifile_append (ifile, "KEY integrate")
	call ifile_append (ifile, "ARG proc_arg = ( proc_id* )")
	call ifile_append (ifile, "IDE proc_id")
	call ifile_append (ifile, "SEQ cmd_iterations = " &
	// "iterations '=' iterations_list")
	call ifile_append (ifile, "KEY iterations")
	call ifile_append (ifile, "LIS iterations_list = iterations_spec+")
	call ifile_append (ifile, "ALT iterations_spec = it_spec")
	call ifile_append (ifile, "SEQ it_spec = expr calls_spec adapt_spec?")
	call ifile_append (ifile, "SEQ calls_spec = ':' expr")
	call ifile_append (ifile, "SEQ adapt_spec = ':' sexpr")
	call ifile_append (ifile, "SEQ cmd_components = " &
	// "active '=' component_list")
	call ifile_append (ifile, "KEY active")
	call ifile_append (ifile, "LIS component_list = sexpr+")
	call ifile_append (ifile, "SEQ cmd_sample_format = " &
	// "sample_format '=' event_format_list")
	call ifile_append (ifile, "KEY sample_format")
	call ifile_append (ifile, "LIS event_format_list = event_format+")
	call ifile_append (ifile, "IDE event_format")
	call ifile_append (ifile, "SEQ cmd_observable = " &
	// "observable analysis_tag options?")
	call ifile_append (ifile, "KEY observable")
	call ifile_append (ifile, "SEQ cmd_histogram = " &
	// "histogram analysis_tag histogram_arg " &
	// "options?")
	call ifile_append (ifile, "KEY histogram")
	call ifile_append (ifile, "ARG histogram_arg = (expr, expr, expr?)")
	call ifile_append (ifile, "SEQ cmd_plot = plot analysis_tag options?")
	call ifile_append (ifile, "KEY plot")
	call ifile_append (ifile, "SEQ cmd_graph = graph graph_term '=' graph_def")
	call ifile_append (ifile, "KEY graph")
	call ifile_append (ifile, "SEQ graph_term = analysis_tag options?")
	call ifile_append (ifile, "SEQ graph_def = graph_term graph_append*")
	call ifile_append (ifile, "SEQ graph_append = '&' graph_term")
	call ifile_append (ifile, "SEQ cmd_analysis = analysis '=' lexpr")
	call ifile_append (ifile, "KEY analysis")
	call ifile_append (ifile, "SEQ cmd_alt_setup = " &
	// "alt_setup '=' option_list_expr")
	call ifile_append (ifile, "KEY alt_setup")
	call ifile_append (ifile, "ALT option_list_expr = " &
	// "grouped_option_list \| option_list")
	call ifile_append (ifile, "GRO grouped_option_list = ( option_list_expr )")
	call ifile_append (ifile, "LIS option_list = options+")
	call ifile_append (ifile, "SEQ cmd_open_out = open_out open_arg options?")
	call ifile_append (ifile, "SEQ cmd_close_out = close_out open_arg options?")
	call ifile_append (ifile, "KEY open_out")
	call ifile_append (ifile, "KEY close_out")
	call ifile_append (ifile, "ARG open_arg = (sexpr)")
	call ifile_append (ifile, "SEQ cmd_printf = printf_cmd options?")
	call ifile_append (ifile, "SEQ printf_cmd = printf_clause sprintf_args?")
	call ifile_append (ifile, "SEQ printf_clause = printf sexpr")
	call ifile_append (ifile, "KEY printf")
	call ifile_append (ifile, "SEQ cmd_record = record_cmd")
	call ifile_append (ifile, "SEQ cmd_unstable = " &
	// "unstable cexpr unstable_arg options?")
	call ifile_append (ifile, "KEY unstable")
	call ifile_append (ifile, "ARG unstable_arg = ( proc_id* )")
	call ifile_append (ifile, "SEQ cmd_stable = stable stable_list options?")
	call ifile_append (ifile, "KEY stable")
	call ifile_append (ifile, "LIS stable_list = cexpr+")
	call ifile_append (ifile, "KEY polarized")
	call ifile_append (ifile, "SEQ cmd_polarized = polarized polarized_list options?")
	call ifile_append (ifile, "LIS polarized_list = cexpr+")
	call ifile_append (ifile, "KEY unpolarized")
	call ifile_append (ifile, "SEQ cmd_unpolarized = unpolarized unpolarized_list options?")
	call ifile_append (ifile, "LIS unpolarized_list = cexpr+")
	call ifile_append (ifile, "SEQ cmd_simulate = " &
	// "simulate proc_arg options?")
	call ifile_append (ifile, "KEY simulate")
	call ifile_append (ifile, "SEQ cmd_rescan = " &
	// "rescan sexpr proc_arg options?")
	call ifile_append (ifile, "KEY rescan")
	call ifile_append (ifile, "SEQ cmd_scan = scan scan_var scan_body?")
	call ifile_append (ifile, "KEY scan")
	call ifile_append (ifile, "ALT scan_var = " &
	// "scan_log_decl \| scan_log \| " &
	// "scan_int \| scan_real \| scan_complex \| scan_num \| " &
	// "scan_string_decl \| scan_string \| scan_alias \| " &
	// "scan_cuts \| scan_weight \| " &
	// "scan_scale \| scan_ren_scale \| scan_fac_scale \| " &
	// "scan_selection \| scan_reweight \| scan_analysis \| " &
	// "scan_model \| scan_library")
	call ifile_append (ifile, "SEQ scan_log_decl = logical scan_log")
	call ifile_append (ifile, "SEQ scan_log = '?' var_name '=' scan_log_arg")
	call ifile_append (ifile, "ARG scan_log_arg = ( lexpr* )")
	call ifile_append (ifile, "SEQ scan_int = int var_name '=' scan_num_arg")
	call ifile_append (ifile, "SEQ scan_real = real var_name '=' scan_num_arg")
	call ifile_append (ifile, "SEQ scan_complex = " &
	// "complex var_name '=' scan_num_arg")
	call ifile_append (ifile, "SEQ scan_num = var_name '=' scan_num_arg")
	call ifile_append (ifile, "ARG scan_num_arg = ( range* )")
	call ifile_append (ifile, "ALT range = grouped_range \| range_expr")
	call ifile_append (ifile, "GRO grouped_range = ( range_expr )")
	call ifile_append (ifile, "SEQ range_expr = expr range_spec?")
	call ifile_append (ifile, "SEQ range_spec = '=>' expr step_spec?")
	call ifile_append (ifile, "SEQ step_spec = step_op expr")
	call ifile_append (ifile, "ALT step_op = " &
	// "'/+' \| '/-' \| '/' \| '//' \| '/+/' \| '//'")
	call ifile_append (ifile, "KEY '/+'")
	call ifile_append (ifile, "KEY '/-'")
	call ifile_append (ifile, "KEY '/*'")
	call ifile_append (ifile, "KEY '//'")
	call ifile_append (ifile, "KEY '/+/'")
	call ifile_append (ifile, "KEY '/*/'")
	call ifile_append (ifile, "SEQ scan_string_decl = string scan_string")
	call ifile_append (ifile, "SEQ scan_string = " &
	// "'$' var_name '=' scan_string_arg")
	call ifile_append (ifile, "ARG scan_string_arg = ( sexpr* )")
	call ifile_append (ifile, "SEQ scan_alias = " &
	// "alias var_name '=' scan_alias_arg")
	call ifile_append (ifile, "ARG scan_alias_arg = ( cexpr* )")
	call ifile_append (ifile, "SEQ scan_cuts = cuts '=' scan_lexpr_arg")
	call ifile_append (ifile, "ARG scan_lexpr_arg = ( lexpr* )")
	call ifile_append (ifile, "SEQ scan_scale = scale '=' scan_expr_arg")
	call ifile_append (ifile, "ARG scan_expr_arg = ( expr* )")
	call ifile_append (ifile, "SEQ scan_fac_scale = " &
	// "factorization_scale '=' scan_expr_arg")
	call ifile_append (ifile, "SEQ scan_ren_scale = " &
	// "renormalization_scale '=' scan_expr_arg")
	call ifile_append (ifile, "SEQ scan_weight = weight '=' scan_expr_arg")
	call ifile_append (ifile, "SEQ scan_selection = selection '=' scan_lexpr_arg")
	call ifile_append (ifile, "SEQ scan_reweight = reweight '=' scan_expr_arg")
	call ifile_append (ifile, "SEQ scan_analysis = analysis '=' scan_lexpr_arg")
	call ifile_append (ifile, "SEQ scan_model = model '=' scan_model_arg")
	call ifile_append (ifile, "ARG scan_model_arg = ( model_name* )")
	call ifile_append (ifile, "SEQ scan_library = library '=' scan_library_arg")
	call ifile_append (ifile, "ARG scan_library_arg = ( lib_name* )")
	call ifile_append (ifile, "GRO scan_body = '{' command_list '}'")
	call ifile_append (ifile, "SEQ cmd_if = " &
	// "if lexpr then command_list elsif_clauses else_clause endif")
	call ifile_append (ifile, "SEQ elsif_clauses = cmd_elsif*")
	call ifile_append (ifile, "SEQ cmd_elsif = elsif lexpr then command_list")
	call ifile_append (ifile, "SEQ else_clause = cmd_else?")
	call ifile_append (ifile, "SEQ cmd_else = else command_list")
	call ifile_append (ifile, "SEQ cmd_include = include include_arg")
	call ifile_append (ifile, "KEY include")
	call ifile_append (ifile, "ARG include_arg = ( string_literal )")
	call ifile_append (ifile, "SEQ cmd_quit = quit_cmd quit_arg?")
	call ifile_append (ifile, "ALT quit_cmd = quit \| exit")
	call ifile_append (ifile, "KEY quit")
	call ifile_append (ifile, "KEY exit")
	call ifile_append (ifile, "ARG quit_arg = ( expr )")
	call ifile_append (ifile, "SEQ cmd_export = export show_arg options?")
	call ifile_append (ifile, "KEY export")
	call ifile_append (ifile, "SEQ cmd_write_analysis = " &
	// "write_analysis_clause options?")
	call ifile_append (ifile, "SEQ cmd_compile_analysis = " &
	// "compile_analysis_clause options?")
	call ifile_append (ifile, "SEQ write_analysis_clause = " &
	// "write_analysis write_analysis_arg?")
	call ifile_append (ifile, "SEQ compile_analysis_clause = " &
	// "compile_analysis write_analysis_arg?")
	call ifile_append (ifile, "KEY write_analysis")
	call ifile_append (ifile, "KEY compile_analysis")
	call ifile_append (ifile, "ARG write_analysis_arg = ( analysis_tag* )")
	call ifile_append (ifile, "SEQ cmd_nlo = " &
	// "nlo_calculation '=' nlo_calculation_list")
	call ifile_append (ifile, "KEY nlo_calculation")
	call ifile_append (ifile, "LIS nlo_calculation_list = nlo_comp+")
	call ifile_append (ifile, "ALT nlo_comp = " // &
	"full \| born \| real \| virtual \| dglap \| subtraction \| " // &
	"mismatch \| GKS")
	call ifile_append (ifile, "KEY full")
	call ifile_append (ifile, "KEY born")
	call ifile_append (ifile, "KEY virtual")
	call ifile_append (ifile, "KEY dglap")
	call ifile_append (ifile, "KEY subtraction")
	call ifile_append (ifile, "KEY mismatch")
	call ifile_append (ifile, "KEY GKS")
	call define_expr_syntax (ifile, particles=.true., analysis=.true.)
	end subroutine define_cmd_list_syntax

	@ %def define_cmd_list_syntax
	<<Commands: public>>=
	public :: lexer_init_cmd_list
	<<Commands: procedures>>=
	subroutine lexer_init_cmd_list (lexer, parent_lexer)
	type(lexer_t), intent(out) :: lexer
	type(lexer_t), intent(in), optional, target :: parent_lexer
	call lexer_init (lexer, &
	comment_chars = "#!", &
	quote_chars = '"', &
	quote_match = '"', &
	single_chars = "()[]{},;:&%?$@", &
	special_class = [ "+-*/^", "<>=~ " ] , &
	keyword_list = syntax_get_keyword_list_ptr (syntax_cmd_list), &
	parent = parent_lexer)
	end subroutine lexer_init_cmd_list

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

	module commands_ut
	use unit_tests
	use system_dependencies, only: MPOST_AVAILABLE
	use commands_uti

	<<Standard module head>>

	<<Commands: public test>>

	contains

	<<Commands: test driver>>

	end module commands_ut
	@ %def commands_ut
	@
	<<[[commands_uti.f90]]>>=
	<<File header>>

	module commands_uti

	<<Use kinds>>
	use kinds, only: i64
	<<Use strings>>
	use io_units
	use ifiles
	use parser
	use interactions, only: reset_interaction_counter
	use prclib_stacks
	use analysis
	use variables, only: var_list_t
	use models
	use slha_interface
	use rt_data
	use event_base, only: generic_event_t, event_callback_t
	use commands

	<<Standard module head>>

	<<Commands: test declarations>>

	<<Commands: test auxiliary types>>

	contains

	<<Commands: tests>>

	<<Commands: test auxiliary>>

	end module commands_uti

	@ %def commands_uti
	@ API: driver for the unit tests below.
	<<Commands: public test>>=
	public :: commands_test
	<<Commands: test driver>>=
	subroutine commands_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Commands: execute tests>>
	end subroutine commands_test

	@ %def commands_test
	@
	\subsubsection{Prepare Sindarin code}
	This routine parses an internal file, prints the parse tree, and
	returns a parse node to the root. We use the routine in the tests
	below.
	<<Commands: public test auxiliary>>=
	public :: parse_ifile
	<<Commands: test auxiliary>>=
	subroutine parse_ifile (ifile, pn_root, u)
	use ifiles
	use lexers
	use parser
	use commands
	type(ifile_t), intent(in) :: ifile
	type(parse_node_t), pointer, intent(out) :: pn_root
	integer, intent(in), optional :: u
	type(stream_t), target :: stream
	type(lexer_t), target :: lexer
	type(parse_tree_t) :: parse_tree

	call lexer_init_cmd_list (lexer)
	call stream_init (stream, ifile)
	call lexer_assign_stream (lexer, stream)

	call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
	if (present (u)) call parse_tree_write (parse_tree, u)
	pn_root => parse_tree%get_root_ptr ()

	call stream_final (stream)
	call lexer_final (lexer)
	end subroutine parse_ifile

	@ %def parse_ifile
	@
	\subsubsection{Empty command list}
	Compile and execute an empty command list. Should do nothing but
	test the integrity of the workflow.
	<<Commands: execute tests>>=
	call test (commands_1, "commands_1", &
	"empty command list", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_1
	<<Commands: tests>>=
	subroutine commands_1 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_1"
	write (u, "(A)") "* Purpose: compile and execute empty command list"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Parse empty file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"

	if (associated (pn_root)) then
	call command_list%compile (pn_root, global)
	end if

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"

	call global%activate ()
	call command_list%execute (global)
	call global%deactivate ()

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

	call ifile_final (ifile)

	call command_list%final ()
	call syntax_cmd_list_final ()
	call global%final ()

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

	end subroutine commands_1

	@ %def commands_1
	@
	\subsubsection{Read model}
	Execute a [[model]] assignment.
	<<Commands: execute tests>>=
	call test (commands_2, "commands_2", &
	"model", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_2
	<<Commands: tests>>=
	subroutine commands_2 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_2"
	write (u, "(A)") "* Purpose: set model"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')

	call ifile_write (ifile, u)

	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_2

	@ %def commands_2
	@
	\subsubsection{Declare Process}
	Read a model, then declare a process. The process library is allocated
	explicitly. For the process definition, We take the default ([[omega]])
	method. Since we do not compile, \oMega\ is not actually called.
	<<Commands: execute tests>>=
	call test (commands_3, "commands_3", &
	"process declaration", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_3
	<<Commands: tests>>=
	subroutine commands_3 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_3"
	write (u, "(A)") "* Purpose: define process"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%var_list%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd3"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process t3 = s, s => s, s')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%prclib_stack%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_3

	@ %def commands_3
	@
	\subsubsection{Compile Process}
	Read a model, then declare a process and compile the library. The process
	library is allocated explicitly. For the process definition, We take the
	default ([[unit_test]]) method. There is no external code, so compilation of
	the library is merely a formal status change.
	<<Commands: execute tests>>=
	call test (commands_4, "commands_4", &
	"compilation", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_4
	<<Commands: tests>>=
	subroutine commands_4 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_4"
	write (u, "(A)") "* Purpose: define process and compile library"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd4"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process t4 = s, s => s, s')
	call ifile_append (ifile, 'compile ("lib_cmd4")')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%prclib_stack%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_4

	@ %def commands_4
	@
	\subsubsection{Integrate Process}
	Read a model, then declare a process, compile the library, and
	integrate over phase space. We take the
	default ([[unit_test]]) method and use the simplest methods of
	phase-space parameterization and integration.
	<<Commands: execute tests>>=
	call test (commands_5, "commands_5", &
	"integration", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_5
	<<Commands: tests>>=
	subroutine commands_5 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_5"
	write (u, "(A)") "* Purpose: define process, iterations, and integrate"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)
	call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd5"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process t5 = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (t5)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call reset_interaction_counter ()
	call command_list%execute (global)

	call global%it_list%write (u)
	write (u, "(A)")
	call global%process_stack%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_5

	@ %def commands_5
	@
	\subsubsection{Variables}
	Set intrinsic and user-defined variables.
	<<Commands: execute tests>>=
	call test (commands_6, "commands_6", &
	"variables", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_6
	<<Commands: tests>>=
	subroutine commands_6 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_6"
	write (u, "(A)") "* Purpose: define and set variables"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()
	call global%write_vars (u, [ &
	var_str ("$run_id"), &
	var_str ("?unweighted"), &
	var_str ("sqrts")])

	write (u, "(A)")
	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$run_id = "run1"')
	call ifile_append (ifile, '?unweighted = false')
	call ifile_append (ifile, 'sqrts = 1000')
	call ifile_append (ifile, 'int j = 10')
	call ifile_append (ifile, 'real x = 1000.')
	call ifile_append (ifile, 'complex z = 5')
	call ifile_append (ifile, 'string $text = "abcd"')
	call ifile_append (ifile, 'logical ?flag = true')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_vars (u, [ &
	var_str ("$run_id"), &
	var_str ("?unweighted"), &
	var_str ("sqrts"), &
	var_str ("j"), &
	var_str ("x"), &
	var_str ("z"), &
	var_str ("$text"), &
	var_str ("?flag")])


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

	call ifile_final (ifile)

	call command_list%final ()
	call syntax_cmd_list_final ()
	call global%final ()

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

	end subroutine commands_6

	@ %def commands_6
	@
	\subsubsection{Process library}
	Open process libraries explicitly.
	<<Commands: execute tests>>=
	call test (commands_7, "commands_7", &
	"process library", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_7
	<<Commands: tests>>=
	subroutine commands_7 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_7"
	write (u, "(A)") "* Purpose: declare process libraries"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()
	call global%var_list%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)
	global%os_data%fc = "Fortran-compiler"
	global%os_data%fcflags = "Fortran-flags"
	global%os_data%fclibs = "Fortran-libs"

	write (u, "(A)")
	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'library = "lib_cmd7_1"')
	call ifile_append (ifile, 'library = "lib_cmd7_2"')
	call ifile_append (ifile, 'library = "lib_cmd7_1"')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_libraries (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call syntax_cmd_list_final ()
	call global%final ()

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

	end subroutine commands_7

	@ %def commands_7
	@
	\subsubsection{Generate events}
	Read a model, then declare a process, compile the library, and
	generate weighted events. We take the
	default ([[unit_test]]) method and use the simplest methods of
	phase-space parameterization and integration.
	<<Commands: execute tests>>=
	call test (commands_8, "commands_8", &
	"event generation", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_8
	<<Commands: tests>>=
	subroutine commands_8 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_8"
	write (u, "(A)") "* Purpose: define process, integrate, generate events"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd8"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_8_p = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (commands_8_p)')
	call ifile_append (ifile, '?unweighted = false')
	call ifile_append (ifile, 'n_events = 3')
	call ifile_append (ifile, '?read_raw = false')
	call ifile_append (ifile, 'simulate (commands_8_p)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"

	call command_list%execute (global)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_8

	@ %def commands_8
	@
	\subsubsection{Define cuts}
	Declare a cut expression.
	<<Commands: execute tests>>=
	call test (commands_9, "commands_9", &
	"cuts", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_9
	<<Commands: tests>>=
	subroutine commands_9 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(string_t), dimension(0) :: no_vars

	write (u, "(A)") "* Test output: commands_9"
	write (u, "(A)") "* Purpose: define cuts"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'cuts = all Pt > 0 [particle]')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write (u, vars = no_vars)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_9

	@ %def commands_9
	@
	\subsubsection{Beams}
	Define beam setup.
	<<Commands: execute tests>>=
	call test (commands_10, "commands_10", &
	"beams", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_10
	<<Commands: tests>>=
	subroutine commands_10 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_10"
	write (u, "(A)") "* Purpose: define beams"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = QCD')
	call ifile_append (ifile, 'sqrts = 1000')
	call ifile_append (ifile, 'beams = p, p')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_beams (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_10

	@ %def commands_10
	@
	\subsubsection{Structure functions}
	Define beam setup with structure functions
	<<Commands: execute tests>>=
	call test (commands_11, "commands_11", &
	"structure functions", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_11
	<<Commands: tests>>=
	subroutine commands_11 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_11"
	write (u, "(A)") "* Purpose: define beams with structure functions"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = QCD')
	call ifile_append (ifile, 'sqrts = 1100')
	call ifile_append (ifile, 'beams = p, p => lhapdf => pdf_builtin, isr')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_beams (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_11

	@ %def commands_11
	@
	\subsubsection{Rescan events}
	Read a model, then declare a process, compile the library, and
	generate weighted events. We take the
	default ([[unit_test]]) method and use the simplest methods of
	phase-space parameterization and integration. Then, rescan the
	generated event sample.
	<<Commands: execute tests>>=
	call test (commands_12, "commands_12", &
	"event rescanning", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_12
	<<Commands: tests>>=
	subroutine commands_12 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_12"
	write (u, "(A)") "* Purpose: generate events and rescan"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()

	call global%global_init ()
	call global%var_list%append_log (&
	var_str ("?rebuild_phase_space"), .false., &
	intrinsic=.true.)
	call global%var_list%append_log (&
	var_str ("?rebuild_grids"), .false., &
	intrinsic=.true.)
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd12"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_12_p = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (commands_12_p)')
	call ifile_append (ifile, '?unweighted = false')
	call ifile_append (ifile, 'n_events = 3')
	call ifile_append (ifile, '?read_raw = false')
	call ifile_append (ifile, 'simulate (commands_12_p)')
	call ifile_append (ifile, '?write_raw = false')
	call ifile_append (ifile, 'rescan "commands_12_p" (commands_12_p)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"

	call command_list%execute (global)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_12

	@ %def commands_12
	@
	\subsubsection{Event Files}
	Set output formats for event files.
	<<Commands: execute tests>>=
	call test (commands_13, "commands_13", &
	"event output formats", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_13
	<<Commands: tests>>=
	subroutine commands_13 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib
	logical :: exist

	write (u, "(A)") "* Test output: commands_13"
	write (u, "(A)") "* Purpose: generate events and rescan"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd13"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_13_p = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (commands_13_p)')
	call ifile_append (ifile, '?unweighted = false')
	call ifile_append (ifile, 'n_events = 1')
	call ifile_append (ifile, '?read_raw = false')
	call ifile_append (ifile, 'sample_format = weight_stream')
	call ifile_append (ifile, 'simulate (commands_13_p)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"

	call command_list%execute (global)

	write (u, "(A)")
	write (u, "(A)") "* Verify output files"
	write (u, "(A)")

	inquire (file = "commands_13_p.evx", exist = exist)
	if (exist) write (u, "(1x,A)") "raw"

	inquire (file = "commands_13_p.weights.dat", exist = exist)
	if (exist) write (u, "(1x,A)") "weight_stream"

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_13

	@ %def commands_13
	@
	\subsubsection{Compile Empty Libraries}
	(This is a regression test:) Declare two empty libraries and compile them.
	<<Commands: execute tests>>=
	call test (commands_14, "commands_14", &
	"empty libraries", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_14
	<<Commands: tests>>=
	subroutine commands_14 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_14"
	write (u, "(A)") "* Purpose: define and compile empty libraries"
	write (u, "(A)")

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

	call syntax_model_file_init ()
	call syntax_cmd_list_init ()

	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'library = "lib1"')
	call ifile_append (ifile, 'library = "lib2"')
	call ifile_append (ifile, 'compile ()')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%prclib_stack%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()

	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_14

	@ %def commands_14
	@
	\subsubsection{Compile Process}
	Read a model, then declare a process and compile the library. The process
	library is allocated explicitly. For the process definition, We take the
	default ([[unit_test]]) method. There is no external code, so compilation of
	the library is merely a formal status change.
	<<Commands: execute tests>>=
	call test (commands_15, "commands_15", &
	"compilation", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_15
	<<Commands: tests>>=
	subroutine commands_15 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_15"
	write (u, "(A)") "* Purpose: define process and compile library"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd15"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process t15 = s, s => s, s')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (t15)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%prclib_stack%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_15

	@ %def commands_15
	@
	\subsubsection{Observable}
	Declare an observable, fill it and display.
	<<Commands: execute tests>>=
	call test (commands_16, "commands_16", &
	"observables", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_16
	<<Commands: tests>>=
	subroutine commands_16 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_16"
	write (u, "(A)") "* Purpose: declare an observable"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$obs_label = "foo"')
	call ifile_append (ifile, '$obs_unit = "cm"')
	call ifile_append (ifile, '$title = "Observable foo"')
	call ifile_append (ifile, '$description = "This is observable foo"')
	call ifile_append (ifile, 'observable foo')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Record two data items"
	write (u, "(A)")

	call analysis_record_data (var_str ("foo"), 1._default)
	call analysis_record_data (var_str ("foo"), 3._default)

	write (u, "(A)") "* Display analysis store"
	write (u, "(A)")

	call analysis_write (u, verbose=.true.)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_16

	@ %def commands_16
	@
	\subsubsection{Histogram}
	Declare a histogram, fill it and display.
	<<Commands: execute tests>>=
	call test (commands_17, "commands_17", &
	"histograms", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_17
	<<Commands: tests>>=
	subroutine commands_17 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(string_t), dimension(3) :: name
	integer :: i

	write (u, "(A)") "* Test output: commands_17"
	write (u, "(A)") "* Purpose: declare histograms"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$obs_label = "foo"')
	call ifile_append (ifile, '$obs_unit = "cm"')
	call ifile_append (ifile, '$title = "Histogram foo"')
	call ifile_append (ifile, '$description = "This is histogram foo"')
	call ifile_append (ifile, 'histogram foo (0,5,1)')
	call ifile_append (ifile, '$title = "Histogram bar"')
	call ifile_append (ifile, '$description = "This is histogram bar"')
	call ifile_append (ifile, 'n_bins = 2')
	call ifile_append (ifile, 'histogram bar (0,5)')
	call ifile_append (ifile, '$title = "Histogram gee"')
	call ifile_append (ifile, '$description = "This is histogram gee"')
	call ifile_append (ifile, '?normalize_bins = true')
	call ifile_append (ifile, 'histogram gee (0,5)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Record two data items"
	write (u, "(A)")

	name(1) = "foo"
	name(2) = "bar"
	name(3) = "gee"

	do i = 1, 3
	call analysis_record_data (name(i), 0.1_default, &
	weight = 0.25_default)
	call analysis_record_data (name(i), 3.1_default)
	call analysis_record_data (name(i), 4.1_default, &
	excess = 0.5_default)
	call analysis_record_data (name(i), 7.1_default)
	end do

	write (u, "(A)") "* Display analysis store"
	write (u, "(A)")

	call analysis_write (u, verbose=.true.)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_17

	@ %def commands_17
	@
	\subsubsection{Plot}
	Declare a plot, fill it and display contents.
	<<Commands: execute tests>>=
	call test (commands_18, "commands_18", &
	"plots", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_18
	<<Commands: tests>>=
	subroutine commands_18 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_18"
	write (u, "(A)") "* Purpose: declare a plot"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$obs_label = "foo"')
	call ifile_append (ifile, '$obs_unit = "cm"')
	call ifile_append (ifile, '$title = "Plot foo"')
	call ifile_append (ifile, '$description = "This is plot foo"')
	call ifile_append (ifile, '$x_label = "x axis"')
	call ifile_append (ifile, '$y_label = "y axis"')
	call ifile_append (ifile, '?x_log = false')
	call ifile_append (ifile, '?y_log = true')
	call ifile_append (ifile, 'x_min = -1')
	call ifile_append (ifile, 'x_max = 1')
	call ifile_append (ifile, 'y_min = 0.1')
	call ifile_append (ifile, 'y_max = 1000')
	call ifile_append (ifile, 'plot foo')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Record two data items"
	write (u, "(A)")

	call analysis_record_data (var_str ("foo"), 0._default, 20._default, &
	xerr = 0.25_default)
	call analysis_record_data (var_str ("foo"), 0.5_default, 0.2_default, &
	yerr = 0.07_default)
	call analysis_record_data (var_str ("foo"), 3._default, 2._default)

	write (u, "(A)") "* Display analysis store"
	write (u, "(A)")

	call analysis_write (u, verbose=.true.)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_18

	@ %def commands_18
	@
	\subsubsection{Graph}
	Combine two (empty) plots to a graph.
	<<Commands: execute tests>>=
	call test (commands_19, "commands_19", &
	"graphs", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_19
	<<Commands: tests>>=
	subroutine commands_19 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_19"
	write (u, "(A)") "* Purpose: combine two plots to a graph"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'plot a')
	call ifile_append (ifile, 'plot b')
	call ifile_append (ifile, '$title = "Graph foo"')
	call ifile_append (ifile, '$description = "This is graph foo"')
	call ifile_append (ifile, 'graph foo = a & b')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Display analysis object"
	write (u, "(A)")

	call analysis_write (var_str ("foo"), u)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_19

	@ %def commands_19
	@
	\subsubsection{Record Data}
	Record data in previously allocated analysis objects.
	<<Commands: execute tests>>=
	call test (commands_20, "commands_20", &
	"record data", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_20
	<<Commands: tests>>=
	subroutine commands_20 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_20"
	write (u, "(A)") "* Purpose: record data"
	write (u, "(A)")

	write (u, "(A)") "* Initialization: create observable, histogram, plot"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call global%global_init ()

	call analysis_init_observable (var_str ("o"))
	call analysis_init_histogram (var_str ("h"), 0._default, 1._default, 3, &
	normalize_bins = .false.)
	call analysis_init_plot (var_str ("p"))

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'record o (1.234)')
	call ifile_append (ifile, 'record h (0.5)')
	call ifile_append (ifile, 'record p (1, 2)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Display analysis object"
	write (u, "(A)")

	call analysis_write (u, verbose = .true.)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_20

	@ %def commands_20
	@
	\subsubsection{Analysis}
	Declare an analysis expression and use it to fill an observable during
	event generation.
	<<Commands: execute tests>>=
	call test (commands_21, "commands_21", &
	"analysis expression", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_21
	<<Commands: tests>>=
	subroutine commands_21 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_21"
	write (u, "(A)") "* Purpose: create and use analysis expression"
	write (u, "(A)")

	write (u, "(A)") "* Initialization: create observable"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd8"))
	call global%add_prclib (lib)

	call analysis_init_observable (var_str ("m"))

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_21_p = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:100')
	call ifile_append (ifile, 'integrate (commands_21_p)')
	call ifile_append (ifile, '?unweighted = true')
	call ifile_append (ifile, 'n_events = 3')
	call ifile_append (ifile, '?read_raw = false')
	call ifile_append (ifile, 'observable m')
	call ifile_append (ifile, 'analysis = record m (eval M [s])')
	call ifile_append (ifile, 'simulate (commands_21_p)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Display analysis object"
	write (u, "(A)")

	call analysis_write (u)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_21

	@ %def commands_21
	@
	\subsubsection{Write Analysis}
	Write accumulated analysis data to file.
	<<Commands: execute tests>>=
	call test (commands_22, "commands_22", &
	"write analysis", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_22
	<<Commands: tests>>=
	subroutine commands_22 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	integer :: u_file, iostat
	logical :: exist
	character(80) :: buffer

	write (u, "(A)") "* Test output: commands_22"
	write (u, "(A)") "* Purpose: write analysis data"
	write (u, "(A)")

	write (u, "(A)") "* Initialization: create observable"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call global%global_init ()

	call analysis_init_observable (var_str ("m"))
	call analysis_record_data (var_str ("m"), 125._default)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$out_file = "commands_22.dat"')
	call ifile_append (ifile, 'write_analysis')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Display analysis data"
	write (u, "(A)")

	inquire (file = "commands_22.dat", exist = exist)
	if (.not. exist) then
	write (u, "(A)") "ERROR: File commands_22.dat not found"
	return
	end if

	u_file = free_unit ()
	open (u_file, file = "commands_22.dat", &
	action = "read", status = "old")
	do
	read (u_file, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do
	close (u_file)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_22

	@ %def commands_22
	@
	\subsubsection{Compile Analysis}
	Write accumulated analysis data to file and compile.
	<<Commands: execute tests>>=
	if (MPOST_AVAILABLE) then
	call test (commands_23, "commands_23", &
	"compile analysis", &
	u, results)
	end if
	<<Commands: test declarations>>=
	public :: commands_23
	<<Commands: tests>>=
	subroutine commands_23 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	integer :: u_file, iostat
	character(256) :: buffer
	logical :: exist
	type(graph_options_t) :: graph_options

	write (u, "(A)") "* Test output: commands_23"
	write (u, "(A)") "* Purpose: write and compile analysis data"
	write (u, "(A)")

	write (u, "(A)") "* Initialization: create and fill histogram"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call global%global_init ()

	- call graph_options_init (graph_options)
	- call graph_options_set (graph_options, &
	- title = var_str ("Histogram for test: commands 23"), &
	+ call graph_options%init ()
	+ call graph_options%set (title = var_str ("Histogram for test: commands 23"), &
	description = var_str ("This is a test."), &
	width_mm = 125, height_mm = 85)
	call analysis_init_histogram (var_str ("h"), &
	0._default, 10._default, 2._default, .false., &
	graph_options = graph_options)
	call analysis_record_data (var_str ("h"), 1._default)
	call analysis_record_data (var_str ("h"), 1._default)
	call analysis_record_data (var_str ("h"), 1._default)
	call analysis_record_data (var_str ("h"), 1._default)
	call analysis_record_data (var_str ("h"), 3._default)
	call analysis_record_data (var_str ("h"), 3._default)
	call analysis_record_data (var_str ("h"), 3._default)
	call analysis_record_data (var_str ("h"), 5._default)
	call analysis_record_data (var_str ("h"), 7._default)
	call analysis_record_data (var_str ("h"), 7._default)
	call analysis_record_data (var_str ("h"), 7._default)
	call analysis_record_data (var_str ("h"), 7._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)
	call analysis_record_data (var_str ("h"), 9._default)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$out_file = "commands_23.dat"')
	call ifile_append (ifile, 'compile_analysis')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Delete Postscript output"
	write (u, "(A)")

	inquire (file = "commands_23.ps", exist = exist)
	if (exist) then
	u_file = free_unit ()
	open (u_file, file = "commands_23.ps", action = "write", status = "old")
	close (u_file, status = "delete")
	end if
	inquire (file = "commands_23.ps", exist = exist)
	write (u, "(1x,A,L1)") "Postcript output exists = ", exist

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* TeX file"
	write (u, "(A)")

	inquire (file = "commands_23.tex", exist = exist)
	if (.not. exist) then
	write (u, "(A)") "ERROR: File commands_23.tex not found"
	return
	end if

	u_file = free_unit ()
	open (u_file, file = "commands_23.tex", &
	action = "read", status = "old")
	do
	read (u_file, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	write (u, "(A)") trim (buffer)
	end do
	close (u_file)
	write (u, *)

	inquire (file = "commands_23.ps", exist = exist)
	write (u, "(1x,A,L1)") "Postcript output exists = ", exist

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_23

	@ %def commands_23
	@
	\subsubsection{Histogram}
	Declare a histogram, fill it and display.
	<<Commands: execute tests>>=
	call test (commands_24, "commands_24", &
	"drawing options", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_24
	<<Commands: tests>>=
	subroutine commands_24 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_24"
	write (u, "(A)") "* Purpose: check graph and drawing options"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, '$title = "Title"')
	call ifile_append (ifile, '$description = "Description"')
	call ifile_append (ifile, '$x_label = "X Label"')
	call ifile_append (ifile, '$y_label = "Y Label"')
	call ifile_append (ifile, 'graph_width_mm = 111')
	call ifile_append (ifile, 'graph_height_mm = 222')
	call ifile_append (ifile, 'x_min = -11')
	call ifile_append (ifile, 'x_max = 22')
	call ifile_append (ifile, 'y_min = -33')
	call ifile_append (ifile, 'y_max = 44')
	call ifile_append (ifile, '$gmlcode_bg = "GML Code BG"')
	call ifile_append (ifile, '$gmlcode_fg = "GML Code FG"')
	call ifile_append (ifile, '$fill_options = "Fill Options"')
	call ifile_append (ifile, '$draw_options = "Draw Options"')
	call ifile_append (ifile, '$err_options = "Error Options"')
	call ifile_append (ifile, '$symbol = "Symbol"')
	call ifile_append (ifile, 'histogram foo (0,1)')
	call ifile_append (ifile, 'plot bar')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Display analysis store"
	write (u, "(A)")

	call analysis_write (u, verbose=.true.)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_24

	@ %def commands_24
	@
	\subsubsection{Local Environment}
	Declare a local environment.
	<<Commands: execute tests>>=
	call test (commands_25, "commands_25", &
	"local process environment", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_25
	<<Commands: tests>>=
	subroutine commands_25 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_25"
	write (u, "(A)") "* Purpose: declare local environment for process"
	write (u, "(A)")

	call syntax_model_file_init ()
	call syntax_cmd_list_init ()
	call global%global_init ()
	call global%var_list%set_log (var_str ("?omega_openmp"), &
	.false., is_known = .true.)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'library = "commands_25_lib"')
	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_25_p1 = g, g => g, g &
	&{ model = "QCD" }')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)
	call global%write_libraries (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_25

	@ %def commands_25
	@
	\subsubsection{Alternative Setups}
	Declare a list of alternative setups.
	<<Commands: execute tests>>=
	call test (commands_26, "commands_26", &
	"alternative setups", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_26
	<<Commands: tests>>=
	subroutine commands_26 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_26"
	write (u, "(A)") "* Purpose: declare alternative setups for simulation"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'int i = 0')
	call ifile_append (ifile, 'alt_setup = ({ i = 1 }, { i = 2 })')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_expr (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_26

	@ %def commands_26
	@
	\subsubsection{Unstable Particle}
	Define decay processes and declare a particle as unstable. Also check
	the commands stable, polarized, unpolarized.
	<<Commands: execute tests>>=
	call test (commands_27, "commands_27", &
	"unstable and polarized particles", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_27
	<<Commands: tests>>=
	subroutine commands_27 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib

	write (u, "(A)") "* Test output: commands_27"
	write (u, "(A)") "* Purpose: modify particle properties"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call global%global_init ()
	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)

	allocate (lib)
	call lib%init (var_str ("commands_27_lib"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'ff = 0.4')
	call ifile_append (ifile, 'process d1 = s => f, fbar')
	call ifile_append (ifile, 'unstable s (d1)')
	call ifile_append (ifile, 'polarized f, fbar')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Show model"
	write (u, "(A)")

	call global%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extra Input"
	write (u, "(A)")

	call ifile_final (ifile)
	call ifile_append (ifile, '?diagonal_decay = true')
	call ifile_append (ifile, 'unstable s (d1)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%final ()
	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Show model"
	write (u, "(A)")

	call global%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extra Input"
	write (u, "(A)")

	call ifile_final (ifile)
	call ifile_append (ifile, '?isotropic_decay = true')
	call ifile_append (ifile, 'unstable s (d1)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%final ()
	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Show model"
	write (u, "(A)")

	call global%model%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extra Input"
	write (u, "(A)")

	call ifile_final (ifile)
	call ifile_append (ifile, 'stable s')
	call ifile_append (ifile, 'unpolarized f')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%final ()
	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Show model"
	write (u, "(A)")

	call global%model%write (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_model_file_init ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_27

	@ %def commands_27
	@
	\subsubsection{Quit the program}
	Quit the program.
	<<Commands: execute tests>>=
	call test (commands_28, "commands_28", &
	"quit", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_28
	<<Commands: tests>>=
	subroutine commands_28 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root1, pn_root2
	type(string_t), dimension(0) :: no_vars

	write (u, "(A)") "* Test output: commands_28"
	write (u, "(A)") "* Purpose: quit the program"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file: quit without code"
	write (u, "(A)")

	call ifile_append (ifile, 'quit')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root1, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root1, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write (u, vars = no_vars)

	write (u, "(A)")
	write (u, "(A)") "* Input file: quit with code"
	write (u, "(A)")

	call ifile_final (ifile)
	call command_list%final ()
	call ifile_append (ifile, 'quit ( 3 + 4 )')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root2, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root2, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write (u, vars = no_vars)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_28

	@ %def commands_28
	@
	\subsubsection{SLHA interface}
	Testing commands steering the SLHA interface.
	<<Commands: execute tests>>=
	call test (commands_29, "commands_29", &
	"SLHA interface", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_29
	<<Commands: tests>>=
	subroutine commands_29 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(var_list_t), pointer :: model_vars
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_29"
	write (u, "(A)") "* Purpose: test SLHA interface"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call syntax_model_file_init ()
	call syntax_slha_init ()
	call global%global_init ()

	write (u, "(A)") "* Model MSSM, read SLHA file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "MSSM"')
	call ifile_append (ifile, '?slha_read_decays = true')
	call ifile_append (ifile, 'read_slha ("sps1ap_decays.slha")')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Model MSSM, default values:"
	write (u, "(A)")

	call global%model%write (u, verbose = .false., &
	show_vertices = .false., show_particles = .false.)

	write (u, "(A)")
	write (u, "(A)") "* Selected global variables"
	write (u, "(A)")

	model_vars => global%model%get_var_list_ptr ()

	call model_vars%write_var (var_str ("mch1"), u)
	call model_vars%write_var (var_str ("wch1"), u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	write (u, "(A)") "* Model MSSM, values from SLHA file"
	write (u, "(A)")

	call global%model%write (u, verbose = .false., &
	show_vertices = .false., show_particles = .false.)

	write (u, "(A)")
	write (u, "(A)") "* Selected global variables"
	write (u, "(A)")

	model_vars => global%model%get_var_list_ptr ()

	call model_vars%write_var (var_str ("mch1"), u)
	call model_vars%write_var (var_str ("wch1"), u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_slha_final ()
	call syntax_model_file_final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_29

	@ %def commands_29
	@
	\subsubsection{Expressions for scales}
	Declare a scale, factorization scale or factorization scale expression.
	<<Commands: execute tests>>=
	call test (commands_30, "commands_30", &
	"scales", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_30
	<<Commands: tests>>=
	subroutine commands_30 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_30"
	write (u, "(A)") "* Purpose: define scales"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'scale = 200 GeV')
	call ifile_append (ifile, &
	'factorization_scale = eval Pt [particle]')
	call ifile_append (ifile, &
	'renormalization_scale = eval E [particle]')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_expr (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_30

	@ %def commands_30
	@
	\subsubsection{Weight and reweight expressions}
	Declare an expression for event weights and reweighting.
	<<Commands: execute tests>>=
	call test (commands_31, "commands_31", &
	"event weights/reweighting", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_31
	<<Commands: tests>>=
	subroutine commands_31 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_31"
	write (u, "(A)") "* Purpose: define weight/reweight"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'weight = eval Pz [particle]')
	call ifile_append (ifile, 'reweight = eval M2 [particle]')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_expr (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_31

	@ %def commands_31
	@
	\subsubsection{Selecting events}
	Declare an expression for selecting events in an analysis.
	<<Commands: execute tests>>=
	call test (commands_32, "commands_32", &
	"event selection", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_32
	<<Commands: tests>>=
	subroutine commands_32 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root

	write (u, "(A)") "* Test output: commands_32"
	write (u, "(A)") "* Purpose: define selection"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'selection = any PDG == 13 [particle]')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

	call global%write_expr (u)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_32

	@ %def commands_32
	@
	\subsubsection{Executing shell commands}
	Execute a shell command.
	<<Commands: execute tests>>=
	call test (commands_33, "commands_33", &
	"execute shell command", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_33
	<<Commands: tests>>=
	subroutine commands_33 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	integer :: u_file, iostat
	character(3) :: buffer

	write (u, "(A)") "* Test output: commands_33"
	write (u, "(A)") "* Purpose: execute shell command"
	write (u, "(A)")

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

	call syntax_cmd_list_init ()
	call global%global_init ()

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'exec ("echo foo >> bar")')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root, u)

	write (u, "(A)")
	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)
	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)
	u_file = free_unit ()
	open (u_file, file = "bar", &
	action = "read", status = "old")
	do
	read (u_file, "(A)", iostat = iostat) buffer
	if (iostat /= 0) exit
	end do
	write (u, "(A,A)") "should be 'foo': ", trim (buffer)
	close (u_file)

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

	call ifile_final (ifile)

	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()

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

	end subroutine commands_33

	@ %def commands_33
	@
	\subsubsection{Callback}
	Instead of an explicit write, use the callback feature to write the
	analysis file during event generation. We generate 4 events and
	arrange that the callback is executed while writing the 3rd event.
	<<Commands: execute tests>>=
	call test (commands_34, "commands_34", &
	"analysis via callback", &
	u, results)
	<<Commands: test declarations>>=
	public :: commands_34
	<<Commands: tests>>=
	subroutine commands_34 (u)
	integer, intent(in) :: u
	type(ifile_t) :: ifile
	type(command_list_t), target :: command_list
	type(rt_data_t), target :: global
	type(parse_node_t), pointer :: pn_root
	type(prclib_entry_t), pointer :: lib
	type(event_callback_34_t) :: event_callback

	write (u, "(A)") "* Test output: commands_34"
	write (u, "(A)") "* Purpose: write analysis data"
	write (u, "(A)")

	write (u, "(A)") "* Initialization: create observable"
	write (u, "(A)")

	call syntax_cmd_list_init ()
	call global%global_init ()

	call syntax_model_file_init ()
	call global%global_init ()
	call global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))

	call global%var_list%set_string (var_str ("$method"), &
	var_str ("unit_test"), is_known=.true.)
	call global%var_list%set_string (var_str ("$phs_method"), &
	var_str ("single"), is_known=.true.)
	call global%var_list%set_string (var_str ("$integration_method"),&
	var_str ("midpoint"), is_known=.true.)
	call global%var_list%set_real (var_str ("sqrts"), &
	1000._default, is_known=.true.)
	call global%var_list%set_log (var_str ("?vis_history"),&
	.false., is_known=.true.)
	call global%var_list%set_log (var_str ("?integration_timer"),&
	.false., is_known = .true.)
	call global%var_list%set_int (var_str ("seed"), 0, is_known=.true.)

	allocate (lib)
	call lib%init (var_str ("lib_cmd34"))
	call global%add_prclib (lib)

	write (u, "(A)") "* Prepare callback for writing analysis to I/O unit"
	write (u, "(A)")

	event_callback%u = u
	call global%set_event_callback (event_callback)

	write (u, "(A)") "* Input file"
	write (u, "(A)")

	call ifile_append (ifile, 'model = "Test"')
	call ifile_append (ifile, 'process commands_34_p = s, s => s, s')
	call ifile_append (ifile, 'compile')
	call ifile_append (ifile, 'iterations = 1:1000')
	call ifile_append (ifile, 'integrate (commands_34_p)')
	call ifile_append (ifile, 'observable sq')
	call ifile_append (ifile, 'analysis = record sq (sqrts)')
	call ifile_append (ifile, 'n_events = 4')
	call ifile_append (ifile, 'event_callback_interval = 3')
	call ifile_append (ifile, 'simulate (commands_34_p)')

	call ifile_write (ifile, u)

	write (u, "(A)")
	write (u, "(A)") "* Parse file"
	write (u, "(A)")

	call parse_ifile (ifile, pn_root)

	write (u, "(A)") "* Compile command list"
	write (u, "(A)")

	call command_list%compile (pn_root, global)

	call command_list%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Execute command list"
	write (u, "(A)")

	call command_list%execute (global)

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

	call ifile_final (ifile)

	call analysis_final ()
	call command_list%final ()
	call global%final ()
	call syntax_cmd_list_final ()
	call syntax_model_file_final ()

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

	end subroutine commands_34

	@ %def commands_34
	@ For this test, we invent a callback object which simply writes the
	analysis file, using the standard call for this. Here we rely on the
	fact that the analysis data are stored as a global entity, otherwise
	we would have to access them via the event object.
	<<Commands: test auxiliary types>>=
	type, extends (event_callback_t) :: event_callback_34_t
	private
	integer :: u = 0
	contains
	procedure :: write => event_callback_34_write
	procedure :: proc => event_callback_34
	end type event_callback_34_t

	@ %def event_callback_t
	@ The output routine is unused. The actual callback should write the
	analysis data to the output unit that we have injected into the
	callback object.
	<<Commands: test auxiliary>>=
	subroutine event_callback_34_write (event_callback, unit)
	class(event_callback_34_t), intent(in) :: event_callback
	integer, intent(in), optional :: unit
	end subroutine event_callback_34_write

	subroutine event_callback_34 (event_callback, i, event)
	class(event_callback_34_t), intent(in) :: event_callback
	integer(i64), intent(in) :: i
	class(generic_event_t), intent(in) :: event
	call analysis_write (event_callback%u)
	end subroutine event_callback_34

	@ %def event_callback_34_write
	@ %def event_callback_34
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Toplevel module WHIZARD}
	<<[[whizard.f90]]>>=
	<<File header>>

	module whizard

	use io_units
	<<Use strings>>
	use system_defs, only: VERSION_STRING
	use system_defs, only: EOF, BACKSLASH
	use diagnostics
	use os_interface
	use ifiles
	use lexers
	use parser
	use eval_trees
	use models
	use phs_forests
	use prclib_stacks
	use slha_interface
	use blha_config
	use rt_data
	use commands

	<<Standard module head>>

	<<WHIZARD: public>>

	<<WHIZARD: types>>

	<<WHIZARD: variables>>

	save

	contains

	<<WHIZARD: procedures>>

	end module whizard
	@ %def whizard
	@
	\subsection{Options}
	Here we introduce a wrapper that holds various user options, so they
	can transparently be passed from the main program to the [[whizard]]
	object. Most parameters are used for initializing the [[global]]
	state.
	<<WHIZARD: public>>=
	public :: whizard_options_t
	<<WHIZARD: types>>=
	type :: whizard_options_t
	type(string_t) :: job_id
	type(string_t), dimension(:), allocatable :: pack_args
	type(string_t), dimension(:), allocatable :: unpack_args
	type(string_t) :: preload_model
	type(string_t) :: default_lib
	type(string_t) :: preload_libraries
	logical :: rebuild_library = .false.
	logical :: recompile_library = .false.
	logical :: rebuild_phs = .false.
	logical :: rebuild_grids = .false.
	logical :: rebuild_events = .false.
	end type whizard_options_t

	@ %def whizard_options_t
	@
	\subsection{Parse tree stack}
	We collect all parse trees that we generate in the [[whizard]] object. To
	this end, we create a stack of parse trees. They must not be finalized before
	the [[global]] object is finalized, because items such as a cut definition may
	contain references to the parse tree from which they were generated.
	<<WHIZARD: types>>=
	type, extends (parse_tree_t) :: pt_entry_t
	type(pt_entry_t), pointer :: previous => null ()
	end type pt_entry_t

	@ %def pt_entry_t
	@ This is the stack. Since we always prepend, we just need the [[last]]
	pointer.
	<<WHIZARD: types>>=
	type :: pt_stack_t
	type(pt_entry_t), pointer :: last => null ()
	contains
	<<WHIZARD: pt stack: TBP>>
	end type pt_stack_t

	@ %def pt_stack_t
	@ The finalizer is called at the very end.
	<<WHIZARD: pt stack: TBP>>=
	procedure :: final => pt_stack_final
	<<WHIZARD: procedures>>=
	subroutine pt_stack_final (pt_stack)
	class(pt_stack_t), intent(inout) :: pt_stack
	type(pt_entry_t), pointer :: current
	do while (associated (pt_stack%last))
	current => pt_stack%last
	pt_stack%last => current%previous
	call parse_tree_final (current%parse_tree_t)
	deallocate (current)
	end do
	end subroutine pt_stack_final

	@ %def pt_stack_final
	@ Create and push a new entry, keeping the previous ones.
	<<WHIZARD: pt stack: TBP>>=
	procedure :: push => pt_stack_push
	<<WHIZARD: procedures>>=
	subroutine pt_stack_push (pt_stack, parse_tree)
	class(pt_stack_t), intent(inout) :: pt_stack
	type(parse_tree_t), intent(out), pointer :: parse_tree
	type(pt_entry_t), pointer :: current
	allocate (current)
	parse_tree => current%parse_tree_t
	current%previous => pt_stack%last
	pt_stack%last => current
	end subroutine pt_stack_push

	@ %def pt_stack_push
	@
	\subsection{The [[whizard]] object}
	An object of type [[whizard_t]] is the top-level wrapper for a
	\whizard\ instance. The object holds various default
	settings and the current state of the generator, the [[global]] object
	of type [[rt_data_t]]. This object contains, for instance, the list
	of variables and the process libraries.

	Since components of the [[global]] subobject are frequently used as
	targets, the [[whizard]] object should also consistently carry the
	[[target]] attribute.

	The various self-tests do no not use this object. They initialize
	only specific subsets of the system, according to their needs.

	Note: we intend to allow several concurrent instances. In the current
	implementation, there are still a few obstacles to this: the model
	library and the syntax tables are global variables, and the error
	handling uses global state. This should be improved.
	<<WHIZARD: public>>=
	public :: whizard_t
	<<WHIZARD: types>>=
	type :: whizard_t
	type(whizard_options_t) :: options
	type(rt_data_t) :: global
	type(pt_stack_t) :: pt_stack
	contains
	<<WHIZARD: whizard: TBP>>
	end type whizard_t

	@ %def whizard_t
	@
	\subsection{Initialization and finalization}
	<<WHIZARD: whizard: TBP>>=
	procedure :: init => whizard_init
	<<WHIZARD: procedures>>=
	subroutine whizard_init (whizard, options, paths, logfile)
	class(whizard_t), intent(out), target :: whizard
	type(whizard_options_t), intent(in) :: options
	type(paths_t), intent(in), optional :: paths
	type(string_t), intent(in), optional :: logfile
	call init_syntax_tables ()
	whizard%options = options
	call whizard%global%global_init (paths, logfile)
	call whizard%init_job_id ()
	call whizard%init_rebuild_flags ()
	call whizard%unpack_files ()
	call whizard%preload_model ()
	call whizard%preload_library ()
	call whizard%global%init_fallback_model &
	(var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"))
	end subroutine whizard_init

	@ %def whizard_init
	@ Apart from the global data which have been initialized above, the
	process and model lists need to be finalized.
	<<WHIZARD: whizard: TBP>>=
	procedure :: final => whizard_final
	<<WHIZARD: procedures>>=
	subroutine whizard_final (whizard)
	class(whizard_t), intent(inout), target :: whizard
	call whizard%global%final ()
	call whizard%pt_stack%final ()
	call whizard%pack_files ()
	call final_syntax_tables ()
	end subroutine whizard_final

	@ %def whizard_final
	@ Set the job ID, if nonempty. If the ID string is empty, the value remains
	undefined.
	<<WHIZARD: whizard: TBP>>=
	procedure :: init_job_id => whizard_init_job_id
	<<WHIZARD: procedures>>=
	subroutine whizard_init_job_id (whizard)
	class(whizard_t), intent(inout), target :: whizard
	associate (var_list => whizard%global%var_list, options => whizard%options)
	if (options%job_id /= "") then
	call var_list%set_string (var_str ("$job_id"), &
	options%job_id, is_known=.true.)
	end if
	end associate
	end subroutine whizard_init_job_id

	@ %def whizard_init_job_id
	@
	Set the rebuild flags. They can be specified on the command line and
	set the initial value for the associated logical variables.
	<<WHIZARD: whizard: TBP>>=
	procedure :: init_rebuild_flags => whizard_init_rebuild_flags
	<<WHIZARD: procedures>>=
	subroutine whizard_init_rebuild_flags (whizard)
	class(whizard_t), intent(inout), target :: whizard
	associate (var_list => whizard%global%var_list, options => whizard%options)
	call var_list%append_log (var_str ("?rebuild_library"), &
	options%rebuild_library, intrinsic=.true.)
	call var_list%append_log (var_str ("?recompile_library"), &
	options%recompile_library, intrinsic=.true.)
	call var_list%append_log (var_str ("?rebuild_phase_space"), &
	options%rebuild_phs, intrinsic=.true.)
	call var_list%append_log (var_str ("?rebuild_grids"), &
	options%rebuild_grids, intrinsic=.true.)
	call var_list%append_log (var_str ("?rebuild_events"), &
	options%rebuild_events, intrinsic=.true.)
	end associate
	end subroutine whizard_init_rebuild_flags

	@ %def whizard_init_rebuild_flags
	@
	Pack/unpack files in the working directory, if requested.
	<<WHIZARD: whizard: TBP>>=
	procedure :: pack_files => whizard_pack_files
	procedure :: unpack_files => whizard_unpack_files
	<<WHIZARD: procedures>>=
	subroutine whizard_pack_files (whizard)
	class(whizard_t), intent(in), target :: whizard
	logical :: exist
	integer :: i
	type(string_t) :: file
	if (allocated (whizard%options%pack_args)) then
	do i = 1, size (whizard%options%pack_args)
	file = whizard%options%pack_args(i)
	call msg_message ("Packing file/dir '" // char (file) // "'")
	exist = os_file_exist (file) .or. os_dir_exist (file)
	if (exist) then
	call os_pack_file (whizard%options%pack_args(i), &
	whizard%global%os_data)
	else
	call msg_error ("File/dir '" // char (file) // "' not found")
	end if
	end do
	end if
	end subroutine whizard_pack_files

	subroutine whizard_unpack_files (whizard)
	class(whizard_t), intent(in), target :: whizard
	logical :: exist
	integer :: i
	type(string_t) :: file
	if (allocated (whizard%options%unpack_args)) then
	do i = 1, size (whizard%options%unpack_args)
	file = whizard%options%unpack_args(i)
	call msg_message ("Unpacking file '" // char (file) // "'")
	exist = os_file_exist (file)
	if (exist) then
	call os_unpack_file (whizard%options%unpack_args(i), &
	whizard%global%os_data)
	else
	call msg_error ("File '" // char (file) // "' not found")
	end if
	end do
	end if
	end subroutine whizard_unpack_files

	@ %def whizard_pack_files
	@ %def whizard_unpack_files
	@
	This procedure preloads a model, if a model name is given.
	<<WHIZARD: whizard: TBP>>=
	procedure :: preload_model => whizard_preload_model
	<<WHIZARD: procedures>>=
	subroutine whizard_preload_model (whizard)
	class(whizard_t), intent(inout), target :: whizard
	type(string_t) :: model_name
	model_name = whizard%options%preload_model
	if (model_name /= "") then
	call whizard%global%read_model (model_name, whizard%global%preload_model)
	whizard%global%model => whizard%global%preload_model
	if (associated (whizard%global%model)) then
	call whizard%global%model%link_var_list (whizard%global%var_list)
	call whizard%global%var_list%set_string (var_str ("$model_name"), &
	model_name, is_known = .true.)
	call msg_message ("Preloaded model: " &
	// char (model_name))
	else
	call msg_fatal ("Preloading model " // char (model_name) &
	// " failed")
	end if
	else
	call msg_message ("No model preloaded")
	end if
	end subroutine whizard_preload_model

	@ %def whizard_preload_model
	@
	This procedure preloads a library, if a library name is given.

	Note: This version just opens a new library with that name. It does not load
	(yet) an existing library on file, as previous \whizard\ versions would do.
	<<WHIZARD: whizard: TBP>>=
	procedure :: preload_library => whizard_preload_library
	<<WHIZARD: procedures>>=
	subroutine whizard_preload_library (whizard)
	class(whizard_t), intent(inout), target :: whizard
	type(string_t) :: library_name, libs
	type(string_t), dimension(:), allocatable :: libname_static
	type(prclib_entry_t), pointer :: lib_entry
	integer :: i
	call get_prclib_static (libname_static)
	do i = 1, size (libname_static)
	allocate (lib_entry)
	call lib_entry%init_static (libname_static(i))
	call whizard%global%add_prclib (lib_entry)
	end do
	libs = adjustl (whizard%options%preload_libraries)
	if (libs == "" .and. whizard%options%default_lib /= "") then
	allocate (lib_entry)
	call lib_entry%init (whizard%options%default_lib)
	call whizard%global%add_prclib (lib_entry)
	call msg_message ("Preloaded library: " // &
	char (whizard%options%default_lib))
	end if
	SCAN_LIBS: do while (libs /= "")
	call split (libs, library_name, " ")
	if (library_name /= "") then
	allocate (lib_entry)
	call lib_entry%init (library_name)
	call whizard%global%add_prclib (lib_entry)
	call msg_message ("Preloaded library: " // char (library_name))
	end if
	end do SCAN_LIBS
	end subroutine whizard_preload_library

	@ %def whizard_preload_library
	@
	\subsection{Initialization and finalization: syntax tables}
	Initialize/finalize the syntax tables used by WHIZARD. These are effectively
	singleton objects. We introduce a module variable that tracks the
	initialization status.

	Without syntax tables, essentially nothing will work. Any initializer has to
	call this.
	<<WHIZARD: variables>>=
	logical :: syntax_tables_exist = .false.
	@ %def syntax_tables_exist
	@
	<<WHIZARD: public>>=
	public :: init_syntax_tables
	public :: final_syntax_tables
	<<WHIZARD: procedures>>=
	subroutine init_syntax_tables ()
	if (.not. syntax_tables_exist) then
	call syntax_model_file_init ()
	call syntax_phs_forest_init ()
	call syntax_pexpr_init ()
	call syntax_slha_init ()
	call syntax_cmd_list_init ()
	syntax_tables_exist = .true.
	end if
	end subroutine init_syntax_tables

	subroutine final_syntax_tables ()
	if (syntax_tables_exist) then
	call syntax_model_file_final ()
	call syntax_phs_forest_final ()
	call syntax_pexpr_final ()
	call syntax_slha_final ()
	call syntax_cmd_list_final ()
	syntax_tables_exist = .false.
	end if
	end subroutine final_syntax_tables

	@ %def init_syntax_tables
	@ %def final_syntax_tables
	@ Write the syntax tables to external files.
	<<WHIZARD: public>>=
	public :: write_syntax_tables
	<<WHIZARD: procedures>>=
	subroutine write_syntax_tables ()
	integer :: unit
	character(*), parameter :: file_model = "whizard.model_file.syntax"
	character(*), parameter :: file_phs = "whizard.phase_space_file.syntax"
	character(*), parameter :: file_pexpr = "whizard.prt_expressions.syntax"
	character(*), parameter :: file_slha = "whizard.slha.syntax"
	character(*), parameter :: file_sindarin = "whizard.sindarin.syntax"
	if (.not. syntax_tables_exist) call init_syntax_tables ()
	unit = free_unit ()
	print *, "Writing file '" // file_model // "'"
	open (unit=unit, file=file_model, status="replace", action="write")
	write (unit, "(A)") VERSION_STRING
	write (unit, "(A)") "Syntax definition file: " // file_model
	call syntax_model_file_write (unit)
	close (unit)
	print *, "Writing file '" // file_phs // "'"
	open (unit=unit, file=file_phs, status="replace", action="write")
	write (unit, "(A)") VERSION_STRING
	write (unit, "(A)") "Syntax definition file: " // file_phs
	call syntax_phs_forest_write (unit)
	close (unit)
	print *, "Writing file '" // file_pexpr // "'"
	open (unit=unit, file=file_pexpr, status="replace", action="write")
	write (unit, "(A)") VERSION_STRING
	write (unit, "(A)") "Syntax definition file: " // file_pexpr
	call syntax_pexpr_write (unit)
	close (unit)
	print *, "Writing file '" // file_slha // "'"
	open (unit=unit, file=file_slha, status="replace", action="write")
	write (unit, "(A)") VERSION_STRING
	write (unit, "(A)") "Syntax definition file: " // file_slha
	call syntax_slha_write (unit)
	close (unit)
	print *, "Writing file '" // file_sindarin // "'"
	open (unit=unit, file=file_sindarin, status="replace", action="write")
	write (unit, "(A)") VERSION_STRING
	write (unit, "(A)") "Syntax definition file: " // file_sindarin
	call syntax_cmd_list_write (unit)
	close (unit)
	end subroutine write_syntax_tables

	@ %def write_syntax_tables
	@
	\subsection{Execute command lists}
	Process commands given on the command line, stored as an [[ifile]]. The whole
	input is read, compiled and executed as a whole.
	<<WHIZARD: whizard: TBP>>=
	procedure :: process_ifile => whizard_process_ifile
	<<WHIZARD: procedures>>=
	subroutine whizard_process_ifile (whizard, ifile, quit, quit_code)
	class(whizard_t), intent(inout), target :: whizard
	type(ifile_t), intent(in) :: ifile
	logical, intent(out) :: quit
	integer, intent(out) :: quit_code
	type(lexer_t), target :: lexer
	type(stream_t), target :: stream
	call msg_message ("Reading commands given on the command line")
	call lexer_init_cmd_list (lexer)
	call stream_init (stream, ifile)
	call whizard%process_stream (stream, lexer, quit, quit_code)
	call stream_final (stream)
	call lexer_final (lexer)
	end subroutine whizard_process_ifile

	@ %def whizard_process_ifile
	@ Process standard input as a command list. The whole input is read,
	compiled and executed as a whole.
	<<WHIZARD: whizard: TBP>>=
	procedure :: process_stdin => whizard_process_stdin
	<<WHIZARD: procedures>>=
	subroutine whizard_process_stdin (whizard, quit, quit_code)
	class(whizard_t), intent(inout), target :: whizard
	logical, intent(out) :: quit
	integer, intent(out) :: quit_code
	type(lexer_t), target :: lexer
	type(stream_t), target :: stream
	call msg_message ("Reading commands from standard input")
	call lexer_init_cmd_list (lexer)
	call stream_init (stream, 5)
	call whizard%process_stream (stream, lexer, quit, quit_code)
	call stream_final (stream)
	call lexer_final (lexer)
	end subroutine whizard_process_stdin

	@ %def whizard_process_stdin
	@ Process a file as a command list.
	<<WHIZARD: whizard: TBP>>=
	procedure :: process_file => whizard_process_file
	<<WHIZARD: procedures>>=
	subroutine whizard_process_file (whizard, file, quit, quit_code)
	class(whizard_t), intent(inout), target :: whizard
	type(string_t), intent(in) :: file
	logical, intent(out) :: quit
	integer, intent(out) :: quit_code
	type(lexer_t), target :: lexer
	type(stream_t), target :: stream
	logical :: exist
	call msg_message ("Reading commands from file '" // char (file) // "'")
	inquire (file=char(file), exist=exist)
	if (exist) then
	call lexer_init_cmd_list (lexer)
	call stream_init (stream, char (file))
	call whizard%process_stream (stream, lexer, quit, quit_code)
	call stream_final (stream)
	call lexer_final (lexer)
	else
	call msg_error ("File '" // char (file) // "' not found")
	end if
	end subroutine whizard_process_file

	@ %def whizard_process_file
	@
	<<WHIZARD: whizard: TBP>>=
	procedure :: process_stream => whizard_process_stream
	<<WHIZARD: procedures>>=
	subroutine whizard_process_stream (whizard, stream, lexer, quit, quit_code)
	class(whizard_t), intent(inout), target :: whizard
	type(stream_t), intent(inout), target :: stream
	type(lexer_t), intent(inout), target :: lexer
	logical, intent(out) :: quit
	integer, intent(out) :: quit_code
	type(parse_tree_t), pointer :: parse_tree
	type(command_list_t), target :: command_list
	call lexer_assign_stream (lexer, stream)
	call whizard%pt_stack%push (parse_tree)
	call parse_tree_init (parse_tree, syntax_cmd_list, lexer)
	if (associated (parse_tree%get_root_ptr ())) then
	whizard%global%lexer => lexer
	call command_list%compile (parse_tree%get_root_ptr (), &
	whizard%global)
	end if
	call whizard%global%activate ()
	call command_list%execute (whizard%global)
	call command_list%final ()
	quit = whizard%global%quit
	quit_code = whizard%global%quit_code
	end subroutine whizard_process_stream

	@ %def whizard_process_stream
	@
	\subsection{The WHIZARD shell}
	This procedure implements interactive mode. One line is processed at
	a time.
	<<WHIZARD: whizard: TBP>>=
	procedure :: shell => whizard_shell
	<<WHIZARD: procedures>>=
	subroutine whizard_shell (whizard, quit_code)
	class(whizard_t), intent(inout), target :: whizard
	integer, intent(out) :: quit_code
	type(lexer_t), target :: lexer
	type(stream_t), target :: stream
	type(string_t) :: prompt1
	type(string_t) :: prompt2
	type(string_t) :: input
	type(string_t) :: extra
	integer :: last
	integer :: iostat
	logical :: mask_tmp
	logical :: quit
	call msg_message ("Launching interactive shell")
	call lexer_init_cmd_list (lexer)
	prompt1 = "whish? "
	prompt2 = " > "
	COMMAND_LOOP: do
	call put (6, prompt1)
	call get (5, input, iostat=iostat)
	if (iostat > 0 .or. iostat == EOF) exit COMMAND_LOOP
	CONTINUE_INPUT: do
	last = len_trim (input)
	if (extract (input, last, last) /= BACKSLASH) exit CONTINUE_INPUT
	call put (6, prompt2)
	call get (5, extra, iostat=iostat)
	if (iostat > 0) exit COMMAND_LOOP
	input = replace (input, last, extra)
	end do CONTINUE_INPUT
	call stream_init (stream, input)
	mask_tmp = mask_fatal_errors
	mask_fatal_errors = .true.
	call whizard%process_stream (stream, lexer, quit, quit_code)
	msg_count = 0
	mask_fatal_errors = mask_tmp
	call stream_final (stream)
	if (quit) exit COMMAND_LOOP
	end do COMMAND_LOOP
	print *
	call lexer_final (lexer)
	end subroutine whizard_shell

	@ %def whizard_shell
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Query Feature Support}
	This module accesses the various optional features (modules) that
	WHIZARD can support and repors on their availability.
	<<[[features.f90]]>>=
	module features

	use string_utils, only: lower_case
	use system_dependencies, only: WHIZARD_VERSION
	<<Features: dependencies>>

	<<Standard module head>>

	<<Features: public>>

	contains

	<<Features: procedures>>

	end module features
	@ %def features
	@
	\subsection{Output}
	<<Features: public>>=
	public :: print_features
	<<Features: procedures>>=
	subroutine print_features ()
	print "(A)", "WHIZARD " // WHIZARD_VERSION
	print "(A)", "Build configuration:"
	<<Features: config>>
	print "(A)", "Optional features available in this build:"
	<<Features: print>>
	end subroutine print_features

	@ %def print_features
	@
	\subsection{Query function}
	<<Features: procedures>>=
	subroutine check (feature, recognized, result, help)
	character(*), intent(in) :: feature
	logical, intent(out) :: recognized
	character(*), intent(out) :: result, help
	recognized = .true.
	result = "no"
	select case (lower_case (trim (feature)))
	<<Features: cases>>
	case default
	recognized = .false.
	end select
	end subroutine check

	@ %def check
	@ Print this result:
	<<Features: procedures>>=
	subroutine print_check (feature)
	character(*), intent(in) :: feature
	character(16) :: f
	logical :: recognized
	character(10) :: result
	character(48) :: help
	call check (feature, recognized, result, help)
	if (.not. recognized) then
	result = "unknown"
	help = ""
	end if
	f = feature
	print "(2x,A,1x,A,'(',A,')')", f, result, trim (help)
	end subroutine print_check

	@ %def print_check
	@
	\subsection{Basic configuration}
	<<Features: config>>=
	call print_check ("precision")
	<<Features: dependencies>>=
	use kinds, only: default
	<<Features: cases>>=
	case ("precision")
	write (result, "(I0)") precision (1._default)
	help = "significant decimals of real/complex numbers"
	@
	\subsection{Optional features case by case}
	<<Features: print>>=
	call print_check ("OpenMP")
	<<Features: dependencies>>=
	use system_dependencies, only: openmp_is_active
	<<Features: cases>>=
	case ("openmp")
	if (openmp_is_active ()) then
	result = "yes"
	end if
	help = "OpenMP parallel execution"
	@
	<<Features: print>>=
	call print_check ("GoSam")
	<<Features: dependencies>>=
	use system_dependencies, only: GOSAM_AVAILABLE
	<<Features: cases>>=
	case ("gosam")
	if (GOSAM_AVAILABLE) then
	result = "yes"
	end if
	help = "external NLO matrix element provider"
	@
	<<Features: print>>=
	call print_check ("OpenLoops")
	<<Features: dependencies>>=
	use system_dependencies, only: OPENLOOPS_AVAILABLE
	<<Features: cases>>=
	case ("openloops")
	if (OPENLOOPS_AVAILABLE) then
	result = "yes"
	end if
	help = "external NLO matrix element provider"
	@
	<<Features: print>>=
	call print_check ("Recola")
	<<Features: dependencies>>=
	use system_dependencies, only: RECOLA_AVAILABLE
	<<Features: cases>>=
	case ("recola")
	if (RECOLA_AVAILABLE) then
	result = "yes"
	end if
	help = "external NLO matrix element provider"
	@
	<<Features: print>>=
	call print_check ("LHAPDF")
	<<Features: dependencies>>=
	use system_dependencies, only: LHAPDF5_AVAILABLE
	use system_dependencies, only: LHAPDF6_AVAILABLE
	<<Features: cases>>=
	case ("lhapdf")
	if (LHAPDF5_AVAILABLE) then
	result = "v5"
	else if (LHAPDF6_AVAILABLE) then
	result = "v6"
	end if
	help = "PDF library"
	@
	<<Features: print>>=
	call print_check ("HOPPET")
	<<Features: dependencies>>=
	use system_dependencies, only: HOPPET_AVAILABLE
	<<Features: cases>>=
	case ("hoppet")
	if (HOPPET_AVAILABLE) then
	result = "yes"
	end if
	help = "PDF evolution package"
	@
	<<Features: print>>=
	call print_check ("fastjet")
	<<Features: dependencies>>=
	use jets, only: fastjet_available
	<<Features: cases>>=
	case ("fastjet")
	if (fastjet_available ()) then
	result = "yes"
	end if
	help = "jet-clustering package"
	@
	<<Features: print>>=
	call print_check ("Pythia6")
	<<Features: dependencies>>=
	use system_dependencies, only: PYTHIA6_AVAILABLE
	<<Features: cases>>=
	case ("pythia6")
	if (PYTHIA6_AVAILABLE) then
	result = "yes"
	end if
	help = "direct access for shower/hadronization"
	@
	<<Features: print>>=
	call print_check ("Pythia8")
	<<Features: dependencies>>=
	use system_dependencies, only: PYTHIA8_AVAILABLE
	<<Features: cases>>=
	case ("pythia8")
	if (PYTHIA8_AVAILABLE) then
	result = "yes"
	end if
	help = "direct access for shower/hadronization"
	@
	<<Features: print>>=
	call print_check ("StdHEP")
	<<Features: cases>>=
	case ("stdhep")
	result = "yes"
	help = "event I/O format"
	@
	<<Features: print>>=
	call print_check ("HepMC")
	<<Features: dependencies>>=
	use hepmc_interface, only: hepmc_is_available
	<<Features: cases>>=
	case ("hepmc")
	if (hepmc_is_available ()) then
	result = "yes"
	end if
	help = "event I/O format"
	@
	<<Features: print>>=
	call print_check ("LCIO")
	<<Features: dependencies>>=
	use lcio_interface, only: lcio_is_available
	<<Features: cases>>=
	case ("lcio")
	if (lcio_is_available ()) then
	result = "yes"
	end if
	help = "event I/O format"
	@
	<<Features: print>>=
	call print_check ("MetaPost")
	<<Features: dependencies>>=
	use system_dependencies, only: EVENT_ANALYSIS
	<<Features: cases>>=
	case ("metapost")
	result = EVENT_ANALYSIS
	help = "graphical event analysis via LaTeX/MetaPost"
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

	Index: trunk/src/types/types.nw
	===================================================================
	--- trunk/src/types/types.nw (revision 8777)
	+++ trunk/src/types/types.nw (revision 8778)
	@@ -1,8147 +1,9213 @@
	%% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: common types and objects
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Sindarin Built-In Types}
	\includemodulegraph{types}

	Here, we define a couple of types and objects which are useful both
	internally for \whizard, and visible to the user, so they correspond
	to Sindarin types.
	\begin{description}
	\item[particle\_specifiers]
	Expressions for particles and particle alternatives, involving
	particle names.
	\item[pdg\_arrays]
	Integer (PDG) codes for particles. Useful for particle aliases
	(e.g., 'quark' for $u,d,s$ etc.).
	\item[jets]
	Define (pseudo)jets as objects. Functional only if the [[fastjet]] library
	is linked. (This may change in the future.)
	\item[subevents]
	Particle collections built from event records, for use in analysis and other
	Sindarin expressions
	\item[analysis]
	Observables, histograms, and plots.
	\end{description}

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Particle Specifiers}
	In this module we introduce a type for specifying a particle or particle
	alternative. In addition to the particle specifiers (strings separated by
	colons), the type contains an optional flag [[polarized]] and a string
	[[decay]]. If the [[polarized]] flag is set, particle polarization
	information should be kept when generating events for this process. If the
	[[decay]] string is set, it is the ID of a decay process which should be
	applied to this particle when generating events.

	In input/output form, the [[polarized]] flag is indicated by an asterisk
	[[(*)]] in brackets, and the [[decay]] is indicated by its ID in brackets.

	The [[read]] and [[write]] procedures in this module are not type-bound but
	generic procedures which handle scalar and array arguments.
	<<[[particle_specifiers.f90]]>>=
	<<File header>>

	module particle_specifiers

	<<Use strings>>
	- use io_units
	- use diagnostics

	<<Standard module head>>

	<<Particle specifiers: public>>

	<<Particle specifiers: types>>

	<<Particle specifiers: interfaces>>

	+ interface
	+<<Particle specifiers: sub interfaces>>
	+ end interface
	+
	contains

	-<<Particle specifiers: procedures>>
	+<<Particle specifiers: main procedures>>

	end module particle_specifiers
	@ %def particle_specifiers
	@
	+<<[[particle_specifiers_sub.f90]]>>=
	+<<File header>>
	+
	+submodule (particle_specifiers) particle_specifiers_s
	+
	+ use io_units
	+ use diagnostics
	+
	+ implicit none
	+
	+contains
	+
	+<<Particle specifiers: procedures>>
	+
	+end submodule particle_specifiers_s
	+
	+@ %def particle_specifiers_s
	+@
	\subsection{Base type}
	This is an abstract type which can hold a single particle or an expression.
	<<Particle specifiers: types>>=
	type, abstract :: prt_spec_expr_t
	contains
	<<Particle specifiers: prt spec expr: TBP>>
	end type prt_spec_expr_t

	@ %def prt_expr_t
	@ Output, as a string.
	<<Particle specifiers: prt spec expr: TBP>>=
	procedure (prt_spec_expr_to_string), deferred :: to_string
	<<Particle specifiers: interfaces>>=
	abstract interface
	function prt_spec_expr_to_string (object) result (string)
	import
	class(prt_spec_expr_t), intent(in) :: object
	type(string_t) :: string
	end function prt_spec_expr_to_string
	end interface

	@ %def prt_spec_expr_to_string
	@ Call an [[expand]] method for all enclosed subexpressions (before handling
	the current expression).
	<<Particle specifiers: prt spec expr: TBP>>=
	procedure (prt_spec_expr_expand_sub), deferred :: expand_sub
	<<Particle specifiers: interfaces>>=
	abstract interface
	subroutine prt_spec_expr_expand_sub (object)
	import
	class(prt_spec_expr_t), intent(inout) :: object
	end subroutine prt_spec_expr_expand_sub
	end interface

	@ %def prt_spec_expr_expand_sub
	@
	\subsection{Wrapper type}
	This wrapper can hold a particle expression of any kind. We need it so we can
	make variadic arrays.
	<<Particle specifiers: public>>=
	public :: prt_expr_t
	<<Particle specifiers: types>>=
	type :: prt_expr_t
	class(prt_spec_expr_t), allocatable :: x
	contains
	<<Particle specifiers: prt expr: TBP>>
	end type prt_expr_t

	@ %def prt_expr_t
	@ Output as a string: delegate.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: to_string => prt_expr_to_string
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module function prt_expr_to_string (object) result (string)
	+ class(prt_expr_t), intent(in) :: object
	+ type(string_t) :: string
	+ end function prt_expr_to_string
	<<Particle specifiers: procedures>>=
	- recursive function prt_expr_to_string (object) result (string)
	+ recursive module function prt_expr_to_string (object) result (string)
	class(prt_expr_t), intent(in) :: object
	type(string_t) :: string
	if (allocated (object%x)) then
	string = object%x%to_string ()
	else
	string = ""
	end if
	end function prt_expr_to_string

	@ %def prt_expr_to_string
	@ Allocate the expression as a particle specifier and copy the value.
	+Due to compiler bugs in gfortran 7-9 not in submodule.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: init_spec => prt_expr_init_spec
	-<<Particle specifiers: procedures>>=
	+<<Particle specifiers: main procedures>>=
	subroutine prt_expr_init_spec (object, spec)
	class(prt_expr_t), intent(out) :: object
	type(prt_spec_t), intent(in) :: spec
	allocate (prt_spec_t :: object%x)
	select type (x => object%x)
	type is (prt_spec_t)
	x = spec
	end select
	end subroutine prt_expr_init_spec

	@ %def prt_expr_init_spec
	@ Allocate as a list/sum and allocate for a given length
	+Due to compiler bugs in gfortran 7-9 not in submodule.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: init_list => prt_expr_init_list
	procedure :: init_sum => prt_expr_init_sum
	-<<Particle specifiers: procedures>>=
	+<<Particle specifiers: main procedures>>=
	subroutine prt_expr_init_list (object, n)
	class(prt_expr_t), intent(out) :: object
	integer, intent(in) :: n
	allocate (prt_spec_list_t :: object%x)
	select type (x => object%x)
	type is (prt_spec_list_t)
	allocate (x%expr (n))
	end select
	end subroutine prt_expr_init_list

	subroutine prt_expr_init_sum (object, n)
	class(prt_expr_t), intent(out) :: object
	integer, intent(in) :: n
	allocate (prt_spec_sum_t :: object%x)
	select type (x => object%x)
	type is (prt_spec_sum_t)
	allocate (x%expr (n))
	end select
	end subroutine prt_expr_init_sum

	@ %def prt_expr_init_list
	@ %def prt_expr_init_sum
	@ Return the number of terms. This is unity, except if the expression is a
	sum.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: get_n_terms => prt_expr_get_n_terms
	+<<Particle specifiers: sub interfaces>>=
	+ module function prt_expr_get_n_terms (object) result (n)
	+ class(prt_expr_t), intent(in) :: object
	+ integer :: n
	+ end function prt_expr_get_n_terms
	<<Particle specifiers: procedures>>=
	- function prt_expr_get_n_terms (object) result (n)
	+ module function prt_expr_get_n_terms (object) result (n)
	class(prt_expr_t), intent(in) :: object
	integer :: n
	if (allocated (object%x)) then
	select type (x => object%x)
	type is (prt_spec_sum_t)
	n = size (x%expr)
	class default
	n = 1
	end select
	else
	n = 0
	end if
	end function prt_expr_get_n_terms

	@ %def prt_expr_get_n_terms
	@ Transform one of the terms, as returned by the previous method, to an array
	of particle specifiers. The array has more than one entry if the selected
	term is a list. This makes sense only if the expression has been completely
	expanded, so the list contains only atoms.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: term_to_array => prt_expr_term_to_array
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module subroutine prt_expr_term_to_array (object, array, i)
	+ class(prt_expr_t), intent(in) :: object
	+ type(prt_spec_t), dimension(:), intent(inout), allocatable :: array
	+ integer, intent(in) :: i
	+ end subroutine prt_expr_term_to_array
	<<Particle specifiers: procedures>>=
	- recursive subroutine prt_expr_term_to_array (object, array, i)
	+ recursive module subroutine prt_expr_term_to_array (object, array, i)
	class(prt_expr_t), intent(in) :: object
	type(prt_spec_t), dimension(:), intent(inout), allocatable :: array
	integer, intent(in) :: i
	integer :: j
	if (allocated (array)) deallocate (array)
	select type (x => object%x)
	type is (prt_spec_t)
	allocate (array (1))
	array(1) = x
	type is (prt_spec_list_t)
	allocate (array (size (x%expr)))
	do j = 1, size (array)
	select type (y => x%expr(j)%x)
	type is (prt_spec_t)
	array(j) = y
	end select
	end do
	type is (prt_spec_sum_t)
	call x%expr(i)%term_to_array (array, 1)
	end select
	end subroutine prt_expr_term_to_array

	@ %def prt_expr_term_to_array
	@
	\subsection{The atomic type}
	The trivial case is a single particle, including optional decay and
	polarization attributes.

	\subsubsection{Definition}
	The particle is unstable if the [[decay]] array is allocated. The
	[[polarized]] flag and decays may not be set simultaneously.
	<<Particle specifiers: public>>=
	public :: prt_spec_t
	<<Particle specifiers: types>>=
	type, extends (prt_spec_expr_t) :: prt_spec_t
	private
	type(string_t) :: name
	logical :: polarized = .false.
	type(string_t), dimension(:), allocatable :: decay
	contains
	<<Particle specifiers: prt spec: TBP>>
	end type prt_spec_t

	@ %def prt_spec_t
	@
	\subsubsection{I/O}
	Output. Old-style subroutines.
	<<Particle specifiers: public>>=
	public :: prt_spec_write
	<<Particle specifiers: interfaces>>=
	interface prt_spec_write
	module procedure prt_spec_write1
	module procedure prt_spec_write2
	end interface prt_spec_write
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_write1 (object, unit, advance)
	+ type(prt_spec_t), intent(in) :: object
	+ integer, intent(in), optional :: unit
	+ character(len=*), intent(in), optional :: advance
	+ end subroutine prt_spec_write1
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_write1 (object, unit, advance)
	+ module subroutine prt_spec_write1 (object, unit, advance)
	type(prt_spec_t), intent(in) :: object
	integer, intent(in), optional :: unit
	character(len=*), intent(in), optional :: advance
	character(3) :: adv
	integer :: u
	u = given_output_unit (unit)
	adv = "yes"; if (present (advance)) adv = advance
	write (u, "(A)", advance = adv) char (object%to_string ())
	end subroutine prt_spec_write1

	@ %def prt_spec_write1
	@ Write an array as a list of particle specifiers.
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_write2 (prt_spec, unit, advance)
	+ type(prt_spec_t), dimension(:), intent(in) :: prt_spec
	+ integer, intent(in), optional :: unit
	+ character(len=*), intent(in), optional :: advance
	+ end subroutine prt_spec_write2
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_write2 (prt_spec, unit, advance)
	+ module subroutine prt_spec_write2 (prt_spec, unit, advance)
	type(prt_spec_t), dimension(:), intent(in) :: prt_spec
	integer, intent(in), optional :: unit
	character(len=*), intent(in), optional :: advance
	character(3) :: adv
	integer :: u, i
	u = given_output_unit (unit)
	adv = "yes"; if (present (advance)) adv = advance
	do i = 1, size (prt_spec)
	if (i > 1) write (u, "(A)", advance="no") ", "
	call prt_spec_write (prt_spec(i), u, advance="no")
	end do
	write (u, "(A)", advance = adv)
	end subroutine prt_spec_write2

	@ %def prt_spec_write2
	@ Read. Input may be string or array of strings.
	<<Particle specifiers: public>>=
	public :: prt_spec_read
	<<Particle specifiers: interfaces>>=
	interface prt_spec_read
	module procedure prt_spec_read1
	module procedure prt_spec_read2
	end interface prt_spec_read
	@ Read a single particle specifier
	+<<Particle specifiers: sub interfaces>>=
	+ pure module subroutine prt_spec_read1 (prt_spec, string)
	+ type(prt_spec_t), intent(out) :: prt_spec
	+ type(string_t), intent(in) :: string
	+ end subroutine prt_spec_read1
	<<Particle specifiers: procedures>>=
	- pure subroutine prt_spec_read1 (prt_spec, string)
	+ pure module subroutine prt_spec_read1 (prt_spec, string)
	type(prt_spec_t), intent(out) :: prt_spec
	type(string_t), intent(in) :: string
	type(string_t) :: arg, buffer
	integer :: b1, b2, c, n, i
	b1 = scan (string, "(")
	b2 = scan (string, ")")
	if (b1 == 0) then
	prt_spec%name = trim (adjustl (string))
	else
	prt_spec%name = trim (adjustl (extract (string, 1, b1-1)))
	arg = trim (adjustl (extract (string, b1+1, b2-1)))
	if (arg == "*") then
	prt_spec%polarized = .true.
	else
	n = 0
	buffer = arg
	do
	if (verify (buffer, " ") == 0) exit
	n = n + 1
	c = scan (buffer, "+")
	if (c == 0) exit
	buffer = extract (buffer, c+1)
	end do
	allocate (prt_spec%decay (n))
	buffer = arg
	do i = 1, n
	c = scan (buffer, "+")
	if (c == 0) c = len (buffer) + 1
	prt_spec%decay(i) = trim (adjustl (extract (buffer, 1, c-1)))
	buffer = extract (buffer, c+1)
	end do
	end if
	end if
	end subroutine prt_spec_read1

	@ %def prt_spec_read1
	@ Read a particle specifier array, given as a single string. The
	array is allocated to the correct size.
	+<<Particle specifiers: sub interfaces>>=
	+ pure module subroutine prt_spec_read2 (prt_spec, string)
	+ type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec
	+ type(string_t), intent(in) :: string
	+ end subroutine prt_spec_read2
	<<Particle specifiers: procedures>>=
	- pure subroutine prt_spec_read2 (prt_spec, string)
	+ pure module subroutine prt_spec_read2 (prt_spec, string)
	type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec
	type(string_t), intent(in) :: string
	type(string_t) :: buffer
	integer :: c, i, n
	n = 0
	buffer = string
	do
	n = n + 1
	c = scan (buffer, ",")
	if (c == 0) exit
	buffer = extract (buffer, c+1)
	end do
	allocate (prt_spec (n))
	buffer = string
	do i = 1, size (prt_spec)
	c = scan (buffer, ",")
	if (c == 0) c = len (buffer) + 1
	call prt_spec_read (prt_spec(i), &
	trim (adjustl (extract (buffer, 1, c-1))))
	buffer = extract (buffer, c+1)
	end do
	end subroutine prt_spec_read2

	@ %def prt_spec_read2
	@
	\subsubsection{Constructor}
	Initialize a particle specifier.
	<<Particle specifiers: public>>=
	public :: new_prt_spec
	<<Particle specifiers: interfaces>>=
	interface new_prt_spec
	- module procedure new_prt_spec
	+ module procedure new_prt_spec_
	module procedure new_prt_spec_polarized
	module procedure new_prt_spec_unstable
	end interface new_prt_spec
	+<<Particle specifiers: sub interfaces>>=
	+ elemental module function new_prt_spec_ (name) result (prt_spec)
	+ type(string_t), intent(in) :: name
	+ type(prt_spec_t) :: prt_spec
	+ end function new_prt_spec_
	+ elemental module function new_prt_spec_polarized (name, polarized) result (prt_spec)
	+ type(string_t), intent(in) :: name
	+ logical, intent(in) :: polarized
	+ type(prt_spec_t) :: prt_spec
	+ end function new_prt_spec_polarized
	+ pure module function new_prt_spec_unstable (name, decay) result (prt_spec)
	+ type(string_t), intent(in) :: name
	+ type(string_t), dimension(:), intent(in) :: decay
	+ type(prt_spec_t) :: prt_spec
	+ end function new_prt_spec_unstable
	<<Particle specifiers: procedures>>=
	- elemental function new_prt_spec (name) result (prt_spec)
	+ elemental module function new_prt_spec_ (name) result (prt_spec)
	type(string_t), intent(in) :: name
	type(prt_spec_t) :: prt_spec
	prt_spec%name = name
	- end function new_prt_spec
	+ end function new_prt_spec_

	- elemental function new_prt_spec_polarized (name, polarized) result (prt_spec)
	+ elemental module function new_prt_spec_polarized (name, polarized) result (prt_spec)
	type(string_t), intent(in) :: name
	logical, intent(in) :: polarized
	type(prt_spec_t) :: prt_spec
	prt_spec%name = name
	prt_spec%polarized = polarized
	end function new_prt_spec_polarized

	- pure function new_prt_spec_unstable (name, decay) result (prt_spec)
	+ pure module function new_prt_spec_unstable (name, decay) result (prt_spec)
	type(string_t), intent(in) :: name
	type(string_t), dimension(:), intent(in) :: decay
	type(prt_spec_t) :: prt_spec
	prt_spec%name = name
	allocate (prt_spec%decay (size (decay)))
	prt_spec%decay = decay
	end function new_prt_spec_unstable

	@ %def new_prt_spec
	@
	\subsubsection{Access Methods}
	Return the particle name without qualifiers
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: get_name => prt_spec_get_name
	+<<Particle specifiers: sub interfaces>>=
	+ elemental module function prt_spec_get_name (prt_spec) result (name)
	+ class(prt_spec_t), intent(in) :: prt_spec
	+ type(string_t) :: name
	+ end function prt_spec_get_name
	<<Particle specifiers: procedures>>=
	- elemental function prt_spec_get_name (prt_spec) result (name)
	+ elemental module function prt_spec_get_name (prt_spec) result (name)
	class(prt_spec_t), intent(in) :: prt_spec
	type(string_t) :: name
	name = prt_spec%name
	end function prt_spec_get_name

	@ %def prt_spec_get_name
	@ Return the name with qualifiers
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: to_string => prt_spec_to_string
	+<<Particle specifiers: sub interfaces>>=
	+ module function prt_spec_to_string (object) result (string)
	+ class(prt_spec_t), intent(in) :: object
	+ type(string_t) :: string
	+ end function prt_spec_to_string
	<<Particle specifiers: procedures>>=
	- function prt_spec_to_string (object) result (string)
	+ module function prt_spec_to_string (object) result (string)
	class(prt_spec_t), intent(in) :: object
	type(string_t) :: string
	integer :: i
	string = object%name
	if (allocated (object%decay)) then
	string = string // "("
	do i = 1, size (object%decay)
	if (i > 1) string = string // " + "
	string = string // object%decay(i)
	end do
	string = string // ")"
	else if (object%polarized) then
	string = string // "(*)"
	end if
	end function prt_spec_to_string

	@ %def prt_spec_to_string
	@ Return the polarization flag
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: is_polarized => prt_spec_is_polarized
	+<<Particle specifiers: sub interfaces>>=
	+ elemental module function prt_spec_is_polarized (prt_spec) result (flag)
	+ class(prt_spec_t), intent(in) :: prt_spec
	+ logical :: flag
	+ end function prt_spec_is_polarized
	<<Particle specifiers: procedures>>=
	- elemental function prt_spec_is_polarized (prt_spec) result (flag)
	+ elemental module function prt_spec_is_polarized (prt_spec) result (flag)
	class(prt_spec_t), intent(in) :: prt_spec
	logical :: flag
	flag = prt_spec%polarized
	end function prt_spec_is_polarized

	@ %def prt_spec_is_polarized
	@ The particle is unstable if there is a decay array.
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: is_unstable => prt_spec_is_unstable
	+<<Particle specifiers: sub interfaces>>=
	+ elemental module function prt_spec_is_unstable (prt_spec) result (flag)
	+ class(prt_spec_t), intent(in) :: prt_spec
	+ logical :: flag
	+ end function prt_spec_is_unstable
	<<Particle specifiers: procedures>>=
	- elemental function prt_spec_is_unstable (prt_spec) result (flag)
	+ elemental module function prt_spec_is_unstable (prt_spec) result (flag)
	class(prt_spec_t), intent(in) :: prt_spec
	logical :: flag
	flag = allocated (prt_spec%decay)
	end function prt_spec_is_unstable

	@ %def prt_spec_is_unstable
	@ Return the number of decay channels
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: get_n_decays => prt_spec_get_n_decays
	+<<Particle specifiers: sub interfaces>>=
	+ elemental module function prt_spec_get_n_decays (prt_spec) result (n)
	+ class(prt_spec_t), intent(in) :: prt_spec
	+ integer :: n
	+ end function prt_spec_get_n_decays
	<<Particle specifiers: procedures>>=
	- elemental function prt_spec_get_n_decays (prt_spec) result (n)
	+ elemental module function prt_spec_get_n_decays (prt_spec) result (n)
	class(prt_spec_t), intent(in) :: prt_spec
	integer :: n
	if (allocated (prt_spec%decay)) then
	n = size (prt_spec%decay)
	else
	n = 0
	end if
	end function prt_spec_get_n_decays

	@ %def prt_spec_get_n_decays
	@ Return the decay channels
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: get_decays => prt_spec_get_decays
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_get_decays (prt_spec, decay)
	+ class(prt_spec_t), intent(in) :: prt_spec
	+ type(string_t), dimension(:), allocatable, intent(out) :: decay
	+ end subroutine prt_spec_get_decays
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_get_decays (prt_spec, decay)
	+ module subroutine prt_spec_get_decays (prt_spec, decay)
	class(prt_spec_t), intent(in) :: prt_spec
	type(string_t), dimension(:), allocatable, intent(out) :: decay
	if (allocated (prt_spec%decay)) then
	allocate (decay (size (prt_spec%decay)))
	decay = prt_spec%decay
	else
	allocate (decay (0))
	end if
	end subroutine prt_spec_get_decays

	@ %def prt_spec_get_decays
	@
	\subsubsection{Miscellaneous}
	There is nothing to expand here:
	<<Particle specifiers: prt spec: TBP>>=
	procedure :: expand_sub => prt_spec_expand_sub
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_expand_sub (object)
	+ class(prt_spec_t), intent(inout) :: object
	+ end subroutine prt_spec_expand_sub
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_expand_sub (object)
	+ module subroutine prt_spec_expand_sub (object)
	class(prt_spec_t), intent(inout) :: object
	end subroutine prt_spec_expand_sub

	@ %def prt_spec_expand_sub
	@
	\subsection{List}
	A list of particle specifiers, indicating, e.g., the final state of a
	process.
	<<Particle specifiers: public>>=
	public :: prt_spec_list_t
	<<Particle specifiers: types>>=
	type, extends (prt_spec_expr_t) :: prt_spec_list_t
	type(prt_expr_t), dimension(:), allocatable :: expr
	contains
	<<Particle specifiers: prt spec list: TBP>>
	end type prt_spec_list_t

	@ %def prt_spec_list_t
	@ Output: Concatenate the components. Insert brackets if the component is
	also a list. The components of the [[expr]] array, if any, should all be
	filled.
	<<Particle specifiers: prt spec list: TBP>>=
	procedure :: to_string => prt_spec_list_to_string
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module function prt_spec_list_to_string (object) result (string)
	+ class(prt_spec_list_t), intent(in) :: object
	+ type(string_t) :: string
	+ end function prt_spec_list_to_string
	<<Particle specifiers: procedures>>=
	- recursive function prt_spec_list_to_string (object) result (string)
	+ recursive module function prt_spec_list_to_string (object) result (string)
	class(prt_spec_list_t), intent(in) :: object
	type(string_t) :: string
	integer :: i
	string = ""
	if (allocated (object%expr)) then
	do i = 1, size (object%expr)
	if (i > 1) string = string // ", "
	select type (x => object%expr(i)%x)
	type is (prt_spec_list_t)
	string = string // "(" // x%to_string () // ")"
	class default
	string = string // x%to_string ()
	end select
	end do
	end if
	end function prt_spec_list_to_string

	@ %def prt_spec_list_to_string
	@ Flatten: if there is a subexpression which is also a list, include the
	components as direct members of the current list.
	<<Particle specifiers: prt spec list: TBP>>=
	procedure :: flatten => prt_spec_list_flatten
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_list_flatten (object)
	+ class(prt_spec_list_t), intent(inout) :: object
	+ end subroutine prt_spec_list_flatten
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_list_flatten (object)
	+ module subroutine prt_spec_list_flatten (object)
	class(prt_spec_list_t), intent(inout) :: object
	type(prt_expr_t), dimension(:), allocatable :: tmp_expr
	integer :: i, n_flat, i_flat
	n_flat = 0
	do i = 1, size (object%expr)
	select type (y => object%expr(i)%x)
	type is (prt_spec_list_t)
	n_flat = n_flat + size (y%expr)
	class default
	n_flat = n_flat + 1
	end select
	end do
	if (n_flat > size (object%expr)) then
	allocate (tmp_expr (n_flat))
	i_flat = 0
	do i = 1, size (object%expr)
	select type (y => object%expr(i)%x)
	type is (prt_spec_list_t)
	tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
	i_flat = i_flat + size (y%expr)
	class default
	tmp_expr (i_flat + 1) = object%expr(i)
	i_flat = i_flat + 1
	end select
	end do
	end if
	if (allocated (tmp_expr)) &
	call move_alloc (from = tmp_expr, to = object%expr)
	end subroutine prt_spec_list_flatten

	@ %def prt_spec_list_flatten
	@ Convert a list of sums into a sum of lists. (Subexpressions which are not
	-sums are left untouched.)
	-<<Particle specifiers: procedures>>=
	+sums are left untouched.) Due to compiler bug in gfortran 7-9 not in submodule.
	+<<Particle specifiers: main procedures>>=
	subroutine distribute_prt_spec_list (object)
	class(prt_spec_expr_t), intent(inout), allocatable :: object
	class(prt_spec_expr_t), allocatable :: new_object
	integer, dimension(:), allocatable :: n, ii
	integer :: k, n_expr, n_terms, i_term
	select type (object)
	type is (prt_spec_list_t)
	n_expr = size (object%expr)
	allocate (n (n_expr), source = 1)
	allocate (ii (n_expr), source = 1)
	do k = 1, size (object%expr)
	select type (y => object%expr(k)%x)
	type is (prt_spec_sum_t)
	n(k) = size (y%expr)
	end select
	end do
	n_terms = product (n)
	if (n_terms > 1) then
	allocate (prt_spec_sum_t :: new_object)
	select type (new_object)
	type is (prt_spec_sum_t)
	allocate (new_object%expr (n_terms))
	do i_term = 1, n_terms
	allocate (prt_spec_list_t :: new_object%expr(i_term)%x)
	select type (x => new_object%expr(i_term)%x)
	type is (prt_spec_list_t)
	allocate (x%expr (n_expr))
	do k = 1, n_expr
	select type (y => object%expr(k)%x)
	type is (prt_spec_sum_t)
	x%expr(k) = y%expr(ii(k))
	class default
	x%expr(k) = object%expr(k)
	end select
	end do
	end select
	INCR_INDEX: do k = n_expr, 1, -1
	if (ii(k) < n(k)) then
	ii(k) = ii(k) + 1
	exit INCR_INDEX
	else
	ii(k) = 1
	end if
	end do INCR_INDEX
	end do
	end select
	end if
	end select
	if (allocated (new_object)) call move_alloc (from = new_object, to = object)
	end subroutine distribute_prt_spec_list

	@ %def distribute_prt_spec_list
	@ Apply [[expand]] to all components of the list.
	<<Particle specifiers: prt spec list: TBP>>=
	procedure :: expand_sub => prt_spec_list_expand_sub
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module subroutine prt_spec_list_expand_sub (object)
	+ class(prt_spec_list_t), intent(inout) :: object
	+ end subroutine prt_spec_list_expand_sub
	<<Particle specifiers: procedures>>=
	- recursive subroutine prt_spec_list_expand_sub (object)
	+ recursive module subroutine prt_spec_list_expand_sub (object)
	class(prt_spec_list_t), intent(inout) :: object
	integer :: i
	if (allocated (object%expr)) then
	do i = 1, size (object%expr)
	call object%expr(i)%expand ()
	end do
	end if
	end subroutine prt_spec_list_expand_sub

	@ %def prt_spec_list_expand_sub
	@
	\subsection{Sum}
	A sum of particle specifiers, indicating, e.g., a sum of final states.
	<<Particle specifiers: public>>=
	public :: prt_spec_sum_t
	<<Particle specifiers: types>>=
	type, extends (prt_spec_expr_t) :: prt_spec_sum_t
	type(prt_expr_t), dimension(:), allocatable :: expr
	contains
	<<Particle specifiers: prt spec sum: TBP>>
	end type prt_spec_sum_t

	@ %def prt_spec_sum_t
	@ Output: Concatenate the components. Insert brackets if the component is
	a list or also a sum. The components of the [[expr]] array, if any, should
	all be filled.
	<<Particle specifiers: prt spec sum: TBP>>=
	procedure :: to_string => prt_spec_sum_to_string
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module function prt_spec_sum_to_string (object) result (string)
	+ class(prt_spec_sum_t), intent(in) :: object
	+ type(string_t) :: string
	+ end function prt_spec_sum_to_string
	<<Particle specifiers: procedures>>=
	- recursive function prt_spec_sum_to_string (object) result (string)
	+ recursive module function prt_spec_sum_to_string (object) result (string)
	class(prt_spec_sum_t), intent(in) :: object
	type(string_t) :: string
	integer :: i
	string = ""
	if (allocated (object%expr)) then
	do i = 1, size (object%expr)
	if (i > 1) string = string // " + "
	select type (x => object%expr(i)%x)
	type is (prt_spec_list_t)
	string = string // "(" // x%to_string () // ")"
	type is (prt_spec_sum_t)
	string = string // "(" // x%to_string () // ")"
	class default
	string = string // x%to_string ()
	end select
	end do
	end if
	end function prt_spec_sum_to_string

	@ %def prt_spec_sum_to_string
	@ Flatten: if there is a subexpression which is also a sum, include the
	components as direct members of the current sum.

	This is identical to [[prt_spec_list_flatten]] above, except for the type.
	<<Particle specifiers: prt spec sum: TBP>>=
	procedure :: flatten => prt_spec_sum_flatten
	+<<Particle specifiers: sub interfaces>>=
	+ module subroutine prt_spec_sum_flatten (object)
	+ class(prt_spec_sum_t), intent(inout) :: object
	+ end subroutine prt_spec_sum_flatten
	<<Particle specifiers: procedures>>=
	- subroutine prt_spec_sum_flatten (object)
	+ module subroutine prt_spec_sum_flatten (object)
	class(prt_spec_sum_t), intent(inout) :: object
	type(prt_expr_t), dimension(:), allocatable :: tmp_expr
	integer :: i, n_flat, i_flat
	n_flat = 0
	do i = 1, size (object%expr)
	select type (y => object%expr(i)%x)
	type is (prt_spec_sum_t)
	n_flat = n_flat + size (y%expr)
	class default
	n_flat = n_flat + 1
	end select
	end do
	if (n_flat > size (object%expr)) then
	allocate (tmp_expr (n_flat))
	i_flat = 0
	do i = 1, size (object%expr)
	select type (y => object%expr(i)%x)
	type is (prt_spec_sum_t)
	tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
	i_flat = i_flat + size (y%expr)
	class default
	tmp_expr (i_flat + 1) = object%expr(i)
	i_flat = i_flat + 1
	end select
	end do
	end if
	if (allocated (tmp_expr)) &
	call move_alloc (from = tmp_expr, to = object%expr)
	end subroutine prt_spec_sum_flatten

	@ %def prt_spec_sum_flatten
	@ Apply [[expand]] to all terms in the sum.
	<<Particle specifiers: prt spec sum: TBP>>=
	procedure :: expand_sub => prt_spec_sum_expand_sub
	+<<Particle specifiers: sub interfaces>>=
	+ recursive module subroutine prt_spec_sum_expand_sub (object)
	+ class(prt_spec_sum_t), intent(inout) :: object
	+ end subroutine prt_spec_sum_expand_sub
	<<Particle specifiers: procedures>>=
	- recursive subroutine prt_spec_sum_expand_sub (object)
	+ recursive module subroutine prt_spec_sum_expand_sub (object)
	class(prt_spec_sum_t), intent(inout) :: object
	integer :: i
	if (allocated (object%expr)) then
	do i = 1, size (object%expr)
	call object%expr(i)%expand ()
	end do
	end if
	end subroutine prt_spec_sum_expand_sub

	@ %def prt_spec_sum_expand_sub
	@
	\subsection{Expression Expansion}
	The [[expand]] method transforms each particle specifier expression into a sum
	of lists, according to the rules
	\begin{align}
	a, (b, c) &\to a, b, c
	\\
	a + (b + c) &\to a + b + c
	\\
	a, b + c &\to (a, b) + (a, c)
	\end{align}
	Note that the precedence of comma and plus are opposite to this expansion, so
	the parentheses in the final expression are necessary.

	We assume that subexpressions are filled, i.e., arrays are allocated.
	+Do to compiler bug in gfortran 7-9 not in submodule.
	<<Particle specifiers: prt expr: TBP>>=
	procedure :: expand => prt_expr_expand
	-<<Particle specifiers: procedures>>=
	+<<Particle specifiers: main procedures>>=
	recursive subroutine prt_expr_expand (expr)
	class(prt_expr_t), intent(inout) :: expr
	if (allocated (expr%x)) then
	call distribute_prt_spec_list (expr%x)
	call expr%x%expand_sub ()
	select type (x => expr%x)
	type is (prt_spec_list_t)
	call x%flatten ()
	type is (prt_spec_sum_t)
	call x%flatten ()
	end select
	end if
	end subroutine prt_expr_expand

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

	module particle_specifiers_ut
	use unit_tests
	use particle_specifiers_uti

	<<Standard module head>>

	<<Particle specifiers: public test>>

	contains

	<<Particle specifiers: test driver>>

	end module particle_specifiers_ut
	@ %def particle_specifiers_ut
	@
	<<[[particle_specifiers_uti.f90]]>>=
	<<File header>>

	module particle_specifiers_uti

	<<Use strings>>

	use particle_specifiers

	<<Standard module head>>

	<<Particle specifiers: test declarations>>

	contains

	<<Particle specifiers: tests>>

	end module particle_specifiers_uti
	@ %def particle_specifiers_ut
	@ API: driver for the unit tests below.
	<<Particle specifiers: public test>>=
	public :: particle_specifiers_test
	<<Particle specifiers: test driver>>=
	subroutine particle_specifiers_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Particle specifiers: execute tests>>
	end subroutine particle_specifiers_test

	@ %def particle_specifiers_test
	@
	\subsubsection{Particle specifier array}
	Define, read and write an array of particle specifiers.
	<<Particle specifiers: execute tests>>=
	call test (particle_specifiers_1, "particle_specifiers_1", &
	"Handle particle specifiers", &
	u, results)
	<<Particle specifiers: test declarations>>=
	public :: particle_specifiers_1
	<<Particle specifiers: tests>>=
	subroutine particle_specifiers_1 (u)
	integer, intent(in) :: u
	type(prt_spec_t), dimension(:), allocatable :: prt_spec
	type(string_t), dimension(:), allocatable :: decay
	type(string_t), dimension(0) :: no_decay
	integer :: i, j

	write (u, "(A)") "* Test output: particle_specifiers_1"
	write (u, "(A)") "* Purpose: Read and write a particle specifier array"
	write (u, "(A)")

	allocate (prt_spec (5))
	prt_spec = [ &
	new_prt_spec (var_str ("a")), &
	new_prt_spec (var_str ("b"), .true.), &
	new_prt_spec (var_str ("c"), [var_str ("dec1")]), &
	new_prt_spec (var_str ("d"), [var_str ("dec1"), var_str ("dec2")]), &
	new_prt_spec (var_str ("e"), no_decay) &
	]
	do i = 1, size (prt_spec)
	write (u, "(A)") char (prt_spec(i)%to_string ())
	end do
	write (u, "(A)")

	call prt_spec_read (prt_spec, &
	var_str (" a, b( *), c( dec1), d (dec1 + dec2 ), e()"))
	call prt_spec_write (prt_spec, u)

	do i = 1, size (prt_spec)
	write (u, "(A)")
	write (u, "(A,A)") char (prt_spec(i)%get_name ()), ":"
	write (u, "(A,L1)") "polarized = ", prt_spec(i)%is_polarized ()
	write (u, "(A,L1)") "unstable = ", prt_spec(i)%is_unstable ()
	write (u, "(A,I0)") "n_decays = ", prt_spec(i)%get_n_decays ()
	call prt_spec(i)%get_decays (decay)
	write (u, "(A)", advance="no") "decays ="
	do j = 1, size (decay)
	write (u, "(1x,A)", advance="no") char (decay(j))
	end do
	write (u, "(A)")
	end do

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

	@ %def particle_specifiers_1
	@
	\subsubsection{Particle specifier expressions}
	Nested expressions (only basic particles, no decay specs).
	<<Particle specifiers: execute tests>>=
	call test (particle_specifiers_2, "particle_specifiers_2", &
	"Particle specifier expressions", &
	u, results)
	<<Particle specifiers: test declarations>>=
	public :: particle_specifiers_2
	<<Particle specifiers: tests>>=
	subroutine particle_specifiers_2 (u)
	integer, intent(in) :: u
	type(prt_spec_t) :: a, b, c, d, e, f
	type(prt_expr_t) :: pe1, pe2, pe3
	type(prt_expr_t) :: pe4, pe5, pe6, pe7, pe8, pe9
	integer :: i
	type(prt_spec_t), dimension(:), allocatable :: pa

	write (u, "(A)") "* Test output: particle_specifiers_2"
	write (u, "(A)") "* Purpose: Create and display particle expressions"
	write (u, "(A)")

	write (u, "(A)") "* Basic expressions"
	write (u, *)

	a = new_prt_spec (var_str ("a"))
	b = new_prt_spec (var_str ("b"))
	c = new_prt_spec (var_str ("c"))
	d = new_prt_spec (var_str ("d"))
	e = new_prt_spec (var_str ("e"))
	f = new_prt_spec (var_str ("f"))

	call pe1%init_spec (a)
	write (u, "(A)") char (pe1%to_string ())

	call pe2%init_sum (2)
	select type (x => pe2%x)
	type is (prt_spec_sum_t)
	call x%expr(1)%init_spec (a)
	call x%expr(2)%init_spec (b)
	end select
	write (u, "(A)") char (pe2%to_string ())

	call pe3%init_list (2)
	select type (x => pe3%x)
	type is (prt_spec_list_t)
	call x%expr(1)%init_spec (a)
	call x%expr(2)%init_spec (b)
	end select
	write (u, "(A)") char (pe3%to_string ())

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

	call pe4%init_list (2)
	select type (x => pe4%x)
	type is (prt_spec_list_t)
	call x%expr(1)%init_sum (2)
	select type (y => x%expr(1)%x)
	type is (prt_spec_sum_t)
	call y%expr(1)%init_spec (a)
	call y%expr(2)%init_spec (b)
	end select
	call x%expr(2)%init_spec (c)
	end select
	write (u, "(A)") char (pe4%to_string ())

	call pe5%init_list (2)
	select type (x => pe5%x)
	type is (prt_spec_list_t)
	call x%expr(1)%init_list (2)
	select type (y => x%expr(1)%x)
	type is (prt_spec_list_t)
	call y%expr(1)%init_spec (a)
	call y%expr(2)%init_spec (b)
	end select
	call x%expr(2)%init_spec (c)
	end select
	write (u, "(A)") char (pe5%to_string ())

	call pe6%init_sum (2)
	select type (x => pe6%x)
	type is (prt_spec_sum_t)
	call x%expr(1)%init_spec (a)
	call x%expr(2)%init_sum (2)
	select type (y => x%expr(2)%x)
	type is (prt_spec_sum_t)
	call y%expr(1)%init_spec (b)
	call y%expr(2)%init_spec (c)
	end select
	end select
	write (u, "(A)") char (pe6%to_string ())

	call pe7%init_list (2)
	select type (x => pe7%x)
	type is (prt_spec_list_t)
	call x%expr(1)%init_sum (2)
	select type (y => x%expr(1)%x)
	type is (prt_spec_sum_t)
	call y%expr(1)%init_spec (a)
	call y%expr(2)%init_list (2)
	select type (z => y%expr(2)%x)
	type is (prt_spec_list_t)
	call z%expr(1)%init_spec (b)
	call z%expr(2)%init_spec (c)
	end select
	end select
	call x%expr(2)%init_spec (d)
	end select
	write (u, "(A)") char (pe7%to_string ())

	call pe8%init_sum (2)
	select type (x => pe8%x)
	type is (prt_spec_sum_t)
	call x%expr(1)%init_list (2)
	select type (y => x%expr(1)%x)
	type is (prt_spec_list_t)
	call y%expr(1)%init_spec (a)
	call y%expr(2)%init_spec (b)
	end select
	call x%expr(2)%init_list (2)
	select type (y => x%expr(2)%x)
	type is (prt_spec_list_t)
	call y%expr(1)%init_spec (c)
	call y%expr(2)%init_spec (d)
	end select
	end select
	write (u, "(A)") char (pe8%to_string ())

	call pe9%init_list (3)
	select type (x => pe9%x)
	type is (prt_spec_list_t)
	call x%expr(1)%init_sum (2)
	select type (y => x%expr(1)%x)
	type is (prt_spec_sum_t)
	call y%expr(1)%init_spec (a)
	call y%expr(2)%init_spec (b)
	end select
	call x%expr(2)%init_spec (c)
	call x%expr(3)%init_sum (3)
	select type (y => x%expr(3)%x)
	type is (prt_spec_sum_t)
	call y%expr(1)%init_spec (d)
	call y%expr(2)%init_spec (e)
	call y%expr(3)%init_spec (f)
	end select
	end select
	write (u, "(A)") char (pe9%to_string ())

	write (u, *)
	write (u, "(A)") "* Expand as sum"
	write (u, *)

	call pe1%expand ()
	write (u, "(A)") char (pe1%to_string ())

	call pe4%expand ()
	write (u, "(A)") char (pe4%to_string ())

	call pe5%expand ()
	write (u, "(A)") char (pe5%to_string ())

	call pe6%expand ()
	write (u, "(A)") char (pe6%to_string ())

	call pe7%expand ()
	write (u, "(A)") char (pe7%to_string ())

	call pe8%expand ()
	write (u, "(A)") char (pe8%to_string ())

	call pe9%expand ()
	write (u, "(A)") char (pe9%to_string ())

	write (u, *)
	write (u, "(A)") "* Transform to arrays:"

	write (u, "(A)") "* Atomic specifier"
	do i = 1, pe1%get_n_terms ()
	call pe1%term_to_array (pa, i)
	call prt_spec_write (pa, u)
	end do

	write (u, *)
	write (u, "(A)") "* List"
	do i = 1, pe5%get_n_terms ()
	call pe5%term_to_array (pa, i)
	call prt_spec_write (pa, u)
	end do

	write (u, *)
	write (u, "(A)") "* Sum of atoms"
	do i = 1, pe6%get_n_terms ()
	call pe6%term_to_array (pa, i)
	call prt_spec_write (pa, u)
	end do

	write (u, *)
	write (u, "(A)") "* Sum of lists"
	do i = 1, pe9%get_n_terms ()
	call pe9%term_to_array (pa, i)
	call prt_spec_write (pa, u)
	end do

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

	@ %def particle_specifiers_2
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{PDG arrays}

	For defining aliases, we introduce a special type which holds a set of
	(integer) PDG codes.
	<<[[pdg_arrays.f90]]>>=
	<<File header>>

	module pdg_arrays

	- use io_units
	- use sorting
	- use physics_defs
	-
	<<Standard module head>>

	<<PDG arrays: public>>

	<<PDG arrays: types>>

	<<PDG arrays: interfaces>>

	+ interface
	+<<PDG arrays: sub interfaces>>
	+ end interface
	+
	+end module pdg_arrays
	+@ %def pdg_arrays
	+@
	+<<[[pdg_arrays_sub.f90]]>>=
	+<<File header>>
	+
	+submodule (pdg_arrays) pdg_arrays_s
	+
	+ use io_units
	+ use sorting
	+ use physics_defs
	+
	+ implicit none
	+
	contains

	<<PDG arrays: procedures>>

	-end module pdg_arrays
	-@ %def pdg_arrays
	+end submodule pdg_arrays_s
	+
	+@ %def pdg_arrays_s
	@
	\subsection{Type definition}
	Using an allocatable array eliminates the need for initializer and/or
	finalizer.
	<<PDG arrays: public>>=
	public :: pdg_array_t
	<<PDG arrays: types>>=
	type :: pdg_array_t
	private
	integer, dimension(:), allocatable :: pdg
	contains
	<<PDG arrays: pdg array: TBP>>
	end type pdg_array_t

	@ %def pdg_array_t
	-@ Output
	-<<PDG arrays: public>>=
	- public :: pdg_array_write
	+@ Output.
	<<PDG arrays: pdg array: TBP>>=
	procedure :: write => pdg_array_write
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_write (aval, unit)
	+ class(pdg_array_t), intent(in) :: aval
	+ integer, intent(in), optional :: unit
	+ end subroutine pdg_array_write
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_write (aval, unit)
	+ module subroutine pdg_array_write (aval, unit)
	class(pdg_array_t), intent(in) :: aval
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)", advance="no") "PDG("
	if (allocated (aval%pdg)) then
	do i = 1, size (aval%pdg)
	if (i > 1) write (u, "(A)", advance="no") ", "
	write (u, "(I0)", advance="no") aval%pdg(i)
	end do
	end if
	write (u, "(A)", advance="no") ")"
	end subroutine pdg_array_write

	@ %def pdg_array_write
	@
	<<PDG arrays: public>>=
	public :: pdg_array_write_set
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_write_set (aval, unit)
	+ type(pdg_array_t), intent(in), dimension(:) :: aval
	+ integer, intent(in), optional :: unit
	+ end subroutine pdg_array_write_set
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_write_set (aval, unit)
	+ module subroutine pdg_array_write_set (aval, unit)
	type(pdg_array_t), intent(in), dimension(:) :: aval
	integer, intent(in), optional :: unit
	integer :: i
	do i = 1, size (aval)
	call aval(i)%write (unit)
	print *, ''
	end do
	end subroutine pdg_array_write_set

	@ %def pdg_array_write_set
	@
	\subsection{Basic operations}
	Assignment. We define assignment from and to an integer array.
	Note that the integer array, if it is the l.h.s., must be declared
	allocatable by the caller.
	<<PDG arrays: public>>=
	public :: assignment(=)
	<<PDG arrays: interfaces>>=
	interface assignment(=)
	module procedure pdg_array_from_int_array
	module procedure pdg_array_from_int
	module procedure int_array_from_pdg_array
	end interface

	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_from_int_array (aval, iarray)
	+ type(pdg_array_t), intent(out) :: aval
	+ integer, dimension(:), intent(in) :: iarray
	+ end subroutine pdg_array_from_int_array
	+ elemental module subroutine pdg_array_from_int (aval, int)
	+ type(pdg_array_t), intent(out) :: aval
	+ integer, intent(in) :: int
	+ end subroutine pdg_array_from_int
	+ module subroutine int_array_from_pdg_array (iarray, aval)
	+ integer, dimension(:), allocatable, intent(out) :: iarray
	+ type(pdg_array_t), intent(in) :: aval
	+ end subroutine int_array_from_pdg_array
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_from_int_array (aval, iarray)
	+ module subroutine pdg_array_from_int_array (aval, iarray)
	type(pdg_array_t), intent(out) :: aval
	integer, dimension(:), intent(in) :: iarray
	allocate (aval%pdg (size (iarray)))
	aval%pdg = iarray
	end subroutine pdg_array_from_int_array

	- elemental subroutine pdg_array_from_int (aval, int)
	+ elemental module subroutine pdg_array_from_int (aval, int)
	type(pdg_array_t), intent(out) :: aval
	integer, intent(in) :: int
	allocate (aval%pdg (1))
	aval%pdg = int
	end subroutine pdg_array_from_int

	- subroutine int_array_from_pdg_array (iarray, aval)
	+ module subroutine int_array_from_pdg_array (iarray, aval)
	integer, dimension(:), allocatable, intent(out) :: iarray
	type(pdg_array_t), intent(in) :: aval
	if (allocated (aval%pdg)) then
	allocate (iarray (size (aval%pdg)))
	iarray = aval%pdg
	else
	allocate (iarray (0))
	end if
	end subroutine int_array_from_pdg_array
	-
	+
	@ %def pdg_array_from_int_array pdg_array_from_int int_array_from_pdg_array
	@ Allocate space for a PDG array
	-<<PDG arrays: public>>=
	- public :: pdg_array_init
	+<<PDG arrays: pdg array: TBP>>=
	+ procedure :: init => pdg_array_init
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_init (aval, n_elements)
	+ class(pdg_array_t), intent(inout) :: aval
	+ integer, intent(in) :: n_elements
	+ end subroutine pdg_array_init
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_init (aval, n_elements)
	- type(pdg_array_t), intent(inout) :: aval
	+ module subroutine pdg_array_init (aval, n_elements)
	+ class(pdg_array_t), intent(inout) :: aval
	integer, intent(in) :: n_elements
	allocate(aval%pdg(n_elements))
	end subroutine pdg_array_init

	@ %def pdg_array_init
	@ Deallocate a previously allocated pdg array
	-<<PDG arrays: public>>=
	- public :: pdg_array_delete
	+<<PDG arrays: pdg array: TBP>>=
	+ procedure :: delete => pdg_array_delete
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_delete (aval)
	+ class(pdg_array_t), intent(inout) :: aval
	+ end subroutine pdg_array_delete
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_delete (aval)
	- type(pdg_array_t), intent(inout) :: aval
	+ module subroutine pdg_array_delete (aval)
	+ class(pdg_array_t), intent(inout) :: aval
	if (allocated (aval%pdg)) deallocate (aval%pdg)
	end subroutine pdg_array_delete

	@ %def pdg_array_delete
	@ Merge two pdg arrays, i.e. append a particle string to another leaving out doublettes
	-<<PDG arrays: public>>=
	- public :: pdg_array_merge
	+<<PDG arrays: pdg array: TBP>>=
	+ procedure :: merge => pdg_array_merge
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_merge (aval1, aval2)
	+ class(pdg_array_t), intent(inout) :: aval1
	+ type(pdg_array_t), intent(in) :: aval2
	+ end subroutine pdg_array_merge
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_merge (aval1, aval2)
	- type(pdg_array_t), intent(inout) :: aval1
	+ module subroutine pdg_array_merge (aval1, aval2)
	+ class(pdg_array_t), intent(inout) :: aval1
	type(pdg_array_t), intent(in) :: aval2
	type(pdg_array_t) :: aval
	if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
	if (.not. any (aval1%pdg == aval2%pdg)) aval = aval1 // aval2
	else if (allocated (aval1%pdg)) then
	aval = aval1
	else if (allocated (aval2%pdg)) then
	aval = aval2
	end if
	call pdg_array_delete (aval1)
	- aval1 = aval%pdg
	+ call pdg_array_from_int_array (aval1, aval%pdg)
	end subroutine pdg_array_merge

	@ %def pdg_array_merge
	@ Length of the array.
	-<<PDG arrays: public>>=
	- public :: pdg_array_get_length
	<<PDG arrays: pdg array: TBP>>=
	procedure :: get_length => pdg_array_get_length
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_get_length (aval) result (n)
	+ class(pdg_array_t), intent(in) :: aval
	+ integer :: n
	+ end function pdg_array_get_length
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_get_length (aval) result (n)
	+ elemental module function pdg_array_get_length (aval) result (n)
	class(pdg_array_t), intent(in) :: aval
	integer :: n
	if (allocated (aval%pdg)) then
	n = size (aval%pdg)
	else
	n = 0
	end if
	end function pdg_array_get_length

	@ %def pdg_array_get_length
	@ Return the element with index i.
	-<<PDG arrays: public>>=
	- public :: pdg_array_get
	<<PDG arrays: pdg array: TBP>>=
	procedure :: get => pdg_array_get
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_get (aval, i) result (pdg)
	+ class(pdg_array_t), intent(in) :: aval
	+ integer, intent(in), optional :: i
	+ integer :: pdg
	+ end function pdg_array_get
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_get (aval, i) result (pdg)
	+ elemental module function pdg_array_get (aval, i) result (pdg)
	class(pdg_array_t), intent(in) :: aval
	integer, intent(in), optional :: i
	integer :: pdg
	if (present (i)) then
	pdg = aval%pdg(i)
	else
	pdg = aval%pdg(1)
	end if
	end function pdg_array_get

	@ %def pdg_array_get
	@ Explicitly set the element with index i.
	<<PDG arrays: pdg array: TBP>>=
	procedure :: set => pdg_array_set
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_array_set (aval, i, pdg)
	+ class(pdg_array_t), intent(inout) :: aval
	+ integer, intent(in) :: i
	+ integer, intent(in) :: pdg
	+ end subroutine pdg_array_set
	<<PDG arrays: procedures>>=
	- subroutine pdg_array_set (aval, i, pdg)
	+ module subroutine pdg_array_set (aval, i, pdg)
	class(pdg_array_t), intent(inout) :: aval
	integer, intent(in) :: i
	integer, intent(in) :: pdg
	aval%pdg(i) = pdg
	end subroutine pdg_array_set

	@ %def pdg_array_set
	@
	<<PDG arrays: pdg array: TBP>>=
	procedure :: add => pdg_array_add
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_add (aval, aval_add) result (aval_out)
	+ type(pdg_array_t) :: aval_out
	+ class(pdg_array_t), intent(in) :: aval
	+ type(pdg_array_t), intent(in) :: aval_add
	+ end function pdg_array_add
	<<PDG arrays: procedures>>=
	- function pdg_array_add (aval, aval_add) result (aval_out)
	+ module function pdg_array_add (aval, aval_add) result (aval_out)
	type(pdg_array_t) :: aval_out
	class(pdg_array_t), intent(in) :: aval
	type(pdg_array_t), intent(in) :: aval_add
	integer :: n, n_add, i
	n = size (aval%pdg)
	n_add = size (aval_add%pdg)
	allocate (aval_out%pdg (n + n_add))
	aval_out%pdg(1:n) = aval%pdg
	do i = 1, n_add
	aval_out%pdg(n+i) = aval_add%pdg(i)
	end do
	end function pdg_array_add

	@ %def pdg_array_add
	@ Replace element with index [[i]] by a new array of elements.
	-<<PDG arrays: public>>=
	- public :: pdg_array_replace
	<<PDG arrays: pdg array: TBP>>=
	procedure :: replace => pdg_array_replace
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_replace (aval, i, pdg_new) result (aval_new)
	+ class(pdg_array_t), intent(in) :: aval
	+ integer, intent(in) :: i
	+ integer, dimension(:), intent(in) :: pdg_new
	+ type(pdg_array_t) :: aval_new
	+ end function pdg_array_replace
	<<PDG arrays: procedures>>=
	- function pdg_array_replace (aval, i, pdg_new) result (aval_new)
	+ module function pdg_array_replace (aval, i, pdg_new) result (aval_new)
	class(pdg_array_t), intent(in) :: aval
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: pdg_new
	type(pdg_array_t) :: aval_new
	integer :: n, l
	n = size (aval%pdg)
	l = size (pdg_new)
	allocate (aval_new%pdg (n + l - 1))
	aval_new%pdg(:i-1) = aval%pdg(:i-1)
	aval_new%pdg(i:i+l-1) = pdg_new
	aval_new%pdg(i+l:) = aval%pdg(i+1:)
	end function pdg_array_replace

	@ %def pdg_array_replace
	@ Concatenate two PDG arrays
	<<PDG arrays: public>>=
	public :: operator(//)
	<<PDG arrays: interfaces>>=
	interface operator(//)
	module procedure concat_pdg_arrays
	end interface

	+<<PDG arrays: sub interfaces>>=
	+ module function concat_pdg_arrays (aval1, aval2) result (aval)
	+ type(pdg_array_t) :: aval
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ end function concat_pdg_arrays
	<<PDG arrays: procedures>>=
	- function concat_pdg_arrays (aval1, aval2) result (aval)
	+ module function concat_pdg_arrays (aval1, aval2) result (aval)
	type(pdg_array_t) :: aval
	type(pdg_array_t), intent(in) :: aval1, aval2
	integer :: n1, n2
	if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
	n1 = size (aval1%pdg)
	n2 = size (aval2%pdg)
	allocate (aval%pdg (n1 + n2))
	aval%pdg(:n1) = aval1%pdg
	aval%pdg(n1+1:) = aval2%pdg
	else if (allocated (aval1%pdg)) then
	aval = aval1
	else if (allocated (aval2%pdg)) then
	aval = aval2
	end if
	end function concat_pdg_arrays

	@ %def concat_pdg_arrays
	@
	\subsection{Matching}
	A PDG array matches a given PDG code if the code is present within the
	array. If either one is zero (UNDEFINED), the match also succeeds.
	<<PDG arrays: public>>=
	public :: operator(.match.)
	<<PDG arrays: interfaces>>=
	interface operator(.match.)
	module procedure pdg_array_match_integer
	module procedure pdg_array_match_pdg_array
	end interface

	@ %def .match.
	@ Match a single code against the array.
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_match_integer (aval, pdg) result (flag)
	+ logical :: flag
	+ type(pdg_array_t), intent(in) :: aval
	+ integer, intent(in) :: pdg
	+ end function pdg_array_match_integer
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_match_integer (aval, pdg) result (flag)
	+ elemental module function pdg_array_match_integer (aval, pdg) result (flag)
	logical :: flag
	type(pdg_array_t), intent(in) :: aval
	integer, intent(in) :: pdg
	if (allocated (aval%pdg)) then
	flag = pdg == UNDEFINED &
	.or. any (aval%pdg == UNDEFINED) &
	.or. any (aval%pdg == pdg)
	else
	flag = .false.
	end if
	end function pdg_array_match_integer

	@ %def pdg_array_match_integer
	@ Check if the pdg-number corresponds to a quark
	<<PDG arrays: public>>=
	public :: is_quark
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_quark (pdg_nr)
	+ logical :: is_quark
	+ integer, intent(in) :: pdg_nr
	+ end function is_quark
	<<PDG arrays: procedures>>=
	- elemental function is_quark (pdg_nr)
	+ elemental module function is_quark (pdg_nr)
	logical :: is_quark
	integer, intent(in) :: pdg_nr
	if (abs (pdg_nr) >= 1 .and. abs (pdg_nr) <= 6) then
	is_quark = .true.
	else
	is_quark = .false.
	end if
	end function is_quark

	@ %def is_quark
	@ Check if pdg-number corresponds to a gluon
	<<PDG arrays: public>>=
	public :: is_gluon
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_gluon (pdg_nr)
	+ logical :: is_gluon
	+ integer, intent(in) :: pdg_nr
	+ end function is_gluon
	<<PDG arrays: procedures>>=
	- elemental function is_gluon (pdg_nr)
	+ elemental module function is_gluon (pdg_nr)
	logical :: is_gluon
	integer, intent(in) :: pdg_nr
	if (pdg_nr == GLUON) then
	is_gluon = .true.
	else
	is_gluon = .false.
	end if
	end function is_gluon

	@ %def is_gluon
	@ Check if pdg-number corresponds to a photon
	<<PDG arrays: public>>=
	public :: is_photon
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_photon (pdg_nr)
	+ logical :: is_photon
	+ integer, intent(in) :: pdg_nr
	+ end function is_photon
	<<PDG arrays: procedures>>=
	- elemental function is_photon (pdg_nr)
	+ elemental module function is_photon (pdg_nr)
	logical :: is_photon
	integer, intent(in) :: pdg_nr
	if (pdg_nr == PHOTON) then
	is_photon = .true.
	else
	is_photon = .false.
	end if
	end function is_photon

	@ %def is_photon
	@ Check if pdg-number corresponds to a colored particle
	<<PDG arrays: public>>=
	public :: is_colored
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_colored (pdg_nr)
	+ logical :: is_colored
	+ integer, intent(in) :: pdg_nr
	+ end function is_colored
	<<PDG arrays: procedures>>=
	- elemental function is_colored (pdg_nr)
	+ elemental module function is_colored (pdg_nr)
	logical :: is_colored
	integer, intent(in) :: pdg_nr
	is_colored = is_quark (pdg_nr) .or. is_gluon (pdg_nr)
	end function is_colored

	@ %def is_colored
	@ Check if the pdg-number corresponds to a lepton
	<<PDG arrays: public>>=
	public :: is_lepton
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_lepton (pdg_nr)
	+ logical :: is_lepton
	+ integer, intent(in) :: pdg_nr
	+ end function is_lepton
	<<PDG arrays: procedures>>=
	- elemental function is_lepton (pdg_nr)
	+ elemental module function is_lepton (pdg_nr)
	logical :: is_lepton
	integer, intent(in) :: pdg_nr
	if (abs (pdg_nr) >= ELECTRON .and. &
	abs (pdg_nr) <= TAU_NEUTRINO) then
	is_lepton = .true.
	else
	is_lepton = .false.
	end if
	end function is_lepton

	@ %def is_lepton
	@
	<<PDG arrays: public>>=
	public :: is_fermion
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_fermion (pdg_nr)
	+ logical :: is_fermion
	+ integer, intent(in) :: pdg_nr
	+ end function is_fermion
	<<PDG arrays: procedures>>=
	- elemental function is_fermion (pdg_nr)
	+ elemental module function is_fermion (pdg_nr)
	logical :: is_fermion
	integer, intent(in) :: pdg_nr
	is_fermion = is_lepton(pdg_nr) .or. is_quark(pdg_nr)
	end function is_fermion

	@ %def is_fermion
	@ Check if the pdg-number corresponds to a massless vector boson
	<<PDG arrays: public>>=
	public :: is_massless_vector
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_massless_vector (pdg_nr)
	+ integer, intent(in) :: pdg_nr
	+ logical :: is_massless_vector
	+ end function is_massless_vector
	<<PDG arrays: procedures>>=
	- elemental function is_massless_vector (pdg_nr)
	+ elemental module function is_massless_vector (pdg_nr)
	integer, intent(in) :: pdg_nr
	logical :: is_massless_vector
	if (pdg_nr == GLUON .or. pdg_nr == PHOTON) then
	is_massless_vector = .true.
	else
	is_massless_vector = .false.
	end if
	end function is_massless_vector

	@ %def is_massless_vector
	@ Check if pdg-number corresponds to a massive vector boson
	<<PDG arrays: public>>=
	public :: is_massive_vector
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_massive_vector (pdg_nr)
	+ integer, intent(in) :: pdg_nr
	+ logical :: is_massive_vector
	+ end function is_massive_vector
	<<PDG arrays: procedures>>=
	- elemental function is_massive_vector (pdg_nr)
	+ elemental module function is_massive_vector (pdg_nr)
	integer, intent(in) :: pdg_nr
	logical :: is_massive_vector
	if (abs (pdg_nr) == Z_BOSON .or. abs (pdg_nr) == W_BOSON) then
	is_massive_vector = .true.
	else
	is_massive_vector = .false.
	end if
	end function is_massive_vector

	@ %def is massive_vector
	@ Check if pdg-number corresponds to a vector boson
	<<PDG arrays: public>>=
	public :: is_vector
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_vector (pdg_nr)
	+ integer, intent(in) :: pdg_nr
	+ logical :: is_vector
	+ end function is_vector
	<<PDG arrays: procedures>>=
	- elemental function is_vector (pdg_nr)
	+ elemental module function is_vector (pdg_nr)
	integer, intent(in) :: pdg_nr
	logical :: is_vector
	if (is_massless_vector (pdg_nr) .or. is_massive_vector (pdg_nr)) then
	is_vector = .true.
	else
	is_vector = .false.
	end if
	end function is_vector

	@ %def is vector
	@ Check if particle is elementary.
	<<PDG arrays: public>>=
	public :: is_elementary
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_elementary (pdg_nr)
	+ integer, intent(in) :: pdg_nr
	+ logical :: is_elementary
	+ end function is_elementary
	<<PDG arrays: procedures>>=
	- elemental function is_elementary (pdg_nr)
	+ elemental module function is_elementary (pdg_nr)
	integer, intent(in) :: pdg_nr
	logical :: is_elementary
	if (is_vector (pdg_nr) .or. is_fermion (pdg_nr) .or. pdg_nr == 25) then
	is_elementary = .true.
	else
	is_elementary = .false.
	end if
	end function is_elementary

	@ %def is_elementary
	@ Check if particle is an EW boson or scalar.
	<<PDG arrays: public>>=
	public :: is_ew_boson_scalar
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function is_ew_boson_scalar (pdg_nr)
	+ integer, intent(in) :: pdg_nr
	+ logical :: is_ew_boson_scalar
	+ end function is_ew_boson_scalar
	<<PDG arrays: procedures>>=
	- elemental function is_ew_boson_scalar (pdg_nr)
	+ elemental module function is_ew_boson_scalar (pdg_nr)
	integer, intent(in) :: pdg_nr
	logical :: is_ew_boson_scalar
	if (is_photon (pdg_nr) .or. is_massive_vector (pdg_nr) .or. pdg_nr == 25) then
	is_ew_boson_scalar = .true.
	else
	is_ew_boson_scalar = .false.
	end if
	end function is_ew_boson_scalar

	@ %def is_ew_boson_scalar
	@ Check if particle is strongly interacting
	<<PDG arrays: pdg array: TBP>>=
	procedure :: has_colored_particles => pdg_array_has_colored_particles
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_has_colored_particles (pdg) result (colored)
	+ class(pdg_array_t), intent(in) :: pdg
	+ logical :: colored
	+ end function pdg_array_has_colored_particles
	<<PDG arrays: procedures>>=
	- function pdg_array_has_colored_particles (pdg) result (colored)
	+ module function pdg_array_has_colored_particles (pdg) result (colored)
	class(pdg_array_t), intent(in) :: pdg
	logical :: colored
	integer :: i, pdg_nr
	colored = .false.
	do i = 1, size (pdg%pdg)
	pdg_nr = pdg%pdg(i)
	if (is_quark (pdg_nr) .or. is_gluon (pdg_nr)) then
	colored = .true.
	exit
	end if
	end do
	end function pdg_array_has_colored_particles

	@ %def pdg_array_has_colored_particles
	This function is a convenience function for the determination of
	possible compatibility of flavor structures of processes with certain
	orders of QCD and QED/EW coupling constants. It assumes the Standard
	Model (SM) as underlying physics model.
	The function is based on a naive counting of external particles which
	are connected to the process by the specific kind of couplings depending
	on the underlying theory (QCD and/or QED/EW) of which the corresponding
	particle is a part of. It is constructed in a way that the exclusion of
	coupling power combinations is well-defined.
	<<PDG arrays: public>>=
	public :: query_coupling_powers
	-<<PDG arrays: procedures>>=
	- function query_coupling_powers (flv, a_power, as_power) result (valid)
	+<<PDG arrays: sub interfaces>>=
	+ module function query_coupling_powers (flv, a_power, as_power) result (valid)
	integer, intent(in), dimension(:) :: flv
	- integer, dimension(:, :), allocatable :: power_pair_array
	- integer, dimension(2) :: power_pair_ref
	integer, intent(in) :: a_power, as_power
	- integer :: i, n_legs, n_gluons, n_quarks, n_gamWZH, n_leptons
	- logical, dimension(:), allocatable :: pairs_included
	logical :: valid
	- integer :: n_bound
	- power_pair_ref = [a_power, as_power]
	- n_legs = size (flv)
	- allocate (power_pair_array (2, n_legs - 1))
	- do i = 1, n_legs - 1
	- power_pair_array (1, i) = n_legs - 1 - i
	- power_pair_array (2, i) = i - 1
	- end do
	- allocate (pairs_included (n_legs - 1))
	- pairs_included = .true.
	- n_gluons = count (is_gluon (flv))
	- n_gamWZH = count (is_ew_boson_scalar (flv))
	- n_quarks = count (is_quark (flv))
	- n_leptons = count (is_lepton (flv))
	- if (n_gluons >= 1 .and. n_gluons <= 3) then
	- do i = 1, n_gluons
	- pairs_included (i) = .false.
	- end do
	- else if (n_gluons > 2 .and. n_quarks <= 2 .and. n_gluons + n_quarks == n_legs) then
	- do i = 1, n_legs - 2
	- pairs_included (i) = .false.
	- end do
	- end if
	- n_bound = 0
	- if (n_gamWZH + n_leptons == n_legs) then
	- n_bound = n_gamWZH + n_leptons - 2
	- else if (n_quarks == 2 .and. n_leptons + n_quarks + n_gamWZH == n_legs) then
	- n_bound = n_legs - 2
	- else if (n_gamWZH + n_leptons > 0) then
	- n_bound = int (n_leptons/2.) + n_gamWZH
	- end if
	- if (n_bound > 0) then
	- do i = 1, n_bound
	- pairs_included (n_legs - i) = .false.
	- end do
	- end if
	- if (n_quarks == 4 .and. .not. qcd_ew_interferences (flv)) then
	- do i = 1, 2
	- pairs_included (n_legs - i) = .false.
	- end do
	- end if
	- valid = .false.
	- do i = 1, n_legs - 1
	- if (all (power_pair_array (:, i) == power_pair_ref) .and. pairs_included (i)) then
	- valid = .true.
	- exit
	- end if
	- end do
	end function query_coupling_powers
	+<<PDG arrays: procedures>>=
	+ module function query_coupling_powers (flv, a_power, as_power) result (valid)
	+ integer, intent(in), dimension(:) :: flv
	+ integer, dimension(:, :), allocatable :: power_pair_array
	+ integer, dimension(2) :: power_pair_ref
	+ integer, intent(in) :: a_power, as_power
	+ integer :: i, n_legs, n_gluons, n_quarks, n_gamWZH, n_leptons
	+ logical, dimension(:), allocatable :: pairs_included
	+ logical :: valid
	+ integer :: n_bound
	+ power_pair_ref = [a_power, as_power]
	+ n_legs = size (flv)
	+ allocate (power_pair_array (2, n_legs - 1))
	+ do i = 1, n_legs - 1
	+ power_pair_array (1, i) = n_legs - 1 - i
	+ power_pair_array (2, i) = i - 1
	+ end do
	+ allocate (pairs_included (n_legs - 1))
	+ pairs_included = .true.
	+ n_gluons = count (is_gluon (flv))
	+ n_gamWZH = count (is_ew_boson_scalar (flv))
	+ n_quarks = count (is_quark (flv))
	+ n_leptons = count (is_lepton (flv))
	+ if (n_gluons >= 1 .and. n_gluons <= 3) then
	+ do i = 1, n_gluons
	+ pairs_included (i) = .false.
	+ end do
	+ else if (n_gluons > 2 .and. n_quarks <= 2 .and. n_gluons + n_quarks == n_legs) then
	+ do i = 1, n_legs - 2
	+ pairs_included (i) = .false.
	+ end do
	+ end if
	+ n_bound = 0
	+ if (n_gamWZH + n_leptons == n_legs) then
	+ n_bound = n_gamWZH + n_leptons - 2
	+ else if (n_quarks == 2 .and. n_leptons + n_quarks + n_gamWZH == n_legs) then
	+ n_bound = n_legs - 2
	+ else if (n_gamWZH + n_leptons > 0) then
	+ n_bound = n_leptons/2 + n_gamWZH
	+ end if
	+ if (n_bound > 0) then
	+ do i = 1, n_bound
	+ pairs_included (n_legs - i) = .false.
	+ end do
	+ end if
	+ if (n_quarks == 4 .and. .not. qcd_ew_interferences (flv)) then
	+ do i = 1, 2
	+ pairs_included (n_legs - i) = .false.
	+ end do
	+ end if
	+ valid = .false.
	+ do i = 1, n_legs - 1
	+ if (all (power_pair_array (:, i) == power_pair_ref) .and. pairs_included (i)) then
	+ valid = .true.
	+ exit
	+ end if
	+ end do
	+ end function query_coupling_powers

	@ %def query_coupling_powers
	This functions checks if there is a flavor structure which possibly can
	induce QCD-EW interference amplitudes. It evaluates to [[true]] if there are
	at least 2 quark pairs whereby the quarks of at least one quark pair must
	have the same flavor.
	<<PDG arrays: public>>=
	public :: qcd_ew_interferences
	-<<PDG arrays: procedures>>=
	- function qcd_ew_interferences (flv) result (valid)
	+<<PDG arrays: sub interfaces>>=
	+ module function qcd_ew_interferences (flv) result (valid)
	integer, intent(in), dimension(:) :: flv
	- integer :: i, n_pairs
	- logical :: valid, qqbar_pair
	- n_pairs = 0
	- valid = .false.
	- qqbar_pair = .false.
	- if (count (is_quark (flv)) >= 4) then
	- do i = DOWN_Q, TOP_Q
	- qqbar_pair = count (abs (flv) == i) >= 2
	- if (qqbar_pair) n_pairs = n_pairs + 1
	- if (n_pairs > 0) then
	- valid = .true.
	- exit
	- end if
	- end do
	- end if
	+ logical :: valid
	end function qcd_ew_interferences
	+<<PDG arrays: procedures>>=
	+ module function qcd_ew_interferences (flv) result (valid)
	+ integer, intent(in), dimension(:) :: flv
	+ integer :: i, n_pairs
	+ logical :: valid, qqbar_pair
	+ n_pairs = 0
	+ valid = .false.
	+ qqbar_pair = .false.
	+ if (count (is_quark (flv)) >= 4) then
	+ do i = DOWN_Q, TOP_Q
	+ qqbar_pair = count (abs (flv) == i) >= 2
	+ if (qqbar_pair) n_pairs = n_pairs + 1
	+ if (n_pairs > 0) then
	+ valid = .true.
	+ exit
	+ end if
	+ end do
	+ end if
	+ end function qcd_ew_interferences

	@ %def qcd_ew_interferences
	@ Match two arrays. Succeeds if any pair of entries matches.
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_match_pdg_array (aval1, aval2) result (flag)
	+ logical :: flag
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ end function pdg_array_match_pdg_array
	<<PDG arrays: procedures>>=
	- function pdg_array_match_pdg_array (aval1, aval2) result (flag)
	+ module function pdg_array_match_pdg_array (aval1, aval2) result (flag)
	logical :: flag
	type(pdg_array_t), intent(in) :: aval1, aval2
	if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
	flag = any (aval1 .match. aval2%pdg)
	else
	flag = .false.
	end if
	end function pdg_array_match_pdg_array

	@ %def pdg_array_match_pdg_array
	@ Comparison. Here, we take the PDG arrays as-is, assuming that they
	are sorted.

	The ordering is a bit odd: first, we look only at the absolute values
	of the PDG codes. If they all match, the particle comes before the
	antiparticle, scanning from left to right.
	<<PDG arrays: public>>=
	public :: operator(<)
	public :: operator(>)
	public :: operator(<=)
	public :: operator(>=)
	public :: operator(==)
	public :: operator(/=)
	<<PDG arrays: interfaces>>=
	interface operator(<)
	module procedure pdg_array_lt
	end interface
	interface operator(>)
	module procedure pdg_array_gt
	end interface
	interface operator(<=)
	module procedure pdg_array_le
	end interface
	interface operator(>=)
	module procedure pdg_array_ge
	end interface
	interface operator(==)
	module procedure pdg_array_eq
	end interface
	interface operator(/=)
	module procedure pdg_array_ne
	end interface

	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_lt (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_lt
	+ elemental module function pdg_array_gt (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_gt
	+ elemental module function pdg_array_le (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_le
	+ elemental module function pdg_array_ge (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_ge
	+ elemental module function pdg_array_eq (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_eq
	+ elemental module function pdg_array_ne (aval1, aval2) result (flag)
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ logical :: flag
	+ end function pdg_array_ne
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_lt (aval1, aval2) result (flag)
	+ elemental module function pdg_array_lt (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	integer :: i
	if (size (aval1%pdg) /= size (aval2%pdg)) then
	flag = size (aval1%pdg) < size (aval2%pdg)
	else
	do i = 1, size (aval1%pdg)
	if (abs (aval1%pdg(i)) /= abs (aval2%pdg(i))) then
	flag = abs (aval1%pdg(i)) < abs (aval2%pdg(i))
	return
	end if
	end do
	do i = 1, size (aval1%pdg)
	if (aval1%pdg(i) /= aval2%pdg(i)) then
	flag = aval1%pdg(i) > aval2%pdg(i)
	return
	end if
	end do
	flag = .false.
	end if
	end function pdg_array_lt

	- elemental function pdg_array_gt (aval1, aval2) result (flag)
	+ elemental module function pdg_array_gt (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	flag = .not. (aval1 < aval2 .or. aval1 == aval2)
	end function pdg_array_gt

	- elemental function pdg_array_le (aval1, aval2) result (flag)
	+ elemental module function pdg_array_le (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	flag = aval1 < aval2 .or. aval1 == aval2
	end function pdg_array_le

	- elemental function pdg_array_ge (aval1, aval2) result (flag)
	+ elemental module function pdg_array_ge (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	flag = .not. (aval1 < aval2)
	end function pdg_array_ge

	- elemental function pdg_array_eq (aval1, aval2) result (flag)
	+ elemental module function pdg_array_eq (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	if (size (aval1%pdg) /= size (aval2%pdg)) then
	flag = .false.
	else
	flag = all (aval1%pdg == aval2%pdg)
	end if
	end function pdg_array_eq

	- elemental function pdg_array_ne (aval1, aval2) result (flag)
	+ elemental module function pdg_array_ne (aval1, aval2) result (flag)
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical :: flag
	flag = .not. (aval1 == aval2)
	end function pdg_array_ne

	@ Equivalence. Two PDG arrays are equivalent if either one contains
	[[UNDEFINED]] or if each element of array 1 is present in array 2, and
	vice versa.
	<<PDG arrays: public>>=
	public :: operator(.eqv.)
	public :: operator(.neqv.)
	<<PDG arrays: interfaces>>=
	interface operator(.eqv.)
	module procedure pdg_array_equivalent
	end interface
	interface operator(.neqv.)
	module procedure pdg_array_inequivalent
	end interface

	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_equivalent (aval1, aval2) result (eq)
	+ logical :: eq
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ end function pdg_array_equivalent
	+ elemental module function pdg_array_inequivalent (aval1, aval2) result (neq)
	+ logical :: neq
	+ type(pdg_array_t), intent(in) :: aval1, aval2
	+ end function pdg_array_inequivalent
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_equivalent (aval1, aval2) result (eq)
	+ elemental module function pdg_array_equivalent (aval1, aval2) result (eq)
	logical :: eq
	type(pdg_array_t), intent(in) :: aval1, aval2
	logical, dimension(:), allocatable :: match1, match2
	integer :: i
	if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
	eq = any (aval1%pdg == UNDEFINED) &
	.or. any (aval2%pdg == UNDEFINED)
	if (.not. eq) then
	allocate (match1 (size (aval1%pdg)))
	allocate (match2 (size (aval2%pdg)))
	match1 = .false.
	match2 = .false.
	do i = 1, size (aval1%pdg)
	match2 = match2 .or. aval1%pdg(i) == aval2%pdg
	end do
	do i = 1, size (aval2%pdg)
	match1 = match1 .or. aval2%pdg(i) == aval1%pdg
	end do
	eq = all (match1) .and. all (match2)
	end if
	else
	eq = .false.
	end if
	end function pdg_array_equivalent

	- elemental function pdg_array_inequivalent (aval1, aval2) result (neq)
	+ elemental module function pdg_array_inequivalent (aval1, aval2) result (neq)
	logical :: neq
	type(pdg_array_t), intent(in) :: aval1, aval2
	neq = .not. pdg_array_equivalent (aval1, aval2)
	end function pdg_array_inequivalent

	@ %def pdg_array_equivalent
	@
	\subsection{Sorting}
	Sort a PDG array by absolute value, particle before antiparticle. After
	sorting, we eliminate double entries.
	<<PDG arrays: public>>=
	public :: sort_abs
	<<PDG arrays: interfaces>>=
	interface sort_abs
	module procedure pdg_array_sort_abs
	end interface

	<<PDG arrays: pdg array: TBP>>=
	procedure :: sort_abs => pdg_array_sort_abs
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_sort_abs (aval1, unique) result (aval2)
	+ class(pdg_array_t), intent(in) :: aval1
	+ logical, intent(in), optional :: unique
	+ type(pdg_array_t) :: aval2
	+ end function pdg_array_sort_abs
	<<PDG arrays: procedures>>=
	- function pdg_array_sort_abs (aval1, unique) result (aval2)
	+ module function pdg_array_sort_abs (aval1, unique) result (aval2)
	class(pdg_array_t), intent(in) :: aval1
	logical, intent(in), optional :: unique
	type(pdg_array_t) :: aval2
	integer, dimension(:), allocatable :: tmp
	logical, dimension(:), allocatable :: mask
	integer :: i, n
	logical :: uni
	uni = .false.; if (present (unique)) uni = unique
	n = size (aval1%pdg)
	if (uni) then
	allocate (tmp (n), mask(n))
	tmp = sort_abs (aval1%pdg)
	mask(1) = .true.
	do i = 2, n
	mask(i) = tmp(i) /= tmp(i-1)
	end do
	allocate (aval2%pdg (count (mask)))
	aval2%pdg = pack (tmp, mask)
	else
	allocate (aval2%pdg (n))
	aval2%pdg = sort_abs (aval1%pdg)
	end if
	end function pdg_array_sort_abs

	@ %def sort_abs
	@
	<<PDG arrays: pdg array: TBP>>=
	procedure :: intersect => pdg_array_intersect
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_intersect (aval1, match) result (aval2)
	+ class(pdg_array_t), intent(in) :: aval1
	+ integer, dimension(:) :: match
	+ type(pdg_array_t) :: aval2
	+ end function pdg_array_intersect
	<<PDG arrays: procedures>>=
	- function pdg_array_intersect (aval1, match) result (aval2)
	+ module function pdg_array_intersect (aval1, match) result (aval2)
	class(pdg_array_t), intent(in) :: aval1
	integer, dimension(:) :: match
	type(pdg_array_t) :: aval2
	integer, dimension(:), allocatable :: isec
	integer :: i
	isec = pack (aval1%pdg, [(any(aval1%pdg(i) == match), i=1,size(aval1%pdg))])
	- aval2 = isec
	+ call pdg_array_from_int_array (aval2, isec)
	end function pdg_array_intersect

	@ %def pdg_array_intersect
	@
	<<PDG arrays: pdg array: TBP>>=
	procedure :: search_for_particle => pdg_array_search_for_particle
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_array_search_for_particle (pdg, i_part) result (found)
	+ class(pdg_array_t), intent(in) :: pdg
	+ integer, intent(in) :: i_part
	+ logical :: found
	+ end function pdg_array_search_for_particle
	<<PDG arrays: procedures>>=
	- elemental function pdg_array_search_for_particle (pdg, i_part) result (found)
	+ elemental module function pdg_array_search_for_particle (pdg, i_part) result (found)
	class(pdg_array_t), intent(in) :: pdg
	integer, intent(in) :: i_part
	logical :: found
	found = any (pdg%pdg == i_part)
	end function pdg_array_search_for_particle

	@ %def pdg_array_search_for_particle
	@
	<<PDG arrays: pdg array: TBP>>=
	procedure :: invert => pdg_array_invert
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_array_invert (pdg) result (pdg_inverse)
	+ class(pdg_array_t), intent(in) :: pdg
	+ type(pdg_array_t) :: pdg_inverse
	+ end function pdg_array_invert
	<<PDG arrays: procedures>>=
	- function pdg_array_invert (pdg) result (pdg_inverse)
	+ module function pdg_array_invert (pdg) result (pdg_inverse)
	class(pdg_array_t), intent(in) :: pdg
	type(pdg_array_t) :: pdg_inverse
	integer :: i, n
	n = size (pdg%pdg)
	allocate (pdg_inverse%pdg (n))
	do i = 1, n
	select case (pdg%pdg(i))
	case (GLUON, PHOTON, Z_BOSON, 25)
	pdg_inverse%pdg(i) = pdg%pdg(i)
	case default
	pdg_inverse%pdg(i) = -pdg%pdg(i)
	end select
	end do
	end function pdg_array_invert

	@ %def pdg_array_invert
	@
	\subsection{PDG array list}
	A PDG array list, or PDG list, is an array of PDG-array objects with
	some convenience methods.
	<<PDG arrays: public>>=
	public :: pdg_list_t
	<<PDG arrays: types>>=
	type :: pdg_list_t
	type(pdg_array_t), dimension(:), allocatable :: a
	contains
	<<PDG arrays: pdg list: TBP>>
	end type pdg_list_t

	@ %def pdg_list_t
	@ Output, as a comma-separated list without advancing I/O.
	<<PDG arrays: pdg list: TBP>>=
	procedure :: write => pdg_list_write
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_write (object, unit)
	+ class(pdg_list_t), intent(in) :: object
	+ integer, intent(in), optional :: unit
	+ end subroutine pdg_list_write
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_write (object, unit)
	+ module subroutine pdg_list_write (object, unit)
	class(pdg_list_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	if (allocated (object%a)) then
	do i = 1, size (object%a)
	if (i > 1) write (u, "(A)", advance="no") ", "
	call object%a(i)%write (u)
	end do
	end if
	end subroutine pdg_list_write

	@ %def pdg_list_write
	@ Initialize for a certain size. The entries are initially empty PDG arrays.
	<<PDG arrays: pdg list: TBP>>=
	generic :: init => pdg_list_init_size
	procedure, private :: pdg_list_init_size
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_init_size (pl, n)
	+ class(pdg_list_t), intent(out) :: pl
	+ integer, intent(in) :: n
	+ end subroutine pdg_list_init_size
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_init_size (pl, n)
	+ module subroutine pdg_list_init_size (pl, n)
	class(pdg_list_t), intent(out) :: pl
	integer, intent(in) :: n
	allocate (pl%a (n))
	end subroutine pdg_list_init_size

	@ %def pdg_list_init_size
	@ Initialize with a definite array of PDG codes. That is, each entry
	in the list becomes a single-particle PDG array.
	<<PDG arrays: pdg list: TBP>>=
	generic :: init => pdg_list_init_int_array
	procedure, private :: pdg_list_init_int_array
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_init_int_array (pl, pdg)
	+ class(pdg_list_t), intent(out) :: pl
	+ integer, dimension(:), intent(in) :: pdg
	+ end subroutine pdg_list_init_int_array
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_init_int_array (pl, pdg)
	+ module subroutine pdg_list_init_int_array (pl, pdg)
	class(pdg_list_t), intent(out) :: pl
	integer, dimension(:), intent(in) :: pdg
	integer :: i
	allocate (pl%a (size (pdg)))
	do i = 1, size (pdg)
	- pl%a(i) = pdg(i)
	+ call pdg_array_from_int (pl%a(i), pdg(i))
	end do
	end subroutine pdg_list_init_int_array

	@ %def pdg_list_init_array
	@ Set one of the entries. No bounds-check.
	<<PDG arrays: pdg list: TBP>>=
	generic :: set => pdg_list_set_int
	generic :: set => pdg_list_set_int_array
	generic :: set => pdg_list_set_pdg_array
	procedure, private :: pdg_list_set_int
	procedure, private :: pdg_list_set_int_array
	procedure, private :: pdg_list_set_pdg_array
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_set_int (pl, i, pdg)
	+ class(pdg_list_t), intent(inout) :: pl
	+ integer, intent(in) :: i
	+ integer, intent(in) :: pdg
	+ end subroutine pdg_list_set_int
	+ module subroutine pdg_list_set_int_array (pl, i, pdg)
	+ class(pdg_list_t), intent(inout) :: pl
	+ integer, intent(in) :: i
	+ integer, dimension(:), intent(in) :: pdg
	+ end subroutine pdg_list_set_int_array
	+ module subroutine pdg_list_set_pdg_array (pl, i, pa)
	+ class(pdg_list_t), intent(inout) :: pl
	+ integer, intent(in) :: i
	+ type(pdg_array_t), intent(in) :: pa
	+ end subroutine pdg_list_set_pdg_array
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_set_int (pl, i, pdg)
	+ module subroutine pdg_list_set_int (pl, i, pdg)
	class(pdg_list_t), intent(inout) :: pl
	integer, intent(in) :: i
	integer, intent(in) :: pdg
	- pl%a(i) = pdg
	+ call pdg_array_from_int (pl%a(i), pdg)
	end subroutine pdg_list_set_int

	- subroutine pdg_list_set_int_array (pl, i, pdg)
	+ module subroutine pdg_list_set_int_array (pl, i, pdg)
	class(pdg_list_t), intent(inout) :: pl
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: pdg
	- pl%a(i) = pdg
	+ call pdg_array_from_int_array (pl%a(i), pdg)
	end subroutine pdg_list_set_int_array

	- subroutine pdg_list_set_pdg_array (pl, i, pa)
	+ module subroutine pdg_list_set_pdg_array (pl, i, pa)
	class(pdg_list_t), intent(inout) :: pl
	integer, intent(in) :: i
	type(pdg_array_t), intent(in) :: pa
	pl%a(i) = pa
	end subroutine pdg_list_set_pdg_array

	@ %def pdg_list_set
	@ Array size, not the length of individual entries
	<<PDG arrays: pdg list: TBP>>=
	procedure :: get_size => pdg_list_get_size
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_get_size (pl) result (n)
	+ class(pdg_list_t), intent(in) :: pl
	+ integer :: n
	+ end function pdg_list_get_size
	<<PDG arrays: procedures>>=
	- function pdg_list_get_size (pl) result (n)
	+ module function pdg_list_get_size (pl) result (n)
	class(pdg_list_t), intent(in) :: pl
	integer :: n
	if (allocated (pl%a)) then
	n = size (pl%a)
	else
	n = 0
	end if
	end function pdg_list_get_size

	@ %def pdg_list_get_size
	@ Return an entry, as a PDG array.
	<<PDG arrays: pdg list: TBP>>=
	procedure :: get => pdg_list_get
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_get (pl, i) result (pa)
	+ type(pdg_array_t) :: pa
	+ class(pdg_list_t), intent(in) :: pl
	+ integer, intent(in) :: i
	+ end function pdg_list_get
	<<PDG arrays: procedures>>=
	- function pdg_list_get (pl, i) result (pa)
	+ module function pdg_list_get (pl, i) result (pa)
	type(pdg_array_t) :: pa
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: i
	pa = pl%a(i)
	end function pdg_list_get

	@ %def pdg_list_get
	@ Check if the list entries are all either mutually disjoint or identical.
	The individual entries (PDG arrays) should already be sorted, so we can test
	for equality.
	<<PDG arrays: pdg list: TBP>>=
	procedure :: is_regular => pdg_list_is_regular
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_is_regular (pl) result (flag)
	+ class(pdg_list_t), intent(in) :: pl
	+ logical :: flag
	+ end function pdg_list_is_regular
	<<PDG arrays: procedures>>=
	- function pdg_list_is_regular (pl) result (flag)
	+ module function pdg_list_is_regular (pl) result (flag)
	class(pdg_list_t), intent(in) :: pl
	logical :: flag
	integer :: i, j, s
	s = pl%get_size ()
	flag = .true.
	do i = 1, s
	do j = i + 1, s
	if (pl%a(i) .match. pl%a(j)) then
	if (pl%a(i) /= pl%a(j)) then
	flag = .false.
	return
	end if
	end if
	end do
	end do
	end function pdg_list_is_regular

	@ %def pdg_list_is_regular
	@ Sort the list. First, each entry gets sorted, including elimination
	of doublers. Then, we sort the list, using the first member of each
	PDG array as the marker. No removal of doublers at this stage.

	If [[n_in]] is supplied, we do not reorder the first [[n_in]] particle
	entries.
	<<PDG arrays: pdg list: TBP>>=
	procedure :: sort_abs => pdg_list_sort_abs
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_sort_abs (pl, n_in) result (pl_sorted)
	+ class(pdg_list_t), intent(in) :: pl
	+ integer, intent(in), optional :: n_in
	+ type(pdg_list_t) :: pl_sorted
	+ end function pdg_list_sort_abs
	<<PDG arrays: procedures>>=
	- function pdg_list_sort_abs (pl, n_in) result (pl_sorted)
	+ module function pdg_list_sort_abs (pl, n_in) result (pl_sorted)
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in), optional :: n_in
	type(pdg_list_t) :: pl_sorted
	type(pdg_array_t), dimension(:), allocatable :: pa
	integer, dimension(:), allocatable :: pdg, map
	integer :: i, n0
	call pl_sorted%init (pl%get_size ())
	if (allocated (pl%a)) then
	allocate (pa (size (pl%a)))
	do i = 1, size (pl%a)
	pa(i) = pl%a(i)%sort_abs (unique = .true.)
	end do
	allocate (pdg (size (pa)), source = 0)
	do i = 1, size (pa)
	if (allocated (pa(i)%pdg)) then
	if (size (pa(i)%pdg) > 0) then
	pdg(i) = pa(i)%pdg(1)
	end if
	end if
	end do
	if (present (n_in)) then
	n0 = n_in
	else
	n0 = 0
	end if
	allocate (map (size (pdg)))
	map(:n0) = [(i, i = 1, n0)]
	map(n0+1:) = n0 + order_abs (pdg(n0+1:))
	do i = 1, size (pa)
	call pl_sorted%set (i, pa(map(i)))
	end do
	end if
	end function pdg_list_sort_abs

	@ %def pdg_list_sort_abs
	@ Compare sorted lists: equality. The result is undefined if some entries
	are not allocated.
	<<PDG arrays: pdg list: TBP>>=
	generic :: operator (==) => pdg_list_eq
	procedure, private :: pdg_list_eq
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_eq (pl1, pl2) result (flag)
	+ class(pdg_list_t), intent(in) :: pl1, pl2
	+ logical :: flag
	+ end function pdg_list_eq
	<<PDG arrays: procedures>>=
	- function pdg_list_eq (pl1, pl2) result (flag)
	+ module function pdg_list_eq (pl1, pl2) result (flag)
	class(pdg_list_t), intent(in) :: pl1, pl2
	logical :: flag
	integer :: i
	flag = .false.
	if (allocated (pl1%a) .and. allocated (pl2%a)) then
	if (size (pl1%a) == size (pl2%a)) then
	do i = 1, size (pl1%a)
	associate (a1 => pl1%a(i), a2 => pl2%a(i))
	if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
	if (size (a1%pdg) == size (a2%pdg)) then
	if (size (a1%pdg) > 0) then
	if (a1%pdg(1) /= a2%pdg(1)) return
	end if
	else
	return
	end if
	else
	return
	end if
	end associate
	end do
	flag = .true.
	end if
	end if
	end function pdg_list_eq

	@ %def pdg_list_eq
	@ Compare sorted lists. The result is undefined if some entries
	are not allocated.

	The ordering is quite complicated. First, a shorter list comes before
	a longer list. Comparing entry by entry, a shorter entry comes
	first. Next, we check the first PDG code within corresponding
	entries. This is compared by absolute value. If equal, particle
	comes before antiparticle. Finally, if all is equal, the result is
	false.
	<<PDG arrays: pdg list: TBP>>=
	generic :: operator (<) => pdg_list_lt
	procedure, private :: pdg_list_lt
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_lt (pl1, pl2) result (flag)
	+ class(pdg_list_t), intent(in) :: pl1, pl2
	+ logical :: flag
	+ end function pdg_list_lt
	<<PDG arrays: procedures>>=
	- function pdg_list_lt (pl1, pl2) result (flag)
	+ module function pdg_list_lt (pl1, pl2) result (flag)
	class(pdg_list_t), intent(in) :: pl1, pl2
	logical :: flag
	integer :: i
	flag = .false.
	if (allocated (pl1%a) .and. allocated (pl2%a)) then
	if (size (pl1%a) < size (pl2%a)) then
	flag = .true.; return
	else if (size (pl1%a) > size (pl2%a)) then
	return
	else
	do i = 1, size (pl1%a)
	associate (a1 => pl1%a(i), a2 => pl2%a(i))
	if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
	if (size (a1%pdg) < size (a2%pdg)) then
	flag = .true.; return
	else if (size (a1%pdg) > size (a2%pdg)) then
	return
	else
	if (size (a1%pdg) > 0) then
	if (abs (a1%pdg(1)) < abs (a2%pdg(1))) then
	flag = .true.; return
	else if (abs (a1%pdg(1)) > abs (a2%pdg(1))) then
	return
	else if (a1%pdg(1) > 0 .and. a2%pdg(1) < 0) then
	flag = .true.; return
	else if (a1%pdg(1) < 0 .and. a2%pdg(1) > 0) then
	return
	end if
	end if
	end if
	else
	return
	end if
	end associate
	end do
	flag = .false.
	end if
	end if
	end function pdg_list_lt

	@ %def pdg_list_lt
	@ Replace an entry. In the result, the entry [[#i]] is replaced by
	the contents of the second argument. The result is not sorted.

	If [[n_in]] is also set and [[i]] is less or equal to [[n_in]],
	replace [[#i]] only by the first entry of [[pl_insert]], and insert
	the remainder after entry [[n_in]].
	<<PDG arrays: pdg list: TBP>>=
	procedure :: replace => pdg_list_replace
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out)
	+ type(pdg_list_t) :: pl_out
	+ class(pdg_list_t), intent(in) :: pl
	+ integer, intent(in) :: i
	+ class(pdg_list_t), intent(in) :: pl_insert
	+ integer, intent(in), optional :: n_in
	+ end function pdg_list_replace
	<<PDG arrays: procedures>>=
	- function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out)
	+ module function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out)
	type(pdg_list_t) :: pl_out
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: i
	class(pdg_list_t), intent(in) :: pl_insert
	integer, intent(in), optional :: n_in
	integer :: n, n_insert, n_out, k
	n = pl%get_size ()
	n_insert = pl_insert%get_size ()
	n_out = n + n_insert - 1
	call pl_out%init (n_out)
	! if (allocated (pl%a)) then
	do k = 1, i - 1
	pl_out%a(k) = pl%a(k)
	end do
	! end if
	if (present (n_in)) then
	pl_out%a(i) = pl_insert%a(1)
	do k = i + 1, n_in
	pl_out%a(k) = pl%a(k)
	end do
	do k = 1, n_insert - 1
	pl_out%a(n_in+k) = pl_insert%a(1+k)
	end do
	do k = 1, n - n_in
	pl_out%a(n_in+k+n_insert-1) = pl%a(n_in+k)
	end do
	else
	! if (allocated (pl_insert%a)) then
	do k = 1, n_insert
	pl_out%a(i-1+k) = pl_insert%a(k)
	end do
	! end if
	! if (allocated (pl%a)) then
	do k = 1, n - i
	pl_out%a(i+n_insert-1+k) = pl%a(i+k)
	end do
	end if
	! end if
	end function pdg_list_replace

	@ %def pdg_list_replace
	@
	<<PDG arrays: pdg list: TBP>>=
	procedure :: fusion => pdg_list_fusion
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out)
	+ type(pdg_list_t) :: pl_out
	+ class(pdg_list_t), intent(in) :: pl
	+ type(pdg_list_t), intent(in) :: pl_insert
	+ integer, intent(in) :: i
	+ logical, intent(in) :: check_if_existing
	+ end function pdg_list_fusion
	<<PDG arrays: procedures>>=
	- function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out)
	+ module function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out)
	type(pdg_list_t) :: pl_out
	class(pdg_list_t), intent(in) :: pl
	type(pdg_list_t), intent(in) :: pl_insert
	integer, intent(in) :: i
	logical, intent(in) :: check_if_existing
	integer :: n, n_insert, k, n_out
	logical :: new_pdg
	n = pl%get_size ()
	n_insert = pl_insert%get_size ()
	new_pdg = .not. check_if_existing .or. &
	(.not. any (pl%search_for_particle (pl_insert%a(1)%pdg)))
	call pl_out%init (n + n_insert - 1)
	do k = 1, n
	if (new_pdg .and. k == i) then
	pl_out%a(k) = pl%a(k)%add (pl_insert%a(1))
	else
	pl_out%a(k) = pl%a(k)
	end if
	end do
	do k = n + 1, n + n_insert - 1
	pl_out%a(k) = pl_insert%a(k-n)
	end do
	end function pdg_list_fusion

	@ %def pdg_list_fusion
	@
	<<PDG arrays: pdg list: TBP>>=
	procedure :: get_pdg_sizes => pdg_list_get_pdg_sizes
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_get_pdg_sizes (pl) result (i_size)
	+ integer, dimension(:), allocatable :: i_size
	+ class(pdg_list_t), intent(in) :: pl
	+ end function pdg_list_get_pdg_sizes
	<<PDG arrays: procedures>>=
	- function pdg_list_get_pdg_sizes (pl) result (i_size)
	+ module function pdg_list_get_pdg_sizes (pl) result (i_size)
	integer, dimension(:), allocatable :: i_size
	class(pdg_list_t), intent(in) :: pl
	integer :: i, n
	n = pl%get_size ()
	allocate (i_size (n))
	do i = 1, n
	i_size(i) = size (pl%a(i)%pdg)
	end do
	end function pdg_list_get_pdg_sizes

	@ %def pdg_list_get_pdg_sizes
	@ Replace the entries of [[pl]] by the matching entries of [[pl_match]], one by
	one. This is done in-place. If there is no match, return failure.
	<<PDG arrays: pdg list: TBP>>=
	procedure :: match_replace => pdg_list_match_replace
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_match_replace (pl, pl_match, success)
	+ class(pdg_list_t), intent(inout) :: pl
	+ class(pdg_list_t), intent(in) :: pl_match
	+ logical, intent(out) :: success
	+ end subroutine pdg_list_match_replace
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_match_replace (pl, pl_match, success)
	+ module subroutine pdg_list_match_replace (pl, pl_match, success)
	class(pdg_list_t), intent(inout) :: pl
	class(pdg_list_t), intent(in) :: pl_match
	logical, intent(out) :: success
	integer :: i, j
	success = .true.
	SCAN_ENTRIES: do i = 1, size (pl%a)
	do j = 1, size (pl_match%a)
	if (pl%a(i) .match. pl_match%a(j)) then
	pl%a(i) = pl_match%a(j)
	cycle SCAN_ENTRIES
	end if
	end do
	success = .false.
	return
	end do SCAN_ENTRIES
	end subroutine pdg_list_match_replace

	@ %def pdg_list_match_replace
	@ Just check if a PDG array matches any entry in the PDG list. The second
	version returns the position of the match within the list. An optional mask
	indicates the list elements that should be checked.
	<<PDG arrays: pdg list: TBP>>=
	generic :: operator (.match.) => pdg_list_match_pdg_array
	procedure, private :: pdg_list_match_pdg_array
	procedure :: find_match => pdg_list_find_match_pdg_array
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_match_pdg_array (pl, pa) result (flag)
	+ class(pdg_list_t), intent(in) :: pl
	+ type(pdg_array_t), intent(in) :: pa
	+ logical :: flag
	+ end function pdg_list_match_pdg_array
	+ module function pdg_list_find_match_pdg_array (pl, pa, mask) result (i)
	+ class(pdg_list_t), intent(in) :: pl
	+ type(pdg_array_t), intent(in) :: pa
	+ logical, dimension(:), intent(in), optional :: mask
	+ integer :: i
	+ end function pdg_list_find_match_pdg_array
	<<PDG arrays: procedures>>=
	- function pdg_list_match_pdg_array (pl, pa) result (flag)
	+ module function pdg_list_match_pdg_array (pl, pa) result (flag)
	class(pdg_list_t), intent(in) :: pl
	type(pdg_array_t), intent(in) :: pa
	logical :: flag
	flag = pl%find_match (pa) /= 0
	end function pdg_list_match_pdg_array

	- function pdg_list_find_match_pdg_array (pl, pa, mask) result (i)
	+ module function pdg_list_find_match_pdg_array (pl, pa, mask) result (i)
	class(pdg_list_t), intent(in) :: pl
	type(pdg_array_t), intent(in) :: pa
	logical, dimension(:), intent(in), optional :: mask
	integer :: i
	do i = 1, size (pl%a)
	if (present (mask)) then
	if (.not. mask(i)) cycle
	end if
	if (pl%a(i) .match. pa) return
	end do
	i = 0
	end function pdg_list_find_match_pdg_array

	@ %def pdg_list_match_pdg_array
	@ %def pdg_list_find_match_pdg_array
	@ Some old compilers have problems with allocatable arrays as
	intent(out) or as function result, so be conservative here:
	<<PDG arrays: pdg list: TBP>>=
	procedure :: create_pdg_array => pdg_list_create_pdg_array
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_create_pdg_array (pl, pdg)
	+ class(pdg_list_t), intent(in) :: pl
	+ type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg
	+ end subroutine pdg_list_create_pdg_array
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_create_pdg_array (pl, pdg)
	+ module subroutine pdg_list_create_pdg_array (pl, pdg)
	class(pdg_list_t), intent(in) :: pl
	type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg
	integer :: n_elements
	integer :: i
	associate (a => pl%a)
	n_elements = size (a)
	if (allocated (pdg)) deallocate (pdg)
	allocate (pdg (n_elements))
	do i = 1, n_elements
	pdg(i) = a(i)
	end do
	end associate
	end subroutine pdg_list_create_pdg_array

	@ %def pdg_list_create_pdg_array
	@
	<<PDG arrays: pdg list: TBP>>=
	procedure :: create_antiparticles => pdg_list_create_antiparticles
	+<<PDG arrays: sub interfaces>>=
	+ module subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles)
	+ class(pdg_list_t), intent(in) :: pl
	+ type(pdg_list_t), intent(out) :: pl_anti
	+ integer, intent(out) :: n_new_particles
	+ end subroutine pdg_list_create_antiparticles
	<<PDG arrays: procedures>>=
	- subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles)
	+ module subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles)
	class(pdg_list_t), intent(in) :: pl
	type(pdg_list_t), intent(out) :: pl_anti
	integer, intent(out) :: n_new_particles
	type(pdg_list_t) :: pl_inverse
	integer :: i, n
	integer :: n_identical
	logical, dimension(:), allocatable :: collect
	n = pl%get_size (); n_identical = 0
	allocate (collect (n)); collect = .true.
	call pl_inverse%init (n)
	do i = 1, n
	pl_inverse%a(i) = pl%a(i)%invert()
	end do
	do i = 1, n
	if (any (pl_inverse%a(i) == pl%a)) then
	collect(i) = .false.
	n_identical = n_identical + 1
	end if
	end do
	n_new_particles = n - n_identical
	if (n_new_particles > 0) then
	call pl_anti%init (n_new_particles)
	do i = 1, n
	if (collect (i)) pl_anti%a(i) = pl_inverse%a(i)
	end do
	end if
	end subroutine pdg_list_create_antiparticles

	@ %def pdg_list_create_antiparticles
	@
	<<PDG arrays: pdg list: TBP>>=
	procedure :: search_for_particle => pdg_list_search_for_particle
	+<<PDG arrays: sub interfaces>>=
	+ elemental module function pdg_list_search_for_particle (pl, i_part) result (found)
	+ logical :: found
	+ class(pdg_list_t), intent(in) :: pl
	+ integer, intent(in) :: i_part
	+ end function pdg_list_search_for_particle
	<<PDG arrays: procedures>>=
	- elemental function pdg_list_search_for_particle (pl, i_part) result (found)
	+ elemental module function pdg_list_search_for_particle (pl, i_part) result (found)
	logical :: found
	class(pdg_list_t), intent(in) :: pl
	integer, intent(in) :: i_part
	integer :: i_pl
	do i_pl = 1, size (pl%a)
	found = pl%a(i_pl)%search_for_particle (i_part)
	if (found) return
	end do
	end function pdg_list_search_for_particle

	@ %def pdg_list_search_for_particle
	@
	<<PDG arrays: pdg list: TBP>>=
	procedure :: contains_colored_particles => pdg_list_contains_colored_particles
	+<<PDG arrays: sub interfaces>>=
	+ module function pdg_list_contains_colored_particles (pl) result (colored)
	+ class(pdg_list_t), intent(in) :: pl
	+ logical :: colored
	+ end function pdg_list_contains_colored_particles
	<<PDG arrays: procedures>>=
	- function pdg_list_contains_colored_particles (pl) result (colored)
	+ module function pdg_list_contains_colored_particles (pl) result (colored)
	class(pdg_list_t), intent(in) :: pl
	logical :: colored
	integer :: i
	colored = .false.
	do i = 1, size (pl%a)
	if (pl%a(i)%has_colored_particles()) then
	colored = .true.
	exit
	end if
	end do
	end function pdg_list_contains_colored_particles

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

	module pdg_arrays_ut
	use unit_tests
	use pdg_arrays_uti

	<<Standard module head>>

	<<PDG arrays: public test>>

	contains

	<<PDG arrays: test driver>>

	end module pdg_arrays_ut
	@ %def pdg_arrays_ut
	@
	<<[[pdg_arrays_uti.f90]]>>=
	<<File header>>

	module pdg_arrays_uti

	use pdg_arrays

	<<Standard module head>>

	<<PDG arrays: test declarations>>

	contains

	<<PDG arrays: tests>>

	end module pdg_arrays_uti
	@ %def pdg_arrays_ut
	@ API: driver for the unit tests below.
	<<PDG arrays: public test>>=
	public :: pdg_arrays_test
	<<PDG arrays: test driver>>=
	subroutine pdg_arrays_test (u, results)
	integer, intent(in) :: u
	type (test_results_t), intent(inout) :: results
	<<PDG arrays: execute tests>>
	end subroutine pdg_arrays_test

	@ %def pdg_arrays_test
	@ Basic functionality.
	<<PDG arrays: execute tests>>=
	call test (pdg_arrays_1, "pdg_arrays_1", &
	"create and sort PDG array", &
	u, results)
	<<PDG arrays: test declarations>>=
	public :: pdg_arrays_1
	<<PDG arrays: tests>>=
	subroutine pdg_arrays_1 (u)
	integer, intent(in) :: u

	type(pdg_array_t) :: pa, pa1, pa2, pa3, pa4, pa5, pa6
	integer, dimension(:), allocatable :: pdg

	write (u, "(A)") "* Test output: pdg_arrays_1"
	write (u, "(A)") "* Purpose: create and sort PDG arrays"
	write (u, "(A)")

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

	call pa%write (u)
	write (u, *)
	write (u, "(A,I0)") "length = ", pa%get_length ()
	pdg = pa
	write (u, "(A,3(1x,I0))") "contents = ", pdg

	write (u, *)
	pa = 1
	call pa%write (u)
	write (u, *)
	write (u, "(A,I0)") "length = ", pa%get_length ()
	pdg = pa
	write (u, "(A,3(1x,I0))") "contents = ", pdg

	write (u, *)
	pa = [1, 2, 3]
	call pa%write (u)
	write (u, *)
	write (u, "(A,I0)") "length = ", pa%get_length ()
	pdg = pa
	write (u, "(A,3(1x,I0))") "contents = ", pdg
	write (u, "(A,I0)") "element #2 = ", pa%get (2)

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

	pa = pa%replace (2, [-5, 5, -7])
	call pa%write (u)
	write (u, *)

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

	pa = [1, -7, 3, -5, 5, 3]
	call pa%write (u)
	write (u, *)
	pa1 = pa%sort_abs ()
	pa2 = pa%sort_abs (unique = .true.)
	call pa1%write (u)
	write (u, *)
	call pa2%write (u)
	write (u, *)

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

	pa1 = [1, 3]
	pa2 = [1, 2, -2]
	pa3 = [1, 2, 4]
	pa4 = [1, 2, 4]
	pa5 = [1, 2, -4]
	pa6 = [1, 2, -3]

	write (u, "(A,6(1x,L1))") "< ", &
	pa1 < pa2, pa2 < pa3, pa3 < pa4, pa4 < pa5, pa5 < pa6, pa6 < pa1
	write (u, "(A,6(1x,L1))") "> ", &
	pa1 > pa2, pa2 > pa3, pa3 > pa4, pa4 > pa5, pa5 > pa6, pa6 > pa1
	write (u, "(A,6(1x,L1))") "<=", &
	pa1 <= pa2, pa2 <= pa3, pa3 <= pa4, pa4 <= pa5, pa5 <= pa6, pa6 <= pa1
	write (u, "(A,6(1x,L1))") ">=", &
	pa1 >= pa2, pa2 >= pa3, pa3 >= pa4, pa4 >= pa5, pa5 >= pa6, pa6 >= pa1
	write (u, "(A,6(1x,L1))") "==", &
	pa1 == pa2, pa2 == pa3, pa3 == pa4, pa4 == pa5, pa5 == pa6, pa6 == pa1
	write (u, "(A,6(1x,L1))") "/=", &
	pa1 /= pa2, pa2 /= pa3, pa3 /= pa4, pa4 /= pa5, pa5 /= pa6, pa6 /= pa1

	write (u, *)
	pa1 = [0]
	pa2 = [1, 2]
	pa3 = [1, -2]

	write (u, "(A,6(1x,L1))") "eqv ", &
	pa1 .eqv. pa1, pa1 .eqv. pa2, &
	pa2 .eqv. pa2, pa2 .eqv. pa3

	write (u, "(A,6(1x,L1))") "neqv", &
	pa1 .neqv. pa1, pa1 .neqv. pa2, &
	pa2 .neqv. pa2, pa2 .neqv. pa3


	write (u, *)
	write (u, "(A,6(1x,L1))") "match", &
	pa1 .match. 0, pa1 .match. 1, &
	pa2 .match. 0, pa2 .match. 1, pa2 .match. 3

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

	end subroutine pdg_arrays_1

	@ %def pdg_arrays_1
	@ PDG array list, i.e., arrays of arrays.
	<<PDG arrays: execute tests>>=
	call test (pdg_arrays_2, "pdg_arrays_2", &
	"create and sort PDG lists", &
	u, results)
	<<PDG arrays: test declarations>>=
	public :: pdg_arrays_2
	<<PDG arrays: tests>>=
	subroutine pdg_arrays_2 (u)
	integer, intent(in) :: u

	type(pdg_array_t) :: pa
	type(pdg_list_t) :: pl, pl1

	write (u, "(A)") "* Test output: pdg_arrays_2"
	write (u, "(A)") "* Purpose: create and sort PDG lists"
	write (u, "(A)")

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

	call pl%init (3)
	call pl%set (1, 42)
	call pl%set (2, [3, 2])
	pa = [5, -5]
	call pl%set (3, pa)
	call pl%write (u)
	write (u, *)
	write (u, "(A,I0)") "size = ", pl%get_size ()

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

	pl = pl%sort_abs ()
	call pl%write (u)
	write (u, *)

	write (u, "(A)")
	write (u, "(A)") "* Extract item #3"
	write (u, "(A)")

	pa = pl%get (3)
	call pa%write (u)
	write (u, *)

	write (u, "(A)")
	write (u, "(A)") "* Replace item #3"
	write (u, "(A)")

	call pl1%init (2)
	call pl1%set (1, [2, 4])
	call pl1%set (2, -7)

	pl = pl%replace (3, pl1)
	call pl%write (u)
	write (u, *)

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

	end subroutine pdg_arrays_2

	@ %def pdg_arrays_2
	@ Check if a (sorted) PDG array lists is regular. The entries (PDG arrays)
	must not overlap, unless they are identical.
	<<PDG arrays: execute tests>>=
	call test (pdg_arrays_3, "pdg_arrays_3", &
	"check PDG lists", &
	u, results)
	<<PDG arrays: test declarations>>=
	public :: pdg_arrays_3
	<<PDG arrays: tests>>=
	subroutine pdg_arrays_3 (u)
	integer, intent(in) :: u

	type(pdg_list_t) :: pl

	write (u, "(A)") "* Test output: pdg_arrays_3"
	write (u, "(A)") "* Purpose: check for regular PDG lists"
	write (u, "(A)")

	write (u, "(A)") "* Regular list"
	write (u, "(A)")

	call pl%init (4)
	call pl%set (1, [1, 2])
	call pl%set (2, [1, 2])
	call pl%set (3, [5, -5])
	call pl%set (4, 42)
	call pl%write (u)
	write (u, *)
	write (u, "(L1)") pl%is_regular ()

	write (u, "(A)")
	write (u, "(A)") "* Irregular list"
	write (u, "(A)")

	call pl%init (4)
	call pl%set (1, [1, 2])
	call pl%set (2, [1, 2])
	call pl%set (3, [2, 5, -5])
	call pl%set (4, 42)
	call pl%write (u)
	write (u, *)
	write (u, "(L1)") pl%is_regular ()

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

	end subroutine pdg_arrays_3

	@ %def pdg_arrays_3
	@ Compare PDG array lists. The lists must be regular, i.e., sorted and with
	non-overlapping (or identical) entries.
	<<PDG arrays: execute tests>>=
	call test (pdg_arrays_4, "pdg_arrays_4", &
	"compare PDG lists", &
	u, results)
	<<PDG arrays: test declarations>>=
	public :: pdg_arrays_4
	<<PDG arrays: tests>>=
	subroutine pdg_arrays_4 (u)
	integer, intent(in) :: u

	type(pdg_list_t) :: pl1, pl2, pl3

	write (u, "(A)") "* Test output: pdg_arrays_4"
	write (u, "(A)") "* Purpose: check for regular PDG lists"
	write (u, "(A)")

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

	call pl1%init (4)
	call pl1%set (1, [1, 2])
	call pl1%set (2, [1, 2])
	call pl1%set (3, [5, -5])
	call pl1%set (4, 42)
	write (u, "(I1,1x)", advance = "no") 1
	call pl1%write (u)
	write (u, *)

	call pl2%init (2)
	call pl2%set (1, 3)
	call pl2%set (2, [5, -5])
	write (u, "(I1,1x)", advance = "no") 2
	call pl2%write (u)
	write (u, *)

	call pl3%init (2)
	call pl3%set (1, 4)
	call pl3%set (2, [5, -5])
	write (u, "(I1,1x)", advance = "no") 3
	call pl3%write (u)
	write (u, *)

	write (u, "(A)")
	write (u, "(A)") "* a == b"
	write (u, "(A)")

	write (u, "(2x,A)") "123"
	write (u, *)
	write (u, "(I1,1x,4L1)") 1, pl1 == pl1, pl1 == pl2, pl1 == pl3
	write (u, "(I1,1x,4L1)") 2, pl2 == pl1, pl2 == pl2, pl2 == pl3
	write (u, "(I1,1x,4L1)") 3, pl3 == pl1, pl3 == pl2, pl3 == pl3

	write (u, "(A)")
	write (u, "(A)") "* a < b"
	write (u, "(A)")

	write (u, "(2x,A)") "123"
	write (u, *)
	write (u, "(I1,1x,4L1)") 1, pl1 < pl1, pl1 < pl2, pl1 < pl3
	write (u, "(I1,1x,4L1)") 2, pl2 < pl1, pl2 < pl2, pl2 < pl3
	write (u, "(I1,1x,4L1)") 3, pl3 < pl1, pl3 < pl2, pl3 < pl3

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

	end subroutine pdg_arrays_4

	@ %def pdg_arrays_4
	@ Match-replace: translate all entries in the first list into the
	matching entries of the second list, if there is a match.
	<<PDG arrays: execute tests>>=
	call test (pdg_arrays_5, "pdg_arrays_5", &
	"match PDG lists", &
	u, results)
	<<PDG arrays: test declarations>>=
	public :: pdg_arrays_5
	<<PDG arrays: tests>>=
	subroutine pdg_arrays_5 (u)
	integer, intent(in) :: u

	type(pdg_list_t) :: pl1, pl2, pl3
	logical :: success

	write (u, "(A)") "* Test output: pdg_arrays_5"
	write (u, "(A)") "* Purpose: match-replace"
	write (u, "(A)")

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

	call pl1%init (2)
	call pl1%set (1, [1, 2])
	call pl1%set (2, 42)
	call pl1%write (u)
	write (u, *)
	call pl3%init (2)
	call pl3%set (1, [42, -42])
	call pl3%set (2, [1, 2, 3, 4])
	call pl1%match_replace (pl3, success)
	call pl3%write (u)
	write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success
	call pl1%write (u)
	write (u, *)

	write (u, *)

	call pl2%init (2)
	call pl2%set (1, 9)
	call pl2%set (2, 42)
	call pl2%write (u)
	write (u, *)
	call pl2%match_replace (pl3, success)
	call pl3%write (u)
	write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success
	call pl2%write (u)
	write (u, *)

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

	end subroutine pdg_arrays_5

	@ %def pdg_arrays_5
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Jets}

	The FastJet library is linked externally, if available. The wrapper code is
	also in a separate directory. Here, we define \whizard-specific procedures
	and tests.
	<<[[jets.f90]]>>=
	<<File header>>

	module jets

	use fastjet !NODEP!

	<<Standard module head>>

	<<Jets: public>>

	contains

	<<Jets: procedures>>

	end module jets
	@ %def jets
	@
	\subsection{Re-exported symbols}
	We use this module as a proxy for the FastJet interface, therefore we
	re-export some symbols.
	<<Jets: public>>=
	public :: fastjet_available
	public :: fastjet_init
	public :: jet_definition_t
	public :: pseudojet_t
	public :: pseudojet_vector_t
	public :: cluster_sequence_t
	public :: assignment (=)

	@ %def jet_definition_t pseudojet_t pseudojet_vector_t cluster_sequence_t
	@ The initialization routine prints the banner.
	<<Jets: procedures>>=
	subroutine fastjet_init ()
	call print_banner ()
	end subroutine fastjet_init

	@ %def fastjet_init
	@ The jet algorithm codes (actually, integers)
	<<Jets: public>>=
	public :: kt_algorithm
	public :: cambridge_algorithm
	public :: antikt_algorithm
	public :: genkt_algorithm
	public :: cambridge_for_passive_algorithm
	public :: genkt_for_passive_algorithm
	public :: ee_kt_algorithm
	public :: ee_genkt_algorithm
	public :: plugin_algorithm
	public :: undefined_jet_algorithm

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

	module jets_ut
	use unit_tests
	use jets_uti

	<<Standard module head>>

	<<Jets: public test>>

	contains

	<<Jets: test driver>>

	end module jets_ut
	@ %def jets_ut
	@
	<<[[jets_uti.f90]]>>=
	<<File header>>

	module jets_uti

	<<Use kinds>>
	use fastjet !NODEP!

	use jets

	<<Standard module head>>

	<<Jets: test declarations>>

	contains

	<<Jets: tests>>

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

	@ %def jets_test
	@ This test is actually the minimal example from the FastJet manual,
	translated to Fortran.

	Note that FastJet creates pseudojet vectors, which we mirror in the
	[[pseudojet_vector_t]], but immediately assign to pseudojet arrays. Without
	automatic finalization available in the compilers, we should avoid this in
	actual code and rather introduce intermediate variables for those objects,
	which we can finalize explicitly.
	<<Jets: execute tests>>=
	call test (jets_1, "jets_1", &
	"basic FastJet functionality", &
	u, results)
	<<Jets: test declarations>>=
	public :: jets_1
	<<Jets: tests>>=
	subroutine jets_1 (u)
	integer, intent(in) :: u

	type(pseudojet_t), dimension(:), allocatable :: prt, jets, constituents
	type(jet_definition_t) :: jet_def
	type(cluster_sequence_t) :: cs

	integer, parameter :: dp = default
	integer :: i, j

	write (u, "(A)") "* Test output: jets_1"
	write (u, "(A)") "* Purpose: test basic FastJet functionality"
	write (u, "(A)")

	write (u, "(A)") "* Print banner"
	call print_banner ()

	write (u, *)
	write (u, "(A)") "* Prepare input particles"
	allocate (prt (3))
	call prt(1)%init ( 99._dp, 0.1_dp, 0._dp, 100._dp)
	call prt(2)%init ( 4._dp,-0.1_dp, 0._dp, 5._dp)
	call prt(3)%init (-99._dp, 0._dp, 0._dp, 99._dp)

	write (u, *)
	write (u, "(A)") "* Define jet algorithm"
	call jet_def%init (antikt_algorithm, 0.7_dp)

	write (u, *)
	write (u, "(A)") "* Cluster particles according to jet algorithm"

	write (u, *)
	write (u, "(A,A)") "Clustering with ", jet_def%description ()
	call cs%init (pseudojet_vector (prt), jet_def)

	write (u, *)
	write (u, "(A)") "* Sort output jets"
	jets = sorted_by_pt (cs%inclusive_jets ())

	write (u, *)
	write (u, "(A)") "* Print jet observables and constituents"
	write (u, *)
	write (u, "(4x,3(7x,A3))") "pt", "y", "phi"
	do i = 1, size (jets)
	write (u, "(A,1x,I0,A,3(1x,F9.5))") &
	"jet", i, ":", jets(i)%perp (), jets(i)%rap (), jets(i)%phi ()
	constituents = jets(i)%constituents ()
	do j = 1, size (constituents)
	write (u, "(4x,A,1x,I0,A,F9.5)") &
	"constituent", j, "'s pt:", constituents(j)%perp ()
	end do
	do j = 1, size (constituents)
	call constituents(j)%final ()
	end do
	end do

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

	do i = 1, size (prt)
	call prt(i)%final ()
	end do
	do i = 1, size (jets)
	call jets(i)%final ()
	end do
	call jet_def%final ()
	call cs%final ()

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

	end subroutine jets_1

	@ %def jets_1
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Subevents}

	The purpose of subevents is to store the relevant part of the physical
	event (either partonic or hadronic), and to hold particle selections
	and combinations which are constructed in cut or analysis expressions.
	<<[[subevents.f90]]>>=
	<<File header>>

	module subevents

	use, intrinsic :: iso_c_binding !NODEP!

	<<Use kinds>>
	- use io_units
	- use format_defs, only: FMT_14, FMT_19
	- use format_utils, only: pac_fmt
	use numeric_utils, only: pacify
	- use physics_defs
	- use sorting
	use c_particles
	use lorentz
	use pdg_arrays
	use jets

	<<Standard module head>>

	<<Subevents: public>>

	<<Subevents: parameters>>

	<<Subevents: types>>

	<<Subevents: interfaces>>

	+ interface
	+<<Subevents: sub interfaces>>
	+ end interface
	+
	+end module subevents
	+@ %def subevents
	+@
	+<<[[subevents_sub.f90]]>>=
	+<<File header>>
	+
	+submodule (subevents) subevents_s
	+
	+ use io_units
	+ use format_defs, only: FMT_14, FMT_19
	+ use format_utils, only: pac_fmt
	+ use physics_defs
	+ use sorting
	+
	+ implicit none
	+
	contains

	<<Subevents: procedures>>

	-end module subevents
	-@ %def subevents
	+end submodule subevents_s
	+
	+@ %def subevents_s
	@
	\subsection{Particles}
	For the purpose of this module, a particle has a type which can
	indicate a beam, incoming, outgoing, or composite particle, flavor and
	helicity codes (integer, undefined for composite), four-momentum and
	invariant mass squared. (Other particles types are used in extended
	event types, but also defined here.) Furthermore, each particle has
	an allocatable array of ancestors -- particle indices which indicate
	the building blocks of a composite particle. For an incoming/outgoing
	particle, the array contains only the index of the particle itself.

	For incoming particles, the momentum is inverted before storing it in
	the particle object.
	<<Subevents: parameters>>=
	integer, parameter, public :: PRT_UNDEFINED = 0
	integer, parameter, public :: PRT_BEAM = -9
	integer, parameter, public :: PRT_INCOMING = 1
	integer, parameter, public :: PRT_OUTGOING = 2
	integer, parameter, public :: PRT_COMPOSITE = 3
	integer, parameter, public :: PRT_VIRTUAL = 4
	integer, parameter, public :: PRT_RESONANT = 5
	integer, parameter, public :: PRT_BEAM_REMNANT = 9

	@ %def PRT_UNDEFINED PRT_BEAM
	@ %def PRT_INCOMING PRT_OUTGOING PRT_COMPOSITE
	@ %def PRT_COMPOSITE PRT_VIRTUAL PRT_RESONANT
	@ %def PRT_BEAM_REMNANT
	@
	\subsubsection{The type}
	We initialize only the type here and mark as unpolarized. The
	initializers below do the rest. The logicals [[is_b_jet]] and
	[[is_c_jet]] are true only if [[prt_t]] comes out of the
	[[subevt_cluster]] routine and fulfils the correct flavor content.
	<<Subevents: public>>=
	public :: prt_t
	<<Subevents: types>>=
	type :: prt_t
	private
	integer :: type = PRT_UNDEFINED
	integer :: pdg
	logical :: polarized = .false.
	logical :: colorized = .false.
	logical :: clustered = .false.
	logical :: is_b_jet = .false.
	logical :: is_c_jet = .false.
	integer :: h
	type(vector4_t) :: p
	real(default) :: p2
	integer, dimension(:), allocatable :: src
	integer, dimension(:), allocatable :: col
	integer, dimension(:), allocatable :: acl
	end type prt_t

	@ %def prt_t
	@ Initializers. Polarization is set separately. Finalizers are not
	needed.
	<<Subevents: procedures>>=
	subroutine prt_init_beam (prt, pdg, p, p2, src)
	type(prt_t), intent(out) :: prt
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in) :: src
	prt%type = PRT_BEAM
	call prt_set (prt, pdg, - p, p2, src)
	end subroutine prt_init_beam

	subroutine prt_init_incoming (prt, pdg, p, p2, src)
	type(prt_t), intent(out) :: prt
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in) :: src
	prt%type = PRT_INCOMING
	call prt_set (prt, pdg, - p, p2, src)
	end subroutine prt_init_incoming

	subroutine prt_init_outgoing (prt, pdg, p, p2, src)
	type(prt_t), intent(out) :: prt
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in) :: src
	prt%type = PRT_OUTGOING
	call prt_set (prt, pdg, p, p2, src)
	end subroutine prt_init_outgoing

	subroutine prt_init_composite (prt, p, src)
	type(prt_t), intent(out) :: prt
	type(vector4_t), intent(in) :: p
	integer, dimension(:), intent(in) :: src
	prt%type = PRT_COMPOSITE
	call prt_set (prt, 0, p, p**2, src)
	end subroutine prt_init_composite

	@ %def prt_init_beam prt_init_incoming prt_init_outgoing prt_init_composite
	@
	This version is for temporary particle objects, so the [[src]] array
	is not set.
	<<Subevents: public>>=
	public :: prt_init_combine
	+<<Subevents: sub interfaces>>=
	+ module subroutine prt_init_combine (prt, prt1, prt2)
	+ type(prt_t), intent(out) :: prt
	+ type(prt_t), intent(in) :: prt1, prt2
	+ end subroutine prt_init_combine
	<<Subevents: procedures>>=
	- subroutine prt_init_combine (prt, prt1, prt2)
	+ module subroutine prt_init_combine (prt, prt1, prt2)
	type(prt_t), intent(out) :: prt
	type(prt_t), intent(in) :: prt1, prt2
	type(vector4_t) :: p
	integer, dimension(0) :: src
	prt%type = PRT_COMPOSITE
	p = prt1%p + prt2%p
	call prt_set (prt, 0, p, p**2, src)
	end subroutine prt_init_combine

	@ %def prt_init_combine
	@ Init from a pseudojet object.
	<<Subevents: procedures>>=
	subroutine prt_init_pseudojet (prt, jet, src, pdg, is_b_jet, is_c_jet)
	type(prt_t), intent(out) :: prt
	type(pseudojet_t), intent(in) :: jet
	integer, dimension(:), intent(in) :: src
	integer, intent(in) :: pdg
	logical, intent(in) :: is_b_jet, is_c_jet
	type(vector4_t) :: p
	prt%type = PRT_COMPOSITE
	p = vector4_moving (jet%e(), &
	vector3_moving ([jet%px(), jet%py(), jet%pz()]))
	call prt_set (prt, pdg, p, p**2, src)
	prt%is_b_jet = is_b_jet
	prt%is_c_jet = is_c_jet
	prt%clustered = .true.
	end subroutine prt_init_pseudojet

	@ %def prt_init_pseudojet
	@
	\subsubsection{Accessing contents}
	<<Subevents: public>>=
	public :: prt_get_pdg
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_get_pdg (prt) result (pdg)
	+ integer :: pdg
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_pdg
	<<Subevents: procedures>>=
	- elemental function prt_get_pdg (prt) result (pdg)
	+ elemental module function prt_get_pdg (prt) result (pdg)
	integer :: pdg
	type(prt_t), intent(in) :: prt
	pdg = prt%pdg
	end function prt_get_pdg

	@ %def prt_get_pdg
	<<Subevents: public>>=
	public :: prt_get_momentum
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_get_momentum (prt) result (p)
	+ type(vector4_t) :: p
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_momentum
	<<Subevents: procedures>>=
	- elemental function prt_get_momentum (prt) result (p)
	+ elemental module function prt_get_momentum (prt) result (p)
	type(vector4_t) :: p
	type(prt_t), intent(in) :: prt
	p = prt%p
	end function prt_get_momentum

	@ %def prt_get_momentum
	<<Subevents: public>>=
	public :: prt_get_msq
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_get_msq (prt) result (msq)
	+ real(default) :: msq
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_msq
	<<Subevents: procedures>>=
	- elemental function prt_get_msq (prt) result (msq)
	+ elemental module function prt_get_msq (prt) result (msq)
	real(default) :: msq
	type(prt_t), intent(in) :: prt
	msq = prt%p2
	end function prt_get_msq

	@ %def prt_get_msq
	<<Subevents: public>>=
	public :: prt_is_polarized
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_polarized (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_polarized
	<<Subevents: procedures>>=
	- elemental function prt_is_polarized (prt) result (flag)
	+ elemental module function prt_is_polarized (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%polarized
	end function prt_is_polarized

	@ %def prt_is_polarized
	<<Subevents: public>>=
	public :: prt_get_helicity
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_get_helicity (prt) result (h)
	+ integer :: h
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_helicity
	<<Subevents: procedures>>=
	- elemental function prt_get_helicity (prt) result (h)
	+ elemental module function prt_get_helicity (prt) result (h)
	integer :: h
	type(prt_t), intent(in) :: prt
	h = prt%h
	end function prt_get_helicity

	@ %def prt_get_helicity
	<<Subevents: public>>=
	public :: prt_is_colorized
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_colorized (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_colorized
	<<Subevents: procedures>>=
	- elemental function prt_is_colorized (prt) result (flag)
	+ elemental module function prt_is_colorized (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%colorized
	end function prt_is_colorized

	@ %def prt_is_colorized
	<<Subevents: public>>=
	public :: prt_is_clustered
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_clustered (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_clustered
	<<Subevents: procedures>>=
	- elemental function prt_is_clustered (prt) result (flag)
	+ elemental module function prt_is_clustered (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%clustered
	end function prt_is_clustered

	@ %def prt_is_clustered
	<<Subevents: public>>=
	public :: prt_is_recombinable
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_recombinable (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_recombinable
	<<Subevents: procedures>>=
	- elemental function prt_is_recombinable (prt) result (flag)
	+ elemental module function prt_is_recombinable (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt_is_parton (prt) .or. &
	abs(prt%pdg) == TOP_Q .or. &
	prt_is_lepton (prt) .or. &
	prt_is_photon (prt)
	end function prt_is_recombinable

	@ %def prt_is_recombinable
	<<Subevents: public>>=
	public :: prt_is_photon
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_photon (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_photon
	<<Subevents: procedures>>=
	- elemental function prt_is_photon (prt) result (flag)
	+ elemental module function prt_is_photon (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%pdg == PHOTON
	end function prt_is_photon
	-
	+
	@ %def prt_is_photon
	We do not take the top quark into account here.
	<<Subevents: public>>=
	public :: prt_is_parton
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_parton (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_parton
	<<Subevents: procedures>>=
	- elemental function prt_is_parton (prt) result (flag)
	+ elemental module function prt_is_parton (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = abs(prt%pdg) == DOWN_Q .or. &
	abs(prt%pdg) == UP_Q .or. &
	abs(prt%pdg) == STRANGE_Q .or. &
	abs(prt%pdg) == CHARM_Q .or. &
	abs(prt%pdg) == BOTTOM_Q .or. &
	prt%pdg == GLUON
	end function prt_is_parton
	-
	+
	@ %def prt_is_parton
	<<Subevents: public>>=
	public :: prt_is_lepton
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_lepton (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_lepton
	<<Subevents: procedures>>=
	- elemental function prt_is_lepton (prt) result (flag)
	+ elemental module function prt_is_lepton (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = abs(prt%pdg) == ELECTRON .or. &
	abs(prt%pdg) == MUON .or. &
	abs(prt%pdg) == TAU
	end function prt_is_lepton
	-
	+
	@ %def prt_is_lepton
	<<Subevents: public>>=
	public :: prt_is_b_jet
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_b_jet (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_b_jet
	<<Subevents: procedures>>=
	- elemental function prt_is_b_jet (prt) result (flag)
	+ elemental module function prt_is_b_jet (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%is_b_jet
	end function prt_is_b_jet

	@ %def prt_is_b_jet
	<<Subevents: public>>=
	public :: prt_is_c_jet
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_is_c_jet (prt) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt
	+ end function prt_is_c_jet
	<<Subevents: procedures>>=
	- elemental function prt_is_c_jet (prt) result (flag)
	+ elemental module function prt_is_c_jet (prt) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt
	flag = prt%is_c_jet
	end function prt_is_c_jet

	@ %def prt_is_c_jet
	@ The number of open color (anticolor) lines. We inspect the list of color
	(anticolor) lines and count the entries that do not appear in the list
	of anticolors (colors). (There is no check against duplicates; we assume that
	color line indices are unique.)
	<<Subevents: public>>=
	public :: prt_get_n_col
	public :: prt_get_n_acl
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_get_n_col (prt) result (n)
	+ integer :: n
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_n_col
	+ elemental module function prt_get_n_acl (prt) result (n)
	+ integer :: n
	+ type(prt_t), intent(in) :: prt
	+ end function prt_get_n_acl
	<<Subevents: procedures>>=
	- elemental function prt_get_n_col (prt) result (n)
	+ elemental module function prt_get_n_col (prt) result (n)
	integer :: n
	type(prt_t), intent(in) :: prt
	integer, dimension(:), allocatable :: col, acl
	integer :: i
	n = 0
	if (prt%colorized) then
	do i = 1, size (prt%col)
	if (all (prt%col(i) /= prt%acl)) n = n + 1
	end do
	end if
	end function prt_get_n_col

	- elemental function prt_get_n_acl (prt) result (n)
	+ elemental module function prt_get_n_acl (prt) result (n)
	integer :: n
	type(prt_t), intent(in) :: prt
	integer, dimension(:), allocatable :: col, acl
	integer :: i
	n = 0
	if (prt%colorized) then
	do i = 1, size (prt%acl)
	if (all (prt%acl(i) /= prt%col)) n = n + 1
	end do
	end if
	end function prt_get_n_acl

	@ %def prt_get_n_col
	@ %def prt_get_n_acl
	@ Return the color and anticolor-flow line indices explicitly.
	<<Subevents: public>>=
	public :: prt_get_color_indices
	+<<Subevents: sub interfaces>>=
	+ module subroutine prt_get_color_indices (prt, col, acl)
	+ type(prt_t), intent(in) :: prt
	+ integer, dimension(:), allocatable, intent(out) :: col, acl
	+ end subroutine prt_get_color_indices
	<<Subevents: procedures>>=
	- subroutine prt_get_color_indices (prt, col, acl)
	+ module subroutine prt_get_color_indices (prt, col, acl)
	type(prt_t), intent(in) :: prt
	integer, dimension(:), allocatable, intent(out) :: col, acl
	if (prt%colorized) then
	col = prt%col
	acl = prt%acl
	else
	col = [integer::]
	acl = [integer::]
	end if
	end subroutine prt_get_color_indices

	@ %def prt_get_color_indices
	@
	\subsubsection{Setting data}
	Set the PDG, momentum and momentum squared, and ancestors. If
	allocate-on-assignment is available, this can be simplified.
	<<Subevents: procedures>>=
	subroutine prt_set (prt, pdg, p, p2, src)
	type(prt_t), intent(inout) :: prt
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in) :: src
	prt%pdg = pdg
	prt%p = p
	prt%p2 = p2
	if (allocated (prt%src)) then
	if (size (src) /= size (prt%src)) then
	deallocate (prt%src)
	allocate (prt%src (size (src)))
	end if
	else
	allocate (prt%src (size (src)))
	end if
	prt%src = src
	end subroutine prt_set

	@ %def prt_set
	@ Set the particle PDG code separately.
	<<Subevents: procedures>>=
	elemental subroutine prt_set_pdg (prt, pdg)
	type(prt_t), intent(inout) :: prt
	integer, intent(in) :: pdg
	prt%pdg = pdg
	end subroutine prt_set_pdg

	@ %def prt_set_pdg
	@ Set the momentum separately.
	<<Subevents: procedures>>=
	elemental subroutine prt_set_p (prt, p)
	type(prt_t), intent(inout) :: prt
	type(vector4_t), intent(in) :: p
	prt%p = p
	end subroutine prt_set_p

	@ %def prt_set_p
	@ Set the squared invariant mass separately.
	<<Subevents: procedures>>=
	elemental subroutine prt_set_p2 (prt, p2)
	type(prt_t), intent(inout) :: prt
	real(default), intent(in) :: p2
	prt%p2 = p2
	end subroutine prt_set_p2

	@ %def prt_set_p2
	@ Set helicity (optional).
	<<Subevents: procedures>>=
	subroutine prt_polarize (prt, h)
	type(prt_t), intent(inout) :: prt
	integer, intent(in) :: h
	prt%polarized = .true.
	prt%h = h
	end subroutine prt_polarize

	@ %def prt_polarize
	@ Set color-flow indices (optional).
	<<Subevents: procedures>>=
	subroutine prt_colorize (prt, col, acl)
	type(prt_t), intent(inout) :: prt
	integer, dimension(:), intent(in) :: col, acl
	prt%colorized = .true.
	prt%col = col
	prt%acl = acl
	end subroutine prt_colorize

	@ %def prt_colorize
	@
	\subsubsection{Conversion}
	Transform a [[prt_t]] object into a [[c_prt_t]] object.
	<<Subevents: public>>=
	public :: c_prt
	<<Subevents: interfaces>>=
	interface c_prt
	module procedure c_prt_from_prt
	end interface

	@ %def c_prt
	+<<Subevents: sub interfaces>>=
	+ elemental module function c_prt_from_prt (prt) result (c_prt)
	+ type(c_prt_t) :: c_prt
	+ type(prt_t), intent(in) :: prt
	+ end function c_prt_from_prt
	<<Subevents: procedures>>=
	- elemental function c_prt_from_prt (prt) result (c_prt)
	+ elemental module function c_prt_from_prt (prt) result (c_prt)
	type(c_prt_t) :: c_prt
	type(prt_t), intent(in) :: prt
	c_prt = prt%p
	c_prt%type = prt%type
	c_prt%pdg = prt%pdg
	if (prt%polarized) then
	c_prt%polarized = 1
	else
	c_prt%polarized = 0
	end if
	c_prt%h = prt%h
	end function c_prt_from_prt

	@ %def c_prt_from_prt
	@
	\subsubsection{Output}
	<<Subevents: public>>=
	public :: prt_write
	+<<Subevents: sub interfaces>>=
	+ module subroutine prt_write (prt, unit, testflag)
	+ type(prt_t), intent(in) :: prt
	+ integer, intent(in), optional :: unit
	+ logical, intent(in), optional :: testflag
	+ end subroutine prt_write
	<<Subevents: procedures>>=
	- subroutine prt_write (prt, unit, testflag)
	+ module subroutine prt_write (prt, unit, testflag)
	type(prt_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	logical :: pacified
	type(prt_t) :: tmp
	character(len=7) :: fmt
	integer :: u, i
	call pac_fmt (fmt, FMT_19, FMT_14, testflag)
	u = given_output_unit (unit); if (u < 0) return
	pacified = .false. ; if (present (testflag)) pacified = testflag
	tmp = prt
	if (pacified) call pacify (tmp)
	write (u, "(1x,A)", advance="no") "prt("
	select case (prt%type)
	case (PRT_UNDEFINED); write (u, "('?')", advance="no")
	case (PRT_BEAM); write (u, "('b:')", advance="no")
	case (PRT_INCOMING); write (u, "('i:')", advance="no")
	case (PRT_OUTGOING); write (u, "('o:')", advance="no")
	case (PRT_COMPOSITE); write (u, "('c:')", advance="no")
	end select
	select case (prt%type)
	case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
	if (prt%polarized) then
	write (u, "(I0,'/',I0,'\|')", advance="no") prt%pdg, prt%h
	else
	write (u, "(I0,'\|')", advance="no") prt%pdg
	end if
	end select
	select case (prt%type)
	case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
	if (prt%colorized) then
	write (u, "(*(I0,:,','))", advance="no") prt%col
	write (u, "('/')", advance="no")
	write (u, "(*(I0,:,','))", advance="no") prt%acl
	write (u, "('\|')", advance="no")
	end if
	end select
	select case (prt%type)
	case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
	write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // &
	FMT_14 // ",','," // FMT_14 // ")", advance="no") tmp%p
	write (u, "('\|'," // fmt // ")", advance="no") tmp%p2
	end select
	if (allocated (prt%src)) then
	write (u, "('\|')", advance="no")
	do i = 1, size (prt%src)
	write (u, "(1x,I0)", advance="no") prt%src(i)
	end do
	end if
	if (prt%is_b_jet) then
	write (u, "('\|b jet')", advance="no")
	end if
	if (prt%is_c_jet) then
	write (u, "('\|c jet')", advance="no")
	end if
	write (u, "(A)") ")"
	end subroutine prt_write

	@ %def prt_write
	@
	\subsubsection{Tools}
	Two particles match if their [[src]] arrays are the same.
	<<Subevents: public>>=
	public :: operator(.match.)
	<<Subevents: interfaces>>=
	interface operator(.match.)
	module procedure prt_match
	end interface

	@ %def .match.
	+<<Subevents: sub interfaces>>=
	+ elemental module function prt_match (prt1, prt2) result (match)
	+ logical :: match
	+ type(prt_t), intent(in) :: prt1, prt2
	+ end function prt_match
	<<Subevents: procedures>>=
	- elemental function prt_match (prt1, prt2) result (match)
	+ elemental module function prt_match (prt1, prt2) result (match)
	logical :: match
	type(prt_t), intent(in) :: prt1, prt2
	if (size (prt1%src) == size (prt2%src)) then
	match = all (prt1%src == prt2%src)
	else
	match = .false.
	end if
	end function prt_match

	@ %def prt_match
	@ The combine operation makes a pseudoparticle whose momentum is the
	result of adding (the momenta of) the pair of input particles. We
	trace the particles from which a particle is built by storing a
	[[src]] array. Each particle entry in the [[src]] list contains a
	list of indices which indicates its building blocks. The indices
	refer to an original list of particles. Index lists are sorted, and
	they contain no element more than once.

	We thus require that in a given pseudoparticle, each original particle
	occurs at most once.

	The result is intent(inout), so it will not be initialized when the
	subroutine is entered.

	If the particles carry color, we recall that the combined particle is a
	composite which is understood as outgoing. If one of the arguments is an
	incoming particle, is color entries must be reversed.
	<<Subevents: procedures>>=
	subroutine prt_combine (prt, prt_in1, prt_in2, ok)
	type(prt_t), intent(inout) :: prt
	type(prt_t), intent(in) :: prt_in1, prt_in2
	logical :: ok
	integer, dimension(:), allocatable :: src
	integer, dimension(:), allocatable :: col1, acl1, col2, acl2
	call combine_index_lists (src, prt_in1%src, prt_in2%src)
	ok = allocated (src)
	if (ok) then
	call prt_init_composite (prt, prt_in1%p + prt_in2%p, src)
	if (prt_in1%colorized .or. prt_in2%colorized) then
	select case (prt_in1%type)
	case default
	call prt_get_color_indices (prt_in1, col1, acl1)
	case (PRT_BEAM, PRT_INCOMING)
	call prt_get_color_indices (prt_in1, acl1, col1)
	end select
	select case (prt_in2%type)
	case default
	call prt_get_color_indices (prt_in2, col2, acl2)
	case (PRT_BEAM, PRT_INCOMING)
	call prt_get_color_indices (prt_in2, acl2, col2)
	end select
	call prt_colorize (prt, [col1, col2], [acl1, acl2])
	end if
	end if
	end subroutine prt_combine

	@ %def prt_combine
	@ This variant does not produce the combined particle, it just checks
	whether the combination is valid (no common [[src]] entry).
	<<Subevents: public>>=
	public :: are_disjoint
	+<<Subevents: sub interfaces>>=
	+ module function are_disjoint (prt_in1, prt_in2) result (flag)
	+ logical :: flag
	+ type(prt_t), intent(in) :: prt_in1, prt_in2
	+ end function are_disjoint
	<<Subevents: procedures>>=
	- function are_disjoint (prt_in1, prt_in2) result (flag)
	+ module function are_disjoint (prt_in1, prt_in2) result (flag)
	logical :: flag
	type(prt_t), intent(in) :: prt_in1, prt_in2
	flag = index_lists_are_disjoint (prt_in1%src, prt_in2%src)
	end function are_disjoint

	@ %def are_disjoint
	@ [[src]] Lists with length $>1$ are built by a [[combine]] operation
	which merges the lists in a sorted manner. If the result would have a
	duplicate entry, it is discarded, and the result is unallocated.
	<<Subevents: procedures>>=
	subroutine combine_index_lists (res, src1, src2)
	integer, dimension(:), intent(in) :: src1, src2
	integer, dimension(:), allocatable :: res
	integer :: i1, i2, i
	allocate (res (size (src1) + size (src2)))
	if (size (src1) == 0) then
	res = src2
	return
	else if (size (src2) == 0) then
	res = src1
	return
	end if
	i1 = 1
	i2 = 1
	LOOP: do i = 1, size (res)
	if (src1(i1) < src2(i2)) then
	res(i) = src1(i1); i1 = i1 + 1
	if (i1 > size (src1)) then
	res(i+1:) = src2(i2:)
	exit LOOP
	end if
	else if (src1(i1) > src2(i2)) then
	res(i) = src2(i2); i2 = i2 + 1
	if (i2 > size (src2)) then
	res(i+1:) = src1(i1:)
	exit LOOP
	end if
	else
	deallocate (res)
	exit LOOP
	end if
	end do LOOP
	end subroutine combine_index_lists

	@ %def combine_index_lists
	@ This function is similar, but it does not actually merge the list,
	it just checks whether they are disjoint (no common [[src]] entry).
	<<Subevents: procedures>>=
	function index_lists_are_disjoint (src1, src2) result (flag)
	logical :: flag
	integer, dimension(:), intent(in) :: src1, src2
	integer :: i1, i2, i
	flag = .true.
	i1 = 1
	i2 = 1
	LOOP: do i = 1, size (src1) + size (src2)
	if (src1(i1) < src2(i2)) then
	i1 = i1 + 1
	if (i1 > size (src1)) then
	exit LOOP
	end if
	else if (src1(i1) > src2(i2)) then
	i2 = i2 + 1
	if (i2 > size (src2)) then
	exit LOOP
	end if
	else
	flag = .false.
	exit LOOP
	end if
	end do LOOP
	end function index_lists_are_disjoint

	@ %def index_lists_are_disjoint
	@
	\subsection{subevents}
	Particles are collected in subevents. This type is implemented as a
	dynamically allocated array, which need not be completely filled. The
	value [[n_active]] determines the number of meaningful entries.

	\subsubsection{Type definition}
	<<Subevents: public>>=
	public :: subevt_t
	<<Subevents: types>>=
	type :: subevt_t
	private
	integer :: n_active = 0
	type(prt_t), dimension(:), allocatable :: prt
	contains
	<<Subevents: subevt: TBP>>
	end type subevt_t

	@ %def subevt_t
	@ Initialize, allocating with size zero (default) or given size. The
	number of contained particles is set equal to the size.
	<<Subevents: public>>=
	public :: subevt_init
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_init (subevt, n_active)
	+ type(subevt_t), intent(out) :: subevt
	+ integer, intent(in), optional :: n_active
	+ end subroutine subevt_init
	<<Subevents: procedures>>=
	- subroutine subevt_init (subevt, n_active)
	+ module subroutine subevt_init (subevt, n_active)
	type(subevt_t), intent(out) :: subevt
	integer, intent(in), optional :: n_active
	if (present (n_active)) subevt%n_active = n_active
	allocate (subevt%prt (subevt%n_active))
	end subroutine subevt_init

	@ %def subevt_init
	@ (Re-)allocate the subevent with some given size. If the size
	is greater than the previous one, do a real reallocation. Otherwise,
	just reset the recorded size. Contents are untouched, but become
	invalid.
	-<<Subevents: public>>=
	- public :: subevt_reset
	+<<Subevents: subevt: TBP>>=
	+ procedure :: reset => subevt_reset
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_reset (subevt, n_active)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: n_active
	+ end subroutine subevt_reset
	<<Subevents: procedures>>=
	- subroutine subevt_reset (subevt, n_active)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_reset (subevt, n_active)
	+ class(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: n_active
	subevt%n_active = n_active
	if (subevt%n_active > size (subevt%prt)) then
	deallocate (subevt%prt)
	allocate (subevt%prt (subevt%n_active))
	end if
	end subroutine subevt_reset

	@ %def subevt_reset
	@ Output. No prefix for the headline 'subevt', because this will usually be
	printed appending to a previous line.
	-<<Subevents: public>>=
	- public :: subevt_write
	<<Subevents: subevt: TBP>>=
	procedure :: write => subevt_write
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_write (object, unit, prefix, pacified)
	+ class(subevt_t), intent(in) :: object
	+ integer, intent(in), optional :: unit
	+ character(*), intent(in), optional :: prefix
	+ logical, intent(in), optional :: pacified
	+ end subroutine subevt_write
	<<Subevents: procedures>>=
	- subroutine subevt_write (object, unit, prefix, pacified)
	+ module subroutine subevt_write (object, unit, prefix, pacified)
	class(subevt_t), intent(in) :: object
	integer, intent(in), optional :: unit
	character(*), intent(in), optional :: prefix
	logical, intent(in), optional :: pacified
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "subevent:"
	do i = 1, object%n_active
	if (present (prefix)) write (u, "(A)", advance="no") prefix
	write (u, "(1x,I0)", advance="no") i
	call prt_write (object%prt(i), unit = unit, testflag = pacified)
	end do
	end subroutine subevt_write

	@ %def subevt_write
	@ Defined assignment: transfer only meaningful entries. This is a
	deep copy (as would be default assignment).
	<<Subevents: interfaces>>=
	interface assignment(=)
	module procedure subevt_assign
	end interface

	@ %def =
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_assign (subevt, subevt_in)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: subevt_in
	+ end subroutine subevt_assign
	<<Subevents: procedures>>=
	- subroutine subevt_assign (subevt, subevt_in)
	+ module subroutine subevt_assign (subevt, subevt_in)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: subevt_in
	if (.not. allocated (subevt%prt)) then
	call subevt_init (subevt, subevt_in%n_active)
	else
	- call subevt_reset (subevt, subevt_in%n_active)
	+ call subevt%reset (subevt_in%n_active)
	end if
	subevt%prt(:subevt%n_active) = subevt_in%prt(:subevt%n_active)
	end subroutine subevt_assign

	@ %def subevt_assign
	@
	\subsubsection{Fill contents}
	Store incoming/outgoing particles which are completely defined.
	<<Subevents: public>>=
	- public :: subevt_set_beam
	- public :: subevt_set_incoming
	- public :: subevt_set_outgoing
	- public :: subevt_set_composite
	+<<Subevents: subevt: TBP>>=
	+ procedure :: set_beam => subevt_set_beam
	+ procedure :: set_composite => subevt_set_composite
	+ procedure :: set_incoming => subevt_set_incoming
	+ procedure :: set_outgoing => subevt_set_outgoing
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_set_beam (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i
	+ integer, intent(in) :: pdg
	+ type(vector4_t), intent(in) :: p
	+ real(default), intent(in) :: p2
	+ integer, dimension(:), intent(in), optional :: src
	+ end subroutine subevt_set_beam
	+ module subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i
	+ integer, intent(in) :: pdg
	+ type(vector4_t), intent(in) :: p
	+ real(default), intent(in) :: p2
	+ integer, dimension(:), intent(in), optional :: src
	+ end subroutine subevt_set_incoming
	+ module subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i
	+ integer, intent(in) :: pdg
	+ type(vector4_t), intent(in) :: p
	+ real(default), intent(in) :: p2
	+ integer, dimension(:), intent(in), optional :: src
	+ end subroutine subevt_set_outgoing
	+ module subroutine subevt_set_composite (subevt, i, p, src)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i
	+ type(vector4_t), intent(in) :: p
	+ integer, dimension(:), intent(in) :: src
	+ end subroutine subevt_set_composite
	<<Subevents: procedures>>=
	- subroutine subevt_set_beam (subevt, i, pdg, p, p2, src)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_beam (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in), optional :: src
	if (present (src)) then
	call prt_init_beam (subevt%prt(i), pdg, p, p2, src)
	else
	call prt_init_beam (subevt%prt(i), pdg, p, p2, [i])
	end if
	end subroutine subevt_set_beam

	- subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in), optional :: src
	if (present (src)) then
	call prt_init_incoming (subevt%prt(i), pdg, p, p2, src)
	else
	call prt_init_incoming (subevt%prt(i), pdg, p, p2, [i])
	end if
	end subroutine subevt_set_incoming

	- subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src)
	+ class(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i
	integer, intent(in) :: pdg
	type(vector4_t), intent(in) :: p
	real(default), intent(in) :: p2
	integer, dimension(:), intent(in), optional :: src
	if (present (src)) then
	call prt_init_outgoing (subevt%prt(i), pdg, p, p2, src)
	else
	call prt_init_outgoing (subevt%prt(i), pdg, p, p2, [i])
	end if
	end subroutine subevt_set_outgoing

	- subroutine subevt_set_composite (subevt, i, p, src)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_composite (subevt, i, p, src)
	+ class(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i
	type(vector4_t), intent(in) :: p
	integer, dimension(:), intent(in) :: src
	call prt_init_composite (subevt%prt(i), p, src)
	end subroutine subevt_set_composite

	@ %def subevt_set_incoming subevt_set_outgoing subevt_set_composite
	@ Separately assign flavors, simultaneously for all incoming/outgoing
	particles.
	-<<Subevents: public>>=
	- public :: subevt_set_pdg_beam
	- public :: subevt_set_pdg_incoming
	- public :: subevt_set_pdg_outgoing
	+<<Subevents: subevt: TBP>>=
	+ procedure :: set_pdg_beam => subevt_set_pdg_beam
	+ procedure :: set_pdg_incoming => subevt_set_pdg_incoming
	+ procedure :: set_pdg_outgoing => subevt_set_pdg_outgoing
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_set_pdg_beam (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, dimension(:), intent(in) :: pdg
	+ end subroutine subevt_set_pdg_beam
	+ module subroutine subevt_set_pdg_incoming (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, dimension(:), intent(in) :: pdg
	+ end subroutine subevt_set_pdg_incoming
	+ module subroutine subevt_set_pdg_outgoing (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	+ integer, dimension(:), intent(in) :: pdg
	+ end subroutine subevt_set_pdg_outgoing
	<<Subevents: procedures>>=
	- subroutine subevt_set_pdg_beam (subevt, pdg)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_pdg_beam (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	integer, dimension(:), intent(in) :: pdg
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_BEAM) then
	call prt_set_pdg (subevt%prt(i), pdg(j))
	j = j + 1
	if (j > size (pdg)) exit
	end if
	end do
	end subroutine subevt_set_pdg_beam

	- subroutine subevt_set_pdg_incoming (subevt, pdg)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_pdg_incoming (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	integer, dimension(:), intent(in) :: pdg
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_INCOMING) then
	call prt_set_pdg (subevt%prt(i), pdg(j))
	j = j + 1
	if (j > size (pdg)) exit
	end if
	end do
	end subroutine subevt_set_pdg_incoming

	- subroutine subevt_set_pdg_outgoing (subevt, pdg)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_pdg_outgoing (subevt, pdg)
	+ class(subevt_t), intent(inout) :: subevt
	integer, dimension(:), intent(in) :: pdg
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_OUTGOING) then
	call prt_set_pdg (subevt%prt(i), pdg(j))
	j = j + 1
	if (j > size (pdg)) exit
	end if
	end do
	end subroutine subevt_set_pdg_outgoing

	@ %def subevt_set_pdg_beam
	@ %def subevt_set_pdg_incoming
	@ %def subevt_set_pdg_outgoing
	@ Separately assign momenta, simultaneously for all incoming/outgoing
	particles.
	-<<Subevents: public>>=
	- public :: subevt_set_p_beam
	- public :: subevt_set_p_incoming
	- public :: subevt_set_p_outgoing
	+<<Subevents: subevt: TBP>>=
	+ procedure :: set_p_beam => subevt_set_p_beam
	+ procedure :: set_p_incoming => subevt_set_p_incoming
	+ procedure :: set_p_outgoing => subevt_set_p_outgoing
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_set_p_beam (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	+ type(vector4_t), dimension(:), intent(in) :: p
	+ end subroutine subevt_set_p_beam
	+ module subroutine subevt_set_p_incoming (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	+ type(vector4_t), dimension(:), intent(in) :: p
	+ end subroutine subevt_set_p_incoming
	+ module subroutine subevt_set_p_outgoing (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	+ type(vector4_t), dimension(:), intent(in) :: p
	+ end subroutine subevt_set_p_outgoing
	<<Subevents: procedures>>=
	- subroutine subevt_set_p_beam (subevt, p)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p_beam (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_BEAM) then
	call prt_set_p (subevt%prt(i), p(j))
	j = j + 1
	if (j > size (p)) exit
	end if
	end do
	end subroutine subevt_set_p_beam

	- subroutine subevt_set_p_incoming (subevt, p)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p_incoming (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_INCOMING) then
	call prt_set_p (subevt%prt(i), p(j))
	j = j + 1
	if (j > size (p)) exit
	end if
	end do
	end subroutine subevt_set_p_incoming

	- subroutine subevt_set_p_outgoing (subevt, p)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p_outgoing (subevt, p)
	+ class(subevt_t), intent(inout) :: subevt
	type(vector4_t), dimension(:), intent(in) :: p
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_OUTGOING) then
	call prt_set_p (subevt%prt(i), p(j))
	j = j + 1
	if (j > size (p)) exit
	end if
	end do
	end subroutine subevt_set_p_outgoing

	@ %def subevt_set_p_beam
	@ %def subevt_set_p_incoming
	@ %def subevt_set_p_outgoing
	@ Separately assign the squared invariant mass, simultaneously for all
	incoming/outgoing particles.
	-<<Subevents: public>>=
	- public :: subevt_set_p2_beam
	- public :: subevt_set_p2_incoming
	- public :: subevt_set_p2_outgoing
	+<<Subevents: subevt: TBP>>=
	+ procedure :: set_p2_beam => subevt_set_p2_beam
	+ procedure :: set_p2_incoming => subevt_set_p2_incoming
	+ procedure :: set_p2_outgoing => subevt_set_p2_outgoing
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_set_p2_beam (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	+ real(default), dimension(:), intent(in) :: p2
	+ end subroutine subevt_set_p2_beam
	+ module subroutine subevt_set_p2_incoming (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	+ real(default), dimension(:), intent(in) :: p2
	+ end subroutine subevt_set_p2_incoming
	+ module subroutine subevt_set_p2_outgoing (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	+ real(default), dimension(:), intent(in) :: p2
	+ end subroutine subevt_set_p2_outgoing
	<<Subevents: procedures>>=
	- subroutine subevt_set_p2_beam (subevt, p2)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p2_beam (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	real(default), dimension(:), intent(in) :: p2
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_BEAM) then
	call prt_set_p2 (subevt%prt(i), p2(j))
	j = j + 1
	if (j > size (p2)) exit
	end if
	end do
	end subroutine subevt_set_p2_beam

	- subroutine subevt_set_p2_incoming (subevt, p2)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p2_incoming (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	real(default), dimension(:), intent(in) :: p2
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_INCOMING) then
	call prt_set_p2 (subevt%prt(i), p2(j))
	j = j + 1
	if (j > size (p2)) exit
	end if
	end do
	end subroutine subevt_set_p2_incoming

	- subroutine subevt_set_p2_outgoing (subevt, p2)
	- type(subevt_t), intent(inout) :: subevt
	+ module subroutine subevt_set_p2_outgoing (subevt, p2)
	+ class(subevt_t), intent(inout) :: subevt
	real(default), dimension(:), intent(in) :: p2
	integer :: i, j
	j = 1
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_OUTGOING) then
	call prt_set_p2 (subevt%prt(i), p2(j))
	j = j + 1
	if (j > size (p2)) exit
	end if
	end do
	end subroutine subevt_set_p2_outgoing

	@ %def subevt_set_p2_beam
	@ %def subevt_set_p2_incoming
	@ %def subevt_set_p2_outgoing
	@ Set polarization for an entry
	<<Subevents: public>>=
	public :: subevt_polarize
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_polarize (subevt, i, h)
	+ type(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i, h
	+ end subroutine subevt_polarize
	<<Subevents: procedures>>=
	- subroutine subevt_polarize (subevt, i, h)
	+ module subroutine subevt_polarize (subevt, i, h)
	type(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i, h
	call prt_polarize (subevt%prt(i), h)
	end subroutine subevt_polarize

	@ %def subevt_polarize
	@ Set color-flow indices for an entry
	<<Subevents: public>>=
	public :: subevt_colorize
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_colorize (subevt, i, col, acl)
	+ type(subevt_t), intent(inout) :: subevt
	+ integer, intent(in) :: i, col, acl
	+ end subroutine subevt_colorize
	<<Subevents: procedures>>=
	- subroutine subevt_colorize (subevt, i, col, acl)
	+ module subroutine subevt_colorize (subevt, i, col, acl)
	type(subevt_t), intent(inout) :: subevt
	integer, intent(in) :: i, col, acl
	if (col > 0 .and. acl > 0) then
	call prt_colorize (subevt%prt(i), [col], [acl])
	else if (col > 0) then
	call prt_colorize (subevt%prt(i), [col], [integer ::])
	else if (acl > 0) then
	call prt_colorize (subevt%prt(i), [integer ::], [acl])
	else
	call prt_colorize (subevt%prt(i), [integer ::], [integer ::])
	end if
	end subroutine subevt_colorize

	@ %def subevt_colorize
	@
	\subsubsection{Accessing contents}
	Return true if the subevent has entries.
	-<<Subevents: public>>=
	- public :: subevt_is_nonempty
	+<<Subevents: subevt: TBP>>=
	+ procedure :: is_nonempty => subevt_is_nonempty
	+<<Subevents: sub interfaces>>=
	+ module function subevt_is_nonempty (subevt) result (flag)
	+ logical :: flag
	+ class(subevt_t), intent(in) :: subevt
	+ end function subevt_is_nonempty
	<<Subevents: procedures>>=
	- function subevt_is_nonempty (subevt) result (flag)
	+ module function subevt_is_nonempty (subevt) result (flag)
	logical :: flag
	- type(subevt_t), intent(in) :: subevt
	+ class(subevt_t), intent(in) :: subevt
	flag = subevt%n_active /= 0
	end function subevt_is_nonempty

	@ %def subevt_is_nonempty
	@ Return the number of entries
	-<<Subevents: public>>=
	- public :: subevt_get_length
	+<<Subevents: subevt: TBP>>=
	+ procedure :: get_length => subevt_get_length
	+<<Subevents: sub interfaces>>=
	+ module function subevt_get_length (subevt) result (length)
	+ integer :: length
	+ class(subevt_t), intent(in) :: subevt
	+ end function subevt_get_length
	<<Subevents: procedures>>=
	- function subevt_get_length (subevt) result (length)
	+ module function subevt_get_length (subevt) result (length)
	integer :: length
	- type(subevt_t), intent(in) :: subevt
	+ class(subevt_t), intent(in) :: subevt
	length = subevt%n_active
	end function subevt_get_length

	@ %def subevt_get_length
	@ Return a specific particle. The index is not checked for validity.
	-<<Subevents: public>>=
	- public :: subevt_get_prt
	+<<Subevents: subevt: TBP>>=
	+ procedure :: get_prt => subevt_get_prt
	+<<Subevents: sub interfaces>>=
	+ module function subevt_get_prt (subevt, i) result (prt)
	+ type(prt_t) :: prt
	+ class(subevt_t), intent(in) :: subevt
	+ integer, intent(in) :: i
	+ end function subevt_get_prt
	<<Subevents: procedures>>=
	- function subevt_get_prt (subevt, i) result (prt)
	+ module function subevt_get_prt (subevt, i) result (prt)
	type(prt_t) :: prt
	- type(subevt_t), intent(in) :: subevt
	+ class(subevt_t), intent(in) :: subevt
	integer, intent(in) :: i
	prt = subevt%prt(i)
	end function subevt_get_prt

	@ %def subevt_get_prt
	@ Return the partonic energy squared. We take the particles with flag
	[[PRT_INCOMING]] and compute their total invariant mass.
	-<<Subevents: public>>=
	- public :: subevt_get_sqrts_hat
	+<<Subevents: subevt: TBP>>=
	+ procedure :: get_sqrts_hat => subevt_get_sqrts_hat
	+<<Subevents: sub interfaces>>=
	+ module function subevt_get_sqrts_hat (subevt) result (sqrts_hat)
	+ class(subevt_t), intent(in) :: subevt
	+ real(default) :: sqrts_hat
	+ end function subevt_get_sqrts_hat
	<<Subevents: procedures>>=
	- function subevt_get_sqrts_hat (subevt) result (sqrts_hat)
	- type(subevt_t), intent(in) :: subevt
	+ module function subevt_get_sqrts_hat (subevt) result (sqrts_hat)
	+ class(subevt_t), intent(in) :: subevt
	real(default) :: sqrts_hat
	type(vector4_t) :: p
	integer :: i
	do i = 1, subevt%n_active
	if (subevt%prt(i)%type == PRT_INCOMING) then
	p = p + prt_get_momentum (subevt%prt(i))
	end if
	end do
	sqrts_hat = p ** 1
	end function subevt_get_sqrts_hat

	@ %def subevt_get_sqrts_hat
	@ Return the number of incoming (outgoing) particles, respectively.
	Beam particles or composites are not counted.
	-<<Subevents: public>>=
	- public :: subevt_get_n_in
	- public :: subevt_get_n_out
	+<<Subevents: subevt: TBP>>=
	+ procedure :: get_n_in => subevt_get_n_in
	+ procedure :: get_n_out => subevt_get_n_out
	+<<Subevents: sub interfaces>>=
	+ module function subevt_get_n_in (subevt) result (n_in)
	+ class(subevt_t), intent(in) :: subevt
	+ integer :: n_in
	+ end function subevt_get_n_in
	+ module function subevt_get_n_out (subevt) result (n_out)
	+ class(subevt_t), intent(in) :: subevt
	+ integer :: n_out
	+ end function subevt_get_n_out
	<<Subevents: procedures>>=
	- function subevt_get_n_in (subevt) result (n_in)
	- type(subevt_t), intent(in) :: subevt
	+ module function subevt_get_n_in (subevt) result (n_in)
	+ class(subevt_t), intent(in) :: subevt
	integer :: n_in
	n_in = count (subevt%prt(:subevt%n_active)%type == PRT_INCOMING)
	end function subevt_get_n_in

	- function subevt_get_n_out (subevt) result (n_out)
	- type(subevt_t), intent(in) :: subevt
	+ module function subevt_get_n_out (subevt) result (n_out)
	+ class(subevt_t), intent(in) :: subevt
	integer :: n_out
	n_out = count (subevt%prt(:subevt%n_active)%type == PRT_OUTGOING)
	end function subevt_get_n_out

	@ %def subevt_get_n_in
	@ %def subevt_get_n_out
	@
	<<Subevents: interfaces>>=
	interface c_prt
	module procedure c_prt_from_subevt
	module procedure c_prt_array_from_subevt
	end interface

	@ %def c_prt
	+<<Subevents: sub interfaces>>=
	+ module function c_prt_from_subevt (subevt, i) result (c_prt)
	+ type(c_prt_t) :: c_prt
	+ type(subevt_t), intent(in) :: subevt
	+ integer, intent(in) :: i
	+ end function c_prt_from_subevt
	+ module function c_prt_array_from_subevt (subevt) result (c_prt_array)
	+ type(subevt_t), intent(in) :: subevt
	+ type(c_prt_t), dimension(subevt%n_active) :: c_prt_array
	+ end function c_prt_array_from_subevt
	<<Subevents: procedures>>=
	- function c_prt_from_subevt (subevt, i) result (c_prt)
	+ module function c_prt_from_subevt (subevt, i) result (c_prt)
	type(c_prt_t) :: c_prt
	type(subevt_t), intent(in) :: subevt
	integer, intent(in) :: i
	c_prt = c_prt_from_prt (subevt%prt(i))
	end function c_prt_from_subevt

	- function c_prt_array_from_subevt (subevt) result (c_prt_array)
	+ module function c_prt_array_from_subevt (subevt) result (c_prt_array)
	type(subevt_t), intent(in) :: subevt
	type(c_prt_t), dimension(subevt%n_active) :: c_prt_array
	c_prt_array = c_prt_from_prt (subevt%prt(1:subevt%n_active))
	end function c_prt_array_from_subevt

	@ %def c_prt_from_subevt
	@ %def c_prt_array_from_subevt
	@
	\subsubsection{Operations with subevents}
	The join operation joins two subevents. When appending the
	elements of the second list, we check for each particle whether it is
	already in the first list. If yes, it is discarded. The result list
	should be initialized already.

	If a mask is present, it refers to the second subevent.
	Particles where the mask is not set are discarded.
	<<Subevents: public>>=
	public :: subevt_join
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_join (subevt, pl1, pl2, mask2)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl1, pl2
	+ logical, dimension(:), intent(in), optional :: mask2
	+ end subroutine subevt_join
	<<Subevents: procedures>>=
	- subroutine subevt_join (subevt, pl1, pl2, mask2)
	+ module subroutine subevt_join (subevt, pl1, pl2, mask2)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl1, pl2
	logical, dimension(:), intent(in), optional :: mask2
	integer :: n1, n2, i, n
	n1 = pl1%n_active
	n2 = pl2%n_active
	- call subevt_reset (subevt, n1 + n2)
	+ call subevt%reset (n1 + n2)
	subevt%prt(:n1) = pl1%prt(:n1)
	n = n1
	if (present (mask2)) then
	do i = 1, pl2%n_active
	if (mask2(i)) then
	if (disjoint (i)) then
	n = n + 1
	subevt%prt(n) = pl2%prt(i)
	end if
	end if
	end do
	else
	do i = 1, pl2%n_active
	if (disjoint (i)) then
	n = n + 1
	subevt%prt(n) = pl2%prt(i)
	end if
	end do
	end if
	subevt%n_active = n
	contains
	function disjoint (i) result (flag)
	integer, intent(in) :: i
	logical :: flag
	integer :: j
	do j = 1, pl1%n_active
	if (.not. are_disjoint (pl1%prt(j), pl2%prt(i))) then
	flag = .false.
	return
	end if
	end do
	flag = .true.
	end function disjoint
	end subroutine subevt_join

	@ %def subevt_join
	@ The combine operation makes a subevent whose entries are the
	result of adding (the momenta of) each pair of particles in the input
	lists. We trace the particles from which a particles is built by
	storing a [[src]] array. Each particle entry in the [[src]] list
	contains a list of indices which indicates its building blocks. The
	indices refer to an original list of particles. Index lists are sorted,
	and they contain no element more than once.

	We thus require that in a given pseudoparticle, each original particle
	occurs at most once.
	<<Subevents: public>>=
	public :: subevt_combine
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_combine (subevt, pl1, pl2, mask12)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl1, pl2
	+ logical, dimension(:,:), intent(in), optional :: mask12
	+ end subroutine subevt_combine
	<<Subevents: procedures>>=
	- subroutine subevt_combine (subevt, pl1, pl2, mask12)
	+ module subroutine subevt_combine (subevt, pl1, pl2, mask12)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl1, pl2
	logical, dimension(:,:), intent(in), optional :: mask12
	integer :: n1, n2, i1, i2, n, j
	logical :: ok
	n1 = pl1%n_active
	n2 = pl2%n_active
	- call subevt_reset (subevt, n1 * n2)
	+ call subevt%reset (n1 * n2)
	n = 1
	do i1 = 1, n1
	do i2 = 1, n2
	if (present (mask12)) then
	ok = mask12(i1,i2)
	else
	ok = .true.
	end if
	if (ok) call prt_combine &
	(subevt%prt(n), pl1%prt(i1), pl2%prt(i2), ok)
	if (ok) then
	CHECK_DOUBLES: do j = 1, n - 1
	if (subevt%prt(n) .match. subevt%prt(j)) then
	ok = .false.; exit CHECK_DOUBLES
	end if
	end do CHECK_DOUBLES
	if (ok) n = n + 1
	end if
	end do
	end do
	subevt%n_active = n - 1
	end subroutine subevt_combine

	@ %def subevt_combine
	@ The collect operation makes a single-entry subevent which
	results from combining (the momenta of) all particles in the input
	list. As above, the result does not contain an original particle more
	than once; this is checked for each particle when it is collected.
	Furthermore, each entry has a mask; where the mask is false, the entry
	is dropped.

	(Thus, if the input particles are already composite, there is some
	chance that the result depends on the order of the input list and is
	not as expected. This situation should be avoided.)
	<<Subevents: public>>=
	public :: subevt_collect
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_collect (subevt, pl1, mask1)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl1
	+ logical, dimension(:), intent(in) :: mask1
	+ end subroutine subevt_collect
	<<Subevents: procedures>>=
	- subroutine subevt_collect (subevt, pl1, mask1)
	+ module subroutine subevt_collect (subevt, pl1, mask1)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl1
	logical, dimension(:), intent(in) :: mask1
	type(prt_t) :: prt
	integer :: i
	logical :: ok
	- call subevt_reset (subevt, 1)
	+ call subevt%reset (1)
	subevt%n_active = 0
	do i = 1, pl1%n_active
	if (mask1(i)) then
	if (subevt%n_active == 0) then
	subevt%n_active = 1
	subevt%prt(1) = pl1%prt(i)
	else
	call prt_combine (prt, subevt%prt(1), pl1%prt(i), ok)
	if (ok) subevt%prt(1) = prt
	end if
	end if
	end do
	end subroutine subevt_collect

	@ %def subevt_collect
	@ The cluster operation is similar to [[collect]], but applies a jet
	algorithm. The result is a subevent consisting of jets and, possibly,
	unclustered extra particles. As above, the result does not contain an
	original particle more than once; this is checked for each particle when it is
	collected. Furthermore, each entry has a mask; where the mask is false, the
	entry is dropped.

	The algorithm: first determine the (pseudo)particles that participate in the
	clustering. They should not overlap, and the mask entry must be set. We then
	cluster the particles, using the given jet definition. The result particles are
	retrieved from the cluster sequence. We still have to determine the source
	indices for each jet: for each input particle, we get the jet index.
	Accumulating the source entries for all particles that are part of a given
	jet, we derive the jet source entries. Finally, we delete the C structures
	that have been constructed by FastJet and its interface.
	<<Subevents: public>>=
	public :: subevt_cluster
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, &
	+ keep_jets, exclusive)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl1
	+ real(default), intent(in) :: dcut
	+ logical, dimension(:), intent(in) :: mask1
	+ type(jet_definition_t), intent(in) :: jet_def
	+ logical, intent(in) :: keep_jets, exclusive
	+ end subroutine subevt_cluster
	<<Subevents: procedures>>=
	- subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, &
	+ module subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, &
	keep_jets, exclusive)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl1
	real(default), intent(in) :: dcut
	logical, dimension(:), intent(in) :: mask1
	type(jet_definition_t), intent(in) :: jet_def
	logical, intent(in) :: keep_jets, exclusive
	integer, dimension(:), allocatable :: map, jet_index
	type(pseudojet_t), dimension(:), allocatable :: jet_in, jet_out
	type(pseudojet_vector_t) :: jv_in, jv_out
	type(cluster_sequence_t) :: cs
	integer :: i, n_src, n_active
	call map_prt_index (pl1, mask1, n_src, map)
	n_active = count (map /= 0)
	allocate (jet_in (n_active))
	allocate (jet_index (n_active))
	do i = 1, n_active
	call jet_in(i)%init (prt_get_momentum (pl1%prt(map(i))))
	end do
	call jv_in%init (jet_in)
	call cs%init (jv_in, jet_def)
	if (exclusive) then
	jv_out = cs%exclusive_jets (dcut)
	else
	jv_out = cs%inclusive_jets ()
	end if
	call cs%assign_jet_indices (jv_out, jet_index)
	allocate (jet_out (jv_out%size ()))
	jet_out = jv_out
	call fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
	do i = 1, size (jet_out)
	call jet_out(i)%final ()
	end do
	call jv_out%final ()
	call cs%final ()
	call jv_in%final ()
	do i = 1, size (jet_in)
	call jet_in(i)%final ()
	end do
	contains
	! Uniquely combine sources and add map those new indices to the old ones
	subroutine map_prt_index (pl1, mask1, n_src, map)
	type(subevt_t), intent(in) :: pl1
	logical, dimension(:), intent(in) :: mask1
	integer, intent(out) :: n_src
	integer, dimension(:), allocatable, intent(out) :: map
	integer, dimension(:), allocatable :: src, src_tmp
	integer :: i
	allocate (src(0))
	allocate (map (pl1%n_active), source = 0)
	n_active = 0
	do i = 1, pl1%n_active
	if (.not. mask1(i)) cycle
	call combine_index_lists (src_tmp, src, pl1%prt(i)%src)
	if (.not. allocated (src_tmp)) cycle
	call move_alloc (from=src_tmp, to=src)
	n_active = n_active + 1
	map(n_active) = i
	end do
	n_src = size (src)
	end subroutine map_prt_index
	! Retrieve source(s) of a jet and fill corresponding subevent
	subroutine fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl1
	type(pseudojet_t), dimension(:), intent(in) :: jet_out
	integer, dimension(:), intent(in) :: jet_index
	integer, dimension(:), intent(in) :: map
	integer, intent(in) :: n_src
	integer, dimension(n_src) :: src_fill
	integer :: i, jet, k, combined_pdg, pdg, n_quarks, n_src_fill
	logical :: is_b, is_c
	- call subevt_reset (subevt, size (jet_out))
	+ call subevt%reset (size (jet_out))
	do jet = 1, size (jet_out)
	pdg = 0; src_fill = 0; n_src_fill = 0; combined_pdg = 0; n_quarks = 0
	is_b = .false.; is_c = .false.
	PARTICLE: do i = 1, size (jet_index)
	if (jet_index(i) /= jet) cycle PARTICLE
	associate (prt => pl1%prt(map(i)), n_src_prt => size(pl1%prt(map(i))%src))
	do k = 1, n_src_prt
	src_fill(n_src_fill + k) = prt%src(k)
	end do
	n_src_fill = n_src_fill + n_src_prt
	if (is_quark (prt%pdg)) then
	n_quarks = n_quarks + 1
	if (.not. is_b) then
	if (abs (prt%pdg) == 5) then
	is_b = .true.
	is_c = .false.
	else if (abs (prt%pdg) == 4) then
	is_c = .true.
	end if
	end if
	if (combined_pdg == 0) combined_pdg = prt%pdg
	end if
	end associate
	end do PARTICLE
	if (keep_jets .and. n_quarks == 1) pdg = combined_pdg
	call prt_init_pseudojet (subevt%prt(jet), jet_out(jet), &
	src_fill(:n_src_fill), pdg, is_b, is_c)
	end do
	end subroutine fill_pseudojet
	end subroutine subevt_cluster

	@ %def subevt_cluster
	@ Do recombination. The incoming subevent [[pl]] is left unchanged if
	it either does not contain photons at all, or consists just of a
	single photon and nothing else or the photon does have a larger $R>R_0$
	distance to the nearest other particle or does not fulfill the
	[[mask1]] condition. Otherwise, the subevent is one entry shorter and
	contains a single recombined particle whose original flavor is kept
	depending on the setting [[keep_flv]]. When this subroutine is called,
	it is explicitly assumed that there is only one photon. For the
	moment, we take here the first photon from the subevent to possibly
	recombine and leave this open for generalization.
	<<Subevents: public>>=
	public :: subevt_recombine
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ logical, dimension(:), intent(in) :: mask1
	+ logical, intent(in) :: keep_flv
	+ real(default), intent(in) :: reco_r0
	+ end subroutine subevt_recombine
	<<Subevents: procedures>>=
	- subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv)
	+ module subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	type(prt_t), dimension(:), allocatable :: prt_rec
	logical, dimension(:), intent(in) :: mask1
	logical, intent(in) :: keep_flv
	real(default), intent(in) :: reco_r0
	real(default), dimension(:), allocatable :: del_rij
	integer, dimension(:), allocatable :: i_sortr
	type(prt_t) :: prt_gam, prt_comb
	logical :: recombine, ok
	integer :: i, n, i_gam, n_gam, n_rec, pdg_orig
	- n = subevt_get_length (pl)
	+ n = pl%get_length ()
	n_gam = 0
	FIND_FIRST_PHOTON: do i = 1, n
	if (prt_is_photon (pl%prt (i))) then
	n_gam = n_gam + 1
	prt_gam = pl%prt (i)
	i_gam = i
	exit FIND_FIRST_PHOTON
	end if
	end do FIND_FIRST_PHOTON
	n_rec = n - n_gam
	if (n_gam == 0) then
	subevt = pl
	else
	if (n_rec > 0) then
	allocate (prt_rec (n_rec))
	do i = 1, n_rec
	if (i == i_gam) cycle
	if (i < i_gam) then
	prt_rec(i) = pl%prt(i)
	else
	prt_rec(i) = pl%prt(i+n_gam)
	end if
	end do
	allocate (del_rij (n_rec), i_sortr (n_rec))
	del_rij(1:n_rec) = eta_phi_distance(prt_get_momentum (prt_gam), &
	prt_get_momentum (prt_rec(1:n_rec)))
	i_sortr = order (del_rij)
	recombine = del_rij (i_sortr (1)) <= reco_r0 .and. mask1(i_gam)
	if (recombine) then
	- call subevt_reset (subevt, pl%n_active-n_gam)
	+ call subevt%reset (pl%n_active-n_gam)
	do i = 1, n_rec
	if (i == i_sortr(1)) then
	pdg_orig = prt_get_pdg (prt_rec(i_sortr (1)))
	call prt_combine (prt_comb, prt_gam, prt_rec(i_sortr (1)), ok)
	if (ok) then
	subevt%prt(i_sortr (1)) = prt_comb
	if (keep_flv) call prt_set_pdg &
	(subevt%prt(i_sortr (1)), pdg_orig)
	end if
	else
	subevt%prt(i) = prt_rec(i)
	end if
	end do
	else
	subevt = pl
	end if
	else
	subevt = pl
	end if
	end if
	end subroutine subevt_recombine

	@ %def subevt_recombine
	@ Return a list of all particles for which the mask is true.
	<<Subevents: public>>=
	public :: subevt_select
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_select (subevt, pl, mask1)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ logical, dimension(:), intent(in) :: mask1
	+ end subroutine subevt_select
	<<Subevents: procedures>>=
	- subroutine subevt_select (subevt, pl, mask1)
	+ module subroutine subevt_select (subevt, pl, mask1)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	logical, dimension(:), intent(in) :: mask1
	integer :: i, n
	- call subevt_reset (subevt, pl%n_active)
	+ call subevt%reset (pl%n_active)
	n = 0
	do i = 1, pl%n_active
	if (mask1(i)) then
	n = n + 1
	subevt%prt(n) = pl%prt(i)
	end if
	end do
	subevt%n_active = n
	end subroutine subevt_select

	@ %def subevt_select
	@ Return a subevent which consists of the single particle with
	specified [[index]]. If [[index]] is negative, count from the end.
	If it is out of bounds, return an empty list.
	<<Subevents: public>>=
	public :: subevt_extract
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_extract (subevt, pl, index)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ integer, intent(in) :: index
	+ end subroutine subevt_extract
	<<Subevents: procedures>>=
	- subroutine subevt_extract (subevt, pl, index)
	+ module subroutine subevt_extract (subevt, pl, index)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	integer, intent(in) :: index
	if (index > 0) then
	if (index <= pl%n_active) then
	- call subevt_reset (subevt, 1)
	+ call subevt%reset (1)
	subevt%prt(1) = pl%prt(index)
	else
	- call subevt_reset (subevt, 0)
	+ call subevt%reset (0)
	end if
	else if (index < 0) then
	if (abs (index) <= pl%n_active) then
	- call subevt_reset (subevt, 1)
	+ call subevt%reset (1)
	subevt%prt(1) = pl%prt(pl%n_active + 1 + index)
	else
	- call subevt_reset (subevt, 0)
	+ call subevt%reset (0)
	end if
	else
	- call subevt_reset (subevt, 0)
	+ call subevt%reset (0)
	end if
	end subroutine subevt_extract

	@ %def subevt_extract
	@ Return the list of particles sorted according to increasing values
	of the provided integer or real array. If no array is given, sort by
	PDG value.
	<<Subevents: public>>=
	public :: subevt_sort
	<<Subevents: interfaces>>=
	interface subevt_sort
	module procedure subevt_sort_pdg
	module procedure subevt_sort_int
	module procedure subevt_sort_real
	end interface

	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_sort_pdg (subevt, pl)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ end subroutine subevt_sort_pdg
	+ module subroutine subevt_sort_int (subevt, pl, ival)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ integer, dimension(:), intent(in) :: ival
	+ end subroutine subevt_sort_int
	+ module subroutine subevt_sort_real (subevt, pl, rval)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(subevt_t), intent(in) :: pl
	+ real(default), dimension(:), intent(in) :: rval
	+ end subroutine subevt_sort_real
	<<Subevents: procedures>>=
	- subroutine subevt_sort_pdg (subevt, pl)
	+ module subroutine subevt_sort_pdg (subevt, pl)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	integer :: n
	n = subevt%n_active
	call subevt_sort_int (subevt, pl, abs (3 * subevt%prt(:n)%pdg - 1))
	end subroutine subevt_sort_pdg

	- subroutine subevt_sort_int (subevt, pl, ival)
	+ module subroutine subevt_sort_int (subevt, pl, ival)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	integer, dimension(:), intent(in) :: ival
	- call subevt_reset (subevt, pl%n_active)
	+ call subevt%reset (pl%n_active)
	subevt%n_active = pl%n_active
	subevt%prt = pl%prt( order (ival) )
	end subroutine subevt_sort_int

	- subroutine subevt_sort_real (subevt, pl, rval)
	+ module subroutine subevt_sort_real (subevt, pl, rval)
	type(subevt_t), intent(inout) :: subevt
	type(subevt_t), intent(in) :: pl
	real(default), dimension(:), intent(in) :: rval
	integer :: i
	integer, dimension(size(rval)) :: idx
	- call subevt_reset (subevt, pl%n_active)
	+ call subevt%reset (pl%n_active)
	subevt%n_active = pl%n_active
	if (allocated (subevt%prt)) deallocate (subevt%prt)
	allocate (subevt%prt (size(pl%prt)))
	idx = order (rval)
	do i = 1, size (idx)
	subevt%prt(i) = pl%prt (idx(i))
	end do
	end subroutine subevt_sort_real

	@ %def subevt_sort
	@ Return the list of particles which have any of the specified PDG
	codes (and optionally particle type: beam, incoming, outgoing).
	<<Subevents: public>>=
	public :: subevt_select_pdg_code
	+<<Subevents: sub interfaces>>=
	+ module subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type)
	+ type(subevt_t), intent(inout) :: subevt
	+ type(pdg_array_t), intent(in) :: aval
	+ type(subevt_t), intent(in) :: subevt_in
	+ integer, intent(in), optional :: prt_type
	+ end subroutine subevt_select_pdg_code
	<<Subevents: procedures>>=
	- subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type)
	+ module subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type)
	type(subevt_t), intent(inout) :: subevt
	type(pdg_array_t), intent(in) :: aval
	type(subevt_t), intent(in) :: subevt_in
	integer, intent(in), optional :: prt_type
	integer :: n_active, n_match
	logical, dimension(:), allocatable :: mask
	integer :: i, j
	n_active = subevt_in%n_active
	allocate (mask (n_active))
	forall (i = 1:n_active) &
	mask(i) = aval .match. subevt_in%prt(i)%pdg
	if (present (prt_type)) &
	mask = mask .and. subevt_in%prt(:n_active)%type == prt_type
	n_match = count (mask)
	- call subevt_reset (subevt, n_match)
	+ call subevt%reset (n_match)
	j = 0
	do i = 1, n_active
	if (mask(i)) then
	j = j + 1
	subevt%prt(j) = subevt_in%prt(i)
	end if
	end do
	end subroutine subevt_select_pdg_code

	@ %def subevt_select_pdg_code
	@
	\subsection{Eliminate numerical noise}
	This is useful for testing purposes: set entries to zero that are smaller in
	absolute values than a given tolerance parameter.

	Note: instead of setting the tolerance in terms of EPSILON
	(kind-dependent), we fix it to $10^{-16}$, which is the typical value
	for double precision. The reason is that there are situations where
	intermediate representations (external libraries, files) are limited
	to double precision, even if the main program uses higher precision.
	<<Subevents: public>>=
	public :: pacify
	<<Subevents: interfaces>>=
	interface pacify
	module procedure pacify_prt
	module procedure pacify_subevt
	end interface pacify

	@ %def pacify
	+<<Subevents: sub interfaces>>=
	+ module subroutine pacify_prt (prt)
	+ class(prt_t), intent(inout) :: prt
	+ end subroutine pacify_prt
	+ module subroutine pacify_subevt (subevt)
	+ class(subevt_t), intent(inout) :: subevt
	+ end subroutine pacify_subevt
	<<Subevents: procedures>>=
	- subroutine pacify_prt (prt)
	+ module subroutine pacify_prt (prt)
	class(prt_t), intent(inout) :: prt
	real(default) :: e
	e = max (1E-10_default * energy (prt%p), 1E-13_default)
	call pacify (prt%p, e)
	call pacify (prt%p2, 1E3_default * e)
	end subroutine pacify_prt

	- subroutine pacify_subevt (subevt)
	+ module subroutine pacify_subevt (subevt)
	class(subevt_t), intent(inout) :: subevt
	integer :: i
	do i = 1, subevt%n_active
	call pacify (subevt%prt(i))
	end do
	end subroutine pacify_subevt

	@ %def pacify_prt
	@ %def pacify_subevt
	@
	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Analysis tools}

	This module defines structures useful for data analysis. These
	include observables, histograms, and plots.

	Observables are quantities that are calculated and summed up event by
	event. At the end, one can compute the average and error.

	Histograms have their bins in addition to the observable properties.
	Histograms are usually written out in tables and displayed
	graphically.

	In plots, each record creates its own entry in a table. This can be
	used for scatter plots if called event by event, or for plotting
	dependencies on parameters if called once per integration run.

	Graphs are container for histograms and plots, which carry their own graphics
	options.

	The type layout is still somewhat obfuscated. This would become much simpler
	if type extension could be used.
	<<[[analysis.f90]]>>=
	<<File header>>

	module analysis

	<<Use kinds>>
	<<Use strings>>
	- use io_units
	- use format_utils, only: quote_underscore, tex_format
	- use system_defs, only: TAB
	- use diagnostics
	use os_interface
	- use ifiles

	<<Standard module head>>

	<<Analysis: public>>

	<<Analysis: parameters>>

	<<Analysis: types>>

	<<Analysis: interfaces>>

	<<Analysis: variables>>

	+ interface
	+<<Analysis: sub interfaces>>
	+ end interface
	+
	+end module analysis
	+@ %def analysis
	+@
	+<<[[analysis_sub.f90]]>>=
	+<<File header>>
	+
	+submodule (analysis) analysis_s
	+
	+ use io_units
	+ use format_utils, only: quote_underscore, tex_format
	+ use system_defs, only: TAB
	+ use diagnostics
	+ use ifiles
	+
	+ implicit none
	+
	contains

	<<Analysis: procedures>>

	-end module analysis
	-@ %def analysis
	+end submodule analysis_s
	+
	+@ %def analysis_s
	@
	\subsection{Output formats}
	These formats share a common field width (alignment).
	<<Analysis: parameters>>=
	character(*), parameter, public :: HISTOGRAM_HEAD_FORMAT = "1x,A15,3x"
	character(*), parameter, public :: HISTOGRAM_INTG_FORMAT = "3x,I9,3x"
	character(*), parameter, public :: HISTOGRAM_DATA_FORMAT = "ES19.12"

	@ %def HISTOGRAM_HEAD_FORMAT HISTOGRAM_INTG_FORMAT HISTOGRAM_DATA_FORMAT
	@
	\subsection{Graph options}
	These parameters are used for displaying data. They apply to a whole graph,
	which may contain more than one plot element.

	The GAMELAN code chunks are part of both [[graph_options]] and
	[[drawing_options]]. The [[drawing_options]] copy is used in histograms and
	plots, also as graph elements. The [[graph_options]] copy is used for
	[[graph]] objects as a whole. Both copies are usually identical.
	<<Analysis: public>>=
	public :: graph_options_t
	<<Analysis: types>>=
	type :: graph_options_t
	private
	type(string_t) :: id
	type(string_t) :: title
	type(string_t) :: description
	type(string_t) :: x_label
	type(string_t) :: y_label
	integer :: width_mm = 130
	integer :: height_mm = 90
	logical :: x_log = .false.
	logical :: y_log = .false.
	real(default) :: x_min = 0
	real(default) :: x_max = 1
	real(default) :: y_min = 0
	real(default) :: y_max = 1
	logical :: x_min_set = .false.
	logical :: x_max_set = .false.
	logical :: y_min_set = .false.
	logical :: y_max_set = .false.
	type(string_t) :: gmlcode_bg
	type(string_t) :: gmlcode_fg
	+ contains
	+ <<Analysis: graph options: TBP>>
	end type graph_options_t

	@ %def graph_options_t
	@ Initialize the record, all strings are empty. The limits are undefined.
	-<<Analysis: public>>=
	- public :: graph_options_init
	+<<Analysis: graph options: TBP>>=
	+ procedure :: init => graph_options_init
	+<<Analysis: sub interfaces>>=
	+ module subroutine graph_options_init (graph_options)
	+ class(graph_options_t), intent(out) :: graph_options
	+ end subroutine graph_options_init
	<<Analysis: procedures>>=
	- subroutine graph_options_init (graph_options)
	- type(graph_options_t), intent(out) :: graph_options
	+ module subroutine graph_options_init (graph_options)
	+ class(graph_options_t), intent(out) :: graph_options
	graph_options%id = ""
	graph_options%title = ""
	graph_options%description = ""
	graph_options%x_label = ""
	graph_options%y_label = ""
	graph_options%gmlcode_bg = ""
	graph_options%gmlcode_fg = ""
	end subroutine graph_options_init

	@ %def graph_options_init
	@ Set individual options.
	-<<Analysis: public>>=
	- public :: graph_options_set
	+<<Analysis: graph options: TBP>>=
	+ procedure :: set => graph_options_set
	+<<Analysis: sub interfaces>>=
	+ module subroutine graph_options_set (graph_options, id, &
	+ title, description, x_label, y_label, width_mm, height_mm, &
	+ x_log, y_log, x_min, x_max, y_min, y_max, &
	+ gmlcode_bg, gmlcode_fg)
	+ class(graph_options_t), intent(inout) :: graph_options
	+ type(string_t), intent(in), optional :: id
	+ type(string_t), intent(in), optional :: title
	+ type(string_t), intent(in), optional :: description
	+ type(string_t), intent(in), optional :: x_label, y_label
	+ integer, intent(in), optional :: width_mm, height_mm
	+ logical, intent(in), optional :: x_log, y_log
	+ real(default), intent(in), optional :: x_min, x_max, y_min, y_max
	+ type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
	+ end subroutine graph_options_set
	<<Analysis: procedures>>=
	- subroutine graph_options_set (graph_options, id, &
	+ module subroutine graph_options_set (graph_options, id, &
	title, description, x_label, y_label, width_mm, height_mm, &
	x_log, y_log, x_min, x_max, y_min, y_max, &
	gmlcode_bg, gmlcode_fg)
	- type(graph_options_t), intent(inout) :: graph_options
	+ class(graph_options_t), intent(inout) :: graph_options
	type(string_t), intent(in), optional :: id
	type(string_t), intent(in), optional :: title
	type(string_t), intent(in), optional :: description
	type(string_t), intent(in), optional :: x_label, y_label
	integer, intent(in), optional :: width_mm, height_mm
	logical, intent(in), optional :: x_log, y_log
	real(default), intent(in), optional :: x_min, x_max, y_min, y_max
	type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
	if (present (id)) graph_options%id = id
	if (present (title)) graph_options%title = title
	if (present (description)) graph_options%description = description
	if (present (x_label)) graph_options%x_label = x_label
	if (present (y_label)) graph_options%y_label = y_label
	if (present (width_mm)) graph_options%width_mm = width_mm
	if (present (height_mm)) graph_options%height_mm = height_mm
	if (present (x_log)) graph_options%x_log = x_log
	if (present (y_log)) graph_options%y_log = y_log
	if (present (x_min)) graph_options%x_min = x_min
	if (present (x_max)) graph_options%x_max = x_max
	if (present (y_min)) graph_options%y_min = y_min
	if (present (y_max)) graph_options%y_max = y_max
	if (present (x_min)) graph_options%x_min_set = .true.
	if (present (x_max)) graph_options%x_max_set = .true.
	if (present (y_min)) graph_options%y_min_set = .true.
	if (present (y_max)) graph_options%y_max_set = .true.
	if (present (gmlcode_bg)) graph_options%gmlcode_bg = gmlcode_bg
	if (present (gmlcode_fg)) graph_options%gmlcode_fg = gmlcode_fg
	end subroutine graph_options_set

	@ %def graph_options_set
	@ Write a simple account of all options.
	-<<Analysis: public>>=
	- public :: graph_options_write
	+<<Analysis: graph options: TBP>>=
	+ procedure :: write => graph_options_write
	+<<Analysis: sub interfaces>>=
	+ module subroutine graph_options_write (gro, unit)
	+ class(graph_options_t), intent(in) :: gro
	+ integer, intent(in), optional :: unit
	+ end subroutine graph_options_write
	<<Analysis: procedures>>=
	- subroutine graph_options_write (gro, unit)
	- type(graph_options_t), intent(in) :: gro
	+ module subroutine graph_options_write (gro, unit)
	+ class(graph_options_t), intent(in) :: gro
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	1 format (A,1x,'"',A,'"')
	2 format (A,1x,L1)
	3 format (A,1x,ES19.12)
	4 format (A,1x,I0)
	5 format (A,1x,'[undefined]')
	write (u, 1) "title =", char (gro%title)
	write (u, 1) "description =", char (gro%description)
	write (u, 1) "x_label =", char (gro%x_label)
	write (u, 1) "y_label =", char (gro%y_label)
	write (u, 2) "x_log =", gro%x_log
	write (u, 2) "y_log =", gro%y_log
	if (gro%x_min_set) then
	write (u, 3) "x_min =", gro%x_min
	else
	write (u, 5) "x_min ="
	end if
	if (gro%x_max_set) then
	write (u, 3) "x_max =", gro%x_max
	else
	write (u, 5) "x_max ="
	end if
	if (gro%y_min_set) then
	write (u, 3) "y_min =", gro%y_min
	else
	write (u, 5) "y_min ="
	end if
	if (gro%y_max_set) then
	write (u, 3) "y_max =", gro%y_max
	else
	write (u, 5) "y_max ="
	end if
	write (u, 4) "width_mm =", gro%width_mm
	write (u, 4) "height_mm =", gro%height_mm
	write (u, 1) "gmlcode_bg =", char (gro%gmlcode_bg)
	write (u, 1) "gmlcode_fg =", char (gro%gmlcode_fg)
	end subroutine graph_options_write

	@ %def graph_options_write
	@ Write a \LaTeX\ header/footer for the analysis file.
	<<Analysis: procedures>>=
	subroutine graph_options_write_tex_header (gro, unit)
	type(graph_options_t), intent(in) :: gro
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	if (gro%title /= "") then
	write (u, "(A)")
	write (u, "(A)") "\section{" // char (gro%title) // "}"
	else
	write (u, "(A)") "\section{" // char (quote_underscore (gro%id)) // "}"
	end if
	if (gro%description /= "") then
	write (u, "(A)") char (gro%description)
	write (u, *)
	write (u, "(A)") "\vspace*{\baselineskip}"
	end if
	write (u, "(A)") "\vspace*{\baselineskip}"
	write (u, "(A)") "\unitlength 1mm"
	write (u, "(A,I0,',',I0,A)") &
	"\begin{gmlgraph*}(", &
	gro%width_mm, gro%height_mm, &
	")[dat]"
	end subroutine graph_options_write_tex_header

	subroutine graph_options_write_tex_footer (gro, unit)
	type(graph_options_t), intent(in) :: gro
	integer, intent(in), optional :: unit
	integer :: u, width, height
	width = gro%width_mm - 10
	height = gro%height_mm - 10
	u = given_output_unit (unit)
	write (u, "(A)") " begingmleps ""Whizard-Logo.eps"";"
	write (u, "(A,I0,A,I0,A)") &
	" base := (", width, "unitlength,", height, "unitlength);"
	write (u, "(A)") " height := 9.6*unitlength;"
	write (u, "(A)") " width := 11.2*unitlength;"
	write (u, "(A)") " endgmleps;"
	write (u, "(A)") "\end{gmlgraph*}"
	end subroutine graph_options_write_tex_footer

	@ %def graph_options_write_tex_header
	@ %def graph_options_write_tex_footer
	@ Return the analysis object ID.
	<<Analysis: procedures>>=
	function graph_options_get_id (gro) result (id)
	type(string_t) :: id
	type(graph_options_t), intent(in) :: gro
	id = gro%id
	end function graph_options_get_id

	@ %def graph_options_get_id
	@ Create an appropriate [[setup]] command (linear/log).
	<<Analysis: procedures>>=
	function graph_options_get_gml_setup (gro) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	type(string_t) :: x_str, y_str
	if (gro%x_log) then
	x_str = "log"
	else
	x_str = "linear"
	end if
	if (gro%y_log) then
	y_str = "log"
	else
	y_str = "linear"
	end if
	cmd = "setup (" // x_str // ", " // y_str // ");"
	end function graph_options_get_gml_setup

	@ %def graph_options_get_gml_setup
	@ Return the labels in GAMELAN form.
	<<Analysis: procedures>>=
	function graph_options_get_gml_x_label (gro) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	cmd = 'label.bot (<' // '<' // gro%x_label // '>' // '>, out);'
	end function graph_options_get_gml_x_label

	function graph_options_get_gml_y_label (gro) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	cmd = 'label.ulft (<' // '<' // gro%y_label // '>' // '>, out);'
	end function graph_options_get_gml_y_label

	@ %def graph_options_get_gml_x_label
	@ %def graph_options_get_gml_y_label
	@ Create an appropriate [[graphrange]] statement for the given graph options.
	Where the graph options are not set, use the supplied arguments, if any,
	otherwise set the undefined value.
	<<Analysis: procedures>>=
	function graph_options_get_gml_graphrange &
	(gro, x_min, x_max, y_min, y_max) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	real(default), intent(in), optional :: x_min, x_max, y_min, y_max
	type(string_t) :: x_min_str, x_max_str, y_min_str, y_max_str
	character(*), parameter :: fmt = "(ES15.8)"
	if (gro%x_min_set) then
	x_min_str = "#" // trim (adjustl (real2string (gro%x_min, fmt)))
	else if (present (x_min)) then
	x_min_str = "#" // trim (adjustl (real2string (x_min, fmt)))
	else
	x_min_str = "??"
	end if
	if (gro%x_max_set) then
	x_max_str = "#" // trim (adjustl (real2string (gro%x_max, fmt)))
	else if (present (x_max)) then
	x_max_str = "#" // trim (adjustl (real2string (x_max, fmt)))
	else
	x_max_str = "??"
	end if
	if (gro%y_min_set) then
	y_min_str = "#" // trim (adjustl (real2string (gro%y_min, fmt)))
	else if (present (y_min)) then
	y_min_str = "#" // trim (adjustl (real2string (y_min, fmt)))
	else
	y_min_str = "??"
	end if
	if (gro%y_max_set) then
	y_max_str = "#" // trim (adjustl (real2string (gro%y_max, fmt)))
	else if (present (y_max)) then
	y_max_str = "#" // trim (adjustl (real2string (y_max, fmt)))
	else
	y_max_str = "??"
	end if
	cmd = "graphrange (" // x_min_str // ", " // y_min_str // "), " &
	// "(" // x_max_str // ", " // y_max_str // ");"
	end function graph_options_get_gml_graphrange

	@ %def graph_options_get_gml_graphrange
	@ Get extra GAMELAN code to be executed before and after the usual drawing
	commands.
	<<Analysis: procedures>>=
	function graph_options_get_gml_bg_command (gro) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	cmd = gro%gmlcode_bg
	end function graph_options_get_gml_bg_command

	function graph_options_get_gml_fg_command (gro) result (cmd)
	type(string_t) :: cmd
	type(graph_options_t), intent(in) :: gro
	cmd = gro%gmlcode_fg
	end function graph_options_get_gml_fg_command

	@ %def graph_options_get_gml_bg_command
	@ %def graph_options_get_gml_fg_command
	@ Append the header for generic data output in ifile format. We print only
	labels, not graphics parameters.
	<<Analysis: procedures>>=
	subroutine graph_options_get_header (pl, header, comment)
	type(graph_options_t), intent(in) :: pl
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	type(string_t) :: c
	if (present (comment)) then
	c = comment
	else
	c = ""
	end if
	call ifile_append (header, &
	c // "ID: " // pl%id)
	call ifile_append (header, &
	c // "title: " // pl%title)
	call ifile_append (header, &
	c // "description: " // pl%description)
	call ifile_append (header, &
	c // "x axis label: " // pl%x_label)
	call ifile_append (header, &
	c // "y axis label: " // pl%y_label)
	end subroutine graph_options_get_header

	@ %def graph_options_get_header
	@
	\subsection{Drawing options}
	These options apply to an individual graph element (histogram or plot).
	<<Analysis: public>>=
	public :: drawing_options_t
	<<Analysis: types>>=
	type :: drawing_options_t
	type(string_t) :: dataset
	logical :: with_hbars = .false.
	logical :: with_base = .false.
	logical :: piecewise = .false.
	logical :: fill = .false.
	logical :: draw = .false.
	logical :: err = .false.
	logical :: symbols = .false.
	type(string_t) :: fill_options
	type(string_t) :: draw_options
	type(string_t) :: err_options
	type(string_t) :: symbol
	type(string_t) :: gmlcode_bg
	type(string_t) :: gmlcode_fg
	+ contains
	+ <<Analysis: drawing options: TBP>>
	end type drawing_options_t

	@ %def drawing_options_t
	@ Write a simple account of all options.
	-<<Analysis: public>>=
	- public :: drawing_options_write
	+<<Analysis: drawing options: TBP>>=
	+ procedure :: write => drawing_options_write
	+<<Analysis: sub interfaces>>=
	+ module subroutine drawing_options_write (dro, unit)
	+ class(drawing_options_t), intent(in) :: dro
	+ integer, intent(in), optional :: unit
	+ end subroutine drawing_options_write
	<<Analysis: procedures>>=
	- subroutine drawing_options_write (dro, unit)
	- type(drawing_options_t), intent(in) :: dro
	+ module subroutine drawing_options_write (dro, unit)
	+ class(drawing_options_t), intent(in) :: dro
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	1 format (A,1x,'"',A,'"')
	2 format (A,1x,L1)
	write (u, 2) "with_hbars =", dro%with_hbars
	write (u, 2) "with_base =", dro%with_base
	write (u, 2) "piecewise =", dro%piecewise
	write (u, 2) "fill =", dro%fill
	write (u, 2) "draw =", dro%draw
	write (u, 2) "err =", dro%err
	write (u, 2) "symbols =", dro%symbols
	write (u, 1) "fill_options=", char (dro%fill_options)
	write (u, 1) "draw_options=", char (dro%draw_options)
	write (u, 1) "err_options =", char (dro%err_options)
	write (u, 1) "symbol =", char (dro%symbol)
	write (u, 1) "gmlcode_bg =", char (dro%gmlcode_bg)
	write (u, 1) "gmlcode_fg =", char (dro%gmlcode_fg)
	end subroutine drawing_options_write

	@ %def drawing_options_write
	@ Init with empty strings and default options, appropriate for either
	histogram or plot.
	-<<Analysis: public>>=
	- public :: drawing_options_init_histogram
	- public :: drawing_options_init_plot
	+<<Analysis: drawing options: TBP>>=
	+ procedure :: init_histogram => drawing_options_init_histogram
	+ procedure :: init_plot => drawing_options_init_plot
	+<<Analysis: sub interfaces>>=
	+ module subroutine drawing_options_init_histogram (dro)
	+ class(drawing_options_t), intent(out) :: dro
	+ end subroutine drawing_options_init_histogram
	+ module subroutine drawing_options_init_plot (dro)
	+ class(drawing_options_t), intent(out) :: dro
	+ end subroutine drawing_options_init_plot
	<<Analysis: procedures>>=
	- subroutine drawing_options_init_histogram (dro)
	- type(drawing_options_t), intent(out) :: dro
	+ module subroutine drawing_options_init_histogram (dro)
	+ class(drawing_options_t), intent(out) :: dro
	dro%dataset = "dat"
	dro%with_hbars = .true.
	dro%with_base = .true.
	dro%piecewise = .true.
	dro%fill = .true.
	dro%draw = .true.
	dro%fill_options = "withcolor col.default"
	dro%draw_options = ""
	dro%err_options = ""
	dro%symbol = "fshape(circle scaled 1mm)()"
	dro%gmlcode_bg = ""
	dro%gmlcode_fg = ""
	end subroutine drawing_options_init_histogram

	- subroutine drawing_options_init_plot (dro)
	- type(drawing_options_t), intent(out) :: dro
	+ module subroutine drawing_options_init_plot (dro)
	+ class(drawing_options_t), intent(out) :: dro
	dro%dataset = "dat"
	dro%draw = .true.
	dro%fill_options = "withcolor col.default"
	dro%draw_options = ""
	dro%err_options = ""
	dro%symbol = "fshape(circle scaled 1mm)()"
	dro%gmlcode_bg = ""
	dro%gmlcode_fg = ""
	end subroutine drawing_options_init_plot

	@ %def drawing_options_init_histogram
	@ %def drawing_options_init_plot
	@ Set individual options.
	-<<Analysis: public>>=
	- public :: drawing_options_set
	+<<Analysis: drawing options: TBP>>=
	+ procedure :: set => drawing_options_set
	+<<Analysis: sub interfaces>>=
	+ module subroutine drawing_options_set (dro, dataset, &
	+ with_hbars, with_base, piecewise, fill, draw, err, symbols, &
	+ fill_options, draw_options, err_options, symbol, &
	+ gmlcode_bg, gmlcode_fg)
	+ class(drawing_options_t), intent(inout) :: dro
	+ type(string_t), intent(in), optional :: dataset
	+ logical, intent(in), optional :: with_hbars, with_base, piecewise
	+ logical, intent(in), optional :: fill, draw, err, symbols
	+ type(string_t), intent(in), optional :: fill_options, draw_options
	+ type(string_t), intent(in), optional :: err_options, symbol
	+ type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
	+ end subroutine drawing_options_set
	<<Analysis: procedures>>=
	- subroutine drawing_options_set (dro, dataset, &
	+ module subroutine drawing_options_set (dro, dataset, &
	with_hbars, with_base, piecewise, fill, draw, err, symbols, &
	fill_options, draw_options, err_options, symbol, &
	gmlcode_bg, gmlcode_fg)
	- type(drawing_options_t), intent(inout) :: dro
	+ class(drawing_options_t), intent(inout) :: dro
	type(string_t), intent(in), optional :: dataset
	logical, intent(in), optional :: with_hbars, with_base, piecewise
	logical, intent(in), optional :: fill, draw, err, symbols
	type(string_t), intent(in), optional :: fill_options, draw_options
	type(string_t), intent(in), optional :: err_options, symbol
	type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
	if (present (dataset)) dro%dataset = dataset
	if (present (with_hbars)) dro%with_hbars = with_hbars
	if (present (with_base)) dro%with_base = with_base
	if (present (piecewise)) dro%piecewise = piecewise
	if (present (fill)) dro%fill = fill
	if (present (draw)) dro%draw = draw
	if (present (err)) dro%err = err
	if (present (symbols)) dro%symbols = symbols
	if (present (fill_options)) dro%fill_options = fill_options
	if (present (draw_options)) dro%draw_options = draw_options
	if (present (err_options)) dro%err_options = err_options
	if (present (symbol)) dro%symbol = symbol
	if (present (gmlcode_bg)) dro%gmlcode_bg = gmlcode_bg
	if (present (gmlcode_fg)) dro%gmlcode_fg = gmlcode_fg
	end subroutine drawing_options_set

	@ %def drawing_options_set
	@ There are sepate commands for drawing the
	curve and for drawing errors. The symbols are applied to the latter. First
	of all, we may have to compute a baseline:
	<<Analysis: procedures>>=
	function drawing_options_get_calc_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	if (dro%with_base) then
	cmd = "calculate " // dro%dataset // ".base (" // dro%dataset // ") " &
	// "(x, #0);"
	else
	cmd = ""
	end if
	end function drawing_options_get_calc_command

	@ %def drawing_options_get_calc_command
	@ Return the drawing command.
	<<Analysis: procedures>>=
	function drawing_options_get_draw_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	if (dro%fill) then
	cmd = "fill"
	else if (dro%draw) then
	cmd = "draw"
	else
	cmd = ""
	end if
	if (dro%fill .or. dro%draw) then
	if (dro%piecewise) cmd = cmd // " piecewise"
	if (dro%draw .and. dro%with_base) cmd = cmd // " cyclic"
	cmd = cmd // " from (" // dro%dataset
	if (dro%with_base) then
	if (dro%piecewise) then
	cmd = cmd // ", " // dro%dataset // ".base/\" ! "
	else
	cmd = cmd // " ~ " // dro%dataset // ".base\" ! "
	end if
	end if
	cmd = cmd // ")"
	if (dro%fill) then
	cmd = cmd // " " // dro%fill_options
	if (dro%draw) cmd = cmd // " outlined"
	end if
	if (dro%draw) cmd = cmd // " " // dro%draw_options
	cmd = cmd // ";"
	end if
	end function drawing_options_get_draw_command

	@ %def drawing_options_get_draw_command
	@ The error command draws error bars, if any.
	<<Analysis: procedures>>=
	function drawing_options_get_err_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	if (dro%err) then
	cmd = "draw piecewise " &
	// "from (" // dro%dataset // ".err)" &
	// " " // dro%err_options // ";"
	else
	cmd = ""
	end if
	end function drawing_options_get_err_command

	@ %def drawing_options_get_err_command
	@ The symbol command draws symbols, if any.
	<<Analysis: procedures>>=
	function drawing_options_get_symb_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	if (dro%symbols) then
	cmd = "phantom" &
	// " from (" // dro%dataset // ")" &
	// " withsymbol (" // dro%symbol // ");"
	else
	cmd = ""
	end if
	end function drawing_options_get_symb_command

	@ %def drawing_options_get_symb_command
	@ Get extra GAMELAN code to be executed before and after the usual drawing
	commands.
	<<Analysis: procedures>>=
	function drawing_options_get_gml_bg_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	cmd = dro%gmlcode_bg
	end function drawing_options_get_gml_bg_command

	function drawing_options_get_gml_fg_command (dro) result (cmd)
	type(string_t) :: cmd
	type(drawing_options_t), intent(in) :: dro
	cmd = dro%gmlcode_fg
	end function drawing_options_get_gml_fg_command

	@ %def drawing_options_get_gml_bg_command
	@ %def drawing_options_get_gml_fg_command
	@
	\subsection{Observables}
	The observable type holds the accumulated observable values and weight
	sums which are necessary for proper averaging.
	<<Analysis: types>>=
	type :: observable_t
	private
	real(default) :: sum_values = 0
	real(default) :: sum_squared_values = 0
	real(default) :: sum_weights = 0
	real(default) :: sum_squared_weights = 0
	integer :: count = 0
	type(string_t) :: obs_label
	type(string_t) :: obs_unit
	type(graph_options_t) :: graph_options
	end type observable_t

	@ %def observable_t
	@ Initialize with defined properties
	<<Analysis: procedures>>=
	subroutine observable_init (obs, obs_label, obs_unit, graph_options)
	type(observable_t), intent(out) :: obs
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	if (present (obs_label)) then
	obs%obs_label = obs_label
	else
	obs%obs_label = ""
	end if
	if (present (obs_unit)) then
	obs%obs_unit = obs_unit
	else
	obs%obs_unit = ""
	end if
	if (present (graph_options)) then
	obs%graph_options = graph_options
	else
	- call graph_options_init (obs%graph_options)
	+ call obs%graph_options%init ()
	end if
	end subroutine observable_init

	@ %def observable_init
	@ Reset all numeric entries.
	<<Analysis: procedures>>=
	subroutine observable_clear (obs)
	type(observable_t), intent(inout) :: obs
	obs%sum_values = 0
	obs%sum_squared_values = 0
	obs%sum_weights = 0
	obs%sum_squared_weights = 0
	obs%count = 0
	end subroutine observable_clear

	@ %def observable_clear
	@ Record a value. Always successful for observables.
	<<Analysis: interfaces>>=
	interface observable_record_value
	module procedure observable_record_value_unweighted
	module procedure observable_record_value_weighted
	end interface

	+<<Analysis: sub interfaces>>=
	+ module subroutine observable_record_value_unweighted (obs, value, success)
	+ type(observable_t), intent(inout) :: obs
	+ real(default), intent(in) :: value
	+ logical, intent(out), optional :: success
	+ end subroutine observable_record_value_unweighted
	+ module subroutine observable_record_value_weighted (obs, value, weight, success)
	+ type(observable_t), intent(inout) :: obs
	+ real(default), intent(in) :: value, weight
	+ logical, intent(out), optional :: success
	+ end subroutine observable_record_value_weighted
	<<Analysis: procedures>>=
	- subroutine observable_record_value_unweighted (obs, value, success)
	+ module subroutine observable_record_value_unweighted (obs, value, success)
	type(observable_t), intent(inout) :: obs
	real(default), intent(in) :: value
	logical, intent(out), optional :: success
	obs%sum_values = obs%sum_values + value
	obs%sum_squared_values = obs%sum_squared_values + value**2
	obs%sum_weights = obs%sum_weights + 1
	obs%sum_squared_weights = obs%sum_squared_weights + 1
	obs%count = obs%count + 1
	if (present (success)) success = .true.
	end subroutine observable_record_value_unweighted

	- subroutine observable_record_value_weighted (obs, value, weight, success)
	+ module subroutine observable_record_value_weighted (obs, value, weight, success)
	type(observable_t), intent(inout) :: obs
	real(default), intent(in) :: value, weight
	logical, intent(out), optional :: success
	obs%sum_values = obs%sum_values + value * weight
	obs%sum_squared_values = obs%sum_squared_values + value*2 weight
	obs%sum_weights = obs%sum_weights + weight
	obs%sum_squared_weights = obs%sum_squared_weights + weight**2
	obs%count = obs%count + 1
	if (present (success)) success = .true.
	end subroutine observable_record_value_weighted

	@ %def observable_record_value
	@ Here are the statistics formulas:
	\begin{enumerate}
	\item Unweighted case:
	Given a sample of $n$ values $x_i$, the average is
	\begin{equation}
	\langle x \rangle = \frac{\sum x_i}{n}
	\end{equation}
	and the error estimate
	\begin{align}
	\Delta x &= \sqrt{\frac{1}{n-1}\langle{\sum(x_i - \langle x\rangle)^2}}
	\\
	&= \sqrt{\frac{1}{n-1}
	\left(\frac{\sum x_i^2}{n} - \frac{(\sum x_i)^2}{n^2}\right)}
	\end{align}
	\item Weighted case:
	Instead of weight 1, each event comes with weight $w_i$.
	\begin{equation}
	\langle x \rangle = \frac{\sum x_i w_i}{\sum w_i}
	\end{equation}
	and
	\begin{equation}
	\Delta x
	= \sqrt{\frac{1}{n-1}
	\left(\frac{\sum x_i^2 w_i}{\sum w_i}
	- \frac{(\sum x_i w_i)^2}{(\sum w_i)^2}\right)}
	\end{equation}
	For $w_i=1$, this specializes to the previous formula.
	\end{enumerate}
	<<Analysis: procedures>>=
	function observable_get_n_entries (obs) result (n)
	integer :: n
	type(observable_t), intent(in) :: obs
	n = obs%count
	end function observable_get_n_entries

	function observable_get_average (obs) result (avg)
	real(default) :: avg
	type(observable_t), intent(in) :: obs
	if (obs%sum_weights /= 0) then
	avg = obs%sum_values / obs%sum_weights
	else
	avg = 0
	end if
	end function observable_get_average

	function observable_get_error (obs) result (err)
	real(default) :: err
	type(observable_t), intent(in) :: obs
	real(default) :: var, n
	if (obs%sum_weights /= 0) then
	select case (obs%count)
	case (0:1)
	err = 0
	case default
	n = obs%count
	var = obs%sum_squared_values / obs%sum_weights &
	- (obs%sum_values / obs%sum_weights) ** 2
	err = sqrt (max (var, 0._default) / (n - 1))
	end select
	else
	err = 0
	end if
	end function observable_get_error

	@ %def observable_get_n_entries
	@ %def observable_get_sum
	@ %def observable_get_average
	@ %def observable_get_error
	@ Write label and/or physical unit to a string.
	<<Analysis: procedures>>=
	function observable_get_label (obs, wl, wu) result (string)
	type(string_t) :: string
	type(observable_t), intent(in) :: obs
	logical, intent(in) :: wl, wu
	type(string_t) :: obs_label, obs_unit
	if (wl) then
	if (obs%obs_label /= "") then
	obs_label = obs%obs_label
	else
	obs_label = "\textrm{Observable}"
	end if
	else
	obs_label = ""
	end if
	if (wu) then
	if (obs%obs_unit /= "") then
	if (wl) then
	obs_unit = "\;[" // obs%obs_unit // "]"
	else
	obs_unit = obs%obs_unit
	end if
	else
	obs_unit = ""
	end if
	else
	obs_unit = ""
	end if
	string = obs_label // obs_unit
	end function observable_get_label

	@ %def observable_get_label
	@
	\subsection{Output}
	<<Analysis: procedures>>=
	subroutine observable_write (obs, unit)
	type(observable_t), intent(in) :: obs
	integer, intent(in), optional :: unit
	real(default) :: avg, err, relerr
	integer :: n
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	avg = observable_get_average (obs)
	err = observable_get_error (obs)
	if (avg /= 0) then
	relerr = err / abs (avg)
	else
	relerr = 0
	end if
	n = observable_get_n_entries (obs)
	if (obs%graph_options%title /= "") then
	write (u, "(A,1x,3A)") &
	"title =", '"', char (obs%graph_options%title), '"'
	end if
	if (obs%graph_options%title /= "") then
	write (u, "(A,1x,3A)") &
	"description =", '"', char (obs%graph_options%description), '"'
	end if
	write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
	"average =", avg
	call write_unit ()
	write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
	"error[abs] =", err
	call write_unit ()
	write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")") &
	"error[rel] =", relerr
	write (u, "(A,1x,I0)") &
	"n_entries =", n
	contains
	subroutine write_unit ()
	if (obs%obs_unit /= "") then
	write (u, "(1x,A)") char (obs%obs_unit)
	else
	write (u, *)
	end if
	end subroutine write_unit
	end subroutine observable_write

	@ %def observable_write
	@ \LaTeX\ output.
	<<Analysis: procedures>>=
	subroutine observable_write_driver (obs, unit, write_heading)
	type(observable_t), intent(in) :: obs
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: write_heading
	real(default) :: avg, err
	integer :: n_digits
	logical :: heading
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	heading = .true.; if (present (write_heading)) heading = write_heading
	avg = observable_get_average (obs)
	err = observable_get_error (obs)
	if (avg /= 0 .and. err /= 0) then
	n_digits = max (2, 2 - int (log10 (abs (err / real (avg, default)))))
	else if (avg /= 0) then
	n_digits = 100
	else
	n_digits = 1
	end if
	if (heading) then
	write (u, "(A)")
	if (obs%graph_options%title /= "") then
	write (u, "(A)") "\section{" // char (obs%graph_options%title) &
	// "}"
	else
	write (u, "(A)") "\section{Observable}"
	end if
	if (obs%graph_options%description /= "") then
	write (u, "(A)") char (obs%graph_options%description)
	write (u, *)
	end if
	write (u, "(A)") "\begin{flushleft}"
	end if
	write (u, "(A)", advance="no") " $\langle{" ! $ sign
	write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.true., wu=.false.))
	write (u, "(A)", advance="no") "}\rangle = "
	write (u, "(A)", advance="no") char (tex_format (avg, n_digits))
	write (u, "(A)", advance="no") "\pm"
	write (u, "(A)", advance="no") char (tex_format (err, 2))
	write (u, "(A)", advance="no") "\;{"
	write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.false., wu=.true.))
	write (u, "(A)") "}"
	write (u, "(A)", advance="no") " \quad[n_{\text{entries}} = "
	write (u, "(I0)",advance="no") observable_get_n_entries (obs)
	write (u, "(A)") "]$" ! $ fool Emacs' noweb mode
	if (heading) then
	write (u, "(A)") "\end{flushleft}"
	end if
	end subroutine observable_write_driver

	@ %def observable_write_driver
	@
	\subsection{Histograms}
	\subsubsection{Bins}
	<<Analysis: types>>=
	type :: bin_t
	private
	real(default) :: midpoint = 0
	real(default) :: width = 0
	real(default) :: sum_weights = 0
	real(default) :: sum_squared_weights = 0
	real(default) :: sum_excess_weights = 0
	integer :: count = 0
	end type bin_t

	@ %def bin_t
	<<Analysis: procedures>>=
	subroutine bin_init (bin, midpoint, width)
	type(bin_t), intent(out) :: bin
	real(default), intent(in) :: midpoint, width
	bin%midpoint = midpoint
	bin%width = width
	end subroutine bin_init

	@ %def bin_init
	<<Analysis: procedures>>=
	elemental subroutine bin_clear (bin)
	type(bin_t), intent(inout) :: bin
	bin%sum_weights = 0
	bin%sum_squared_weights = 0
	bin%sum_excess_weights = 0
	bin%count = 0
	end subroutine bin_clear

	@ %def bin_clear
	<<Analysis: procedures>>=
	subroutine bin_record_value (bin, normalize, weight, excess)
	type(bin_t), intent(inout) :: bin
	logical, intent(in) :: normalize
	real(default), intent(in) :: weight
	real(default), intent(in), optional :: excess
	real(default) :: w, e
	if (normalize) then
	if (bin%width /= 0) then
	w = weight / bin%width
	if (present (excess)) e = excess / bin%width
	else
	w = 0
	if (present (excess)) e = 0
	end if
	else
	w = weight
	if (present (excess)) e = excess
	end if
	bin%sum_weights = bin%sum_weights + w
	bin%sum_squared_weights = bin%sum_squared_weights + w ** 2
	if (present (excess)) &
	bin%sum_excess_weights = bin%sum_excess_weights + abs (e)
	bin%count = bin%count + 1
	end subroutine bin_record_value

	@ %def bin_record_value
	<<Analysis: procedures>>=
	function bin_get_midpoint (bin) result (x)
	real(default) :: x
	type(bin_t), intent(in) :: bin
	x = bin%midpoint
	end function bin_get_midpoint

	function bin_get_width (bin) result (w)
	real(default) :: w
	type(bin_t), intent(in) :: bin
	w = bin%width
	end function bin_get_width

	function bin_get_n_entries (bin) result (n)
	integer :: n
	type(bin_t), intent(in) :: bin
	n = bin%count
	end function bin_get_n_entries

	function bin_get_sum (bin) result (s)
	real(default) :: s
	type(bin_t), intent(in) :: bin
	s = bin%sum_weights
	end function bin_get_sum

	function bin_get_error (bin) result (err)
	real(default) :: err
	type(bin_t), intent(in) :: bin
	err = sqrt (bin%sum_squared_weights)
	end function bin_get_error

	function bin_get_excess (bin) result (excess)
	real(default) :: excess
	type(bin_t), intent(in) :: bin
	excess = bin%sum_excess_weights
	end function bin_get_excess

	@ %def bin_get_midpoint
	@ %def bin_get_width
	@ %def bin_get_n_entries
	@ %def bin_get_sum
	@ %def bin_get_error
	@ %def bin_get_excess
	<<Analysis: procedures>>=
	subroutine bin_write_header (unit)
	integer, intent(in), optional :: unit
	character(120) :: buffer
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (buffer, "(A,4(1x," //HISTOGRAM_HEAD_FORMAT // "),2x,A)") &
	"#", "bin midpoint", "value ", "error ", &
	"excess ", "n"
	write (u, "(A)") trim (buffer)
	end subroutine bin_write_header

	subroutine bin_write (bin, unit)
	type(bin_t), intent(in) :: bin
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "),2x,I0)") &
	bin_get_midpoint (bin), &
	bin_get_sum (bin), &
	bin_get_error (bin), &
	bin_get_excess (bin), &
	bin_get_n_entries (bin)
	end subroutine bin_write

	@ %def bin_write_header
	@ %def bin_write
	@
	\subsubsection{Histograms}
	<<Analysis: types>>=
	type :: histogram_t
	private
	real(default) :: lower_bound = 0
	real(default) :: upper_bound = 0
	real(default) :: width = 0
	integer :: n_bins = 0
	logical :: normalize_bins = .false.
	type(observable_t) :: obs
	type(observable_t) :: obs_within_bounds
	type(bin_t) :: underflow
	type(bin_t), dimension(:), allocatable :: bin
	type(bin_t) :: overflow
	type(graph_options_t) :: graph_options
	type(drawing_options_t) :: drawing_options
	end type histogram_t

	@ %def histogram_t
	@
	\subsubsection{Initializer/finalizer}
	Initialize a histogram. We may provide either the bin width or the
	number of bins. A finalizer is not needed, since the histogram contains no
	pointer (sub)components.
	<<Analysis: interfaces>>=
	interface histogram_init
	module procedure histogram_init_n_bins
	module procedure histogram_init_bin_width
	end interface

	+<<Analysis: sub interfaces>>=
	+ module subroutine histogram_init_n_bins (h, id, &
	+ lower_bound, upper_bound, n_bins, normalize_bins, &
	+ obs_label, obs_unit, graph_options, drawing_options)
	+ type(histogram_t), intent(out) :: h
	+ type(string_t), intent(in) :: id
	+ real(default), intent(in) :: lower_bound, upper_bound
	+ integer, intent(in) :: n_bins
	+ logical, intent(in) :: normalize_bins
	+ type(string_t), intent(in), optional :: obs_label, obs_unit
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine histogram_init_n_bins
	+ module subroutine histogram_init_bin_width (h, id, &
	+ lower_bound, upper_bound, bin_width, normalize_bins, &
	+ obs_label, obs_unit, graph_options, drawing_options)
	+ type(histogram_t), intent(out) :: h
	+ type(string_t), intent(in) :: id
	+ real(default), intent(in) :: lower_bound, upper_bound, bin_width
	+ logical, intent(in) :: normalize_bins
	+ type(string_t), intent(in), optional :: obs_label, obs_unit
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine histogram_init_bin_width
	<<Analysis: procedures>>=
	- subroutine histogram_init_n_bins (h, id, &
	+ module subroutine histogram_init_n_bins (h, id, &
	lower_bound, upper_bound, n_bins, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	type(histogram_t), intent(out) :: h
	type(string_t), intent(in) :: id
	real(default), intent(in) :: lower_bound, upper_bound
	integer, intent(in) :: n_bins
	logical, intent(in) :: normalize_bins
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	real(default) :: bin_width
	integer :: i
	call observable_init (h%obs_within_bounds, obs_label, obs_unit)
	call observable_init (h%obs, obs_label, obs_unit)
	h%lower_bound = lower_bound
	h%upper_bound = upper_bound
	h%n_bins = max (n_bins, 1)
	h%width = h%upper_bound - h%lower_bound
	h%normalize_bins = normalize_bins
	bin_width = h%width / h%n_bins
	allocate (h%bin (h%n_bins))
	call bin_init (h%underflow, h%lower_bound, 0._default)
	do i = 1, h%n_bins
	call bin_init (h%bin(i), &
	h%lower_bound - bin_width/2 + i * bin_width, bin_width)
	end do
	call bin_init (h%overflow, h%upper_bound, 0._default)
	if (present (graph_options)) then
	h%graph_options = graph_options
	else
	- call graph_options_init (h%graph_options)
	+ call h%graph_options%init ()
	end if
	call graph_options_set (h%graph_options, id = id)
	if (present (drawing_options)) then
	h%drawing_options = drawing_options
	else
	- call drawing_options_init_histogram (h%drawing_options)
	+ call h%drawing_options%init_histogram ()
	end if
	end subroutine histogram_init_n_bins

	- subroutine histogram_init_bin_width (h, id, &
	+ module subroutine histogram_init_bin_width (h, id, &
	lower_bound, upper_bound, bin_width, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	type(histogram_t), intent(out) :: h
	type(string_t), intent(in) :: id
	real(default), intent(in) :: lower_bound, upper_bound, bin_width
	logical, intent(in) :: normalize_bins
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	integer :: n_bins
	if (bin_width /= 0) then
	n_bins = nint ((upper_bound - lower_bound) / bin_width)
	else
	n_bins = 1
	end if
	call histogram_init_n_bins (h, id, &
	lower_bound, upper_bound, n_bins, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	end subroutine histogram_init_bin_width

	@ %def histogram_init
	@ Initialize a histogram by copying another one.

	Since [[h]] has no pointer (sub)components, intrinsic assignment is
	sufficient. Optionally, we replace the drawing options.
	<<Analysis: procedures>>=
	subroutine histogram_init_histogram (h, h_in, drawing_options)
	type(histogram_t), intent(out) :: h
	type(histogram_t), intent(in) :: h_in
	type(drawing_options_t), intent(in), optional :: drawing_options
	h = h_in
	if (present (drawing_options)) then
	h%drawing_options = drawing_options
	end if
	end subroutine histogram_init_histogram

	@ %def histogram_init_histogram
	@
	\subsubsection{Fill histograms}
	Clear the histogram contents, but do not modify the structure.
	<<Analysis: procedures>>=
	subroutine histogram_clear (h)
	type(histogram_t), intent(inout) :: h
	call observable_clear (h%obs)
	call observable_clear (h%obs_within_bounds)
	call bin_clear (h%underflow)
	if (allocated (h%bin)) call bin_clear (h%bin)
	call bin_clear (h%overflow)
	end subroutine histogram_clear

	@ %def histogram_clear
	@ Record a value. Successful if the value is within bounds, otherwise
	it is recorded as under-/overflow. Optionally, we may provide an
	excess weight that could be returned by the unweighting procedure.
	<<Analysis: procedures>>=
	subroutine histogram_record_value_unweighted (h, value, excess, success)
	type(histogram_t), intent(inout) :: h
	real(default), intent(in) :: value
	real(default), intent(in), optional :: excess
	logical, intent(out), optional :: success
	integer :: i_bin
	call observable_record_value (h%obs, value)
	if (h%width /= 0) then
	i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
	else
	i_bin = 0
	end if
	if (i_bin <= 0) then
	call bin_record_value (h%underflow, .false., 1._default, excess)
	if (present (success)) success = .false.
	else if (i_bin <= h%n_bins) then
	call observable_record_value (h%obs_within_bounds, value)
	call bin_record_value &
	(h%bin(i_bin), h%normalize_bins, 1._default, excess)
	if (present (success)) success = .true.
	else
	call bin_record_value (h%overflow, .false., 1._default, excess)
	if (present (success)) success = .false.
	end if
	end subroutine histogram_record_value_unweighted

	@ %def histogram_record_value_unweighted
	@ Weighted events: analogous, but no excess weight.
	<<Analysis: procedures>>=
	subroutine histogram_record_value_weighted (h, value, weight, success)
	type(histogram_t), intent(inout) :: h
	real(default), intent(in) :: value, weight
	logical, intent(out), optional :: success
	integer :: i_bin
	call observable_record_value (h%obs, value, weight)
	if (h%width /= 0) then
	i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
	else
	i_bin = 0
	end if
	if (i_bin <= 0) then
	call bin_record_value (h%underflow, .false., weight)
	if (present (success)) success = .false.
	else if (i_bin <= h%n_bins) then
	call observable_record_value (h%obs_within_bounds, value, weight)
	call bin_record_value (h%bin(i_bin), h%normalize_bins, weight)
	if (present (success)) success = .true.
	else
	call bin_record_value (h%overflow, .false., weight)
	if (present (success)) success = .false.
	end if
	end subroutine histogram_record_value_weighted

	@ %def histogram_record_value_weighted
	@
	\subsubsection{Access contents}
	Inherited from the observable component (all-over average etc.)
	<<Analysis: procedures>>=
	function histogram_get_n_entries (h) result (n)
	integer :: n
	type(histogram_t), intent(in) :: h
	n = observable_get_n_entries (h%obs)
	end function histogram_get_n_entries

	function histogram_get_average (h) result (avg)
	real(default) :: avg
	type(histogram_t), intent(in) :: h
	avg = observable_get_average (h%obs)
	end function histogram_get_average

	function histogram_get_error (h) result (err)
	real(default) :: err
	type(histogram_t), intent(in) :: h
	err = observable_get_error (h%obs)
	end function histogram_get_error

	@ %def histogram_get_n_entries
	@ %def histogram_get_average
	@ %def histogram_get_error
	@ Analogous, but applied only to events within bounds.
	<<Analysis: procedures>>=
	function histogram_get_n_entries_within_bounds (h) result (n)
	integer :: n
	type(histogram_t), intent(in) :: h
	n = observable_get_n_entries (h%obs_within_bounds)
	end function histogram_get_n_entries_within_bounds

	function histogram_get_average_within_bounds (h) result (avg)
	real(default) :: avg
	type(histogram_t), intent(in) :: h
	avg = observable_get_average (h%obs_within_bounds)
	end function histogram_get_average_within_bounds

	function histogram_get_error_within_bounds (h) result (err)
	real(default) :: err
	type(histogram_t), intent(in) :: h
	err = observable_get_error (h%obs_within_bounds)
	end function histogram_get_error_within_bounds

	@ %def histogram_get_n_entries_within_bounds
	@ %def histogram_get_average_within_bounds
	@ %def histogram_get_error_within_bounds
	Get the number of bins
	<<Analysis: procedures>>=
	function histogram_get_n_bins (h) result (n)
	type(histogram_t), intent(in) :: h
	integer :: n
	n = h%n_bins
	end function histogram_get_n_bins

	@ %def histogram_get_n_bins
	@ Check bins. If the index is zero or above the limit, return the
	results for underflow or overflow, respectively.
	<<Analysis: procedures>>=
	function histogram_get_n_entries_for_bin (h, i) result (n)
	integer :: n
	type(histogram_t), intent(in) :: h
	integer, intent(in) :: i
	if (i <= 0) then
	n = bin_get_n_entries (h%underflow)
	else if (i <= h%n_bins) then
	n = bin_get_n_entries (h%bin(i))
	else
	n = bin_get_n_entries (h%overflow)
	end if
	end function histogram_get_n_entries_for_bin

	function histogram_get_sum_for_bin (h, i) result (avg)
	real(default) :: avg
	type(histogram_t), intent(in) :: h
	integer, intent(in) :: i
	if (i <= 0) then
	avg = bin_get_sum (h%underflow)
	else if (i <= h%n_bins) then
	avg = bin_get_sum (h%bin(i))
	else
	avg = bin_get_sum (h%overflow)
	end if
	end function histogram_get_sum_for_bin

	function histogram_get_error_for_bin (h, i) result (err)
	real(default) :: err
	type(histogram_t), intent(in) :: h
	integer, intent(in) :: i
	if (i <= 0) then
	err = bin_get_error (h%underflow)
	else if (i <= h%n_bins) then
	err = bin_get_error (h%bin(i))
	else
	err = bin_get_error (h%overflow)
	end if
	end function histogram_get_error_for_bin

	function histogram_get_excess_for_bin (h, i) result (err)
	real(default) :: err
	type(histogram_t), intent(in) :: h
	integer, intent(in) :: i
	if (i <= 0) then
	err = bin_get_excess (h%underflow)
	else if (i <= h%n_bins) then
	err = bin_get_excess (h%bin(i))
	else
	err = bin_get_excess (h%overflow)
	end if
	end function histogram_get_excess_for_bin

	@ %def histogram_get_n_entries_for_bin
	@ %def histogram_get_sum_for_bin
	@ %def histogram_get_error_for_bin
	@ %def histogram_get_excess_for_bin
	@ Return a pointer to the graph options.
	<<Analysis: procedures>>=
	function histogram_get_graph_options_ptr (h) result (ptr)
	type(graph_options_t), pointer :: ptr
	type(histogram_t), intent(in), target :: h
	ptr => h%graph_options
	end function histogram_get_graph_options_ptr

	@ %def histogram_get_graph_options_ptr
	@ Return a pointer to the drawing options.
	<<Analysis: procedures>>=
	function histogram_get_drawing_options_ptr (h) result (ptr)
	type(drawing_options_t), pointer :: ptr
	type(histogram_t), intent(in), target :: h
	ptr => h%drawing_options
	end function histogram_get_drawing_options_ptr

	@ %def histogram_get_drawing_options_ptr
	@
	\subsubsection{Output}
	<<Analysis: procedures>>=
	subroutine histogram_write (h, unit)
	type(histogram_t), intent(in) :: h
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call bin_write_header (u)
	if (allocated (h%bin)) then
	do i = 1, h%n_bins
	call bin_write (h%bin(i), u)
	end do
	end if
	write (u, "(A)")
	write (u, "(A,1x,A)") "#", "Underflow:"
	call bin_write (h%underflow, u)
	write (u, "(A)")
	write (u, "(A,1x,A)") "#", "Overflow:"
	call bin_write (h%overflow, u)
	write (u, "(A)")
	write (u, "(A,1x,A)") "#", "Summary: data within bounds"
	call observable_write (h%obs_within_bounds, u)
	write (u, "(A)")
	write (u, "(A,1x,A)") "#", "Summary: all data"
	call observable_write (h%obs, u)
	write (u, "(A)")
	end subroutine histogram_write

	@ %def histogram_write
	@ Write the GAMELAN reader for histogram contents.
	<<Analysis: procedures>>=
	subroutine histogram_write_gml_reader (h, filename, unit)
	type(histogram_t), intent(in) :: h
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	character(*), parameter :: fmt = "(ES15.8)"
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(2x,A)") 'fromfile "' // char (filename) // '":'
	write (u, "(4x,A)") 'key "# Histogram:";'
	write (u, "(4x,A)") 'dx := #' &
	// real2char (h%width / h%n_bins / 2, fmt) // ';'
	write (u, "(4x,A)") 'for i withinblock:'
	write (u, "(6x,A)") 'get x, y, y.d, y.n, y.e;'
	if (h%drawing_options%with_hbars) then
	write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
	// ') (x,y) hbar dx;'
	else
	write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
	// ') (x,y);'
	end if
	if (h%drawing_options%err) then
	write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
	// '.err) ' &
	// '(x,y) vbar y.d;'
	end if
	!!! Future excess options for plots
	! write (u, "(6x,A)") 'if show_excess: ' // &
	! & 'plot(dat.e)(x, y plus y.e) hbar dx; fi'
	write (u, "(4x,A)") 'endfor'
	write (u, "(2x,A)") 'endfrom'
	end subroutine histogram_write_gml_reader

	@ %def histogram_write_gml_reader
	@ \LaTeX\ and GAMELAN output.
	<<Analysis: procedures>>=
	subroutine histogram_write_gml_driver (h, filename, unit)
	type(histogram_t), intent(in) :: h
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call graph_options_write_tex_header (h%graph_options, unit)
	write (u, "(2x,A)") char (graph_options_get_gml_setup (h%graph_options))
	write (u, "(2x,A)") char (graph_options_get_gml_graphrange &
	(h%graph_options, x_min=h%lower_bound, x_max=h%upper_bound))
	call histogram_write_gml_reader (h, filename, unit)
	calc_cmd = drawing_options_get_calc_command (h%drawing_options)
	if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
	bg_cmd = drawing_options_get_gml_bg_command (h%drawing_options)
	if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
	draw_cmd = drawing_options_get_draw_command (h%drawing_options)
	if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
	err_cmd = drawing_options_get_err_command (h%drawing_options)
	if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
	symb_cmd = drawing_options_get_symb_command (h%drawing_options)
	if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
	fg_cmd = drawing_options_get_gml_fg_command (h%drawing_options)
	if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
	write (u, "(2x,A)") char (graph_options_get_gml_x_label (h%graph_options))
	write (u, "(2x,A)") char (graph_options_get_gml_y_label (h%graph_options))
	call graph_options_write_tex_footer (h%graph_options, unit)
	write (u, "(A)") "\vspace*{2\baselineskip}"
	write (u, "(A)") "\begin{flushleft}"
	write (u, "(A)") "\textbf{Data within bounds:} \\"
	call observable_write_driver (h%obs_within_bounds, unit, &
	write_heading=.false.)
	write (u, "(A)") "\\[0.5\baselineskip]"
	write (u, "(A)") "\textbf{All data:} \\"
	call observable_write_driver (h%obs, unit, write_heading=.false.)
	write (u, "(A)") "\end{flushleft}"
	end subroutine histogram_write_gml_driver

	@ %def histogram_write_gml_driver
	@ Return the header for generic data output as an ifile.
	<<Analysis: procedures>>=
	subroutine histogram_get_header (h, header, comment)
	type(histogram_t), intent(in) :: h
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	type(string_t) :: c
	if (present (comment)) then
	c = comment
	else
	c = ""
	end if
	call ifile_append (header, c // "WHIZARD histogram data")
	call graph_options_get_header (h%graph_options, header, comment)
	call ifile_append (header, &
	c // "range: " // real2string (h%lower_bound) &
	// " - " // real2string (h%upper_bound))
	call ifile_append (header, &
	c // "counts total: " &
	// int2char (histogram_get_n_entries_within_bounds (h)))
	call ifile_append (header, &
	c // "total average: " &
	// real2string (histogram_get_average_within_bounds (h)) // " +- " &
	// real2string (histogram_get_error_within_bounds (h)))
	end subroutine histogram_get_header

	@ %def histogram_get_header
	@
	\subsection{Plots}
	\subsubsection{Points}
	<<Analysis: types>>=
	type :: point_t
	private
	real(default) :: x = 0
	real(default) :: y = 0
	real(default) :: yerr = 0
	real(default) :: xerr = 0
	type(point_t), pointer :: next => null ()
	end type point_t

	@ %def point_t
	<<Analysis: interfaces>>=
	interface point_init
	module procedure point_init_contents
	module procedure point_init_point
	end interface
	+<<Analysis: sub interfaces>>=
	+ module subroutine point_init_contents (point, x, y, yerr, xerr)
	+ type(point_t), intent(out) :: point
	+ real(default), intent(in) :: x, y
	+ real(default), intent(in), optional :: yerr, xerr
	+ end subroutine point_init_contents
	+ module subroutine point_init_point (point, point_in)
	+ type(point_t), intent(out) :: point
	+ type(point_t), intent(in) :: point_in
	+ end subroutine point_init_point
	<<Analysis: procedures>>=
	- subroutine point_init_contents (point, x, y, yerr, xerr)
	+ module subroutine point_init_contents (point, x, y, yerr, xerr)
	type(point_t), intent(out) :: point
	real(default), intent(in) :: x, y
	real(default), intent(in), optional :: yerr, xerr
	point%x = x
	point%y = y
	if (present (yerr)) point%yerr = yerr
	if (present (xerr)) point%xerr = xerr
	end subroutine point_init_contents

	- subroutine point_init_point (point, point_in)
	+ module subroutine point_init_point (point, point_in)
	type(point_t), intent(out) :: point
	type(point_t), intent(in) :: point_in
	point%x = point_in%x
	point%y = point_in%y
	point%yerr = point_in%yerr
	point%xerr = point_in%xerr
	end subroutine point_init_point

	@ %def point_init
	<<Analysis: procedures>>=
	function point_get_x (point) result (x)
	real(default) :: x
	type(point_t), intent(in) :: point
	x = point%x
	end function point_get_x

	function point_get_y (point) result (y)
	real(default) :: y
	type(point_t), intent(in) :: point
	y = point%y
	end function point_get_y

	function point_get_xerr (point) result (xerr)
	real(default) :: xerr
	type(point_t), intent(in) :: point
	xerr = point%xerr
	end function point_get_xerr

	function point_get_yerr (point) result (yerr)
	real(default) :: yerr
	type(point_t), intent(in) :: point
	yerr = point%yerr
	end function point_get_yerr

	@ %def point_get_x
	@ %def point_get_y
	@ %def point_get_xerr
	@ %def point_get_yerr
	<<Analysis: procedures>>=
	subroutine point_write_header (unit)
	integer, intent(in) :: unit
	character(120) :: buffer
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (buffer, "(A,4(1x," // HISTOGRAM_HEAD_FORMAT // "))") &
	"#", "x ", "y ", "yerr ", "xerr "
	write (u, "(A)") trim (buffer)
	end subroutine point_write_header

	subroutine point_write (point, unit)
	type(point_t), intent(in) :: point
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "))") &
	point_get_x (point), &
	point_get_y (point), &
	point_get_yerr (point), &
	point_get_xerr (point)
	end subroutine point_write

	@ %def point_write
	@
	\subsubsection{Plots}
	<<Analysis: types>>=
	type :: plot_t
	private
	type(point_t), pointer :: first => null ()
	type(point_t), pointer :: last => null ()
	integer :: count = 0
	type(graph_options_t) :: graph_options
	type(drawing_options_t) :: drawing_options
	end type plot_t

	@ %def plot_t
	@
	\subsubsection{Initializer/finalizer}
	Initialize a plot. We provide the lower and upper bound in the $x$
	direction.
	<<Analysis: interfaces>>=
	interface plot_init
	module procedure plot_init_empty
	module procedure plot_init_plot
	end interface
	+<<Analysis: sub interfaces>>=
	+ module subroutine plot_init_empty (p, id, graph_options, drawing_options)
	+ type(plot_t), intent(out) :: p
	+ type(string_t), intent(in) :: id
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine plot_init_empty
	<<Analysis: procedures>>=
	- subroutine plot_init_empty (p, id, graph_options, drawing_options)
	+ module subroutine plot_init_empty (p, id, graph_options, drawing_options)
	type(plot_t), intent(out) :: p
	type(string_t), intent(in) :: id
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	if (present (graph_options)) then
	p%graph_options = graph_options
	else
	- call graph_options_init (p%graph_options)
	+ call p%graph_options%init ()
	end if
	- call graph_options_set (p%graph_options, id = id)
	+ call p%graph_options%set (id = id)
	if (present (drawing_options)) then
	p%drawing_options = drawing_options
	else
	- call drawing_options_init_plot (p%drawing_options)
	+ call p%drawing_options%init_plot ()
	end if
	end subroutine plot_init_empty

	@ %def plot_init
	@ Initialize a plot by copying another one, optionally merging in a new
	set of drawing options.

	Since [[p]] has pointer (sub)components, we have to explicitly deep-copy the
	original.
	+<<Analysis: sub interfaces>>=
	+ module subroutine plot_init_plot (p, p_in, drawing_options)
	+ type(plot_t), intent(out) :: p
	+ type(plot_t), intent(in) :: p_in
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine plot_init_plot
	<<Analysis: procedures>>=
	- subroutine plot_init_plot (p, p_in, drawing_options)
	+ module subroutine plot_init_plot (p, p_in, drawing_options)
	type(plot_t), intent(out) :: p
	type(plot_t), intent(in) :: p_in
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(point_t), pointer :: current, new
	current => p_in%first
	do while (associated (current))
	allocate (new)
	call point_init (new, current)
	if (associated (p%last)) then
	p%last%next => new
	else
	p%first => new
	end if
	p%last => new
	current => current%next
	end do
	p%count = p_in%count
	p%graph_options = p_in%graph_options
	if (present (drawing_options)) then
	p%drawing_options = drawing_options
	else
	p%drawing_options = p_in%drawing_options
	end if
	end subroutine plot_init_plot

	@ %def plot_init_plot
	@ Finalize the plot by deallocating the list of points.
	<<Analysis: procedures>>=
	subroutine plot_final (plot)
	type(plot_t), intent(inout) :: plot
	type(point_t), pointer :: current
	do while (associated (plot%first))
	current => plot%first
	plot%first => current%next
	deallocate (current)
	end do
	plot%last => null ()
	end subroutine plot_final

	@ %def plot_final
	@
	\subsubsection{Fill plots}
	Clear the plot contents, but do not modify the structure.
	<<Analysis: procedures>>=
	subroutine plot_clear (plot)
	type(plot_t), intent(inout) :: plot
	plot%count = 0
	call plot_final (plot)
	end subroutine plot_clear

	@ %def plot_clear
	@ Record a value. Successful if the value is within bounds, otherwise
	it is recorded as under-/overflow.
	<<Analysis: procedures>>=
	subroutine plot_record_value (plot, x, y, yerr, xerr, success)
	type(plot_t), intent(inout) :: plot
	real(default), intent(in) :: x, y
	real(default), intent(in), optional :: yerr, xerr
	logical, intent(out), optional :: success
	type(point_t), pointer :: point
	plot%count = plot%count + 1
	allocate (point)
	call point_init (point, x, y, yerr, xerr)
	if (associated (plot%first)) then
	plot%last%next => point
	else
	plot%first => point
	end if
	plot%last => point
	if (present (success)) success = .true.
	end subroutine plot_record_value

	@ %def plot_record_value
	@
	\subsubsection{Access contents}
	The number of points.
	<<Analysis: procedures>>=
	function plot_get_n_entries (plot) result (n)
	integer :: n
	type(plot_t), intent(in) :: plot
	n = plot%count
	end function plot_get_n_entries

	@ %def plot_get_n_entries
	@ Return a pointer to the graph options.
	<<Analysis: procedures>>=
	function plot_get_graph_options_ptr (p) result (ptr)
	type(graph_options_t), pointer :: ptr
	type(plot_t), intent(in), target :: p
	ptr => p%graph_options
	end function plot_get_graph_options_ptr

	@ %def plot_get_graph_options_ptr
	@ Return a pointer to the drawing options.
	<<Analysis: procedures>>=
	function plot_get_drawing_options_ptr (p) result (ptr)
	type(drawing_options_t), pointer :: ptr
	type(plot_t), intent(in), target :: p
	ptr => p%drawing_options
	end function plot_get_drawing_options_ptr

	@ %def plot_get_drawing_options_ptr
	@
	\subsubsection{Output}
	This output format is used by the GAMELAN driver below.
	<<Analysis: procedures>>=
	subroutine plot_write (plot, unit)
	type(plot_t), intent(in) :: plot
	integer, intent(in), optional :: unit
	type(point_t), pointer :: point
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call point_write_header (u)
	point => plot%first
	do while (associated (point))
	call point_write (point, unit)
	point => point%next
	end do
	write (u, *)
	write (u, "(A,1x,A)") "#", "Summary:"
	write (u, "(A,1x,I0)") &
	"n_entries =", plot_get_n_entries (plot)
	write (u, *)
	end subroutine plot_write

	@ %def plot_write
	@ Write the GAMELAN reader for plot contents.
	<<Analysis: procedures>>=
	subroutine plot_write_gml_reader (p, filename, unit)
	type(plot_t), intent(in) :: p
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(2x,A)") 'fromfile "' // char (filename) // '":'
	write (u, "(4x,A)") 'key "# Plot:";'
	write (u, "(4x,A)") 'for i withinblock:'
	write (u, "(6x,A)") 'get x, y, y.err, x.err;'
	write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) &
	// ') (x,y);'
	if (p%drawing_options%err) then
	write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) &
	// '.err) (x,y) vbar y.err hbar x.err;'
	end if
	write (u, "(4x,A)") 'endfor'
	write (u, "(2x,A)") 'endfrom'
	end subroutine plot_write_gml_reader

	@ %def plot_write_gml_header
	@ \LaTeX\ and GAMELAN output. Analogous to histogram output.
	<<Analysis: procedures>>=
	subroutine plot_write_gml_driver (p, filename, unit)
	type(plot_t), intent(in) :: p
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	call graph_options_write_tex_header (p%graph_options, unit)
	write (u, "(2x,A)") &
	char (graph_options_get_gml_setup (p%graph_options))
	write (u, "(2x,A)") &
	char (graph_options_get_gml_graphrange (p%graph_options))
	call plot_write_gml_reader (p, filename, unit)
	calc_cmd = drawing_options_get_calc_command (p%drawing_options)
	if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
	bg_cmd = drawing_options_get_gml_bg_command (p%drawing_options)
	if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
	draw_cmd = drawing_options_get_draw_command (p%drawing_options)
	if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
	err_cmd = drawing_options_get_err_command (p%drawing_options)
	if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
	symb_cmd = drawing_options_get_symb_command (p%drawing_options)
	if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
	fg_cmd = drawing_options_get_gml_fg_command (p%drawing_options)
	if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
	write (u, "(2x,A)") char (graph_options_get_gml_x_label (p%graph_options))
	write (u, "(2x,A)") char (graph_options_get_gml_y_label (p%graph_options))
	call graph_options_write_tex_footer (p%graph_options, unit)
	end subroutine plot_write_gml_driver

	@ %def plot_write_driver
	@ Append header for generic data output in ifile format.
	<<Analysis: procedures>>=
	subroutine plot_get_header (plot, header, comment)
	type(plot_t), intent(in) :: plot
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	type(string_t) :: c
	if (present (comment)) then
	c = comment
	else
	c = ""
	end if
	call ifile_append (header, c // "WHIZARD plot data")
	call graph_options_get_header (plot%graph_options, header, comment)
	call ifile_append (header, &
	c // "number of points: " &
	// int2char (plot_get_n_entries (plot)))
	end subroutine plot_get_header

	@ %def plot_get_header
	@
	\subsection{Graphs}
	A graph is a container for several graph elements. Each graph element is
	either a plot or a histogram. There is an appropriate base type below
	(the [[analysis_object_t]]), but to avoid recursion, we define a separate base
	type here. Note that there is no actual recursion: a graph is an analysis
	object, but a graph cannot contain graphs.

	(If we could use type extension, the implementation would be much more
	transparent.)

	\subsubsection{Graph elements}
	Graph elements cannot be filled by the [[record]] command directly. The
	contents are always copied from elementary histograms or plots.
	<<Analysis: types>>=
	type :: graph_element_t
	private
	integer :: type = AN_UNDEFINED
	type(histogram_t), pointer :: h => null ()
	type(plot_t), pointer :: p => null ()
	end type graph_element_t

	@ %def graph_element_t
	<<Analysis: procedures>>=
	subroutine graph_element_final (el)
	type(graph_element_t), intent(inout) :: el
	select case (el%type)
	case (AN_HISTOGRAM)
	deallocate (el%h)
	case (AN_PLOT)
	call plot_final (el%p)
	deallocate (el%p)
	end select
	el%type = AN_UNDEFINED
	end subroutine graph_element_final

	@ %def graph_element_final
	@ Return the number of entries in the graph element:
	<<Analysis: procedures>>=
	function graph_element_get_n_entries (el) result (n)
	integer :: n
	type(graph_element_t), intent(in) :: el
	select case (el%type)
	case (AN_HISTOGRAM); n = histogram_get_n_entries (el%h)
	case (AN_PLOT); n = plot_get_n_entries (el%p)
	case default; n = 0
	end select
	end function graph_element_get_n_entries

	@ %def graph_element_get_n_entries
	@ Return a pointer to the graph / drawing options.
	<<Analysis: procedures>>=
	function graph_element_get_graph_options_ptr (el) result (ptr)
	type(graph_options_t), pointer :: ptr
	type(graph_element_t), intent(in) :: el
	select case (el%type)
	case (AN_HISTOGRAM); ptr => histogram_get_graph_options_ptr (el%h)
	case (AN_PLOT); ptr => plot_get_graph_options_ptr (el%p)
	case default; ptr => null ()
	end select
	end function graph_element_get_graph_options_ptr

	function graph_element_get_drawing_options_ptr (el) result (ptr)
	type(drawing_options_t), pointer :: ptr
	type(graph_element_t), intent(in) :: el
	select case (el%type)
	case (AN_HISTOGRAM); ptr => histogram_get_drawing_options_ptr (el%h)
	case (AN_PLOT); ptr => plot_get_drawing_options_ptr (el%p)
	case default; ptr => null ()
	end select
	end function graph_element_get_drawing_options_ptr

	@ %def graph_element_get_graph_options_ptr
	@ %def graph_element_get_drawing_options_ptr
	@ Output, simple wrapper for the plot/histogram writer.
	<<Analysis: procedures>>=
	subroutine graph_element_write (el, unit)
	type(graph_element_t), intent(in) :: el
	integer, intent(in), optional :: unit
	type(graph_options_t), pointer :: gro
	type(string_t) :: id
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	gro => graph_element_get_graph_options_ptr (el)
	id = graph_options_get_id (gro)
	write (u, "(A,A)") '#', repeat ("-", 78)
	select case (el%type)
	case (AN_HISTOGRAM)
	write (u, "(A)", advance="no") "# Histogram: "
	write (u, "(1x,A)") char (id)
	call histogram_write (el%h, unit)
	case (AN_PLOT)
	write (u, "(A)", advance="no") "# Plot: "
	write (u, "(1x,A)") char (id)
	call plot_write (el%p, unit)
	end select
	end subroutine graph_element_write

	@ %def graph_element_write
	<<Analysis: procedures>>=
	subroutine graph_element_write_gml_reader (el, filename, unit)
	type(graph_element_t), intent(in) :: el
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	select case (el%type)
	case (AN_HISTOGRAM); call histogram_write_gml_reader (el%h, filename, unit)
	case (AN_PLOT); call plot_write_gml_reader (el%p, filename, unit)
	end select
	end subroutine graph_element_write_gml_reader

	@ %def graph_element_write_gml_reader
	@
	\subsubsection{The graph type}
	The actual graph type contains its own [[graph_options]], which override the
	individual settings. The [[drawing_options]] are set in the graph elements.
	This distinction motivates the separation of the two types.
	<<Analysis: types>>=
	type :: graph_t
	private
	type(graph_element_t), dimension(:), allocatable :: el
	type(graph_options_t) :: graph_options
	end type graph_t

	@ %def graph_t
	@
	\subsubsection{Initializer/finalizer}
	The graph is created with a definite number of elements. The elements are
	filled one by one, optionally with modified drawing options.
	<<Analysis: procedures>>=
	subroutine graph_init (g, id, n_elements, graph_options)
	type(graph_t), intent(out) :: g
	type(string_t), intent(in) :: id
	integer, intent(in) :: n_elements
	type(graph_options_t), intent(in), optional :: graph_options
	allocate (g%el (n_elements))
	if (present (graph_options)) then
	g%graph_options = graph_options
	else
	- call graph_options_init (g%graph_options)
	+ call g%graph_options%init ()
	end if
	- call graph_options_set (g%graph_options, id = id)
	+ call g%graph_options%set (id = id)
	end subroutine graph_init

	@ %def graph_init
	<<Analysis: procedures>>=
	subroutine graph_insert_histogram (g, i, h, drawing_options)
	type(graph_t), intent(inout), target :: g
	integer, intent(in) :: i
	type(histogram_t), intent(in) :: h
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(graph_options_t), pointer :: gro
	type(drawing_options_t), pointer :: dro
	type(string_t) :: id
	g%el(i)%type = AN_HISTOGRAM
	allocate (g%el(i)%h)
	call histogram_init_histogram (g%el(i)%h, h, drawing_options)
	gro => histogram_get_graph_options_ptr (g%el(i)%h)
	dro => histogram_get_drawing_options_ptr (g%el(i)%h)
	id = graph_options_get_id (gro)
	- call drawing_options_set (dro, dataset = "dat." // id)
	+ call dro%set (dataset = "dat." // id)
	end subroutine graph_insert_histogram

	@ %def graph_insert_histogram
	<<Analysis: procedures>>=
	subroutine graph_insert_plot (g, i, p, drawing_options)
	type(graph_t), intent(inout) :: g
	integer, intent(in) :: i
	type(plot_t), intent(in) :: p
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(graph_options_t), pointer :: gro
	type(drawing_options_t), pointer :: dro
	type(string_t) :: id
	g%el(i)%type = AN_PLOT
	allocate (g%el(i)%p)
	call plot_init_plot (g%el(i)%p, p, drawing_options)
	gro => plot_get_graph_options_ptr (g%el(i)%p)
	dro => plot_get_drawing_options_ptr (g%el(i)%p)
	id = graph_options_get_id (gro)
	- call drawing_options_set (dro, dataset = "dat." // id)
	+ call dro%set (dataset = "dat." // id)
	end subroutine graph_insert_plot

	@ %def graph_insert_plot
	@ Finalizer.
	<<Analysis: procedures>>=
	subroutine graph_final (g)
	type(graph_t), intent(inout) :: g
	integer :: i
	do i = 1, size (g%el)
	call graph_element_final (g%el(i))
	end do
	deallocate (g%el)
	end subroutine graph_final

	@ %def graph_final
	@
	\subsubsection{Access contents}
	The number of elements.
	<<Analysis: procedures>>=
	function graph_get_n_elements (graph) result (n)
	integer :: n
	type(graph_t), intent(in) :: graph
	n = size (graph%el)
	end function graph_get_n_elements

	@ %def graph_get_n_elements
	@ Retrieve a pointer to the drawing options of an element, so they can be
	modified. (The [[target]] attribute is not actually needed because the
	components are pointers.)
	<<Analysis: procedures>>=
	function graph_get_drawing_options_ptr (g, i) result (ptr)
	type(drawing_options_t), pointer :: ptr
	type(graph_t), intent(in), target :: g
	integer, intent(in) :: i
	ptr => graph_element_get_drawing_options_ptr (g%el(i))
	end function graph_get_drawing_options_ptr

	@ %def graph_get_drawing_options_ptr
	@
	\subsubsection{Output}
	The default output format just writes histogram and plot data.
	<<Analysis: procedures>>=
	subroutine graph_write (graph, unit)
	type(graph_t), intent(in) :: graph
	integer, intent(in), optional :: unit
	integer :: i
	do i = 1, size (graph%el)
	call graph_element_write (graph%el(i), unit)
	end do
	end subroutine graph_write

	@ %def graph_write
	@ The GAMELAN driver is not a simple wrapper, but it writes the plot/histogram
	contents embedded the complete graph. First, data are read in, global
	background commands next, then individual elements, then global foreground
	commands.
	<<Analysis: procedures>>=
	subroutine graph_write_gml_driver (g, filename, unit)
	type(graph_t), intent(in) :: g
	type(string_t), intent(in) :: filename
	type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
	integer, intent(in), optional :: unit
	type(drawing_options_t), pointer :: dro
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	call graph_options_write_tex_header (g%graph_options, unit)
	write (u, "(2x,A)") &
	char (graph_options_get_gml_setup (g%graph_options))
	write (u, "(2x,A)") &
	char (graph_options_get_gml_graphrange (g%graph_options))
	do i = 1, size (g%el)
	call graph_element_write_gml_reader (g%el(i), filename, unit)
	calc_cmd = drawing_options_get_calc_command &
	(graph_element_get_drawing_options_ptr (g%el(i)))
	if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
	end do
	bg_cmd = graph_options_get_gml_bg_command (g%graph_options)
	if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
	do i = 1, size (g%el)
	dro => graph_element_get_drawing_options_ptr (g%el(i))
	bg_cmd = drawing_options_get_gml_bg_command (dro)
	if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
	draw_cmd = drawing_options_get_draw_command (dro)
	if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
	err_cmd = drawing_options_get_err_command (dro)
	if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
	symb_cmd = drawing_options_get_symb_command (dro)
	if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
	fg_cmd = drawing_options_get_gml_fg_command (dro)
	if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
	end do
	fg_cmd = graph_options_get_gml_fg_command (g%graph_options)
	if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
	write (u, "(2x,A)") char (graph_options_get_gml_x_label (g%graph_options))
	write (u, "(2x,A)") char (graph_options_get_gml_y_label (g%graph_options))
	call graph_options_write_tex_footer (g%graph_options, unit)
	end subroutine graph_write_gml_driver

	@ %def graph_write_gml_driver
	@ Append header for generic data output in ifile format.
	<<Analysis: procedures>>=
	subroutine graph_get_header (graph, header, comment)
	type(graph_t), intent(in) :: graph
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	type(string_t) :: c
	if (present (comment)) then
	c = comment
	else
	c = ""
	end if
	call ifile_append (header, c // "WHIZARD graph data")
	call graph_options_get_header (graph%graph_options, header, comment)
	call ifile_append (header, &
	c // "number of graph elements: " &
	// int2char (graph_get_n_elements (graph)))
	end subroutine graph_get_header

	@ %def graph_get_header
	@
	\subsection{Analysis objects}
	This data structure holds all observables, histograms and such that
	are currently active. We have one global store; individual items are
	identified by their ID strings.

	(This should rather be coded by type extension.)
	<<Analysis: parameters>>=
	integer, parameter :: AN_UNDEFINED = 0
	integer, parameter :: AN_OBSERVABLE = 1
	integer, parameter :: AN_HISTOGRAM = 2
	integer, parameter :: AN_PLOT = 3
	integer, parameter :: AN_GRAPH = 4
	<<Analysis: public>>=
	public :: AN_UNDEFINED, AN_HISTOGRAM, AN_OBSERVABLE, AN_PLOT, AN_GRAPH

	@ %def AN_UNDEFINED
	@ %def AN_OBSERVABLE AN_HISTOGRAM AN_PLOT AN_GRAPH
	<<Analysis: types>>=
	type :: analysis_object_t
	private
	type(string_t) :: id
	integer :: type = AN_UNDEFINED
	type(observable_t), pointer :: obs => null ()
	type(histogram_t), pointer :: h => null ()
	type(plot_t), pointer :: p => null ()
	type(graph_t), pointer :: g => null ()
	type(analysis_object_t), pointer :: next => null ()
	end type analysis_object_t

	@ %def analysis_object_t
	@
	\subsubsection{Initializer/finalizer}
	Allocate with the correct type but do not fill initial values.
	<<Analysis: procedures>>=
	subroutine analysis_object_init (obj, id, type)
	type(analysis_object_t), intent(out) :: obj
	type(string_t), intent(in) :: id
	integer, intent(in) :: type
	obj%id = id
	obj%type = type
	select case (obj%type)
	case (AN_OBSERVABLE); allocate (obj%obs)
	case (AN_HISTOGRAM); allocate (obj%h)
	case (AN_PLOT); allocate (obj%p)
	case (AN_GRAPH); allocate (obj%g)
	end select
	end subroutine analysis_object_init

	@ %def analysis_object_init
	<<Analysis: procedures>>=
	subroutine analysis_object_final (obj)
	type(analysis_object_t), intent(inout) :: obj
	select case (obj%type)
	case (AN_OBSERVABLE)
	deallocate (obj%obs)
	case (AN_HISTOGRAM)
	deallocate (obj%h)
	case (AN_PLOT)
	call plot_final (obj%p)
	deallocate (obj%p)
	case (AN_GRAPH)
	call graph_final (obj%g)
	deallocate (obj%g)
	end select
	obj%type = AN_UNDEFINED
	end subroutine analysis_object_final

	@ %def analysis_object_final
	@ Clear the analysis object, i.e., reset it to its initial state. Not
	applicable to graphs, which are always combinations of other existing
	objects.
	<<Analysis: procedures>>=
	subroutine analysis_object_clear (obj)
	type(analysis_object_t), intent(inout) :: obj
	select case (obj%type)
	case (AN_OBSERVABLE)
	call observable_clear (obj%obs)
	case (AN_HISTOGRAM)
	call histogram_clear (obj%h)
	case (AN_PLOT)
	call plot_clear (obj%p)
	end select
	end subroutine analysis_object_clear

	@ %def analysis_object_clear
	@
	\subsubsection{Fill with data}
	Record data. The effect depends on the type of analysis object.
	<<Analysis: procedures>>=
	subroutine analysis_object_record_data (obj, &
	x, y, yerr, xerr, weight, excess, success)
	type(analysis_object_t), intent(inout) :: obj
	real(default), intent(in) :: x
	real(default), intent(in), optional :: y, yerr, xerr, weight, excess
	logical, intent(out), optional :: success
	select case (obj%type)
	case (AN_OBSERVABLE)
	if (present (weight)) then
	call observable_record_value_weighted (obj%obs, x, weight, success)
	else
	call observable_record_value_unweighted (obj%obs, x, success)
	end if
	case (AN_HISTOGRAM)
	if (present (weight)) then
	call histogram_record_value_weighted (obj%h, x, weight, success)
	else
	call histogram_record_value_unweighted (obj%h, x, excess, success)
	end if
	case (AN_PLOT)
	if (present (y)) then
	call plot_record_value (obj%p, x, y, yerr, xerr, success)
	else
	if (present (success)) success = .false.
	end if
	case default
	if (present (success)) success = .false.
	end select
	end subroutine analysis_object_record_data

	@ %def analysis_object_record_data
	@ Explicitly set the pointer to the next object in the list.
	<<Analysis: procedures>>=
	subroutine analysis_object_set_next_ptr (obj, next)
	type(analysis_object_t), intent(inout) :: obj
	type(analysis_object_t), pointer :: next
	obj%next => next
	end subroutine analysis_object_set_next_ptr

	@ %def analysis_object_set_next_ptr
	@
	\subsubsection{Access contents}
	Return a pointer to the next object in the list.
	<<Analysis: procedures>>=
	function analysis_object_get_next_ptr (obj) result (next)
	type(analysis_object_t), pointer :: next
	type(analysis_object_t), intent(in) :: obj
	next => obj%next
	end function analysis_object_get_next_ptr

	@ %def analysis_object_get_next_ptr
	@ Return data as appropriate for the object type.
	<<Analysis: procedures>>=
	function analysis_object_get_n_elements (obj) result (n)
	integer :: n
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_HISTOGRAM)
	n = 1
	case (AN_PLOT)
	n = 1
	case (AN_GRAPH)
	n = graph_get_n_elements (obj%g)
	case default
	n = 0
	end select
	end function analysis_object_get_n_elements

	function analysis_object_get_n_entries (obj, within_bounds) result (n)
	integer :: n
	type(analysis_object_t), intent(in) :: obj
	logical, intent(in), optional :: within_bounds
	logical :: wb
	select case (obj%type)
	case (AN_OBSERVABLE)
	n = observable_get_n_entries (obj%obs)
	case (AN_HISTOGRAM)
	wb = .false.; if (present (within_bounds)) wb = within_bounds
	if (wb) then
	n = histogram_get_n_entries_within_bounds (obj%h)
	else
	n = histogram_get_n_entries (obj%h)
	end if
	case (AN_PLOT)
	n = plot_get_n_entries (obj%p)
	case default
	n = 0
	end select
	end function analysis_object_get_n_entries

	function analysis_object_get_average (obj, within_bounds) result (avg)
	real(default) :: avg
	type(analysis_object_t), intent(in) :: obj
	logical, intent(in), optional :: within_bounds
	logical :: wb
	select case (obj%type)
	case (AN_OBSERVABLE)
	avg = observable_get_average (obj%obs)
	case (AN_HISTOGRAM)
	wb = .false.; if (present (within_bounds)) wb = within_bounds
	if (wb) then
	avg = histogram_get_average_within_bounds (obj%h)
	else
	avg = histogram_get_average (obj%h)
	end if
	case default
	avg = 0
	end select
	end function analysis_object_get_average

	function analysis_object_get_error (obj, within_bounds) result (err)
	real(default) :: err
	type(analysis_object_t), intent(in) :: obj
	logical, intent(in), optional :: within_bounds
	logical :: wb
	select case (obj%type)
	case (AN_OBSERVABLE)
	err = observable_get_error (obj%obs)
	case (AN_HISTOGRAM)
	wb = .false.; if (present (within_bounds)) wb = within_bounds
	if (wb) then
	err = histogram_get_error_within_bounds (obj%h)
	else
	err = histogram_get_error (obj%h)
	end if
	case default
	err = 0
	end select
	end function analysis_object_get_error

	@ %def analysis_object_get_n_elements
	@ %def analysis_object_get_n_entries
	@ %def analysis_object_get_average
	@ %def analysis_object_get_error
	@ Return pointers to the actual contents:
	<<Analysis: procedures>>=
	function analysis_object_get_observable_ptr (obj) result (obs)
	type(observable_t), pointer :: obs
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_OBSERVABLE); obs => obj%obs
	case default; obs => null ()
	end select
	end function analysis_object_get_observable_ptr

	function analysis_object_get_histogram_ptr (obj) result (h)
	type(histogram_t), pointer :: h
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_HISTOGRAM); h => obj%h
	case default; h => null ()
	end select
	end function analysis_object_get_histogram_ptr

	function analysis_object_get_plot_ptr (obj) result (plot)
	type(plot_t), pointer :: plot
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_PLOT); plot => obj%p
	case default; plot => null ()
	end select
	end function analysis_object_get_plot_ptr

	function analysis_object_get_graph_ptr (obj) result (g)
	type(graph_t), pointer :: g
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_GRAPH); g => obj%g
	case default; g => null ()
	end select
	end function analysis_object_get_graph_ptr

	@ %def analysis_object_get_observable_ptr
	@ %def analysis_object_get_histogram_ptr
	@ %def analysis_object_get_plot_ptr
	@ %def analysis_object_get_graph_ptr
	@ Return true if the object has a graphical representation:
	<<Analysis: procedures>>=
	function analysis_object_has_plot (obj) result (flag)
	logical :: flag
	type(analysis_object_t), intent(in) :: obj
	select case (obj%type)
	case (AN_HISTOGRAM); flag = .true.
	case (AN_PLOT); flag = .true.
	case (AN_GRAPH); flag = .true.
	case default; flag = .false.
	end select
	end function analysis_object_has_plot

	@ %def analysis_object_has_plot
	@
	\subsubsection{Output}
	<<Analysis: procedures>>=
	subroutine analysis_object_write (obj, unit, verbose)
	type(analysis_object_t), intent(in) :: obj
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	logical :: verb
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	verb = .false.; if (present (verbose)) verb = verbose
	write (u, "(A)") repeat ("#", 79)
	select case (obj%type)
	case (AN_OBSERVABLE)
	write (u, "(A)", advance="no") "# Observable:"
	case (AN_HISTOGRAM)
	write (u, "(A)", advance="no") "# Histogram: "
	case (AN_PLOT)
	write (u, "(A)", advance="no") "# Plot: "
	case (AN_GRAPH)
	write (u, "(A)", advance="no") "# Graph: "
	case default
	write (u, "(A)") "# [undefined analysis object]"
	return
	end select
	write (u, "(1x,A)") char (obj%id)
	select case (obj%type)
	case (AN_OBSERVABLE)
	call observable_write (obj%obs, unit)
	case (AN_HISTOGRAM)
	if (verb) then
	- call graph_options_write (obj%h%graph_options, unit)
	+ call obj%h%graph_options%write (unit)
	write (u, *)
	- call drawing_options_write (obj%h%drawing_options, unit)
	+ call obj%h%drawing_options%write (unit)
	write (u, *)
	end if
	call histogram_write (obj%h, unit)
	case (AN_PLOT)
	if (verb) then
	- call graph_options_write (obj%p%graph_options, unit)
	+ call obj%p%graph_options%write (unit)
	write (u, *)
	- call drawing_options_write (obj%p%drawing_options, unit)
	+ call obj%p%drawing_options%write (unit)
	write (u, *)
	end if
	call plot_write (obj%p, unit)
	case (AN_GRAPH)
	call graph_write (obj%g, unit)
	end select
	end subroutine analysis_object_write

	@ %def analysis_object_write
	@ Write the object part of the \LaTeX\ driver file.
	<<Analysis: procedures>>=
	subroutine analysis_object_write_driver (obj, filename, unit)
	type(analysis_object_t), intent(in) :: obj
	type(string_t), intent(in) :: filename
	integer, intent(in), optional :: unit
	select case (obj%type)
	case (AN_OBSERVABLE)
	call observable_write_driver (obj%obs, unit)
	case (AN_HISTOGRAM)
	call histogram_write_gml_driver (obj%h, filename, unit)
	case (AN_PLOT)
	call plot_write_gml_driver (obj%p, filename, unit)
	case (AN_GRAPH)
	call graph_write_gml_driver (obj%g, filename, unit)
	end select
	end subroutine analysis_object_write_driver

	@ %def analysis_object_write_driver
	@ Return a data header for external formats, in ifile form.
	<<Analysis: procedures>>=
	subroutine analysis_object_get_header (obj, header, comment)
	type(analysis_object_t), intent(in) :: obj
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	select case (obj%type)
	case (AN_HISTOGRAM)
	call histogram_get_header (obj%h, header, comment)
	case (AN_PLOT)
	call plot_get_header (obj%p, header, comment)
	end select
	end subroutine analysis_object_get_header

	@ %def analysis_object_get_header
	@
	\subsection{Analysis object iterator}
	Analysis objects are containers which have iterable data structures:
	histograms/bins and plots/points. If they are to be treated on a common
	basis, it is useful to have an iterator which hides the implementation
	details.

	The iterator is used only for elementary analysis objects that contain plot
	data: histograms or plots. It is invalid for meta-objects (graphs) and
	non-graphical objects (observables).
	-<<Analysis: public>>=
	- public :: analysis_iterator_t
	<<Analysis: types>>=
	type :: analysis_iterator_t
	private
	integer :: type = AN_UNDEFINED
	type(analysis_object_t), pointer :: object => null ()
	integer :: index = 1
	type(point_t), pointer :: point => null ()
	end type

	@ %def analysis_iterator_t
	@ The initializer places the iterator at the beginning of the analysis object.
	<<Analysis: procedures>>=
	subroutine analysis_iterator_init (iterator, object)
	type(analysis_iterator_t), intent(out) :: iterator
	type(analysis_object_t), intent(in), target :: object
	iterator%object => object
	if (associated (iterator%object)) then
	iterator%type = iterator%object%type
	select case (iterator%type)
	case (AN_PLOT)
	iterator%point => iterator%object%p%first
	end select
	end if
	end subroutine analysis_iterator_init

	@ %def analysis_iterator_init
	@ The iterator is valid as long as it points to an existing entry. An
	iterator for a data object without array data (observable) is always invalid.
	-<<Analysis: public>>=
	- public :: analysis_iterator_is_valid
	<<Analysis: procedures>>=
	function analysis_iterator_is_valid (iterator) result (valid)
	logical :: valid
	type(analysis_iterator_t), intent(in) :: iterator
	if (associated (iterator%object)) then
	select case (iterator%type)
	case (AN_HISTOGRAM)
	valid = iterator%index <= histogram_get_n_bins (iterator%object%h)
	case (AN_PLOT)
	valid = associated (iterator%point)
	case default
	valid = .false.
	end select
	else
	valid = .false.
	end if
	end function analysis_iterator_is_valid

	@ %def analysis_iterator_is_valid
	@ Advance the iterator.
	-<<Analysis: public>>=
	- public :: analysis_iterator_advance
	<<Analysis: procedures>>=
	subroutine analysis_iterator_advance (iterator)
	type(analysis_iterator_t), intent(inout) :: iterator
	if (associated (iterator%object)) then
	select case (iterator%type)
	case (AN_PLOT)
	iterator%point => iterator%point%next
	end select
	iterator%index = iterator%index + 1
	end if
	end subroutine analysis_iterator_advance

	@ %def analysis_iterator_advance
	@ Retrieve the object type:
	-<<Analysis: public>>=
	- public :: analysis_iterator_get_type
	<<Analysis: procedures>>=
	function analysis_iterator_get_type (iterator) result (type)
	integer :: type
	type(analysis_iterator_t), intent(in) :: iterator
	type = iterator%type
	end function analysis_iterator_get_type

	@ %def analysis_iterator_get_type
	@ Use the iterator to retrieve data. We implement a common routine which
	takes the data descriptors as optional arguments. Data which do not occur in
	the selected type trigger to an error condition.

	The iterator must point to a valid entry.
	-<<Analysis: public>>=
	- public :: analysis_iterator_get_data
	<<Analysis: procedures>>=
	subroutine analysis_iterator_get_data (iterator, &
	x, y, yerr, xerr, width, excess, index, n_total)
	type(analysis_iterator_t), intent(in) :: iterator
	real(default), intent(out), optional :: x, y, yerr, xerr, width, excess
	integer, intent(out), optional :: index, n_total
	select case (iterator%type)
	case (AN_HISTOGRAM)
	if (present (x)) &
	x = bin_get_midpoint (iterator%object%h%bin(iterator%index))
	if (present (y)) &
	y = bin_get_sum (iterator%object%h%bin(iterator%index))
	if (present (yerr)) &
	yerr = bin_get_error (iterator%object%h%bin(iterator%index))
	if (present (xerr)) &
	call invalid ("histogram", "xerr")
	if (present (width)) &
	width = bin_get_width (iterator%object%h%bin(iterator%index))
	if (present (excess)) &
	excess = bin_get_excess (iterator%object%h%bin(iterator%index))
	if (present (index)) &
	index = iterator%index
	if (present (n_total)) &
	n_total = histogram_get_n_bins (iterator%object%h)
	case (AN_PLOT)
	if (present (x)) &
	x = point_get_x (iterator%point)
	if (present (y)) &
	y = point_get_y (iterator%point)
	if (present (yerr)) &
	yerr = point_get_yerr (iterator%point)
	if (present (xerr)) &
	xerr = point_get_xerr (iterator%point)
	if (present (width)) &
	call invalid ("plot", "width")
	if (present (excess)) &
	call invalid ("plot", "excess")
	if (present (index)) &
	index = iterator%index
	if (present (n_total)) &
	n_total = plot_get_n_entries (iterator%object%p)
	case default
	call msg_bug ("analysis_iterator_get_data: called " &
	// "for unsupported analysis object type")
	end select
	contains
	subroutine invalid (typestr, objstr)
	character(*), intent(in) :: typestr, objstr
	call msg_bug ("analysis_iterator_get_data: attempt to get '" &
	// objstr // "' for type '" // typestr // "'")
	end subroutine invalid
	end subroutine analysis_iterator_get_data

	@ %def analysis_iterator_get_data
	@
	\subsection{Analysis store}
	This data structure holds all observables, histograms and such that
	are currently active. We have one global store; individual items are
	identified by their ID strings and types.
	<<Analysis: variables>>=
	type(analysis_store_t), save :: analysis_store

	@ %def analysis_store
	<<Analysis: types>>=
	type :: analysis_store_t
	private
	type(analysis_object_t), pointer :: first => null ()
	type(analysis_object_t), pointer :: last => null ()
	end type analysis_store_t

	@ %def analysis_store_t
	@ Delete the analysis store
	<<Analysis: public>>=
	public :: analysis_final
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_final ()
	+ end subroutine analysis_final
	<<Analysis: procedures>>=
	- subroutine analysis_final ()
	+ module subroutine analysis_final ()
	type(analysis_object_t), pointer :: current
	do while (associated (analysis_store%first))
	current => analysis_store%first
	analysis_store%first => current%next
	call analysis_object_final (current)
	end do
	analysis_store%last => null ()
	end subroutine analysis_final

	@ %def analysis_final
	@ Append a new analysis object
	<<Analysis: procedures>>=
	subroutine analysis_store_append_object (id, type)
	type(string_t), intent(in) :: id
	integer, intent(in) :: type
	type(analysis_object_t), pointer :: obj
	allocate (obj)
	call analysis_object_init (obj, id, type)
	if (associated (analysis_store%last)) then
	analysis_store%last%next => obj
	else
	analysis_store%first => obj
	end if
	analysis_store%last => obj
	end subroutine analysis_store_append_object

	@ %def analysis_store_append_object
	@ Return a pointer to the analysis object with given ID.
	<<Analysis: procedures>>=
	function analysis_store_get_object_ptr (id) result (obj)
	type(string_t), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	obj => analysis_store%first
	do while (associated (obj))
	if (obj%id == id) return
	obj => obj%next
	end do
	end function analysis_store_get_object_ptr

	@ %def analysis_store_get_object_ptr
	@ Initialize an analysis object: either reset it if present, or append
	a new entry.
	<<Analysis: procedures>>=
	subroutine analysis_store_init_object (id, type, obj)
	type(string_t), intent(in) :: id
	integer, intent(in) :: type
	type(analysis_object_t), pointer :: obj, next
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	next => analysis_object_get_next_ptr (obj)
	call analysis_object_final (obj)
	call analysis_object_init (obj, id, type)
	call analysis_object_set_next_ptr (obj, next)
	else
	call analysis_store_append_object (id, type)
	obj => analysis_store%last
	end if
	end subroutine analysis_store_init_object

	@ %def analysis_store_init_object
	@ Get the type of a analysis object
	<<Analysis: public>>=
	public :: analysis_store_get_object_type
	+<<Analysis: sub interfaces>>=
	+ module function analysis_store_get_object_type (id) result (type)
	+ type(string_t), intent(in) :: id
	+ integer :: type
	+ end function analysis_store_get_object_type
	<<Analysis: procedures>>=
	- function analysis_store_get_object_type (id) result (type)
	+ module function analysis_store_get_object_type (id) result (type)
	type(string_t), intent(in) :: id
	integer :: type
	type(analysis_object_t), pointer :: object
	object => analysis_store_get_object_ptr (id)
	if (associated (object)) then
	type = object%type
	else
	type = AN_UNDEFINED
	end if
	end function analysis_store_get_object_type

	@ %def analysis_store_get_object_type
	@ Return the number of objects in the store.
	<<Analysis: procedures>>=
	function analysis_store_get_n_objects () result (n)
	integer :: n
	type(analysis_object_t), pointer :: current
	n = 0
	current => analysis_store%first
	do while (associated (current))
	n = n + 1
	current => current%next
	end do
	end function analysis_store_get_n_objects

	@ %def analysis_store_get_n_objects
	@ Allocate an array and fill it with all existing IDs.
	<<Analysis: public>>=
	public :: analysis_store_get_ids
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_store_get_ids (id)
	+ type(string_t), dimension(:), allocatable, intent(out) :: id
	+ end subroutine analysis_store_get_ids
	<<Analysis: procedures>>=
	- subroutine analysis_store_get_ids (id)
	+ module subroutine analysis_store_get_ids (id)
	type(string_t), dimension(:), allocatable, intent(out) :: id
	type(analysis_object_t), pointer :: current
	integer :: i
	allocate (id (analysis_store_get_n_objects()))
	i = 0
	current => analysis_store%first
	do while (associated (current))
	i = i + 1
	id(i) = current%id
	current => current%next
	end do
	end subroutine analysis_store_get_ids

	@ %def analysis_store_get_ids
	@
	\subsection{\LaTeX\ driver file}
	Write a driver file for all objects in the store.
	<<Analysis: procedures>>=
	subroutine analysis_store_write_driver_all (filename_data, unit)
	type(string_t), intent(in) :: filename_data
	integer, intent(in), optional :: unit
	type(analysis_object_t), pointer :: obj
	call analysis_store_write_driver_header (unit)
	obj => analysis_store%first
	do while (associated (obj))
	call analysis_object_write_driver (obj, filename_data, unit)
	obj => obj%next
	end do
	call analysis_store_write_driver_footer (unit)
	end subroutine analysis_store_write_driver_all

	@ %def analysis_store_write_driver_all
	@
	Write a driver file for an array of objects.
	<<Analysis: procedures>>=
	subroutine analysis_store_write_driver_obj (filename_data, id, unit)
	type(string_t), intent(in) :: filename_data
	type(string_t), dimension(:), intent(in) :: id
	integer, intent(in), optional :: unit
	type(analysis_object_t), pointer :: obj
	integer :: i
	call analysis_store_write_driver_header (unit)
	do i = 1, size (id)
	obj => analysis_store_get_object_ptr (id(i))
	if (associated (obj)) &
	call analysis_object_write_driver (obj, filename_data, unit)
	end do
	call analysis_store_write_driver_footer (unit)
	end subroutine analysis_store_write_driver_obj

	@ %def analysis_store_write_driver_obj
	@ The beginning of the driver file.
	<<Analysis: procedures>>=
	subroutine analysis_store_write_driver_header (unit)
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, '(A)') "\documentclass[12pt]{article}"
	write (u, *)
	write (u, '(A)') "\usepackage{gamelan}"
	write (u, '(A)') "\usepackage{amsmath}"
	write (u, '(A)') "\usepackage{ifpdf}"
	write (u, '(A)') "\ifpdf"
	write (u, '(A)') " \DeclareGraphicsRule{}{mps}{}{}"
	write (u, '(A)') "\else"
	write (u, '(A)') " \DeclareGraphicsRule{}{eps}{}{}"
	write (u, '(A)') "\fi"
	write (u, *)
	write (u, '(A)') "\begin{document}"
	write (u, '(A)') "\begin{gmlfile}"
	write (u, *)
	write (u, '(A)') "\begin{gmlcode}"
	write (u, '(A)') " color col.default, col.excess;"
	write (u, '(A)') " col.default = 0.9white;"
	write (u, '(A)') " col.excess = red;"
	write (u, '(A)') " boolean show_excess;"
	!!! Future excess options for plots
	! if (mcs(1)%plot_excess .and. mcs(1)%unweighted) then
	! write (u, '(A)') " show_excess = true;"
	! else
	write (u, '(A)') " show_excess = false;"
	! end if
	write (u, '(A)') "\end{gmlcode}"
	write (u, *)
	end subroutine analysis_store_write_driver_header

	@ %def analysis_store_write_driver_header
	@ The end of the driver file.
	<<Analysis: procedures>>=
	subroutine analysis_store_write_driver_footer (unit)
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write(u, *)
	write(u, '(A)') "\end{gmlfile}"
	write(u, '(A)') "\end{document}"
	end subroutine analysis_store_write_driver_footer

	@ %def analysis_store_write_driver_footer
	@
	\subsection{API}
	\subsubsection{Creating new objects}
	The specific versions below:
	<<Analysis: public>>=
	public :: analysis_init_observable
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options)
	+ type(string_t), intent(in) :: id
	+ type(string_t), intent(in), optional :: obs_label, obs_unit
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ end subroutine analysis_init_observable
	<<Analysis: procedures>>=
	- subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options)
	+ module subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options)
	type(string_t), intent(in) :: id
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	type(analysis_object_t), pointer :: obj
	type(observable_t), pointer :: obs
	call analysis_store_init_object (id, AN_OBSERVABLE, obj)
	obs => analysis_object_get_observable_ptr (obj)
	call observable_init (obs, obs_label, obs_unit, graph_options)
	end subroutine analysis_init_observable

	@ %def analysis_init_observable
	<<Analysis: public>>=
	public :: analysis_init_histogram
	<<Analysis: interfaces>>=
	interface analysis_init_histogram
	module procedure analysis_init_histogram_n_bins
	module procedure analysis_init_histogram_bin_width
	end interface

	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_init_histogram_n_bins &
	+ (id, lower_bound, upper_bound, n_bins, normalize_bins, &
	+ obs_label, obs_unit, graph_options, drawing_options)
	+ type(string_t), intent(in) :: id
	+ real(default), intent(in) :: lower_bound, upper_bound
	+ integer, intent(in) :: n_bins
	+ logical, intent(in) :: normalize_bins
	+ type(string_t), intent(in), optional :: obs_label, obs_unit
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine analysis_init_histogram_n_bins
	+ module subroutine analysis_init_histogram_bin_width &
	+ (id, lower_bound, upper_bound, bin_width, normalize_bins, &
	+ obs_label, obs_unit, graph_options, drawing_options)
	+ type(string_t), intent(in) :: id
	+ real(default), intent(in) :: lower_bound, upper_bound, bin_width
	+ logical, intent(in) :: normalize_bins
	+ type(string_t), intent(in), optional :: obs_label, obs_unit
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine analysis_init_histogram_bin_width
	<<Analysis: procedures>>=
	- subroutine analysis_init_histogram_n_bins &
	+ module subroutine analysis_init_histogram_n_bins &
	(id, lower_bound, upper_bound, n_bins, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	type(string_t), intent(in) :: id
	real(default), intent(in) :: lower_bound, upper_bound
	integer, intent(in) :: n_bins
	logical, intent(in) :: normalize_bins
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(analysis_object_t), pointer :: obj
	type(histogram_t), pointer :: h
	call analysis_store_init_object (id, AN_HISTOGRAM, obj)
	h => analysis_object_get_histogram_ptr (obj)
	call histogram_init (h, id, &
	lower_bound, upper_bound, n_bins, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	end subroutine analysis_init_histogram_n_bins

	- subroutine analysis_init_histogram_bin_width &
	+ module subroutine analysis_init_histogram_bin_width &
	(id, lower_bound, upper_bound, bin_width, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	type(string_t), intent(in) :: id
	real(default), intent(in) :: lower_bound, upper_bound, bin_width
	logical, intent(in) :: normalize_bins
	type(string_t), intent(in), optional :: obs_label, obs_unit
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(analysis_object_t), pointer :: obj
	type(histogram_t), pointer :: h
	call analysis_store_init_object (id, AN_HISTOGRAM, obj)
	h => analysis_object_get_histogram_ptr (obj)
	call histogram_init (h, id, &
	lower_bound, upper_bound, bin_width, normalize_bins, &
	obs_label, obs_unit, graph_options, drawing_options)
	end subroutine analysis_init_histogram_bin_width

	@ %def analysis_init_histogram_n_bins
	@ %def analysis_init_histogram_bin_width
	<<Analysis: public>>=
	public :: analysis_init_plot
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_init_plot (id, graph_options, drawing_options)
	+ type(string_t), intent(in) :: id
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine analysis_init_plot
	<<Analysis: procedures>>=
	- subroutine analysis_init_plot (id, graph_options, drawing_options)
	+ module subroutine analysis_init_plot (id, graph_options, drawing_options)
	type(string_t), intent(in) :: id
	type(graph_options_t), intent(in), optional :: graph_options
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(analysis_object_t), pointer :: obj
	type(plot_t), pointer :: plot
	call analysis_store_init_object (id, AN_PLOT, obj)
	plot => analysis_object_get_plot_ptr (obj)
	call plot_init (plot, id, graph_options, drawing_options)
	end subroutine analysis_init_plot

	@ %def analysis_init_plot
	<<Analysis: public>>=
	public :: analysis_init_graph
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_init_graph (id, n_elements, graph_options)
	+ type(string_t), intent(in) :: id
	+ integer, intent(in) :: n_elements
	+ type(graph_options_t), intent(in), optional :: graph_options
	+ end subroutine analysis_init_graph
	<<Analysis: procedures>>=
	- subroutine analysis_init_graph (id, n_elements, graph_options)
	+ module subroutine analysis_init_graph (id, n_elements, graph_options)
	type(string_t), intent(in) :: id
	integer, intent(in) :: n_elements
	type(graph_options_t), intent(in), optional :: graph_options
	type(analysis_object_t), pointer :: obj
	type(graph_t), pointer :: graph
	call analysis_store_init_object (id, AN_GRAPH, obj)
	graph => analysis_object_get_graph_ptr (obj)
	call graph_init (graph, id, n_elements, graph_options)
	end subroutine analysis_init_graph

	@ %def analysis_init_graph
	@
	\subsubsection{Recording data}
	This procedure resets an object or the whole store to its initial
	state.
	<<Analysis: public>>=
	public :: analysis_clear
	<<Analysis: interfaces>>=
	interface analysis_clear
	module procedure analysis_store_clear_obj
	module procedure analysis_store_clear_all
	end interface

	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_store_clear_obj (id)
	+ type(string_t), intent(in) :: id
	+ end subroutine analysis_store_clear_obj
	+ module subroutine analysis_store_clear_all ()
	+ end subroutine analysis_store_clear_all
	<<Analysis: procedures>>=
	- subroutine analysis_store_clear_obj (id)
	+ module subroutine analysis_store_clear_obj (id)
	type(string_t), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	call analysis_object_clear (obj)
	end if
	end subroutine analysis_store_clear_obj

	- subroutine analysis_store_clear_all ()
	+ module subroutine analysis_store_clear_all ()
	type(analysis_object_t), pointer :: obj
	obj => analysis_store%first
	do while (associated (obj))
	call analysis_object_clear (obj)
	obj => obj%next
	end do
	end subroutine analysis_store_clear_all

	@ %def analysis_clear
	@
	There is one generic recording function whose behavior depends on the
	type of analysis object.
	<<Analysis: public>>=
	public :: analysis_record_data
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_record_data (id, x, y, yerr, xerr, &
	+ weight, excess, success, exist)
	+ type(string_t), intent(in) :: id
	+ real(default), intent(in) :: x
	+ real(default), intent(in), optional :: y, yerr, xerr, weight, excess
	+ logical, intent(out), optional :: success, exist
	+ end subroutine analysis_record_data
	<<Analysis: procedures>>=
	- subroutine analysis_record_data (id, x, y, yerr, xerr, &
	+ module subroutine analysis_record_data (id, x, y, yerr, xerr, &
	weight, excess, success, exist)
	type(string_t), intent(in) :: id
	real(default), intent(in) :: x
	real(default), intent(in), optional :: y, yerr, xerr, weight, excess
	logical, intent(out), optional :: success, exist
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	call analysis_object_record_data (obj, x, y, yerr, xerr, &
	weight, excess, success)
	if (present (exist)) exist = .true.
	else
	if (present (success)) success = .false.
	if (present (exist)) exist = .false.
	end if
	end subroutine analysis_record_data

	@ %def analysis_record_data
	@
	\subsubsection{Build a graph}
	This routine sets up the array of graph elements by copying the graph elements
	given as input. The object must exist and already be initialized as a graph.
	<<Analysis: public>>=
	public :: analysis_fill_graph
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_fill_graph (id, i, id_in, drawing_options)
	+ type(string_t), intent(in) :: id
	+ integer, intent(in) :: i
	+ type(string_t), intent(in) :: id_in
	+ type(drawing_options_t), intent(in), optional :: drawing_options
	+ end subroutine analysis_fill_graph
	<<Analysis: procedures>>=
	- subroutine analysis_fill_graph (id, i, id_in, drawing_options)
	+ module subroutine analysis_fill_graph (id, i, id_in, drawing_options)
	type(string_t), intent(in) :: id
	integer, intent(in) :: i
	type(string_t), intent(in) :: id_in
	type(drawing_options_t), intent(in), optional :: drawing_options
	type(analysis_object_t), pointer :: obj
	type(graph_t), pointer :: g
	type(histogram_t), pointer :: h
	type(plot_t), pointer :: p
	obj => analysis_store_get_object_ptr (id)
	g => analysis_object_get_graph_ptr (obj)
	obj => analysis_store_get_object_ptr (id_in)
	if (associated (obj)) then
	select case (obj%type)
	case (AN_HISTOGRAM)
	h => analysis_object_get_histogram_ptr (obj)
	call graph_insert_histogram (g, i, h, drawing_options)
	case (AN_PLOT)
	p => analysis_object_get_plot_ptr (obj)
	call graph_insert_plot (g, i, p, drawing_options)
	case default
	call msg_error ("Graph '" // char (id) // "': Element '" &
	// char (id_in) // "' is neither histogram nor plot.")
	end select
	else
	call msg_error ("Graph '" // char (id) // "': Element '" &
	// char (id_in) // "' is undefined.")
	end if
	end subroutine analysis_fill_graph

	@ %def analysis_fill_graph
	@
	\subsubsection{Retrieve generic results}
	Check if a named object exists.
	<<Analysis: public>>=
	public :: analysis_exists
	+<<Analysis: sub interfaces>>=
	+ module function analysis_exists (id) result (flag)
	+ type(string_t), intent(in) :: id
	+ logical :: flag
	+ end function analysis_exists
	<<Analysis: procedures>>=
	- function analysis_exists (id) result (flag)
	+ module function analysis_exists (id) result (flag)
	type(string_t), intent(in) :: id
	logical :: flag
	type(analysis_object_t), pointer :: obj
	flag = .true.
	obj => analysis_store%first
	do while (associated (obj))
	if (obj%id == id) return
	obj => obj%next
	end do
	flag = .false.
	end function analysis_exists

	@ %def analysis_exists
	@ The following functions should work for all kinds of analysis object:
	<<Analysis: public>>=
	public :: analysis_get_n_elements
	public :: analysis_get_n_entries
	public :: analysis_get_average
	public :: analysis_get_error
	+
	+<<Analysis: sub interfaces>>=
	+ module function analysis_get_n_elements (id) result (n)
	+ integer :: n
	+ type(string_t), intent(in) :: id
	+ end function analysis_get_n_elements
	+ module function analysis_get_n_entries (id, within_bounds) result (n)
	+ integer :: n
	+ type(string_t), intent(in) :: id
	+ logical, intent(in), optional :: within_bounds
	+ end function analysis_get_n_entries
	+ module function analysis_get_average (id, within_bounds) result (avg)
	+ real(default) :: avg
	+ type(string_t), intent(in) :: id
	+ logical, intent(in), optional :: within_bounds
	+ end function analysis_get_average
	+ module function analysis_get_error (id, within_bounds) result (err)
	+ real(default) :: err
	+ type(string_t), intent(in) :: id
	+ logical, intent(in), optional :: within_bounds
	+ end function analysis_get_error
	<<Analysis: procedures>>=
	- function analysis_get_n_elements (id) result (n)
	+ module function analysis_get_n_elements (id) result (n)
	integer :: n
	type(string_t), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	n = analysis_object_get_n_elements (obj)
	else
	n = 0
	end if
	end function analysis_get_n_elements

	- function analysis_get_n_entries (id, within_bounds) result (n)
	+ module function analysis_get_n_entries (id, within_bounds) result (n)
	integer :: n
	type(string_t), intent(in) :: id
	logical, intent(in), optional :: within_bounds
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	n = analysis_object_get_n_entries (obj, within_bounds)
	else
	n = 0
	end if
	end function analysis_get_n_entries

	- function analysis_get_average (id, within_bounds) result (avg)
	+ module function analysis_get_average (id, within_bounds) result (avg)
	real(default) :: avg
	type(string_t), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	logical, intent(in), optional :: within_bounds
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	avg = analysis_object_get_average (obj, within_bounds)
	else
	avg = 0
	end if
	end function analysis_get_average

	- function analysis_get_error (id, within_bounds) result (err)
	+ module function analysis_get_error (id, within_bounds) result (err)
	real(default) :: err
	type(string_t), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	logical, intent(in), optional :: within_bounds
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	err = analysis_object_get_error (obj, within_bounds)
	else
	err = 0
	end if
	end function analysis_get_error

	@ %def analysis_get_n_elements
	@ %def analysis_get_n_entries
	@ %def analysis_get_average
	@ %def analysis_get_error
	@ Return true if any analysis object is graphical
	<<Analysis: public>>=
	public :: analysis_has_plots
	<<Analysis: interfaces>>=
	interface analysis_has_plots
	module procedure analysis_has_plots_any
	module procedure analysis_has_plots_obj
	end interface

	+<<Analysis: sub interfaces>>=
	+ module function analysis_has_plots_any () result (flag)
	+ logical :: flag
	+ end function analysis_has_plots_any
	+ module function analysis_has_plots_obj (id) result (flag)
	+ logical :: flag
	+ type(string_t), dimension(:), intent(in) :: id
	+ end function analysis_has_plots_obj
	<<Analysis: procedures>>=
	- function analysis_has_plots_any () result (flag)
	+ module function analysis_has_plots_any () result (flag)
	logical :: flag
	type(analysis_object_t), pointer :: obj
	flag = .false.
	obj => analysis_store%first
	do while (associated (obj))
	flag = analysis_object_has_plot (obj)
	if (flag) return
	end do
	end function analysis_has_plots_any

	- function analysis_has_plots_obj (id) result (flag)
	+ module function analysis_has_plots_obj (id) result (flag)
	logical :: flag
	type(string_t), dimension(:), intent(in) :: id
	type(analysis_object_t), pointer :: obj
	integer :: i
	flag = .false.
	do i = 1, size (id)
	obj => analysis_store_get_object_ptr (id(i))
	if (associated (obj)) then
	flag = analysis_object_has_plot (obj)
	if (flag) return
	end if
	end do
	end function analysis_has_plots_obj

	@ %def analysis_has_plots
	@
	\subsubsection{Iterators}
	Initialize an iterator for the given object. If the object does not exist or
	has wrong type, the iterator will be invalid.
	-<<Analysis: public>>=
	- public :: analysis_init_iterator
	<<Analysis: procedures>>=
	subroutine analysis_init_iterator (id, iterator)
	type(string_t), intent(in) :: id
	type(analysis_iterator_t), intent(out) :: iterator
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) call analysis_iterator_init (iterator, obj)
	end subroutine analysis_init_iterator

	@ %def analysis_init_iterator
	@
	\subsubsection{Output}
	<<Analysis: public>>=
	public :: analysis_write
	<<Analysis: interfaces>>=
	interface analysis_write
	module procedure analysis_write_object
	module procedure analysis_write_all
	end interface

	@ %def interface
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_write_object (id, unit, verbose)
	+ type(string_t), intent(in) :: id
	+ integer, intent(in), optional :: unit
	+ logical, intent(in), optional :: verbose
	+ end subroutine analysis_write_object
	+ module subroutine analysis_write_all (unit, verbose)
	+ integer, intent(in), optional :: unit
	+ logical, intent(in), optional :: verbose
	+ end subroutine analysis_write_all
	<<Analysis: procedures>>=
	- subroutine analysis_write_object (id, unit, verbose)
	+ module subroutine analysis_write_object (id, unit, verbose)
	type(string_t), intent(in) :: id
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	type(analysis_object_t), pointer :: obj
	obj => analysis_store_get_object_ptr (id)
	if (associated (obj)) then
	call analysis_object_write (obj, unit, verbose)
	else
	call msg_error ("Analysis object '" // char (id) // "' not found")
	end if
	end subroutine analysis_write_object

	- subroutine analysis_write_all (unit, verbose)
	+ module subroutine analysis_write_all (unit, verbose)
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	type(analysis_object_t), pointer :: obj
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	obj => analysis_store%first
	do while (associated (obj))
	call analysis_object_write (obj, unit, verbose)
	obj => obj%next
	end do
	end subroutine analysis_write_all

	@ %def analysis_write_object
	@ %def analysis_write_all
	<<Analysis: public>>=
	public :: analysis_write_driver
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_write_driver (filename_data, id, unit)
	+ type(string_t), intent(in) :: filename_data
	+ type(string_t), dimension(:), intent(in), optional :: id
	+ integer, intent(in), optional :: unit
	+ end subroutine analysis_write_driver
	<<Analysis: procedures>>=
	- subroutine analysis_write_driver (filename_data, id, unit)
	+ module subroutine analysis_write_driver (filename_data, id, unit)
	type(string_t), intent(in) :: filename_data
	type(string_t), dimension(:), intent(in), optional :: id
	integer, intent(in), optional :: unit
	if (present (id)) then
	call analysis_store_write_driver_obj (filename_data, id, unit)
	else
	call analysis_store_write_driver_all (filename_data, unit)
	end if
	end subroutine analysis_write_driver

	@ %def analysis_write_driver
	<<Analysis: public>>=
	public :: analysis_compile_tex
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_compile_tex (file, has_gmlcode, os_data)
	+ type(string_t), intent(in) :: file
	+ logical, intent(in) :: has_gmlcode
	+ type(os_data_t), intent(in) :: os_data
	+ end subroutine analysis_compile_tex
	<<Analysis: procedures>>=
	- subroutine analysis_compile_tex (file, has_gmlcode, os_data)
	+ module subroutine analysis_compile_tex (file, has_gmlcode, os_data)
	type(string_t), intent(in) :: file
	logical, intent(in) :: has_gmlcode
	type(os_data_t), intent(in) :: os_data
	integer :: status
	if (os_data%event_analysis_ps) then
	call os_system_call ("make compile " // os_data%makeflags // " -f " // &
	char (file) // "_ana.makefile", status)
	if (status /= 0) then
	call msg_error ("Unable to compile analysis output file")
	end if
	else
	call msg_warning ("Skipping results display because " &
	// "latex/mpost/dvips is not available")
	end if
	end subroutine analysis_compile_tex

	@ %def analysis_compile_tex
	@ Write header for generic data output to an ifile.
	-<<Analysis: public>>=
	- public :: analysis_get_header
	<<Analysis: procedures>>=
	subroutine analysis_get_header (id, header, comment)
	type(string_t), intent(in) :: id
	type(ifile_t), intent(inout) :: header
	type(string_t), intent(in), optional :: comment
	type(analysis_object_t), pointer :: object
	object => analysis_store_get_object_ptr (id)
	if (associated (object)) then
	call analysis_object_get_header (object, header, comment)
	end if
	end subroutine analysis_get_header

	@ %def analysis_get_header
	@ Write a makefile in order to do the compile steps.
	<<Analysis: public>>=
	public :: analysis_write_makefile
	+<<Analysis: sub interfaces>>=
	+ module subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data)
	+ type(string_t), intent(in) :: filename
	+ integer, intent(in) :: unit
	+ logical, intent(in) :: has_gmlcode
	+ type(os_data_t), intent(in) :: os_data
	+ end subroutine analysis_write_makefile
	<<Analysis: procedures>>=
	- subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data)
	+ module subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data)
	type(string_t), intent(in) :: filename
	integer, intent(in) :: unit
	logical, intent(in) :: has_gmlcode
	type(os_data_t), intent(in) :: os_data
	write (unit, "(3A)") "# WHIZARD: Makefile for analysis '", &
	char (filename), "'"
	write (unit, "(A)") "# Automatically generated file, do not edit"
	write (unit, "(A)") ""
	write (unit, "(A)") "# LaTeX setup"
	write (unit, "(A)") "LATEX = " // char (os_data%latex)
	write (unit, "(A)") "MPOST = " // char (os_data%mpost)
	write (unit, "(A)") "GML = " // char (os_data%gml)
	write (unit, "(A)") "DVIPS = " // char (os_data%dvips)
	write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf)
	write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // &
	char(os_data%whizard_texpath) // '"'
	write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // &
	char(os_data%whizard_texpath) // '"'
	write (unit, "(A)") ""
	write (unit, "(5A)") "TEX_SOURCES = ", char (filename), ".tex"
	if (os_data%event_analysis_pdf) then
	write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".pdf"
	else
	write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".ps"
	end if
	if (os_data%event_analysis_ps) then
	if (os_data%event_analysis_pdf) then
	write (unit, "(5A)") char (filename), ".pdf: ", &
	char (filename), ".tex"
	else
	write (unit, "(5A)") char (filename), ".ps: ", &
	char (filename), ".tex"
	end if
	write (unit, "(5A)") TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
	char (filename) // ".tex"
	if (has_gmlcode) then
	write (unit, "(5A)") TAB, "$(GML) " // char (filename)
	write (unit, "(5A)") TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
	char (filename) // ".tex"
	end if
	write (unit, "(5A)") TAB, "$(DVIPS) -o " // char (filename) // ".ps " // &
	char (filename) // ".dvi"
	if (os_data%event_analysis_pdf) then
	write (unit, "(5A)") TAB, "$(PS2PDF) " // char (filename) // ".ps"
	end if
	end if
	write (unit, "(A)")
	write (unit, "(A)") "compile: $(TEX_OBJECTS)"
	write (unit, "(A)") ".PHONY: compile"
	write (unit, "(A)")
	write (unit, "(5A)") "CLEAN_OBJECTS = ", char (filename), ".aux"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".log"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".out"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9][0-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9][0-9]"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ltp"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mp"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mpx"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ps"
	write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".pdf"
	write (unit, "(A)")
	write (unit, "(A)") "# Generic cleanup targets"
	write (unit, "(A)") "clean-objects:"
	write (unit, "(A)") TAB // "rm -f $(CLEAN_OBJECTS)"
	write (unit, "(A)") ""
	write (unit, "(A)") "clean: clean-objects"
	write (unit, "(A)") ".PHONY: clean"
	end subroutine analysis_write_makefile

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

	module analysis_ut
	use unit_tests
	use analysis_uti

	<<Standard module head>>

	<<Analysis: public test>>

	contains

	<<Analysis: test driver>>

	end module analysis_ut
	@ %def analysis_ut
	@
	<<[[analysis_uti.f90]]>>=
	<<File header>>

	module analysis_uti

	<<Use kinds>>
	<<Use strings>>
	use format_defs, only: FMT_19

	use analysis

	<<Standard module head>>

	<<Analysis: test declarations>>

	contains

	<<Analysis: tests>>

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

	@ %def analysis_test
	<<Analysis: execute tests>>=
	call test (analysis_1, "analysis_1", &
	"check elementary analysis building blocks", &
	u, results)
	<<Analysis: test declarations>>=
	public :: analysis_1
	<<Analysis: tests>>=
	subroutine analysis_1 (u)
	integer, intent(in) :: u
	type(string_t) :: id1, id2, id3, id4
	integer :: i
	id1 = "foo"
	id2 = "bar"
	id3 = "hist"
	id4 = "plot"

	write (u, "(A)") "* Test output: Analysis"
	write (u, "(A)") "* Purpose: test the analysis routines"
	write (u, "(A)")

	call analysis_init_observable (id1)
	call analysis_init_observable (id2)
	call analysis_init_histogram &
	(id3, 0.5_default, 5.5_default, 1._default, normalize_bins=.false.)
	call analysis_init_plot (id4)
	do i = 1, 3
	write (u, "(A,1x," // FMT_19 // ")") "data = ", real(i,default)
	call analysis_record_data (id1, real(i,default))
	call analysis_record_data (id2, real(i,default), &
	weight=real(i,default))
	call analysis_record_data (id3, real(i,default))
	call analysis_record_data (id4, real(i,default), real(i,default)**2)
	end do
	write (u, "(A,10(1x,I5))") "n_entries = ", &
	analysis_get_n_entries (id1), &
	analysis_get_n_entries (id2), &
	analysis_get_n_entries (id3), &
	analysis_get_n_entries (id3, within_bounds = .true.), &
	analysis_get_n_entries (id4), &
	analysis_get_n_entries (id4, within_bounds = .true.)
	write (u, "(A,10(1x," // FMT_19 // "))") "average = ", &
	analysis_get_average (id1), &
	analysis_get_average (id2), &
	analysis_get_average (id3), &
	analysis_get_average (id3, within_bounds = .true.)
	write (u, "(A,10(1x," // FMT_19 // "))") "error = ", &
	analysis_get_error (id1), &
	analysis_get_error (id2), &
	analysis_get_error (id3), &
	analysis_get_error (id3, within_bounds = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Clear analysis #2"
	write (u, "(A)")

	call analysis_clear (id2)
	do i = 4, 6
	print *, "data = ", real(i,default)
	call analysis_record_data (id1, real(i,default))
	call analysis_record_data (id2, real(i,default), &
	weight=real(i,default))
	call analysis_record_data (id3, real(i,default))
	call analysis_record_data (id4, real(i,default), real(i,default)**2)
	end do
	write (u, "(A,10(1x,I5))") "n_entries = ", &
	analysis_get_n_entries (id1), &
	analysis_get_n_entries (id2), &
	analysis_get_n_entries (id3), &
	analysis_get_n_entries (id3, within_bounds = .true.), &
	analysis_get_n_entries (id4), &
	analysis_get_n_entries (id4, within_bounds = .true.)
	write (u, "(A,10(1x," // FMT_19 // "))") "average = ", &
	analysis_get_average (id1), &
	analysis_get_average (id2), &
	analysis_get_average (id3), &
	analysis_get_average (id3, within_bounds = .true.)
	write (u, "(A,10(1x," // FMT_19 // "))") "error = ", &
	analysis_get_error (id1), &
	analysis_get_error (id2), &
	analysis_get_error (id3), &
	analysis_get_error (id3, within_bounds = .true.)
	write (u, "(A)")
	call analysis_write (u)

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

	call analysis_clear ()
	call analysis_final ()

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

	@ %def analysis_1
	Index: trunk/src/types/Makefile.am
	===================================================================
	--- trunk/src/types/Makefile.am (revision 8777)
	+++ trunk/src/types/Makefile.am (revision 8778)
	@@ -1,204 +1,221 @@
	## Makefile.am -- Makefile for WHIZARD
	##
	## Process this file with automake to produce Makefile.in
	#
	# Copyright (C) 1999-2022 by
	# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	# Juergen Reuter <juergen.reuter@desy.de>
	# with contributions from
	# cf. main AUTHORS file
	#
	# WHIZARD is free software; you can redistribute it and/or modify it
	# under the terms of the GNU General Public License as published by
	# the Free Software Foundation; either version 2, or (at your option)
	# any later version.
	#
	# WHIZARD is distributed in the hope that it will be useful, but
	# WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	# GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	#
	########################################################################

	## The files in this directory implement objects and methods
	## as they appear in the Sindarin language

	## We create a library which is still to be combined with auxiliary libs.
	noinst_LTLIBRARIES = libtypes.la
	check_LTLIBRARIES = libtypes_ut.la

	libtypes_la_SOURCES = \
	+ $(TYPES_MODULES) \
	+ $(TYPES_SUBMODULES)
	+
	+TYPES_MODULES = \
	particle_specifiers.f90 \
	analysis.f90 \
	pdg_arrays.f90 \
	jets.f90 \
	subevents.f90

	+TYPES_SUBMODULES = \
	+ particle_specifiers_sub.f90 \
	+ analysis_sub.f90 \
	+ pdg_arrays_sub.f90 \
	+ subevents_sub.f90
	+
	libtypes_ut_la_SOURCES = \
	particle_specifiers_uti.f90 particle_specifiers_ut.f90 \
	analysis_uti.f90 analysis_ut.f90 \
	pdg_arrays_uti.f90 pdg_arrays_ut.f90 \
	jets_uti.f90 jets_ut.f90

	## Omitting this would exclude it from the distribution
	dist_noinst_DATA = types.nw

	# Modules and installation
	# Dump module names into file Modules
	execmoddir = $(fmoddir)/whizard
	nodist_execmod_HEADERS = \
	- ${libtypes_la_SOURCES:.f90=.$(FCMOD)}
	+ ${TYPES_MODULES:.f90=.$(FCMOD)}

	-libtypes_Modules = ${libtypes_la_SOURCES:.f90=} ${libtypes_ut_la_SOURCES:.f90=}
	+# Submodules must not be included here
	+libtypes_Modules = ${TYPES_MODULES:.f90=} ${libtypes_ut_la_SOURCES:.f90=}
	Modules: Makefile
	@for module in $(libtypes_Modules); do \
	echo $$module >> $@.new; \
	done
	@if diff $@ $@.new -q >/dev/null; then \
	rm $@.new; \
	else \
	mv $@.new $@; echo "Modules updated"; \
	fi
	BUILT_SOURCES = Modules

	## Fortran module dependencies
	# Get module lists from other directories
	module_lists = \
	../basics/Modules \
	../utilities/Modules \
	../testing/Modules \
	../system/Modules \
	../combinatorics/Modules \
	../parsing/Modules \
	../physics/Modules

	$(module_lists):
	$(MAKE) -C `dirname $@` Modules

	Module_dependencies.sed: $(libtypes_la_SOURCES) $(libtypes_ut_la_SOURCES)
	Module_dependencies.sed: $(module_lists)
	@rm -f $@
	echo 's/, only:.//' >> $@
	echo 's/, *&//' >> $@
	echo 's/, .=>.*//' >> $@
	echo 's/$$/.lo/' >> $@
	for list in $(module_lists); do \
	dir="`dirname $$list`"; \
	for mod in `cat $$list`; do \
	echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
	done \
	done

	DISTCLEANFILES = Module_dependencies.sed

	# The following line just says
	# include Makefile.depend
	# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
	@am__include@ @am__quote@Makefile.depend@am__quote@

	Makefile.depend: Module_dependencies.sed
	Makefile.depend: $(libtypes_la_SOURCES) $(libtypes_ut_la_SOURCES)
	@rm -f $@
	for src in $^; do \
	module="`basename $$src \| sed 's/\.f[90][0358]//'`"; \
	grep '^ *use ' $$src \
	\| grep -v '!NODEP!' \
	\| sed -e 's/^ use /'$$module'.lo: /' \
	-f Module_dependencies.sed; \
	done > $@

	DISTCLEANFILES += Makefile.depend

	# Fortran90 module files are generated at the same time as object files
	.lo.$(FCMOD):
	@:
	# touch $@

	AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../physics -I../qft -I../fastjet

	+########################################################################
	+# For the moment, the submodule dependencies will be hard-coded
	+particle_specifiers_sub.lo: particle_specifiers.lo
	+analysis_sub.lo: analysis.lo
	+pdg_arrays_sub.lo: pdg_arrays.lo
	+subevents_sub.lo: subevents.lo

	########################################################################
	## Default Fortran compiler options

	## Profiling
	if FC_USE_PROFILING
	AM_FCFLAGS += $(FCFLAGS_PROFILING)
	endif

	## OpenMP
	if FC_USE_OPENMP
	AM_FCFLAGS += $(FCFLAGS_OPENMP)
	endif

	## MPI
	if FC_USE_MPI
	AM_FCFLAGS += $(FCFLAGS_MPI)
	endif

	########################################################################
	## Non-standard targets and dependencies

	## Dependencies across directories and packages, if not automatically generated
	$(libtypes_la_OBJECTS): \
	../fastjet/fastjet.$(FCMOD)

	## (Re)create F90 sources from NOWEB source.
	if NOWEB_AVAILABLE

	PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
	POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw

	types.stamp: $(PRELUDE) $(srcdir)/types.nw $(POSTLUDE)
	@rm -f types.tmp
	@touch types.tmp
	for src in $(libtypes_la_SOURCES) $(libtypes_ut_la_SOURCES); do \
	$(NOTANGLE) -R[[$$src]] $^ \| $(CPIF) $$src; \
	done
	@mv -f types.tmp types.stamp

	$(libtypes_la_SOURCES) $(libtypes_ut_la_SOURCES): types.stamp
	## Recover from the removal of $@
	@if test -f $@; then :; else \
	rm -f types.stamp; \
	$(MAKE) $(AM_MAKEFLAGS) types.stamp; \
	fi

	endif


	########################################################################
	## Non-standard cleanup tasks
	## Remove sources that can be recreated using NOWEB
	if NOWEB_AVAILABLE
	maintainer-clean-noweb:
	-rm -f .f90 .c
	endif
	.PHONY: maintainer-clean-noweb

	## Remove those sources also if builddir and srcdir are different
	if NOWEB_AVAILABLE
	clean-noweb:
	test "$(srcdir)" != "." && rm -f .f90 .c \|\| true
	endif
	.PHONY: clean-noweb

	## Remove F90 module files
	clean-local: clean-noweb
	-rm -f types.stamp types.tmp
	-rm -f *.$(FCMOD)
	if FC_SUBMODULES
	- -rm -f *.smod
	+ -rm -f .smod .sub
	endif

	## Remove backup files
	maintainer-clean-backup:
	-rm -f *~
	.PHONY: maintainer-clean-backup

	## Register additional clean targets
	maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
	Index: trunk/src/beams/beams.nw
	===================================================================
	--- trunk/src/beams/beams.nw (revision 8777)
	+++ trunk/src/beams/beams.nw (revision 8778)
	@@ -1,25483 +1,25483 @@
	%% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD code as NOWEB source: beams and beam structure
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Beams}
	\includemodulegraph{beams}

	These modules implement beam configuration and beam structure, the
	latter in abstract terms.
	\begin{description}
	\item[beam\_structures]
	The [[beam_structure_t]] type is a messenger type that communicates
	the user settings to the \whizard\ core.
	\item[beams]
	Beam configuration.
	\item[sf\_aux]
	Tools for handling structure functions and splitting
	\item[sf\_mappings]
	Mapping functions, useful for structure function implementation
	\item[sf\_base]
	The abstract structure-function interaction and structure-function
	chain types.
	\end{description}

	These are the implementation modules, the concrete counterparts of
	[[sf_base]]:
	\begin{description}
	\item[sf\_isr]
	ISR structure function (photon radiation inclusive and resummed in
	collinear and IR regions).
	\item[sf\_epa]
	Effective Photon Approximation.
	\item[sf\_ewa]
	Effective $W$ (and $Z$) approximation.
	\item[sf\_escan]
	Energy spectrum that emulates a uniform energy scan.
	\item[sf\_gaussian]
	Gaussian beam spread
	\item[sf\_beam\_events]
	Beam-event generator that reads its input from an external file.
	\item[sf\_circe1]
	CIRCE1 beam spectra for electrons and photons.
	\item[sf\_circe2]
	CIRCE2 beam spectra for electrons and photons.
	\item[hoppet\_interface]
	Support for $b$-quark matching, addon to PDF modules.
	\item[sf\_pdf\_builtin]
	Direct support for selected hadron PDFs.
	\item[sf\_lhapdf]
	LHAPDF library support.
	\end{description}

	\clearpage
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Beam structure}

	This module stores the beam structure definition as it is declared in
	the SINDARIN script. The structure definition is not analyzed, just
	recorded for later use.

	We do not capture any numerical parameters, just names of particles and
	structure functions.
	<<[[beam_structures.f90]]>>=
	<<File header>>

	module beam_structures

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_19
	use diagnostics
	use lorentz
	use polarizations

	<<Standard module head>>

	<<Beam structures: public>>

	<<Beam structures: types>>

	<<Beam structures: interfaces>>

	contains

	<<Beam structures: procedures>>

	end module beam_structures
	@ %def beam_structures
	@
	\subsection{Beam structure elements}
	An entry in a beam-structure record consists of a string
	that denotes a type of structure function.
	<<Beam structures: types>>=
	type :: beam_structure_entry_t
	logical :: is_valid = .false.
	type(string_t) :: name
	contains
	<<Beam structures: beam structure entry: TBP>>
	end type beam_structure_entry_t

	@ %def beam_structure_entry_t
	@ Output.
	<<Beam structures: beam structure entry: TBP>>=
	procedure :: to_string => beam_structure_entry_to_string
	<<Beam structures: procedures>>=
	function beam_structure_entry_to_string (object) result (string)
	class(beam_structure_entry_t), intent(in) :: object
	type(string_t) :: string
	if (object%is_valid) then
	string = object%name
	else
	string = "none"
	end if
	end function beam_structure_entry_to_string

	@ %def beam_structure_entry_to_string
	@
	A record in the beam-structure sequence denotes either a
	structure-function entry, a pair of such entries, or a pair spectrum.
	<<Beam structures: types>>=
	type :: beam_structure_record_t
	type(beam_structure_entry_t), dimension(:), allocatable :: entry
	end type beam_structure_record_t

	@ %def beam_structure_record_t
	@
	\subsection{Beam structure type}
	The beam-structure object contains the beam particle(s) as simple strings.
	The sequence of records indicates the structure functions by name. No
	numerical parameters are stored.
	<<Beam structures: public>>=
	public :: beam_structure_t
	<<Beam structures: types>>=
	type :: beam_structure_t
	private
	integer :: n_beam = 0
	type(string_t), dimension(:), allocatable :: prt
	type(beam_structure_record_t), dimension(:), allocatable :: record
	type(smatrix_t), dimension(:), allocatable :: smatrix
	real(default), dimension(:), allocatable :: pol_f
	real(default), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: theta
	real(default), dimension(:), allocatable :: phi
	contains
	<<Beam structures: beam structure: TBP>>
	end type beam_structure_t

	@ %def beam_structure_t
	@ The finalizer deletes all contents explicitly, so we can continue
	with an empty beam record. (It is not needed for deallocation.) We
	have distinct finalizers for the independent parts of the beam structure.
	<<Beam structures: beam structure: TBP>>=
	procedure :: final_sf => beam_structure_final_sf
	<<Beam structures: procedures>>=
	subroutine beam_structure_final_sf (object)
	class(beam_structure_t), intent(inout) :: object
	if (allocated (object%prt)) deallocate (object%prt)
	if (allocated (object%record)) deallocate (object%record)
	object%n_beam = 0
	end subroutine beam_structure_final_sf

	@ %def beam_structure_final_sf
	@ Output. The actual information fits in a single line, therefore we can
	provide a [[to_string]] method. The [[show]] method also lists the
	current values of relevant global variables.
	<<Beam structures: beam structure: TBP>>=
	procedure :: write => beam_structure_write
	procedure :: to_string => beam_structure_to_string
	<<Beam structures: procedures>>=
	subroutine beam_structure_write (object, unit)
	class(beam_structure_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ())
	if (allocated (object%smatrix)) then
	do i = 1, size (object%smatrix)
	write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):"
	call object%smatrix(i)%write (u, indent=2)
	end do
	end if
	if (allocated (object%pol_f)) then
	write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", &
	object%pol_f
	end if
	if (allocated (object%p)) then
	write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
	")") "momentum =", object%p
	end if
	if (allocated (object%theta)) then
	write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
	")") "angle th =", object%theta
	end if
	if (allocated (object%phi)) then
	write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
	")") "angle ph =", object%phi
	end if
	end subroutine beam_structure_write

	function beam_structure_to_string (object, sf_only) result (string)
	class(beam_structure_t), intent(in) :: object
	logical, intent(in), optional :: sf_only
	type(string_t) :: string
	integer :: i, j
	logical :: with_beams
	with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only
	select case (object%n_beam)
	case (1)
	if (with_beams) then
	string = object%prt(1)
	else
	string = ""
	end if
	case (2)
	if (with_beams) then
	string = object%prt(1) // ", " // object%prt(2)
	else
	string = ""
	end if
	if (allocated (object%record)) then
	if (size (object%record) > 0) then
	if (with_beams) string = string // " => "
	do i = 1, size (object%record)
	if (i > 1) string = string // " => "
	do j = 1, size (object%record(i)%entry)
	if (j > 1) string = string // ", "
	string = string // object%record(i)%entry(j)%to_string ()
	end do
	end do
	end if
	end if
	case default
	string = "[any particles]"
	end select
	end function beam_structure_to_string

	@ %def beam_structure_write beam_structure_to_string
	@ Initializer: dimension the beam structure record. Each array
	element denotes the number of entries for a record within the
	beam-structure sequence. The number of entries is either one or two,
	while the number of records is unlimited.
	<<Beam structures: beam structure: TBP>>=
	procedure :: init_sf => beam_structure_init_sf
	<<Beam structures: procedures>>=
	subroutine beam_structure_init_sf (beam_structure, prt, dim_array)
	class(beam_structure_t), intent(inout) :: beam_structure
	type(string_t), dimension(:), intent(in) :: prt
	integer, dimension(:), intent(in), optional :: dim_array
	integer :: i
	call beam_structure%final_sf ()
	beam_structure%n_beam = size (prt)
	allocate (beam_structure%prt (size (prt)))
	beam_structure%prt = prt
	if (present (dim_array)) then
	allocate (beam_structure%record (size (dim_array)))
	do i = 1, size (dim_array)
	allocate (beam_structure%record(i)%entry (dim_array(i)))
	end do
	else
	allocate (beam_structure%record (0))
	end if
	end subroutine beam_structure_init_sf

	@ %def beam_structure_init_sf
	@ Set an entry, specified by record number and entry number.
	<<Beam structures: beam structure: TBP>>=
	procedure :: set_sf => beam_structure_set_sf
	<<Beam structures: procedures>>=
	subroutine beam_structure_set_sf (beam_structure, i, j, name)
	class(beam_structure_t), intent(inout) :: beam_structure
	integer, intent(in) :: i, j
	type(string_t), intent(in) :: name
	associate (entry => beam_structure%record(i)%entry(j))
	entry%name = name
	entry%is_valid = .true.
	end associate
	end subroutine beam_structure_set_sf

	@ %def beam_structure_set_sf
	@ Expand the beam-structure object. (i) For a pair spectrum, keep the
	entry. (ii) For a single-particle structure function written as a
	single entry, replace this by a record with two entries.
	(ii) For a record with two nontrivial entries, separate this into two
	records with one trivial entry each.

	To achieve this, we need a function that tells us whether an entry is
	a spectrum or a structure function. It returns 0 for a trivial entry,
	1 for a single-particle structure function, and 2 for a two-particle
	spectrum.
	<<Beam structures: interfaces>>=
	abstract interface
	function strfun_mode_fun (name) result (n)
	import
	type(string_t), intent(in) :: name
	integer :: n
	end function strfun_mode_fun
	end interface

	@ %def is_spectrum_t
	@ Algorithm: (1) Mark entries as invalid where necessary. (2) Count
	the number of entries that we will need. (3) Expand and copy
	entries to a new record array. (4) Replace the old array by the new one.
	<<Beam structures: beam structure: TBP>>=
	procedure :: expand => beam_structure_expand
	<<Beam structures: procedures>>=
	subroutine beam_structure_expand (beam_structure, strfun_mode)
	class(beam_structure_t), intent(inout) :: beam_structure
	procedure(strfun_mode_fun) :: strfun_mode
	type(beam_structure_record_t), dimension(:), allocatable :: new
	integer :: n_record, i, j
	if (.not. allocated (beam_structure%record)) return
	do i = 1, size (beam_structure%record)
	associate (entry => beam_structure%record(i)%entry)
	do j = 1, size (entry)
	select case (strfun_mode (entry(j)%name))
	case (0); entry(j)%is_valid = .false.
	end select
	end do
	end associate
	end do
	n_record = 0
	do i = 1, size (beam_structure%record)
	associate (entry => beam_structure%record(i)%entry)
	select case (size (entry))
	case (1)
	if (entry(1)%is_valid) then
	select case (strfun_mode (entry(1)%name))
	case (1); n_record = n_record + 2
	case (2); n_record = n_record + 1
	end select
	end if
	case (2)
	do j = 1, 2
	if (entry(j)%is_valid) then
	select case (strfun_mode (entry(j)%name))
	case (1); n_record = n_record + 1
	case (2)
	call beam_structure%write ()
	call msg_fatal ("Pair spectrum used as &
	&single-particle structure function")
	end select
	end if
	end do
	end select
	end associate
	end do
	allocate (new (n_record))
	n_record = 0
	do i = 1, size (beam_structure%record)
	associate (entry => beam_structure%record(i)%entry)
	select case (size (entry))
	case (1)
	if (entry(1)%is_valid) then
	select case (strfun_mode (entry(1)%name))
	case (1)
	n_record = n_record + 1
	allocate (new(n_record)%entry (2))
	new(n_record)%entry(1) = entry(1)
	n_record = n_record + 1
	allocate (new(n_record)%entry (2))
	new(n_record)%entry(2) = entry(1)
	case (2)
	n_record = n_record + 1
	allocate (new(n_record)%entry (1))
	new(n_record)%entry(1) = entry(1)
	end select
	end if
	case (2)
	do j = 1, 2
	if (entry(j)%is_valid) then
	n_record = n_record + 1
	allocate (new(n_record)%entry (2))
	new(n_record)%entry(j) = entry(j)
	end if
	end do
	end select
	end associate
	end do
	call move_alloc (from = new, to = beam_structure%record)
	end subroutine beam_structure_expand

	@ %def beam_structure_expand
	@
	\subsection{Polarization}
	To record polarization, we provide an allocatable array of [[smatrix]]
	objects, sparse matrices. The polarization structure is independent of the
	structure-function setup, they are combined only when an actual beam object is
	constructed.
	<<Beam structures: beam structure: TBP>>=
	procedure :: final_pol => beam_structure_final_pol
	procedure :: init_pol => beam_structure_init_pol
	<<Beam structures: procedures>>=
	subroutine beam_structure_final_pol (beam_structure)
	class(beam_structure_t), intent(inout) :: beam_structure
	if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix)
	if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f)
	end subroutine beam_structure_final_pol

	subroutine beam_structure_init_pol (beam_structure, n)
	class(beam_structure_t), intent(inout) :: beam_structure
	integer, intent(in) :: n
	if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix)
	allocate (beam_structure%smatrix (n))
	if (.not. allocated (beam_structure%pol_f)) &
	allocate (beam_structure%pol_f (n), source = 1._default)
	end subroutine beam_structure_init_pol

	@ %def beam_structure_final_pol
	@ %def beam_structure_init_pol
	@ Check if polarized beams are used.
	<<Beam structures: beam structure: TBP>>=
	procedure :: has_polarized_beams => beam_structure_has_polarized_beams
	<<Beam structures: procedures>>=
	elemental function beam_structure_has_polarized_beams (beam_structure) result (pol)
	logical :: pol
	class(beam_structure_t), intent(in) :: beam_structure
	if (allocated (beam_structure%pol_f)) then
	pol = any (beam_structure%pol_f /= 0)
	else
	pol = .false.
	end if
	end function beam_structure_has_polarized_beams

	@ %def beam_structure_has_polarized_beams
	@ Directly copy the spin density matrices.
	<<Beam structures: beam structure: TBP>>=
	procedure :: set_smatrix => beam_structure_set_smatrix
	<<Beam structures: procedures>>=
	subroutine beam_structure_set_smatrix (beam_structure, i, smatrix)
	class(beam_structure_t), intent(inout) :: beam_structure
	integer, intent(in) :: i
	type(smatrix_t), intent(in) :: smatrix
	beam_structure%smatrix(i) = smatrix
	end subroutine beam_structure_set_smatrix

	@ %def beam_structure_set_smatrix
	@ Initialize one of the spin density matrices manually.
	<<Beam structures: beam structure: TBP>>=
	procedure :: init_smatrix => beam_structure_init_smatrix
	<<Beam structures: procedures>>=
	subroutine beam_structure_init_smatrix (beam_structure, i, n_entry)
	class(beam_structure_t), intent(inout) :: beam_structure
	integer, intent(in) :: i
	integer, intent(in) :: n_entry
	call beam_structure%smatrix(i)%init (2, n_entry)
	end subroutine beam_structure_init_smatrix

	@ %def beam_structure_init_smatrix
	@ Set a polarization entry.
	<<Beam structures: beam structure: TBP>>=
	procedure :: set_sentry => beam_structure_set_sentry
	<<Beam structures: procedures>>=
	subroutine beam_structure_set_sentry &
	(beam_structure, i, i_entry, index, value)
	class(beam_structure_t), intent(inout) :: beam_structure
	integer, intent(in) :: i
	integer, intent(in) :: i_entry
	integer, dimension(:), intent(in) :: index
	complex(default), intent(in) :: value
	call beam_structure%smatrix(i)%set_entry (i_entry, index, value)
	end subroutine beam_structure_set_sentry

	@ %def beam_structure_set_sentry
	@ Set the array of polarization fractions.
	<<Beam structures: beam structure: TBP>>=
	procedure :: set_pol_f => beam_structure_set_pol_f
	<<Beam structures: procedures>>=
	subroutine beam_structure_set_pol_f (beam_structure, f)
	class(beam_structure_t), intent(inout) :: beam_structure
	real(default), dimension(:), intent(in) :: f
	if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f)
	allocate (beam_structure%pol_f (size (f)), source = f)
	end subroutine beam_structure_set_pol_f

	@ %def beam_structure_set_pol_f
	@
	\subsection{Beam momenta}
	By default, beam momenta are deduced from the [[sqrts]] value or from
	the mass of the decaying particle, assuming a c.m.\ setup. Here we
	set them explicitly.
	<<Beam structures: beam structure: TBP>>=
	procedure :: final_mom => beam_structure_final_mom
	<<Beam structures: procedures>>=
	subroutine beam_structure_final_mom (beam_structure)
	class(beam_structure_t), intent(inout) :: beam_structure
	if (allocated (beam_structure%p)) deallocate (beam_structure%p)
	if (allocated (beam_structure%theta)) deallocate (beam_structure%theta)
	if (allocated (beam_structure%phi)) deallocate (beam_structure%phi)
	end subroutine beam_structure_final_mom

	@ %def beam_structure_final_mom
	<<Beam structures: beam structure: TBP>>=
	procedure :: set_momentum => beam_structure_set_momentum
	procedure :: set_theta => beam_structure_set_theta
	procedure :: set_phi => beam_structure_set_phi
	<<Beam structures: procedures>>=
	subroutine beam_structure_set_momentum (beam_structure, p)
	class(beam_structure_t), intent(inout) :: beam_structure
	real(default), dimension(:), intent(in) :: p
	if (allocated (beam_structure%p)) deallocate (beam_structure%p)
	allocate (beam_structure%p (size (p)), source = p)
	end subroutine beam_structure_set_momentum

	subroutine beam_structure_set_theta (beam_structure, theta)
	class(beam_structure_t), intent(inout) :: beam_structure
	real(default), dimension(:), intent(in) :: theta
	if (allocated (beam_structure%theta)) deallocate (beam_structure%theta)
	allocate (beam_structure%theta (size (theta)), source = theta)
	end subroutine beam_structure_set_theta

	subroutine beam_structure_set_phi (beam_structure, phi)
	class(beam_structure_t), intent(inout) :: beam_structure
	real(default), dimension(:), intent(in) :: phi
	if (allocated (beam_structure%phi)) deallocate (beam_structure%phi)
	allocate (beam_structure%phi (size (phi)), source = phi)
	end subroutine beam_structure_set_phi

	@ %def beam_structure_set_momentum
	@ %def beam_structure_set_theta
	@ %def beam_structure_set_phi
	@
	\subsection{Get contents}
	Look at the incoming particles. We may also have the case that beam
	particles are not specified, but polarization.
	<<Beam structures: beam structure: TBP>>=
	procedure :: is_set => beam_structure_is_set
	procedure :: get_n_beam => beam_structure_get_n_beam
	procedure :: get_prt => beam_structure_get_prt
	<<Beam structures: procedures>>=
	function beam_structure_is_set (beam_structure) result (flag)
	class(beam_structure_t), intent(in) :: beam_structure
	logical :: flag
	flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric ()
	end function beam_structure_is_set

	function beam_structure_get_n_beam (beam_structure) result (n)
	class(beam_structure_t), intent(in) :: beam_structure
	integer :: n
	n = beam_structure%n_beam
	end function beam_structure_get_n_beam

	function beam_structure_get_prt (beam_structure) result (prt)
	class(beam_structure_t), intent(in) :: beam_structure
	type(string_t), dimension(:), allocatable :: prt
	allocate (prt (size (beam_structure%prt)))
	prt = beam_structure%prt
	end function beam_structure_get_prt

	@ %def beam_structure_is_set
	@ %def beam_structure_get_n_beam
	@ %def beam_structure_get_prt
	@
	Return the number of records.
	<<Beam structures: beam structure: TBP>>=
	procedure :: get_n_record => beam_structure_get_n_record
	<<Beam structures: procedures>>=
	function beam_structure_get_n_record (beam_structure) result (n)
	class(beam_structure_t), intent(in) :: beam_structure
	integer :: n
	if (allocated (beam_structure%record)) then
	n = size (beam_structure%record)
	else
	n = 0
	end if
	end function beam_structure_get_n_record

	@ %def beam_structure_get_n_record
	@ Return an array consisting of the beam indices affected by the valid
	entries within a record. After expansion, there should be exactly one
	valid entry per record.
	<<Beam structures: beam structure: TBP>>=
	procedure :: get_i_entry => beam_structure_get_i_entry
	<<Beam structures: procedures>>=
	function beam_structure_get_i_entry (beam_structure, i) result (i_entry)
	class(beam_structure_t), intent(in) :: beam_structure
	integer, intent(in) :: i
	integer, dimension(:), allocatable :: i_entry
	associate (record => beam_structure%record(i))
	select case (size (record%entry))
	case (1)
	if (record%entry(1)%is_valid) then
	allocate (i_entry (2), source = [1, 2])
	else
	allocate (i_entry (0))
	end if
	case (2)
	if (all (record%entry%is_valid)) then
	allocate (i_entry (2), source = [1, 2])
	else if (record%entry(1)%is_valid) then
	allocate (i_entry (1), source = [1])
	else if (record%entry(2)%is_valid) then
	allocate (i_entry (1), source = [2])
	else
	allocate (i_entry (0))
	end if
	end select
	end associate
	end function beam_structure_get_i_entry

	@ %def beam_structure_get_i_entry
	@ Return the name of the first valid entry within a record. After
	expansion, there should be exactly one valid entry per record.
	<<Beam structures: beam structure: TBP>>=
	procedure :: get_name => beam_structure_get_name
	<<Beam structures: procedures>>=
	function beam_structure_get_name (beam_structure, i) result (name)
	type(string_t) :: name
	class(beam_structure_t), intent(in) :: beam_structure
	integer, intent(in) :: i
	associate (record => beam_structure%record(i))
	if (record%entry(1)%is_valid) then
	name = record%entry(1)%name
	else if (size (record%entry) == 2) then
	name = record%entry(2)%name
	end if
	end associate
	end function beam_structure_get_name

	@ %def beam_structure_get_name
	@
	<<Beam structures: beam structure: TBP>>=
	procedure :: has_pdf => beam_structure_has_pdf
	<<Beam structures: procedures>>=
	function beam_structure_has_pdf (beam_structure) result (has_pdf)
	logical :: has_pdf
	class(beam_structure_t), intent(in) :: beam_structure
	integer :: i
	type(string_t) :: name
	has_pdf = .false.
	do i = 1, beam_structure%get_n_record ()
	name = beam_structure%get_name (i)
	has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf")
	end do
	end function beam_structure_has_pdf

	@ %def beam_structure_has_pdf
	@ Return true if the beam structure contains a particular structure
	function identifier (such as [[lhapdf]], [[isr]], etc.)
	<<Beam structures: beam structure: TBP>>=
	procedure :: contains => beam_structure_contains
	<<Beam structures: procedures>>=
	function beam_structure_contains (beam_structure, name) result (flag)
	class(beam_structure_t), intent(in) :: beam_structure
	character(*), intent(in) :: name
	logical :: flag
	integer :: i, j
	flag = .false.
	if (allocated (beam_structure%record)) then
	do i = 1, size (beam_structure%record)
	do j = 1, size (beam_structure%record(i)%entry)
	flag = beam_structure%record(i)%entry(j)%name == name
	if (flag) return
	end do
	end do
	end if
	end function beam_structure_contains

	@ %def beam_structure_contains
	@ Return polarization data.
	<<Beam structures: beam structure: TBP>>=
	procedure :: polarized => beam_structure_polarized
	procedure :: get_smatrix => beam_structure_get_smatrix
	procedure :: get_pol_f => beam_structure_get_pol_f
	procedure :: asymmetric => beam_structure_asymmetric
	<<Beam structures: procedures>>=
	function beam_structure_polarized (beam_structure) result (flag)
	class(beam_structure_t), intent(in) :: beam_structure
	logical :: flag
	flag = allocated (beam_structure%smatrix)
	end function beam_structure_polarized

	function beam_structure_get_smatrix (beam_structure) result (smatrix)
	class(beam_structure_t), intent(in) :: beam_structure
	type(smatrix_t), dimension(:), allocatable :: smatrix
	allocate (smatrix (size (beam_structure%smatrix)), &
	source = beam_structure%smatrix)
	end function beam_structure_get_smatrix

	function beam_structure_get_pol_f (beam_structure) result (pol_f)
	class(beam_structure_t), intent(in) :: beam_structure
	real(default), dimension(:), allocatable :: pol_f
	allocate (pol_f (size (beam_structure%pol_f)), &
	source = beam_structure%pol_f)
	end function beam_structure_get_pol_f

	function beam_structure_asymmetric (beam_structure) result (flag)
	class(beam_structure_t), intent(in) :: beam_structure
	logical :: flag
	flag = allocated (beam_structure%p) &
	.or. allocated (beam_structure%theta) &
	.or. allocated (beam_structure%phi)
	end function beam_structure_asymmetric

	@ %def beam_structure_polarized
	@ %def beam_structure_get_smatrix
	@ %def beam_structure_get_pol_f
	@ %def beam_structure_asymmetric
	@ Return the beam momenta (the space part, i.e., three-momenta). This
	is meaningful only if momenta and, optionally, angles have been set.
	<<Beam structures: beam structure: TBP>>=
	procedure :: get_momenta => beam_structure_get_momenta
	<<Beam structures: procedures>>=
	function beam_structure_get_momenta (beam_structure) result (p)
	class(beam_structure_t), intent(in) :: beam_structure
	type(vector3_t), dimension(:), allocatable :: p
	real(default), dimension(:), allocatable :: theta, phi
	integer :: n, i
	if (allocated (beam_structure%p)) then
	n = size (beam_structure%p)
	if (allocated (beam_structure%theta)) then
	if (size (beam_structure%theta) == n) then
	allocate (theta (n), source = beam_structure%theta)
	else
	call msg_fatal ("Beam structure: mismatch in momentum vs. &
	&angle theta specification")
	end if
	else
	allocate (theta (n), source = 0._default)
	end if
	if (allocated (beam_structure%phi)) then
	if (size (beam_structure%phi) == n) then
	allocate (phi (n), source = beam_structure%phi)
	else
	call msg_fatal ("Beam structure: mismatch in momentum vs. &
	&angle phi specification")
	end if
	else
	allocate (phi (n), source = 0._default)
	end if
	allocate (p (n))
	do i = 1, n
	p(i) = beam_structure%p(i) * vector3_moving ([ &
	sin (theta(i)) * cos (phi(i)), &
	sin (theta(i)) * sin (phi(i)), &
	cos (theta(i))])
	end do
	if (n == 2) p(2) = - p(2)
	else
	call msg_fatal ("Beam structure: angle theta/phi specified but &
	&momentum/a p undefined")
	end if
	end function beam_structure_get_momenta

	@ %def beam_structure_get_momenta
	@ Check for a complete beam structure. The [[applies]] flag tells if
	the beam structure should actually be used for a process with the
	given [[n_in]] number of incoming particles.

	It set if the beam structure matches the process as either decay or
	scattering. It is unset if beam structure references a scattering
	setup but the process is a decay. It is also unset if the beam
	structure itself is empty.

	If the beam structure cannot be used, terminate with fatal error.
	<<Beam structures: beam structure: TBP>>=
	procedure :: check_against_n_in => beam_structure_check_against_n_in
	<<Beam structures: procedures>>=
	subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies)
	class(beam_structure_t), intent(in) :: beam_structure
	integer, intent(in) :: n_in
	logical, intent(out) :: applies
	if (beam_structure%is_set ()) then
	if (n_in == beam_structure%get_n_beam ()) then
	applies = .true.
	else if (beam_structure%get_n_beam () == 0) then
	call msg_fatal &
	("Asymmetric beams: missing beam particle specification")
	applies = .false.
	else
	call msg_fatal &
	("Mismatch of process and beam setup (scattering/decay)")
	applies = .false.
	end if
	else
	applies = .false.
	end if
	end subroutine beam_structure_check_against_n_in

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

	module beam_structures_ut
	use unit_tests
	use beam_structures_uti

	<<Standard module head>>

	<<Beam structures: public test>>

	contains

	<<Beam structures: test driver>>

	end module beam_structures_ut
	@ %def beam_structures_ut
	@
	<<[[beam_structures_uti.f90]]>>=
	<<File header>>

	module beam_structures_uti

	<<Use kinds>>
	<<Use strings>>

	use beam_structures

	<<Standard module head>>

	<<Beam structures: test declarations>>

	contains

	<<Beam structures: tests>>

	<<Beam structures: test auxiliary>>

	end module beam_structures_uti
	@ %def beam_structures_ut
	@ API: driver for the unit tests below.
	<<Beam structures: public test>>=
	public :: beam_structures_test
	<<Beam structures: test driver>>=
	subroutine beam_structures_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<Beam structures: execute tests>>
	end subroutine beam_structures_test

	@ %def beam_structures_tests
	@
	\subsubsection{Empty structure}
	<<Beam structures: execute tests>>=
	call test (beam_structures_1, "beam_structures_1", &
	"empty beam structure record", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_1
	<<Beam structures: tests>>=
	subroutine beam_structures_1 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure

	write (u, "(A)") "* Test output: beam_structures_1"
	write (u, "(A)") "* Purpose: display empty beam structure record"
	write (u, "(A)")

	call beam_structure%write (u)

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

	end subroutine beam_structures_1

	@ %def beam_structures_1
	@
	\subsubsection{Nontrivial configurations}
	<<Beam structures: execute tests>>=
	call test (beam_structures_2, "beam_structures_2", &
	"beam structure records", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_2
	<<Beam structures: tests>>=
	subroutine beam_structures_2 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure
	integer, dimension(0) :: empty_array
	type(string_t) :: s

	write (u, "(A)") "* Test output: beam_structures_2"
	write (u, "(A)") "* Purpose: setup beam structure records"
	write (u, "(A)")

	s = "s"

	call beam_structure%init_sf ([s], empty_array)
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [1])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [2])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%set_sf (1, 2, var_str ("b"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [2, 1])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%set_sf (1, 2, var_str ("b"))
	call beam_structure%set_sf (2, 1, var_str ("c"))
	call beam_structure%write (u)

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

	end subroutine beam_structures_2

	@ %def beam_structures_2
	@
	\subsubsection{Expansion}
	Provide a function that tells, for the dummy structure function names
	used here, whether they are considered a two-particle spectrum or a
	single-particle structure function:
	<<Beam structures: test auxiliary>>=
	function test_strfun_mode (name) result (n)
	type(string_t), intent(in) :: name
	integer :: n
	select case (char (name))
	case ("a"); n = 2
	case ("b"); n = 1
	case default; n = 0
	end select
	end function test_strfun_mode

	@ %def test_ist_pair_spectrum
	@
	<<Beam structures: execute tests>>=
	call test (beam_structures_3, "beam_structures_3", &
	"beam structure expansion", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_3
	<<Beam structures: tests>>=
	subroutine beam_structures_3 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure
	type(string_t) :: s

	write (u, "(A)") "* Test output: beam_structures_3"
	write (u, "(A)") "* Purpose: expand beam structure records"
	write (u, "(A)")

	s = "s"

	write (u, "(A)") "* Pair spectrum (keep as-is)"
	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [1])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%expand (test_strfun_mode)
	call beam_structure%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Structure function pair (expand)"
	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [2])
	call beam_structure%set_sf (1, 1, var_str ("b"))
	call beam_structure%set_sf (1, 2, var_str ("b"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%expand (test_strfun_mode)
	call beam_structure%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Structure function (separate and expand)"
	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [1])
	call beam_structure%set_sf (1, 1, var_str ("b"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%expand (test_strfun_mode)
	call beam_structure%write (u)

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

	call beam_structure%init_sf ([s, s], [1, 1])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%set_sf (2, 1, var_str ("b"))
	call beam_structure%write (u)

	write (u, "(A)")

	call beam_structure%expand (test_strfun_mode)
	call beam_structure%write (u)

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

	end subroutine beam_structures_3

	@ %def beam_structures_3
	@
	\subsubsection{Public methods}
	Check the methods that can be called to get the beam-structure
	contents.
	<<Beam structures: execute tests>>=
	call test (beam_structures_4, "beam_structures_4", &
	"beam structure contents", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_4
	<<Beam structures: tests>>=
	subroutine beam_structures_4 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure
	type(string_t) :: s
	type(string_t), dimension(2) :: prt
	integer :: i

	write (u, "(A)") "* Test output: beam_structures_4"
	write (u, "(A)") "* Purpose: check the API"
	write (u, "(A)")

	s = "s"

	write (u, "(A)") "* Structure-function combination"
	write (u, "(A)")

	call beam_structure%init_sf ([s, s], [1, 2, 2])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%set_sf (2, 1, var_str ("b"))
	call beam_structure%set_sf (3, 2, var_str ("c"))
	call beam_structure%write (u)

	write (u, *)
	write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam ()
	prt = beam_structure%get_prt ()
	write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2))

	write (u, *)
	write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record ()

	do i = 1, 3
	write (u, "(A)")
	write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", &
	char (beam_structure%get_name (i))
	write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", &
	beam_structure%get_i_entry (i)
	end do

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

	end subroutine beam_structures_4

	@ %def beam_structures_4
	@
	\subsubsection{Polarization}
	The polarization properties are independent from the structure-function setup.
	<<Beam structures: execute tests>>=
	call test (beam_structures_5, "beam_structures_5", &
	"polarization", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_5
	<<Beam structures: tests>>=
	subroutine beam_structures_5 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure
	integer, dimension(0) :: empty_array
	type(string_t) :: s

	write (u, "(A)") "* Test output: beam_structures_5"
	write (u, "(A)") "* Purpose: setup polarization in beam structure records"
	write (u, "(A)")

	s = "s"

	call beam_structure%init_sf ([s], empty_array)
	call beam_structure%init_pol (1)
	call beam_structure%init_smatrix (1, 1)
	call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
	call beam_structure%set_pol_f ([0.5_default])
	call beam_structure%write (u)


	write (u, "(A)")
	call beam_structure%final_sf ()
	call beam_structure%final_pol ()

	call beam_structure%init_sf ([s, s], [1])
	call beam_structure%set_sf (1, 1, var_str ("a"))
	call beam_structure%init_pol (2)
	call beam_structure%init_smatrix (1, 2)
	call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default))
	call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default))
	call beam_structure%init_smatrix (2, 0)
	call beam_structure%write (u)

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

	end subroutine beam_structures_5

	@ %def beam_structures_5
	@
	\subsubsection{Momenta}
	The momenta are independent from the structure-function setup.
	<<Beam structures: execute tests>>=
	call test (beam_structures_6, "beam_structures_6", &
	"momenta", &
	u, results)
	<<Beam structures: test declarations>>=
	public :: beam_structures_6
	<<Beam structures: tests>>=
	subroutine beam_structures_6 (u)
	integer, intent(in) :: u
	type(beam_structure_t) :: beam_structure
	integer, dimension(0) :: empty_array
	type(string_t) :: s

	write (u, "(A)") "* Test output: beam_structures_6"
	write (u, "(A)") "* Purpose: setup momenta in beam structure records"
	write (u, "(A)")

	s = "s"

	call beam_structure%init_sf ([s], empty_array)
	call beam_structure%set_momentum ([500._default])
	call beam_structure%write (u)


	write (u, "(A)")
	call beam_structure%final_sf ()
	call beam_structure%final_mom ()

	call beam_structure%init_sf ([s, s], [1])
	call beam_structure%set_momentum ([500._default, 700._default])
	call beam_structure%set_theta ([0._default, 0.1_default])
	call beam_structure%set_phi ([0._default, 1.51_default])
	call beam_structure%write (u)

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

	end subroutine beam_structures_6

	@ %def beam_structures_6
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Beams for collisions and decays}

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

	module beams

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_19
	use numeric_utils
	use diagnostics
	use md5
	use lorentz
	use model_data
	use flavors
	use quantum_numbers
	use state_matrices
	use interactions
	use polarizations
	use beam_structures

	<<Standard module head>>

	<<Beams: public>>

	<<Beams: types>>

	<<Beams: interfaces>>

	contains

	<<Beams: procedures>>

	end module beams
	@ %def beams
	@
	\subsection{Beam data}
	The beam data type contains beam data for one or two beams, depending
	on whether we are dealing with beam collisions or particle decay. In
	addition, it holds the c.m.\ energy [[sqrts]], the Lorentz
	transformation [[L]] that transforms the c.m.\ system into the lab
	system, and the pair of c.m.\ momenta.
	<<Beams: public>>=
	public :: beam_data_t
	<<Beams: types>>=
	type :: beam_data_t
	logical :: initialized = .false.
	integer :: n = 0
	type(flavor_t), dimension(:), allocatable :: flv
	real(default), dimension(:), allocatable :: mass
	type(pmatrix_t), dimension(:), allocatable :: pmatrix
	logical :: lab_is_cm = .true.
	type(vector4_t), dimension(:), allocatable :: p_cm
	type(vector4_t), dimension(:), allocatable :: p
	type(lorentz_transformation_t), allocatable :: L_cm_to_lab
	real(default) :: sqrts = 0
	character(32) :: md5sum = ""
	contains
	<<Beams: beam data: TBP>>
	end type beam_data_t

	@ %def beam_data_t
	@ Generic initializer. This is called by the specific initializers
	below. Initialize either for decay or for collision.
	<<Beams: procedures>>=
	subroutine beam_data_init (beam_data, n)
	type(beam_data_t), intent(out) :: beam_data
	integer, intent(in) :: n
	beam_data%n = n
	allocate (beam_data%flv (n))
	allocate (beam_data%mass (n))
	allocate (beam_data%pmatrix (n))
	allocate (beam_data%p_cm (n))
	allocate (beam_data%p (n))
	beam_data%initialized = .true.
	end subroutine beam_data_init

	@ %def beam_data_init
	@ Finalizer: needed for the polarization components of the beams.
	<<Beams: beam data: TBP>>=
	procedure :: final => beam_data_final
	<<Beams: procedures>>=
	subroutine beam_data_final (beam_data)
	class(beam_data_t), intent(inout) :: beam_data
	beam_data%initialized = .false.
	end subroutine beam_data_final

	@ %def beam_data_final
	@ The verbose (default) version is for debugging. The short version
	is for screen output in the UI.
	<<Beams: beam data: TBP>>=
	procedure :: write => beam_data_write
	<<Beams: procedures>>=
	subroutine beam_data_write (beam_data, unit, verbose, write_md5sum)
	class(beam_data_t), intent(in) :: beam_data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, write_md5sum
	integer :: prt_name_len
	logical :: verb, write_md5
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	verb = .false.; if (present (verbose)) verb = verbose
	write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum
	if (.not. beam_data%initialized) then
	write (u, "(1x,A)") "Beam data: [undefined]"
	return
	end if
	prt_name_len = maxval (len (beam_data%flv%get_name ()))
	select case (beam_data%n)
	case (1)
	write (u, "(1x,A)") "Beam data (decay):"
	if (verb) then
	call write_prt (1)
	call beam_data%pmatrix(1)%write (u)
	write (u, *) "R.f. momentum:"
	call vector4_write (beam_data%p_cm(1), u)
	write (u, *) "Lab momentum:"
	call vector4_write (beam_data%p(1), u)
	else
	call write_prt (1)
	end if
	case (2)
	write (u, "(1x,A)") "Beam data (collision):"
	if (verb) then
	call write_prt (1)
	call beam_data%pmatrix(1)%write (u)
	call write_prt (2)
	call beam_data%pmatrix(2)%write (u)
	call write_sqrts
	write (u, *) "C.m. momenta:"
	call vector4_write (beam_data%p_cm(1), u)
	call vector4_write (beam_data%p_cm(2), u)
	write (u, *) "Lab momenta:"
	call vector4_write (beam_data%p(1), u)
	call vector4_write (beam_data%p(2), u)
	else
	call write_prt (1)
	call write_prt (2)
	call write_sqrts
	end if
	end select
	if (allocated (beam_data%L_cm_to_lab)) then
	if (verb) then
	call lorentz_transformation_write (beam_data%L_cm_to_lab, u)
	else
	write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ"
	end if
	end if
	if (write_md5) then
	write (u, *) "MD5 sum: ", beam_data%md5sum
	end if
	contains
	subroutine write_sqrts
	character(80) :: sqrts_str
	write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts
	write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV"
	end subroutine write_sqrts
	subroutine write_prt (i)
	integer, intent(in) :: i
	character(80) :: name_str, mass_str
	write (name_str, "(A)") char (beam_data%flv(i)%get_name ())
	write (mass_str, "(ES13.7)") beam_data%mass(i)
	write (u, "(3x,A)", advance="no") &
	name_str(:prt_name_len) // " (mass = " &
	// trim (adjustl (mass_str)) // " GeV)"
	if (beam_data%pmatrix(i)%is_polarized ()) then
	write (u, "(2x,A)") "polarized"
	else
	write (u, *)
	end if
	end subroutine write_prt
	end subroutine beam_data_write

	@ %def beam_data_write
	@ Return initialization status:
	<<Beams: beam data: TBP>>=
	procedure :: are_valid => beam_data_are_valid
	<<Beams: procedures>>=
	function beam_data_are_valid (beam_data) result (flag)
	class(beam_data_t), intent(in) :: beam_data
	logical :: flag
	flag = beam_data%initialized
	end function beam_data_are_valid

	@ %def beam_data_are_valid
	@ Check whether beam data agree with the current values of relevant
	parameters.
	<<Beams: beam data: TBP>>=
	procedure :: check_scattering => beam_data_check_scattering
	<<Beams: procedures>>=
	subroutine beam_data_check_scattering (beam_data, sqrts)
	class(beam_data_t), intent(in) :: beam_data
	real(default), intent(in), optional :: sqrts
	if (beam_data_are_valid (beam_data)) then
	if (present (sqrts)) then
	if (.not. nearly_equal (sqrts, beam_data%sqrts)) then
	call msg_error ("Current setting of sqrts is inconsistent " &
	// "with beam setup (ignored).")
	end if
	end if
	else
	call msg_bug ("Beam setup: invalid beam data")
	end if
	end subroutine beam_data_check_scattering

	@ %def beam_data_check_scattering
	@ Return the number of beams (1 for decays, 2 for collisions).
	<<Beams: beam data: TBP>>=
	procedure :: get_n_in => beam_data_get_n_in
	<<Beams: procedures>>=
	function beam_data_get_n_in (beam_data) result (n_in)
	class(beam_data_t), intent(in) :: beam_data
	integer :: n_in
	n_in = beam_data%n
	end function beam_data_get_n_in

	@ %def beam_data_get_n_in
	@ Return the beam flavor
	<<Beams: beam data: TBP>>=
	procedure :: get_flavor => beam_data_get_flavor
	<<Beams: procedures>>=
	function beam_data_get_flavor (beam_data) result (flv)
	class(beam_data_t), intent(in) :: beam_data
	type(flavor_t), dimension(:), allocatable :: flv
	allocate (flv (beam_data%n))
	flv = beam_data%flv
	end function beam_data_get_flavor

	@ %def beam_data_get_flavor
	@ Return the beam energies
	<<Beams: beam data: TBP>>=
	procedure :: get_energy => beam_data_get_energy
	<<Beams: procedures>>=
	function beam_data_get_energy (beam_data) result (e)
	class(beam_data_t), intent(in) :: beam_data
	real(default), dimension(:), allocatable :: e
	integer :: i
	allocate (e (beam_data%n))
	if (beam_data%initialized) then
	do i = 1, beam_data%n
	e(i) = energy (beam_data%p(i))
	end do
	else
	e = 0
	end if
	end function beam_data_get_energy

	@ %def beam_data_get_energy
	@ Return the c.m.\ energy.
	<<Beams: beam data: TBP>>=
	procedure :: get_sqrts => beam_data_get_sqrts
	<<Beams: procedures>>=
	function beam_data_get_sqrts (beam_data) result (sqrts)
	class(beam_data_t), intent(in) :: beam_data
	real(default) :: sqrts
	sqrts = beam_data%sqrts
	end function beam_data_get_sqrts

	@ %def beam_data_get_sqrts
	@ Return the polarization in case it is just two degrees
	<<Beams: beam data: TBP>>=
	procedure :: get_polarization => beam_data_get_polarization
	<<Beams: procedures>>=
	function beam_data_get_polarization (beam_data) result (pol)
	class(beam_data_t), intent(in) :: beam_data
	real(default), dimension(beam_data%n) :: pol
	pol = beam_data%pmatrix%get_simple_pol ()
	end function beam_data_get_polarization

	@ %def beam_data_get_polarization
	@
	<<Beams: beam data: TBP>>=
	procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix
	<<Beams: procedures>>=
	function beam_data_get_helicity_state_matrix (beam_data) result (state_hel)
	type(state_matrix_t) :: state_hel
	class(beam_data_t), intent(in) :: beam_data
	type(polarization_t), dimension(:), allocatable :: pol
	integer :: i
	allocate (pol (beam_data%n))
	do i = 1, beam_data%n
	call pol(i)%init_pmatrix (beam_data%pmatrix(i))
	end do
	call combine_polarization_states (pol, state_hel)
	end function beam_data_get_helicity_state_matrix

	@ %def beam_data_get_helicity_state_matrix
	@
	<<Beams: beam data: TBP>>=
	procedure :: is_initialized => beam_data_is_initialized
	<<Beams: procedures>>=
	function beam_data_is_initialized (beam_data) result (initialized)
	logical :: initialized
	class(beam_data_t), intent(in) :: beam_data
	initialized = any (beam_data%pmatrix%exists ())
	end function beam_data_is_initialized

	@ %def beam_data_is_initialized
	@ Return a MD5 checksum for beam data. If no checksum is present
	(because beams have not been initialized), compute the checksum of the
	sqrts value.
	<<Beams: beam data: TBP>>=
	procedure :: get_md5sum => beam_data_get_md5sum
	<<Beams: procedures>>=
	function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams)
	class(beam_data_t), intent(in) :: beam_data
	real(default), intent(in) :: sqrts
	character(32) :: md5sum_beams
	character(80) :: buffer
	if (beam_data%md5sum /= "") then
	md5sum_beams = beam_data%md5sum
	else
	write (buffer, *) sqrts
	md5sum_beams = md5sum (buffer)
	end if
	end function beam_data_get_md5sum

	@ %def beam_data_get_md5sum
	@
	\subsection{Initializers: beam structure}
	Initialize the beam data object from a beam structure object, given energy and
	model.
	<<Beams: beam data: TBP>>=
	procedure :: init_structure => beam_data_init_structure
	<<Beams: procedures>>=
	subroutine beam_data_init_structure &
	(beam_data, structure, sqrts, model, decay_rest_frame)
	class(beam_data_t), intent(out) :: beam_data
	type(beam_structure_t), intent(in) :: structure
	integer :: n_beam
	real(default), intent(in) :: sqrts
	class(model_data_t), intent(in), target :: model
	logical, intent(in), optional :: decay_rest_frame
	type(flavor_t), dimension(:), allocatable :: flv
	n_beam = structure%get_n_beam ()
	allocate (flv (n_beam))
	call flv%init (structure%get_prt (), model)
	if (structure%asymmetric ()) then
	if (structure%polarized ()) then
	call beam_data%init_momenta (structure%get_momenta (), flv, &
	structure%get_smatrix (), structure%get_pol_f ())
	else
	call beam_data%init_momenta (structure%get_momenta (), flv)
	end if
	else
	select case (n_beam)
	case (1)
	if (structure%polarized ()) then
	call beam_data%init_decay (flv, &
	structure%get_smatrix (), structure%get_pol_f (), &
	rest_frame = decay_rest_frame)
	else
	call beam_data%init_decay (flv, &
	rest_frame = decay_rest_frame)
	end if
	case (2)
	if (structure%polarized ()) then
	call beam_data%init_sqrts (sqrts, flv, &
	structure%get_smatrix (), structure%get_pol_f ())
	else
	call beam_data%init_sqrts (sqrts, flv)
	end if
	case default
	call msg_bug ("Beam data: invalid beam structure object")
	end select
	end if
	end subroutine beam_data_init_structure

	@ %def beam_data_init_structure
	@
	\subsection{Initializers: collisions}
	This is the simplest one: just the two flavors, c.m.\ energy,
	polarization. Color is inferred from flavor. Beam momenta and c.m.\
	momenta coincide.
	<<Beams: beam data: TBP>>=
	procedure :: init_sqrts => beam_data_init_sqrts
	<<Beams: procedures>>=
	subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f)
	class(beam_data_t), intent(out) :: beam_data
	real(default), intent(in) :: sqrts
	type(flavor_t), dimension(:), intent(in) :: flv
	type(smatrix_t), dimension(:), intent(in), optional :: smatrix
	real(default), dimension(:), intent(in), optional :: pol_f
	real(default), dimension(size(flv)) :: E, p
	call beam_data_init (beam_data, size (flv))
	beam_data%sqrts = sqrts
	beam_data%lab_is_cm = .true.
	select case (beam_data%n)
	case (1)
	E = sqrts; p = 0
	beam_data%p_cm = vector4_moving (E, p, 3)
	beam_data%p = beam_data%p_cm
	case (2)
	beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ())
	beam_data%p = colliding_momenta (sqrts, flv%get_mass ())
	end select
	call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
	end subroutine beam_data_init_sqrts

	@ %def beam_data_init_sqrts
	@ This version sets beam momenta directly, assuming that they are
	asymmetric, i.e., lab frame and c.m.\ frame do not coincide.
	Polarization info is deferred to a common initializer.

	The Lorentz transformation that we compute here is not actually used
	in the calculation; instead, it will be recomputed for each event in
	the subroutine [[phs_set_incoming_momenta]]. We compute it here for
	the nominal beam setup nevertheless, so we can print it and, in
	particular, include it in the MD5 sum.
	<<Beams: beam data: TBP>>=
	procedure :: init_momenta => beam_data_init_momenta
	<<Beams: procedures>>=
	subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f)
	class(beam_data_t), intent(out) :: beam_data
	type(vector3_t), dimension(:), intent(in) :: p3
	type(flavor_t), dimension(:), intent(in) :: flv
	type(smatrix_t), dimension(:), intent(in), optional :: smatrix
	real(default), dimension(:), intent(in), optional :: pol_f
	type(vector4_t) :: p0
	type(vector4_t), dimension(:), allocatable :: p, p_cm_rot
	real(default), dimension(size(p3)) :: e
	real(default), dimension(size(flv)) :: m
	type(lorentz_transformation_t) :: L_boost, L_rot
	call beam_data_init (beam_data, size (flv))
	m = flv%get_mass ()
	e = sqrt (p3 2 + m 2)
	allocate (p (beam_data%n))
	p = vector4_moving (e, p3)
	p0 = sum (p)
	beam_data%p = p
	beam_data%lab_is_cm = .false.
	beam_data%sqrts = p0 ** 1
	L_boost = boost (p0, beam_data%sqrts)
	allocate (p_cm_rot (beam_data%n))
	p_cm_rot = inverse (L_boost) * p
	allocate (beam_data%L_cm_to_lab)
	select case (beam_data%n)
	case (1)
	beam_data%L_cm_to_lab = L_boost
	beam_data%p_cm = vector4_at_rest (beam_data%sqrts)
	case (2)
	L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1)))
	beam_data%L_cm_to_lab = L_boost * L_rot
	beam_data%p_cm = &
	colliding_momenta (beam_data%sqrts, flv%get_mass ())
	end select
	call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
	end subroutine beam_data_init_momenta

	@ %def beam_data_init_momenta
	@
	Final steps:
	If requested, rotate the beams in the lab frame, and set
	the beam-data components.
	<<Beams: procedures>>=
	subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
	type(beam_data_t), intent(inout) :: beam_data
	type(flavor_t), dimension(:), intent(in) :: flv
	type(smatrix_t), dimension(:), intent(in), optional :: smatrix
	real(default), dimension(:), intent(in), optional :: pol_f
	integer :: i
	do i = 1, beam_data%n
	beam_data%flv(i) = flv(i)
	beam_data%mass(i) = flv(i)%get_mass ()
	if (present (smatrix)) then
	if (size (smatrix) /= beam_data%n) &
	call msg_fatal ("Beam data: &
	&polarization density array has wrong dimension")
	beam_data%pmatrix(i) = smatrix(i)
	if (present (pol_f)) then
	if (size (pol_f) /= size (smatrix)) &
	call msg_fatal ("Beam data: &
	&polarization fraction array has wrong dimension")
	call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i))
	else
	call beam_data%pmatrix(i)%normalize (flv(i), 1._default)
	end if
	else
	call beam_data%pmatrix(i)%init (2, 0)
	call beam_data%pmatrix(i)%normalize (flv(i), 0._default)
	end if
	end do
	call beam_data%compute_md5sum ()
	end subroutine beam_data_finish_initialization

	@ %def beam_data_finish_initialization
	@
	The MD5 sum is stored within the beam-data record, so it can be
	checked for integrity in subsequent runs.
	<<Beams: beam data: TBP>>=
	procedure :: compute_md5sum => beam_data_compute_md5sum
	<<Beams: procedures>>=
	subroutine beam_data_compute_md5sum (beam_data)
	class(beam_data_t), intent(inout) :: beam_data
	integer :: unit
	unit = free_unit ()
	open (unit = unit, status = "scratch", action = "readwrite")
	call beam_data%write (unit, write_md5sum = .false., &
	verbose = .true.)
	rewind (unit)
	beam_data%md5sum = md5sum (unit)
	close (unit)
	end subroutine beam_data_compute_md5sum

	@ %def beam_data_compute_md5sum
	@
	\subsection{Initializers: decays}
	This is the simplest one: decay in rest frame. We need just flavor
	and polarization. Color is inferred from flavor. Beam momentum and
	c.m.\ momentum coincide.
	<<Beams: beam data: TBP>>=
	procedure :: init_decay => beam_data_init_decay
	<<Beams: procedures>>=
	subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame)
	class(beam_data_t), intent(out) :: beam_data
	type(flavor_t), dimension(1), intent(in) :: flv
	type(smatrix_t), dimension(1), intent(in), optional :: smatrix
	real(default), dimension(:), intent(in), optional :: pol_f
	logical, intent(in), optional :: rest_frame
	real(default), dimension(1) :: m
	m = flv%get_mass ()
	if (present (smatrix)) then
	call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
	else
	call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
	end if
	if (present (rest_frame)) beam_data%lab_is_cm = rest_frame
	end subroutine beam_data_init_decay

	@ %def beam_data_init_decay
	@
	\subsection{The beams type}
	Beam objects are interaction objects that contain the actual beam
	data including polarization and density matrix. For collisions, the
	beam object actually contains two beams.
	<<Beams: public>>=
	public :: beam_t
	<<Beams: types>>=
	type :: beam_t
	private
	type(interaction_t) :: int
	end type beam_t

	@ %def beam_t
	@ The constructor contains code that converts beam data into the
	(entangled) particle-pair quantum state. First, we set the number of
	particles and polarization mask. (The polarization mask is handed
	over to all later interactions, so if helicity is diagonal or absent, this fact
	is used when constructing the hard-interaction events.) Then, we
	construct the entangled state that combines helicity, flavor and color
	of the two particles (where flavor and color are unique, while several
	helicity states are possible). Then, we transfer this state together
	with the associated values from the spin density matrix into the
	[[interaction_t]] object.

	Calling the [[add_state]] method of the interaction object, we keep
	the entries of the helicity density matrix without adding them up.
	This ensures that for unpolarized states, we do not normalize but end
	up with an $1/N$ entry, where $N$ is the initial-state multiplicity.
	<<Beams: public>>=
	public :: beam_init
	<<Beams: procedures>>=
	subroutine beam_init (beam, beam_data)
	type(beam_t), intent(out) :: beam
	type(beam_data_t), intent(in), target :: beam_data
	logical, dimension(beam_data%n) :: polarized, diagonal
	type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d
	type(state_matrix_t), target :: state_hel, state_fc, state_tmp
	type(state_iterator_t) :: it_hel, it_tmp
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	complex(default) :: value
	real(default), parameter :: tolerance = 100 * epsilon (1._default)
	polarized = beam_data%pmatrix%is_polarized ()
	diagonal = beam_data%pmatrix%is_diagonal ()
	mask = quantum_numbers_mask (.false., .false., &
	mask_h = .not. polarized, &
	mask_hd = diagonal)
	mask_d = quantum_numbers_mask (.false., .false., .false., &
	mask_hd = polarized .and. diagonal)
	call beam%int%basic_init &
	(0, 0, beam_data%n, mask = mask, store_values = .true.)
	state_hel = beam_data%get_helicity_state_matrix ()
	allocate (qn (beam_data%n))
	call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1))
	call state_fc%init ()
	call state_fc%add_state (qn)
	call merge_state_matrices (state_hel, state_fc, state_tmp)
	call it_hel%init (state_hel)
	call it_tmp%init (state_tmp)
	do while (it_hel%is_valid ())
	qn = it_tmp%get_quantum_numbers ()
	value = it_hel%get_matrix_element ()
	if (any (qn%are_redundant (mask_d))) then
	! skip off-diagonal elements for diagonal polarization
	else if (abs (value) <= tolerance) then
	! skip zero entries
	else
	call beam%int%add_state (qn, value = value)
	end if
	call it_hel%advance ()
	call it_tmp%advance ()
	end do
	call beam%int%freeze ()
	call beam%int%set_momenta (beam_data%p, outgoing = .true.)
	call state_hel%final ()
	call state_fc%final ()
	call state_tmp%final ()
	end subroutine beam_init

	@ %def beam_init
	@ Finalizer:
	<<Beams: public>>=
	public :: beam_final
	<<Beams: procedures>>=
	subroutine beam_final (beam)
	type(beam_t), intent(inout) :: beam
	call beam%int%final ()
	end subroutine beam_final

	@ %def beam_final
	@ I/O:
	<<Beams: public>>=
	public :: beam_write
	<<Beams: procedures>>=
	subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose)
	type(beam_t), intent(in) :: beam
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: col_verbose
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	select case (beam%int%get_n_out ())
	case (1); write (u, *) "Decaying particle:"
	case (2); write (u, *) "Colliding beams:"
	end select
	call beam%int%basic_write &
	(unit, verbose = verbose, show_momentum_sum = &
	show_momentum_sum, show_mass = show_mass, &
	col_verbose = col_verbose)
	end subroutine beam_write

	@ %def beam_write
	@ Defined assignment: deep copy
	<<Beams: public>>=
	public :: assignment(=)
	<<Beams: interfaces>>=
	interface assignment(=)
	module procedure beam_assign
	end interface

	<<Beams: procedures>>=
	subroutine beam_assign (beam_out, beam_in)
	type(beam_t), intent(out) :: beam_out
	type(beam_t), intent(in) :: beam_in
	beam_out%int = beam_in%int
	end subroutine beam_assign

	@ %def beam_assign
	@
	\subsection{Inherited procedures}
	<<Beams: public>>=
	public :: interaction_set_source_link
	<<Beams: interfaces>>=
	interface interaction_set_source_link
	module procedure interaction_set_source_link_beam
	end interface
	<<Beams: procedures>>=
	subroutine interaction_set_source_link_beam (int, i, beam1, i1)
	type(interaction_t), intent(inout) :: int
	type(beam_t), intent(in), target :: beam1
	integer, intent(in) :: i, i1
	call int%set_source_link (i, beam1%int, i1)
	end subroutine interaction_set_source_link_beam

	@ %def interaction_set_source_link_beam
	@
	\subsection{Accessing contents}
	Return the interaction component -- as a pointer, to avoid any copying.
	<<Beams: public>>=
	public :: beam_get_int_ptr
	<<Beams: procedures>>=
	function beam_get_int_ptr (beam) result (int)
	type(interaction_t), pointer :: int
	type(beam_t), intent(in), target :: beam
	int => beam%int
	end function beam_get_int_ptr

	@ %def beam_get_int_ptr
	@ Set beam momenta directly. (Used for cascade decays.)
	<<Beams: public>>=
	public :: beam_set_momenta
	<<Beams: procedures>>=
	subroutine beam_set_momenta (beam, p)
	type(beam_t), intent(inout) :: beam
	type(vector4_t), dimension(:), intent(in) :: p
	call beam%int%set_momenta (p)
	end subroutine beam_set_momenta

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

	module beams_ut
	use unit_tests
	use beams_uti

	<<Standard module head>>

	<<Beams: public test>>

	contains

	<<Beams: test driver>>

	end module beams_ut
	@ %def beams_ut
	@
	<<[[beams_uti.f90]]>>=
	<<File header>>

	module beams_uti

	<<Use kinds>>
	use lorentz
	use flavors
	use interactions, only: reset_interaction_counter
	use polarizations, only: smatrix_t
	use model_data
	use beam_structures

	use beams

	<<Standard module head>>

	<<Beams: test declarations>>

	contains

	<<Beams: tests>>

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

	@ %def beams_test
	@ Test the basic beam setup.
	<<Beams: execute tests>>=
	call test (beam_1, "beam_1", &
	"check basic beam setup", &
	u, results)
	<<Beams: test declarations>>=
	public :: beam_1
	<<Beams: tests>>=
	subroutine beam_1 (u)
	integer, intent(in) :: u
	type(beam_data_t), target :: beam_data
	type(beam_t) :: beam
	real(default) :: sqrts
	type(flavor_t), dimension(2) :: flv
	type(smatrix_t), dimension(2) :: smatrix
	real(default), dimension(2) :: pol_f
	type(model_data_t), target :: model

	write (u, "(A)") "* Test output: beam_1"
	write (u, "(A)") "* Purpose: test basic beam setup"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call model%init_sm_test ()

	write (u, "(A)") "* Unpolarized scattering, massless fermions"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([1,-1], model)

	call beam_data%init_sqrts (sqrts, flv)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized scattering, massless bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([22,22], model)

	call beam_data%init_sqrts (sqrts, flv)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized scattering, massive bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([24,-24], model)

	call beam_data%init_sqrts (sqrts, flv)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Polarized scattering, massless fermions"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([1,-1], model)

	call smatrix(1)%init (2, 1)
	call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default))
	pol_f(1) = 0.5_default

	call smatrix(2)%init (2, 3)
	call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
	call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default))
	call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default))
	pol_f(2) = 1._default

	call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Semi-polarized scattering, massless bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([22,22], model)

	call smatrix(1)%init (2, 0)
	pol_f(1) = 0._default

	call smatrix(2)%init (2, 1)
	call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
	pol_f(2) = 1._default

	call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Semi-polarized scattering, massive bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([24,-24], model)

	call smatrix(1)%init (2, 0)
	pol_f(1) = 0._default

	call smatrix(2)%init (2, 1)
	call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default))
	pol_f(2) = 1._default

	call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized decay, massive boson"
	write (u, "(A)")

	call reset_interaction_counter ()
	call flv(1)%init (23, model)

	call beam_data%init_decay (flv(1:1))
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)

	write (u, "(A)")
	write (u, "(A)") "* Polarized decay, massive boson"
	write (u, "(A)")

	call reset_interaction_counter ()
	call flv(1)%init (23, model)
	call smatrix(1)%init (2, 1)
	call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default))
	pol_f(1) = 0.4_default

	call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1))
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)

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

	call beam_final (beam)
	call beam_data%final ()

	call model%final ()

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

	end subroutine beam_1

	@ %def beam_1
	@ Test advanced beam setup.
	<<Beams: execute tests>>=
	call test (beam_2, "beam_2", &
	"beam initialization", &
	u, results)
	<<Beams: test declarations>>=
	public :: beam_2
	<<Beams: tests>>=
	subroutine beam_2 (u)
	integer, intent(in) :: u
	type(beam_data_t), target :: beam_data
	type(beam_t) :: beam
	real(default) :: sqrts
	type(flavor_t), dimension(2) :: flv
	integer, dimension(0) :: no_records
	type(beam_structure_t) :: beam_structure
	type(model_data_t), target :: model

	write (u, "(A)") "* Test output: beam_2"
	write (u, "(A)") "* Purpose: transfer beam polarization using &
	&beam structure"
	write (u, "(A)")

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

	call model%init_sm_test ()

	write (u, "(A)") "* Unpolarized scattering, massless fermions"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([1,-1], model)
	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%final_pol ()

	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized scattering, massless bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([22,22], model)

	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%final_pol ()

	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized scattering, massive bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([24,-24], model)

	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%final_pol ()

	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Polarized scattering, massless fermions"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([1,-1], model)
	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%init_pol (2)

	call beam_structure%init_smatrix (1, 1)
	call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default))

	call beam_structure%init_smatrix (2, 3)
	call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))
	call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default))
	call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default))

	call beam_structure%set_pol_f ([0.5_default, 1._default])
	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)
	write (u, *)

	call beam_init (beam, beam_data)
	call beam_write (beam, u)

	call beam_final (beam)
	call beam_data%final ()
	call beam_structure%final_pol ()
	call beam_structure%final_sf ()

	write (u, "(A)")
	write (u, "(A)") "* Semi-polarized scattering, massless bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([22,22], model)

	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%init_pol (2)

	call beam_structure%init_smatrix (1, 0)

	call beam_structure%init_smatrix (2, 1)
	call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))

	call beam_structure%set_pol_f ([0._default, 1._default])
	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Semi-polarized scattering, massive bosons"
	write (u, "(A)")

	call reset_interaction_counter ()
	sqrts = 500
	call flv%init ([24,-24], model)

	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%init_pol (2)

	call beam_structure%init_smatrix (1, 0)

	call beam_structure%init_smatrix (2, 1)
	call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default))
	call beam_structure%write (u)

	write (u, "(A)")
	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)
	call beam_final (beam)
	call beam_data%final ()

	write (u, "(A)")
	write (u, "(A)") "* Unpolarized decay, massive boson"
	write (u, "(A)")

	call reset_interaction_counter ()
	call flv(1)%init (23, model)

	call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
	call beam_structure%final_pol ()
	call beam_structure%write (u)

	write (u, "(A)")
	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)

	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)

	write (u, "(A)")
	write (u, "(A)") "* Polarized decay, massive boson"
	write (u, "(A)")

	call reset_interaction_counter ()
	call flv(1)%init (23, model)
	call beam_structure%init_sf ([flv(1)%get_name ()], no_records)

	call beam_structure%init_pol (1)

	call beam_structure%init_smatrix (1, 1)
	call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
	call beam_structure%set_pol_f ([0.4_default])
	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, sqrts, model)
	call beam_data%write (u)
	write (u, "(A)")
	call beam_init (beam, beam_data)
	call beam_write (beam, u)

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

	call beam_final (beam)
	call beam_data%final ()

	call model%final ()

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

	end subroutine beam_2

	@ %def beam_2
	@ Test advanced beam setup, completely arbitrary momenta.
	<<Beams: execute tests>>=
	call test (beam_3, "beam_3", &
	"generic beam momenta", &
	u, results)
	<<Beams: test declarations>>=
	public :: beam_3
	<<Beams: tests>>=
	subroutine beam_3 (u)
	integer, intent(in) :: u
	type(beam_data_t), target :: beam_data
	type(beam_t) :: beam
	type(flavor_t), dimension(2) :: flv
	integer, dimension(0) :: no_records
	type(model_data_t), target :: model
	type(beam_structure_t) :: beam_structure
	type(vector3_t), dimension(2) :: p3
	type(vector4_t), dimension(2) :: p

	write (u, "(A)") "* Test output: beam_3"
	write (u, "(A)") "* Purpose: set up beams with generic momenta"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call model%init_sm_test ()

	write (u, "(A)") "* 1: Scattering process"
	write (u, "(A)")

	call flv%init ([2212,2212], model)

	p3(1) = vector3_moving ([5._default, 0._default, 10._default])
	p3(2) = -vector3_moving ([1._default, 1._default, -10._default])

	call beam_structure%init_sf (flv%get_name (), no_records)
	call beam_structure%set_momentum (p3 ** 1)
	call beam_structure%set_theta (polar_angle (p3))
	call beam_structure%set_phi (azimuthal_angle (p3))
	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, 0._default, model)
	call pacify (beam_data%l_cm_to_lab, 1e-20_default)
	call beam_data%compute_md5sum ()
	call beam_data%write (u, verbose = .true.)
	write (u, *)

	write (u, "(1x,A)") "Beam momenta reconstructed from LT:"
	p = beam_data%L_cm_to_lab * beam_data%p_cm
	call pacify (p, 1e-12_default)
	call vector4_write (p(1), u)
	call vector4_write (p(2), u)
	write (u, "(A)")

	call beam_init (beam, beam_data)
	call beam_write (beam, u)

	call beam_final (beam)
	call beam_data%final ()
	call beam_structure%final_sf ()
	call beam_structure%final_mom ()

	write (u, "(A)")
	write (u, "(A)") "* 2: Decay"
	write (u, "(A)")

	call flv(1)%init (23, model)
	p3(1) = vector3_moving ([10._default, 5._default, 50._default])

	call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
	call beam_structure%set_momentum ([p3(1) ** 1])
	call beam_structure%set_theta ([polar_angle (p3(1))])
	call beam_structure%set_phi ([azimuthal_angle (p3(1))])
	call beam_structure%write (u)
	write (u, *)

	call beam_data%init_structure (beam_structure, 0._default, model)
	call beam_data%write (u, verbose = .true.)
	write (u, "(A)")

	write (u, "(1x,A)") "Beam momentum reconstructed from LT:"
	p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1)
	call pacify (p(1), 1e-12_default)
	call vector4_write (p(1), u)
	write (u, "(A)")

	call beam_init (beam, beam_data)
	call beam_write (beam, u)

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

	call beam_final (beam)
	call beam_data%final ()
	call beam_structure%final_sf ()
	call beam_structure%final_mom ()

	call model%final ()

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

	end subroutine beam_3

	@ %def beam_3
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Tools}

	This module contains auxiliary procedures that can be accessed by the
	structure function code.

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

	module sf_aux

	<<Use kinds>>
	use io_units
	use constants, only: twopi
	use numeric_utils

	use lorentz

	<<Standard module head>>

	<<SF aux: public>>

	<<SF aux: parameters>>

	<<SF aux: types>>

	contains

	<<SF aux: procedures>>

	end module sf_aux

	@ %def sf_aux
	@
	\subsection{Momentum splitting}
	Let us consider first an incoming parton with momentum $k$ and
	invariant mass squared $s=k^2$ that splits into two partons with
	momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an
	abuse of the Mandelstam notation. $t$ is actually the momentum
	transfer, assuming that $p$ is radiated and $q$ initiates the hard
	process.) The energy is split among the partons such that if $E=k^0$,
	we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$.

	We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the
	momentum axis of the incoming momentum $k$. Ignoring azimuthal angle,
	we can write the four-momenta in the basis $(E,p_T,p_L)$ as
	\begin{equation}
	k =
	\begin{pmatrix}
	E \\ 0 \\ p
	\end{pmatrix},
	\qquad
	p =
	\begin{pmatrix}
	\bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta
	\end{pmatrix},
	\qquad
	q =
	\begin{pmatrix}
	x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta
	\end{pmatrix},
	\end{equation}
	where the first two mass-shell conditions are
	\begin{equation}
	p^2 = E^2 - s,
	\qquad
	\bar p^2 = E^2 - \frac{u}{\bar x^2}.
	\end{equation}
	The second condition implies that, for positive $u$, $\bar x^2 >
	u/E^2$, or equivalently
	\begin{equation}
	x < 1 - \sqrt{u} / E.
	\end{equation}

	We are interested in the third mass-shell conditions: $s$ and $u$ are
	fixed, so we need $t$ as a function of $\cos\theta$:
	\begin{equation}
	t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u.
	\end{equation}
	Solving for $\cos\theta$, we get
	\begin{equation}
	\cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}.
	\end{equation}
	We can compute $\sin\theta$ numerically as
	$\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this
	in view of numerical stability. To this end, we first determine the
	bounds for $t$. The cosine must be between $-1$ and $1$, so the
	bounds are
	\begin{align}
	t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u,
	\\
	t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u.
	\end{align}
	Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the
	numerator is a quadratic polynomial in $t$ which has the zeros $t_0$
	and $t_1$, while the common denominator is given by $(2\bar x p\bar
	p)^2$. Hence, we can write
	\begin{equation}
	\sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2}
	\qquad\text{and}\qquad
	\cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p},
	\end{equation}
	which is free of large cancellations near $t=t_0$ or $t=t_1$.

	If all is massless, i.e., $s=u=0$, this simplifies to
	\begin{align}
	t_0 &= -4\bar x E^2,
	&
	t_1 &= 0,
	\\
	\sin^2\theta &= -\frac{t}{\bar x E^2}
	\left(1 + \frac{t}{4\bar x E^2}\right),
	&
	\cos\theta &= 1 + \frac{t}{2\bar x E^2}.
	\end{align}

	Here is the implementation. First, we define a container for the
	kinematical integration limits and some further data.

	Note: contents are public only for easy access in unit test.
	<<SF aux: public>>=
	public :: splitting_data_t
	<<SF aux: types>>=
	type :: splitting_data_t
	! private
	logical :: collinear = .false.
	real(default) :: x0 = 0
	real(default) :: x1
	real(default) :: t0
	real(default) :: t1
	real(default) :: phi0 = 0
	real(default) :: phi1 = twopi
	real(default) :: E, p, s, u, m2
	real(default) :: x, xb, pb
	real(default) :: t = 0
	real(default) :: phi = 0
	contains
	<<SF aux: splitting data: TBP>>
	end type splitting_data_t

	@ %def splitting_data_t
	@ I/O for debugging:
	<<SF aux: splitting data: TBP>>=
	procedure :: write => splitting_data_write
	<<SF aux: procedures>>=
	subroutine splitting_data_write (d, unit)
	class(splitting_data_t), intent(in) :: d
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(A)") "Splitting data:"
	write (u, "(2x,A,L1)") "collinear = ", d%collinear
	1 format (2x,A,1x,ES15.8)
	write (u, 1) "x0 =", d%x0
	write (u, 1) "x =", d%x
	write (u, 1) "xb =", d%xb
	write (u, 1) "x1 =", d%x1
	write (u, 1) "t0 =", d%t0
	write (u, 1) "t =", d%t
	write (u, 1) "t1 =", d%t1
	write (u, 1) "phi0 =", d%phi0
	write (u, 1) "phi =", d%phi
	write (u, 1) "phi1 =", d%phi1
	write (u, 1) "E =", d%E
	write (u, 1) "p =", d%p
	write (u, 1) "pb =", d%pb
	write (u, 1) "s =", d%s
	write (u, 1) "u =", d%u
	write (u, 1) "m2 =", d%m2
	end subroutine splitting_data_write

	@ %def splitting_data_write
	@
	\subsection{Constant data}
	This is the initializer for the data. The input consists of the
	incoming momentum, its invariant mass squared, and the invariant mass
	squared of the radiated particle. $m2$ is the \emph{physical} mass
	squared of the outgoing particle. The $t$ bounds depend on the chosen $x$
	value and cannot be determined yet.
	<<SF aux: splitting data: TBP>>=
	procedure :: init => splitting_data_init
	<<SF aux: procedures>>=
	subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear)
	class(splitting_data_t), intent(out) :: d
	type(vector4_t), intent(in) :: k
	real(default), intent(in) :: mk2, mr2, mo2
	logical, intent(in), optional :: collinear
	if (present (collinear)) d%collinear = collinear
	d%E = energy (k)
	d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E
	d%p = sqrt (d%E**2 - mk2)
	d%s = mk2
	d%u = mr2
	d%m2 = mo2
	end subroutine splitting_data_init

	@ %def splitting_data_init
	@ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an
	$x$ value is done by the caller, since this is the part that depends
	on the nature of the structure function.
	<<SF aux: splitting data: TBP>>=
	procedure :: get_x_bounds => splitting_get_x_bounds
	<<SF aux: procedures>>=
	function splitting_get_x_bounds (d) result (x)
	class(splitting_data_t), intent(in) :: d
	real(default), dimension(2) :: x
	x = [ d%x0, d%x1 ]
	end function splitting_get_x_bounds

	@ %def splitting_get_x_bounds
	@ Now set the momentum fraction and compute $t_0$ and $t_1$.

	[The calculation of $t_1$ is subject to numerical problems. The exact
	formula is ($s=m_i^2$, $u=m_r^2$)
	\begin{equation}
	t_1 = -2\bar x E^2 + m_i^2 + m_r^2
	+ 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}.
	\end{equation}
	The structure-function paradigm is useful only if $E\gg m_i,m_r$. In
	a Taylor expansion for large $E$, the leading term cancels. The
	expansion of the square roots (to subleading order) yields
	\begin{equation}
	t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2.
	\end{equation}
	There are two cases of interest: $m_i=m_o$ and $m_r=0$,
	\begin{equation}
	t_1 = xm_o^2
	\end{equation}
	and $m_i=m_r$ and $m_o=0$,
	\begin{equation}
	t_1 = -\frac{x^2}{\bar x}m_i^2.
	\end{equation}
	In both cases, $t_1\leq m_o^2$.]

	That said, it turns out that taking the $t_1$ evaluation at face value
	leads to less problems than the approximation. We express the angles
	in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be
	tolerated.
	<<SF aux: splitting data: TBP>>=
	procedure :: set_t_bounds => splitting_set_t_bounds
	<<SF aux: procedures>>=
	elemental subroutine splitting_set_t_bounds (d, x, xb)
	class(splitting_data_t), intent(inout) :: d
	real(default), intent(in), optional :: x, xb
	real(default) :: tp, tm
	if (present (x)) d%x = x
	if (present (xb)) d%xb = xb
	if (vanishes (d%u)) then
	d%pb = d%E
	else
	if (.not. vanishes (d%xb)) then
	d%pb = sqrt (max (d%E2 - d%u / d%xb2, 0._default))
	else
	d%pb = 0
	end if
	end if
	tp = -2 * d%xb * d%E**2 + d%s + d%u
	tm = -2 * d%xb * d%p * d%pb
	d%t0 = tp + tm
	d%t1 = tp - tm
	d%t = d%t1
	end subroutine splitting_set_t_bounds

	@ %def splitting_set_t_bounds
	@
	\subsection{Sampling recoil}
	Compute a value for the momentum transfer $t$, using a random number
	$r$. We assume a logarithmic distribution for $t-m^2$, corresponding
	to the propagator $1/(t-m^2)$ with the physical mass $m$ for the
	outgoing particle. Optionally, we can narrow the kinematical bounds.

	If all three masses in the splitting vanish, the upper limit for $t$
	is zero. In that case, the $t$ value is set to zero and the splitting
	will be collinear.
	<<SF aux: splitting data: TBP>>=
	procedure :: sample_t => splitting_sample_t
	<<SF aux: procedures>>=
	subroutine splitting_sample_t (d, r, t0, t1)
	class(splitting_data_t), intent(inout) :: d
	real(default), intent(in) :: r
	real(default), intent(in), optional :: t0, t1
	real(default) :: tt0, tt1, tt0m, tt1m
	if (d%collinear) then
	d%t = d%t1
	else
	tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0)
	tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1)
	tt0m = tt0 - d%m2
	tt1m = tt1 - d%m2
	if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > &
	epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then
	d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m))
	else
	d%t = tt1
	end if
	end if
	end subroutine splitting_sample_t

	@ %def splitting_sample_t
	@ The inverse operation: Given $t$, we recover the value of $r$ that
	would have produced this value.
	<<SF aux: splitting data: TBP>>=
	procedure :: inverse_t => splitting_inverse_t
	<<SF aux: procedures>>=
	subroutine splitting_inverse_t (d, r, t0, t1)
	class(splitting_data_t), intent(in) :: d
	real(default), intent(out) :: r
	real(default), intent(in), optional :: t0, t1
	real(default) :: tt0, tt1, tt0m, tt1m
	if (d%collinear) then
	r = 0
	else
	tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0)
	tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1)
	tt0m = tt0 - d%m2
	tt1m = tt1 - d%m2
	if (tt0m < 0 .and. tt1m < 0) then
	r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m)
	else
	r = 0
	end if
	end if
	end subroutine splitting_inverse_t

	@ %def splitting_inverse_t
	@ This is trivial, but provided for convenience:
	<<SF aux: splitting data: TBP>>=
	procedure :: sample_phi => splitting_sample_phi
	<<SF aux: procedures>>=
	subroutine splitting_sample_phi (d, r)
	class(splitting_data_t), intent(inout) :: d
	real(default), intent(in) :: r
	if (d%collinear) then
	d%phi = 0
	else
	d%phi = (1-r) * d%phi0 + r * d%phi1
	end if
	end subroutine splitting_sample_phi

	@ %def splitting_sample_phi
	@ Inverse:
	<<SF aux: splitting data: TBP>>=
	procedure :: inverse_phi => splitting_inverse_phi
	<<SF aux: procedures>>=
	subroutine splitting_inverse_phi (d, r)
	class(splitting_data_t), intent(in) :: d
	real(default), intent(out) :: r
	if (d%collinear) then
	r = 0
	else
	r = (d%phi - d%phi0) / (d%phi1 - d%phi0)
	end if
	end subroutine splitting_inverse_phi

	@ %def splitting_inverse_phi
	@
	\subsection{Splitting}
	In this function, we actually perform the splitting. The incoming momentum
	$k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$.

	Apart from the splitting data, we need the incoming momentum $k$, the momentum
	transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is
	already known here.

	Alternatively, we can split without recoil. The azimuthal angle is
	irrelevant, and the momentum transfer is always equal to the upper
	limit $t_1$, so the polar angle is zero. Obviously, if there are
	nonzero masses it is not possible to keep both energy-momentum
	conservation and at the same time all particles on shell. We choose
	for dropping the on-shell condition here.
	<<SF aux: splitting data: TBP>>=
	procedure :: split_momentum => splitting_split_momentum
	<<SF aux: procedures>>=
	function splitting_split_momentum (d, k) result (q)
	class(splitting_data_t), intent(in) :: d
	type(vector4_t), dimension(2) :: q
	type(vector4_t), intent(in) :: k
	real(default) :: st2, ct2, st, ct, cp, sp
	type(lorentz_transformation_t) :: rot
	real(default) :: tt0, tt1, den
	type(vector3_t) :: kk, q1, q2
	if (d%collinear) then
	if (vanishes (d%s) .and. vanishes(d%u)) then
	q(1) = d%xb * k
	q(2) = d%x * k
	else
	kk = space_part (k)
	q1 = d%xb * (d%pb / d%p) * kk
	q2 = kk - q1
	q(1) = vector4_moving (d%xb * d%E, q1)
	q(2) = vector4_moving (d%x * d%E, q2)
	end if
	else
	den = 2 * d%xb * d%p * d%pb
	tt0 = max (d%t - d%t0, 0._default)
	tt1 = min (d%t - d%t1, 0._default)
	if (den**2 <= epsilon(den)) then
	st2 = 0
	else
	st2 = - (tt0 * tt1) / den ** 2
	end if
	if (st2 > 1) then
	st2 = 1
	end if
	ct2 = 1 - st2
	st = sqrt (max (st2, 0._default))
	ct = sqrt (max (ct2, 0._default))
	if ((d%t - d%t0 + d%t - d%t1) < 0) then
	ct = - ct
	end if
	sp = sin (d%phi)
	cp = cos (d%phi)
	rot = rotation_to_2nd (3, space_part (k))
	q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct])
	q2 = vector3_moving (d%p, 3) - q1
	q(1) = rot * vector4_moving (d%xb * d%E, q1)
	q(2) = rot * vector4_moving (d%x * d%E, q2)
	end if
	end function splitting_split_momentum

	@ %def splitting_split_momentum
	@
	Momenta generated by splitting will in general be off-shell. They are
	on-shell only if they are collinear and massless. This subroutine
	puts them on shell by brute force, violating either momentum or energy
	conservation. The direction of three-momentum is always retained.

	If the energy is below mass shell, we return a zero momentum.
	<<SF aux: parameters>>=
	integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1
	@ %def KEEP_ENERGY KEEP_MOMENTUM
	<<SF aux: public>>=
	public :: on_shell
	<<SF aux: procedures>>=
	elemental subroutine on_shell (p, m2, keep)
	type(vector4_t), intent(inout) :: p
	real(default), intent(in) :: m2
	integer, intent(in) :: keep
	real(default) :: E, E2, pn
	select case (keep)
	case (KEEP_ENERGY)
	E = energy (p)
	E2 = E ** 2
	if (E2 >= m2) then
	pn = sqrt (E2 - m2)
	p = vector4_moving (E, pn * direction (space_part (p)))
	else
	p = vector4_null
	end if
	case (KEEP_MOMENTUM)
	E = sqrt (space_part (p) ** 2 + m2)
	p = vector4_moving (E, space_part (p))
	end select
	end subroutine on_shell

	@ %def on_shell
	@
	\subsection{Recovering the splitting}
	This is the inverse problem. We have on-shell momenta and want to
	deduce the splitting parameters $x$, $t$, and $\phi$.

	Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use
	not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]]
	for recovering $x$ and $\bar x$ separately. If $x$ happens to be
	close to $1$, we would completely lose the tiny $\bar x$ value,
	otherwise, and thus get a meaningless result.
	<<SF aux: splitting data: TBP>>=
	procedure :: recover => splitting_recover
	<<SF aux: procedures>>=
	subroutine splitting_recover (d, k, q, keep)
	class(splitting_data_t), intent(inout) :: d
	type(vector4_t), intent(in) :: k
	type(vector4_t), dimension(2), intent(in) :: q
	integer, intent(in) :: keep
	type(lorentz_transformation_t) :: rot
	type(vector4_t) :: k0
	type(vector4_t), dimension(2) :: q0
	real(default) :: p1, p2, p3, pt2, pp2, pl
	real(default) :: aux, den, norm
	real(default) :: st2, ct2, ct
	rot = inverse (rotation_to_2nd (3, space_part (k)))
	q0 = rot * q
	p1 = vector4_get_component (q0(2), 1)
	p2 = vector4_get_component (q0(2), 2)
	p3 = vector4_get_component (q0(2), 3)
	pt2 = p1 2 + p2 2
	pp2 = p1 2 + p2 2 + p3 ** 2
	pl = abs (p3)
	k0 = vector4_moving (d%E, d%p, 3)
	select case (keep)
	case (KEEP_ENERGY)
	d%x = energy (q0(2)) / d%E
	d%xb = energy (q0(1)) / d%E
	call d%set_t_bounds ()
	if (.not. d%collinear) then
	aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2
	den = d%p ** 2 - (d%xb * d%pb) ** 2
	if (aux >= 0 .and. den > 0) then
	norm = (d%p * pl + sqrt (aux)) / den
	else
	norm = 1
	end if
	end if
	case (KEEP_MOMENTUM)
	d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E
	d%x = 1 - d%xb
	call d%set_t_bounds ()
	norm = 1
	end select
	if (d%collinear) then
	d%t = d%t1
	d%phi = 0
	else
	if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then
	st2 = 1
	else
	st2 = pt2 / (d%xb * d%pb * norm ) ** 2
	end if
	if (st2 > 1) then
	st2 = 1
	end if
	ct2 = 1 - st2
	ct = sqrt (max (ct2, 0._default))
	if (.not. vanishes (1 + ct)) then
	d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct)
	else
	d%t = d%t0
	end if
	if (.not. vanishes (p1) .or. .not. vanishes (p2)) then
	d%phi = atan2 (-p2, -p1)
	else
	d%phi = 0
	end if
	end if
	end subroutine splitting_recover

	@ %def splitting_recover
	@
	\subsection{Extract data}
	<<SF aux: splitting data: TBP>>=
	procedure :: get_x => splitting_get_x
	procedure :: get_xb => splitting_get_xb
	<<SF aux: procedures>>=
	function splitting_get_x (sd) result (x)
	class(splitting_data_t), intent(in) :: sd
	real(default) :: x
	x = sd%x
	end function splitting_get_x

	function splitting_get_xb (sd) result (xb)
	class(splitting_data_t), intent(in) :: sd
	real(default) :: xb
	xb = sd%xb
	end function splitting_get_xb

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

	module sf_aux_ut
	use unit_tests
	use sf_aux_uti

	<<Standard module head>>

	<<SF aux: public test>>

	contains

	<<SF aux: test driver>>

	end module sf_aux_ut
	@ %def sf_aux_ut
	@
	<<[[sf_aux_uti.f90]]>>=
	<<File header>>

	module sf_aux_uti

	<<Use kinds>>
	use numeric_utils, only: pacify
	use lorentz

	use sf_aux

	<<Standard module head>>

	<<SF aux: test declarations>>

	contains

	<<SF aux: tests>>

	end module sf_aux_uti
	@ %def sf_aux_ut
	@ API: driver for the unit tests below.
	<<SF aux: public test>>=
	public :: sf_aux_test
	<<SF aux: test driver>>=
	subroutine sf_aux_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF aux: execute tests>>
	end subroutine sf_aux_test

	@ %def sf_aux_test
	@
	\subsubsection{Momentum splitting: massless radiation}
	Compute momentum splitting for generic kinematics. It turns out that
	for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
	lower bounds (this can be directly seen from the logarithmic
	distribution in the function [[sample_t]] for $r \equiv x = 1 - x =
	0.5$), we arrive at an exact number $t=-0.15$ for the given
	input values.
	<<SF aux: execute tests>>=
	call test (sf_aux_1, "sf_aux_1", &
	"massless radiation", &
	u, results)
	<<SF aux: test declarations>>=
	public :: sf_aux_1
	<<SF aux: tests>>=
	subroutine sf_aux_1 (u)
	integer, intent(in) :: u
	type(splitting_data_t) :: sd
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q, q0
	real(default) :: E, mk, mp, mq
	real(default) :: x, r1, r2, r1o, r2o
	real(default) :: k2, q0_2, q1_2, q2_2

	write (u, "(A)") "* Test output: sf_aux_1"
	write (u, "(A)") "* Purpose: compute momentum splitting"
	write (u, "(A)") " (massless radiated particle)"
	write (u, "(A)")

	E = 1
	mk = 0.3_default
	mp = 0
	mq = mk

	k = vector4_moving (E, sqrt (E2 - mk2), 3)
	k2 = k ** 2; call pacify (k2, 1e-10_default)

	x = 0.6_default
	r1 = 0.5_default
	r2 = 0.125_default

	write (u, "(A)") "* (1) Non-collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%sample_t (r1)
	call sd%sample_phi (r2)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "Extract: x, 1-x"
	write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb ()

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q0_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t


	call sd%inverse_t (r1o)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q0_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	call sd%inverse_t (r1o)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (2) Collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, 1 - x)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q0_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q0_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

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

	end subroutine sf_aux_1

	@ %def sf_aux_1
	@
	\subsubsection{Momentum splitting: massless parton}
	Compute momentum splitting for generic kinematics. It turns out that
	for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
	lower bounds, we arrive at an exact number $t=-0.36$ for the given
	input values.
	<<SF aux: execute tests>>=
	call test (sf_aux_2, "sf_aux_2", &
	"massless parton", &
	u, results)
	<<SF aux: test declarations>>=
	public :: sf_aux_2
	<<SF aux: tests>>=
	subroutine sf_aux_2 (u)
	integer, intent(in) :: u
	type(splitting_data_t) :: sd
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q, q0
	real(default) :: E, mk, mp, mq
	real(default) :: x, r1, r2, r1o, r2o
	real(default) :: k2, q02_2, q1_2, q2_2

	write (u, "(A)") "* Test output: sf_aux_2"
	write (u, "(A)") "* Purpose: compute momentum splitting"
	write (u, "(A)") " (massless outgoing particle)"
	write (u, "(A)")

	E = 1
	mk = 0.3_default
	mp = mk
	mq = 0

	k = vector4_moving (E, sqrt (E2 - mk2), 3)
	k2 = k ** 2; call pacify (k2, 1e-10_default)

	x = 0.6_default
	r1 = 0.5_default
	r2 = 0.125_default

	write (u, "(A)") "* (1) Non-collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%sample_t (r1)
	call sd%sample_phi (r2)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t


	call sd%inverse_t (r1o)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	call sd%inverse_t (r1o)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (2) Collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, 1 - x)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

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

	end subroutine sf_aux_2

	@ %def sf_aux_2
	@
	\subsubsection{Momentum splitting: all massless}
	Compute momentum splitting for massless kinematics. In the non-collinear
	case, we need a lower cutoff for $\|t\|$, otherwise a logarithmic distribution
	is not possible.
	<<SF aux: execute tests>>=
	call test (sf_aux_3, "sf_aux_3", &
	"massless parton", &
	u, results)
	<<SF aux: test declarations>>=
	public :: sf_aux_3
	<<SF aux: tests>>=
	subroutine sf_aux_3 (u)
	integer, intent(in) :: u
	type(splitting_data_t) :: sd
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q, q0
	real(default) :: E, mk, mp, mq, qmin, qmax
	real(default) :: x, r1, r2, r1o, r2o
	real(default) :: k2, q02_2, q1_2, q2_2

	write (u, "(A)") "* Test output: sf_aux_3"
	write (u, "(A)") "* Purpose: compute momentum splitting"
	write (u, "(A)") " (all massless, q cuts)"
	write (u, "(A)")

	E = 1
	mk = 0
	mp = 0
	mq = 0
	qmin = 1e-2_default
	qmax = 1e0_default

	k = vector4_moving (E, sqrt (E2 - mk2), 3)
	k2 = k ** 2; call pacify (k2, 1e-10_default)

	x = 0.6_default
	r1 = 0.5_default
	r2 = 0.125_default

	write (u, "(A)") "* (1) Non-collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%sample_t (r1, t1 = - qmin 2, t0 = - qmax 2)
	call sd%sample_phi (r2)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t


	call sd%inverse_t (r1o, t1 = - qmin 2, t0 = - qmax 2)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	call sd%inverse_t (r1o, t1 = - qmin 2, t0 = - qmax 2)

	write (u, "(A)") "Compare: r1"
	write (u, "(2(1x,F11.8))") r1, r1o

	call sd%inverse_phi (r2o)

	write (u, "(A)") "Compare: r2"
	write (u, "(2(1x,F11.8))") r2, r2o

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (2) Collinear setup"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, 1 - x)

	call sd%write (u)

	q = sd%split_momentum (k)
	q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default)
	q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: s"
	write (u, "(2(1x,F11.8))") sd%s, k2

	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") sd%t, q2_2

	write (u, "(A)") "Compare: u"
	write (u, "(2(1x,F11.8))") sd%u, q1_2

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k)

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep energy)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_ENERGY)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Project on-shell (keep momentum)"

	q0 = q
	call on_shell (q0, [mp2, mq2], KEEP_MOMENTUM)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q0), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q0(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q0(2), u)
	write (u, "(A)")

	write (u, "(A)") "Compare: mo^2"
	q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default)
	write (u, "(2(1x,F11.8))") sd%m2, q02_2
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momentum"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2)
	call sd%set_t_bounds (x, 1 - x)
	call sd%recover (k, q0, KEEP_MOMENTUM)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x
	write (u, "(A)") "Compare: t"
	write (u, "(2(1x,F11.8))") q2_2, sd%t

	write (u, "(A)")
	call sd%write (u)

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

	end subroutine sf_aux_3

	@ %def sf_aux_3
	@
	\subsubsection{Endpoint stability}
	Compute momentum splitting for collinear kinematics close to both
	endpoints. In particular, check both directions $x\to$ momenta and
	momenta $\to x$.

	For purely massless collinear splitting, the [[KEEP_XXX]] flag is
	irrelevant. We choose [[KEEP_ENERGY]] here.
	<<SF aux: execute tests>>=
	call test (sf_aux_4, "sf_aux_4", &
	"endpoint numerics", &
	u, results)
	<<SF aux: test declarations>>=
	public :: sf_aux_4
	<<SF aux: tests>>=
	subroutine sf_aux_4 (u)
	integer, intent(in) :: u
	type(splitting_data_t) :: sd
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E, mk, mp, mq, qmin, qmax
	real(default) :: x, xb

	write (u, "(A)") "* Test output: sf_aux_4"
	write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint"

	E = 1
	mk = 0
	mp = 0
	mq = 0
	qmin = 1e-2_default
	qmax = 1e0_default

	k = vector4_moving (E, sqrt (E2 - mk2), 3)

	x = 0.1_default
	xb = 1 - x

	write (u, "(A)")
	write (u, "(A)") "* (1) Collinear setup, moderate kinematics"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)

	call sd%write (u)

	q = sd%split_momentum (k)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momenta"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)
	call sd%recover (k, q, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") xb, sd%xb

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (2) Close to x=0"
	write (u, "(A)")

	x = 1e-9_default
	xb = 1 - x

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)

	call sd%write (u)

	q = sd%split_momentum (k)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momenta"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)
	call sd%recover (k, q, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") xb, sd%xb

	write (u, "(A)")
	call sd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* (3) Close to x=1"
	write (u, "(A)")

	xb = 1e-9_default
	x = 1 - xb

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)

	call sd%write (u)

	q = sd%split_momentum (k)

	write (u, "(A)")
	write (u, "(A)") "Incoming momentum k ="
	call vector4_write (k, u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum sum p + q ="
	call vector4_write (sum (q), u)
	write (u, "(A)")
	write (u, "(A)") "Radiated momentum p ="
	call vector4_write (q(1), u)
	write (u, "(A)")
	write (u, "(A)") "Outgoing momentum q ="
	call vector4_write (q(2), u)
	write (u, "(A)")

	write (u, "(A)") "* Recover parameters from outgoing momenta"
	write (u, "(A)")

	call sd%init (k, mk2, mp2, mq**2, collinear = .true.)
	call sd%set_t_bounds (x, xb)
	call sd%recover (k, q, KEEP_ENERGY)

	write (u, "(A)") "Compare: x"
	write (u, "(2(1x,F11.8))") x, sd%x

	write (u, "(A)") "Compare: 1-x"
	write (u, "(2(1x,F11.8))") xb, sd%xb

	write (u, "(A)")
	call sd%write (u)

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

	end subroutine sf_aux_4

	@ %def sf_aux_4
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Mappings for structure functions}
	In this module, we provide a wrapper for useful mappings of the unit
	(hyper-)square that we can apply to a set of structure functions.

	In some cases it is useful, or even mandatory, to map the MC input
	parameters nontrivially onto a set of structure functions for the two
	beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as
	parameters for the beams, we generate one parameter that is equal, or
	related to, the product $x_1x_2\cdots$ (so it directly corresponds to
	$\sqrt{s}$). The other parameters describe the distribution of energy
	(loss) between beams and radiations.
	<<[[sf_mappings.f90]]>>=
	<<File header>>

	module sf_mappings

	<<Use kinds>>
	use kinds, only: double
	use io_units
	use constants, only: pi, zero, one
	use numeric_utils
	use diagnostics

	<<Standard module head>>

	<<SF mappings: public>>

	<<SF mappings: parameters>>

	<<SF mappings: types>>

	<<SF mappings: interfaces>>

	contains

	<<SF mappings: procedures>>

	end module sf_mappings
	@ %def sf_mappings
	@
	\subsection{Base type}
	First, we define an abstract base type for the mapping. In all cases
	we need to store the indices of the parameters on which the mapping
	applies. Additional parameters can be stored in the extensions of
	this type.
	<<SF mappings: public>>=
	public :: sf_mapping_t
	<<SF mappings: types>>=
	type, abstract :: sf_mapping_t
	integer, dimension(:), allocatable :: i
	contains
	<<SF mappings: sf mapping: TBP>>
	end type sf_mapping_t

	@ %def sf_mapping_t
	@ The output routine is deferred:
	<<SF mappings: sf mapping: TBP>>=
	procedure (sf_mapping_write), deferred :: write
	<<SF mappings: interfaces>>=
	abstract interface
	subroutine sf_mapping_write (object, unit)
	import
	class(sf_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	end subroutine sf_mapping_write
	end interface

	@ %def sf_mapping_write
	@ Initializer for the base type. The array of parameter indices is
	allocated but initialized to zero.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: base_init => sf_mapping_base_init
	<<SF mappings: procedures>>=
	subroutine sf_mapping_base_init (mapping, n_par)
	class(sf_mapping_t), intent(out) :: mapping
	integer, intent(in) :: n_par
	allocate (mapping%i (n_par))
	mapping%i = 0
	end subroutine sf_mapping_base_init

	@ %def sf_mapping_base_init
	@ Set an index value.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: set_index => sf_mapping_set_index
	<<SF mappings: procedures>>=
	subroutine sf_mapping_set_index (mapping, j, i)
	class(sf_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: j, i
	mapping%i(j) = i
	end subroutine sf_mapping_set_index

	@ %def sf_mapping_set_index
	@ Retrieve an index value.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: get_index => sf_mapping_get_index
	<<SF mappings: procedures>>=
	function sf_mapping_get_index (mapping, j) result (i)
	class(sf_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: j
	integer :: i
	i = mapping%i(j)
	end function sf_mapping_get_index

	@ %def sf_mapping_get_index
	@ Return the dimensionality, i.e., the number of parameters.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: get_n_dim => sf_mapping_get_n_dim
	<<SF mappings: procedures>>=
	function sf_mapping_get_n_dim (mapping) result (n)
	class(sf_mapping_t), intent(in) :: mapping
	integer :: n
	n = size (mapping%i)
	end function sf_mapping_get_n_dim

	@ %def sf_mapping_get_n_dim
	@ Computation: the values [[p]] are the input parameters, the values
	[[r]] are the output parameters. The values [[rb]] are defined as
	$\bar r = 1 - r$, but provided explicitly. They allow us to avoid
	numerical problems near $r=1$.

	The extra parameter [[x_free]]
	indicates that the total energy has already been renormalized by this
	factor. We have to take such a factor into account in a resonance or
	on-shell mapping.

	The Jacobian is [[f]]. We modify only
	the two parameters indicated by the indices [[i]].
	<<SF mappings: sf mapping: TBP>>=
	procedure (sf_mapping_compute), deferred :: compute
	<<SF mappings: interfaces>>=
	abstract interface
	subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	import
	class(sf_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	end subroutine sf_mapping_compute
	end interface

	@ %def sf_mapping_compute
	@ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]]
	and also compute [[f]].
	<<SF mappings: sf mapping: TBP>>=
	procedure (sf_mapping_inverse), deferred :: inverse
	<<SF mappings: interfaces>>=
	abstract interface
	subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	import
	class(sf_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	end subroutine sf_mapping_inverse
	end interface

	@ %def sf_mapping_inverse
	@
	\subsection{Methods for self-tests}
	This is a shorthand for: inject parameters, compute the mapping,
	display results, compute the inverse, display again. We provide an
	output format for the parameters and, optionally, a different output
	format for the Jacobians.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: check => sf_mapping_check
	<<SF mappings: procedures>>=
	subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f)
	class(sf_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: u
	real(default), dimension(:), intent(in) :: p_in, pb_in
	character(*), intent(in) :: fmt_p
	character(*), intent(in), optional :: fmt_f
	real(default), dimension(size(p_in)) :: p, pb, r, rb
	real(default) :: f, tolerance
	tolerance = 1.5E-17
	p = p_in
	pb= pb_in
	call mapping%compute (r, rb, f, p, pb)
	call pacify (p, tolerance)
	call pacify (pb, tolerance)
	call pacify (r, tolerance)
	call pacify (rb, tolerance)
	write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p
	write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb
	write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r
	write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb
	if (present (fmt_f)) then
	write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f
	else
	write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f
	end if
	write (u, *)
	call mapping%inverse (r, rb, f, p, pb)
	call pacify (p, tolerance)
	call pacify (pb, tolerance)
	call pacify (r, tolerance)
	call pacify (rb, tolerance)
	write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p
	write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb
	write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r
	write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb
	if (present (fmt_f)) then
	write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f
	else
	write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f
	end if
	write (u, *)
	write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r)
	end subroutine sf_mapping_check

	@ %def sf_mapping_check
	@ This is a consistency check for the self-tests: the integral over the unit
	square should be unity. We estimate this by a simple binning and adding up
	the values; this should be sufficient for a self-test.

	The argument is the requested number of sampling points. We take the square
	root for binning in both dimensions, so the precise number might be
	different.
	<<SF mappings: sf mapping: TBP>>=
	procedure :: integral => sf_mapping_integral
	<<SF mappings: procedures>>=
	function sf_mapping_integral (mapping, n_calls) result (integral)
	class(sf_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: n_calls
	real(default) :: integral
	integer :: n_dim, n_bin, k
	real(default), dimension(:), allocatable :: p, pb, r, rb
	integer, dimension(:), allocatable :: ii
	real(default) :: dx, f, s

	n_dim = mapping%get_n_dim ()
	allocate (p (n_dim))
	allocate (pb(n_dim))
	allocate (r (n_dim))
	allocate (rb(n_dim))
	allocate (ii(n_dim))
	n_bin = nint (real (n_calls, default) ** (1._default / n_dim))
	dx = 1._default / n_bin
	s = 0
	ii = 1

	SAMPLE: do
	do k = 1, n_dim
	p(k) = ii(k) * dx - dx/2
	pb(k) = (n_bin - ii(k)) * dx + dx/2
	end do
	call mapping%compute (r, rb, f, p, pb)
	s = s + f
	INCR: do k = 1, n_dim
	ii(k) = ii(k) + 1
	if (ii(k) <= n_bin) then
	exit INCR
	else if (k < n_dim) then
	ii(k) = 1
	else
	exit SAMPLE
	end if
	end do INCR
	end do SAMPLE

	integral = s / real (n_bin, default) ** n_dim

	end function sf_mapping_integral

	@ %def sf_mapping_integral
	@
	\subsection{Implementation: standard mapping}
	This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
	while $p_2$ is related to the ratio.
	<<SF mappings: public>>=
	public :: sf_s_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_s_mapping_t
	logical :: power_set = .false.
	real(default) :: power = 1
	contains
	<<SF mappings: sf standard mapping: TBP>>
	end type sf_s_mapping_t

	@ %def sf_s_mapping_t
	@ Output.
	<<SF mappings: sf standard mapping: TBP>>=
	procedure :: write => sf_s_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_s_mapping_write (object, unit)
	class(sf_s_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A)") ": standard (", object%power, ")"
	end subroutine sf_s_mapping_write

	@ %def sf_s_mapping_write
	@ Initialize: index pair and power parameter.
	<<SF mappings: sf standard mapping: TBP>>=
	procedure :: init => sf_s_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_s_mapping_init (mapping, power)
	class(sf_s_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: power
	call mapping%base_init (2)
	if (present (power)) then
	mapping%power_set = .true.
	mapping%power = power
	end if
	end subroutine sf_s_mapping_init

	@ %def sf_s_mapping_init
	@ Apply mapping.
	<<SF mappings: sf standard mapping: TBP>>=
	procedure :: compute => sf_s_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_s_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2
	integer :: j
	if (mapping%power_set) then
	call map_unit_square (r2, f, p(mapping%i), mapping%power)
	else
	call map_unit_square (r2, f, p(mapping%i))
	end if
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_s_mapping_compute

	@ %def sf_s_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf standard mapping: TBP>>=
	procedure :: inverse => sf_s_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_s_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: p2
	integer :: j
	if (mapping%power_set) then
	call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power)
	else
	call map_unit_square_inverse (r(mapping%i), f, p2)
	end if
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = 1 - p2(j)
	end do
	end subroutine sf_s_mapping_inverse

	@ %def sf_s_mapping_inverse
	@
	\subsection{Implementation: resonance pair mapping}
	This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
	while $p_2$ is related to the ratio, then it maps $p_1$ to itself
	according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$
	results in a Breit-Wigner distribution. Mass and width of the BW are
	rescaled by the energy, thus dimensionless fractions.
	<<SF mappings: public>>=
	public :: sf_res_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_res_mapping_t
	real(default) :: m = 0
	real(default) :: w = 0
	contains
	<<SF mappings: sf resonance mapping: TBP>>
	end type sf_res_mapping_t

	@ %def sf_res_mapping_t
	@ Output.
	<<SF mappings: sf resonance mapping: TBP>>=
	procedure :: write => sf_res_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_write (object, unit)
	class(sf_res_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")"
	end subroutine sf_res_mapping_write

	@ %def sf_res_mapping_write
	@ Initialize: index pair and dimensionless mass and width parameters.
	<<SF mappings: sf resonance mapping: TBP>>=
	procedure :: init => sf_res_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_init (mapping, m, w)
	class(sf_res_mapping_t), intent(out) :: mapping
	real(default), intent(in) :: m, w
	call mapping%base_init (2)
	mapping%m = m
	mapping%w = w
	end subroutine sf_res_mapping_init

	@ %def sf_res_mapping_init
	@ Apply mapping.
	<<SF mappings: sf resonance mapping: TBP>>=
	procedure :: compute => sf_res_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_res_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, p2
	real(default) :: fbw, f2, p1m
	integer :: j
	p2 = p(mapping%i)
	call map_breit_wigner &
	(p1m, fbw, p2(1), mapping%m, mapping%w, x_free)
	call map_unit_square (r2, f2, [p1m, p2(2)])
	f = fbw * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_res_mapping_compute

	@ %def sf_res_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf resonance mapping: TBP>>=
	procedure :: inverse => sf_res_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_res_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: p2
	real(default) :: fbw, f2, p1m
	call map_unit_square_inverse (r(mapping%i), f2, p2)
	call map_breit_wigner_inverse &
	(p2(1), fbw, p1m, mapping%m, mapping%w, x_free)
	p = r
	pb= rb
	p (mapping%i(1)) = p1m
	pb(mapping%i(1)) = 1 - p1m
	p (mapping%i(2)) = p2(2)
	pb(mapping%i(2)) = 1 - p2(2)
	f = fbw * f2
	end subroutine sf_res_mapping_inverse

	@ %def sf_res_mapping_inverse
	@
	\subsection{Implementation: resonance single mapping}
	While simpler, this is needed for structure-function setups only in
	exceptional cases.

	This maps the unit interval ($r_1$) to itself
	according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$
	results in a Breit-Wigner distribution. Mass and width of the BW are
	rescaled by the energy, thus dimensionless fractions.
	<<SF mappings: public>>=
	public :: sf_res_mapping_single_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_res_mapping_single_t
	real(default) :: m = 0
	real(default) :: w = 0
	contains
	<<SF mappings: sf resonance single mapping: TBP>>
	end type sf_res_mapping_single_t

	@ %def sf_res_mapping_single_t
	@ Output.
	<<SF mappings: sf resonance single mapping: TBP>>=
	procedure :: write => sf_res_mapping_single_write
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_single_write (object, unit)
	class(sf_res_mapping_single_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")"
	end subroutine sf_res_mapping_single_write

	@ %def sf_res_mapping_single_write
	@ Initialize: single index (!) and dimensionless mass and width parameters.
	<<SF mappings: sf resonance single mapping: TBP>>=
	procedure :: init => sf_res_mapping_single_init
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_single_init (mapping, m, w)
	class(sf_res_mapping_single_t), intent(out) :: mapping
	real(default), intent(in) :: m, w
	call mapping%base_init (1)
	mapping%m = m
	mapping%w = w
	end subroutine sf_res_mapping_single_init

	@ %def sf_res_mapping_single_init
	@ Apply mapping.
	<<SF mappings: sf resonance single mapping: TBP>>=
	procedure :: compute => sf_res_mapping_single_compute
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_res_mapping_single_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(1) :: r2, p2
	real(default) :: fbw
	integer :: j
	p2 = p(mapping%i)
	call map_breit_wigner &
	(r2(1), fbw, p2(1), mapping%m, mapping%w, x_free)
	f = fbw
	r = p
	rb= pb
	r (mapping%i(1)) = r2(1)
	rb(mapping%i(1)) = 1 - r2(1)
	end subroutine sf_res_mapping_single_compute

	@ %def sf_res_mapping_single_compute
	@ Apply inverse.
	<<SF mappings: sf resonance single mapping: TBP>>=
	procedure :: inverse => sf_res_mapping_single_inverse
	<<SF mappings: procedures>>=
	subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_res_mapping_single_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(1) :: p2
	real(default) :: fbw
	call map_breit_wigner_inverse &
	(r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free)
	p = r
	pb= rb
	p (mapping%i(1)) = p2(1)
	pb(mapping%i(1)) = 1 - p2(1)
	f = fbw
	end subroutine sf_res_mapping_single_inverse

	@ %def sf_res_mapping_single_inverse
	@
	\subsection{Implementation: on-shell mapping}
	This is a degenerate version of the unit-square mapping where the
	product $r_1r_2$ is constant. This product is given by the rescaled
	squared mass. We introduce an artificial first parameter $p_1$ to
	keep the counting, but nothing depends on it. The second parameter is
	the same $p_2$ as for the standard unit-square mapping for $\alpha=1$,
	it parameterizes the ratio of $r_1$ and $r_2$.
	<<SF mappings: public>>=
	public :: sf_os_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_os_mapping_t
	real(default) :: m = 0
	real(default) :: lm2 = 0
	contains
	<<SF mappings: sf on-shell mapping: TBP>>
	end type sf_os_mapping_t

	@ %def sf_os_mapping_t
	@ Output.
	<<SF mappings: sf on-shell mapping: TBP>>=
	procedure :: write => sf_os_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_write (object, unit)
	class(sf_os_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")"
	end subroutine sf_os_mapping_write

	@ %def sf_os_mapping_write
	@ Initialize: index pair and dimensionless mass parameter.
	<<SF mappings: sf on-shell mapping: TBP>>=
	procedure :: init => sf_os_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_init (mapping, m)
	class(sf_os_mapping_t), intent(out) :: mapping
	real(default), intent(in) :: m
	call mapping%base_init (2)
	mapping%m = m
	mapping%lm2 = abs (2 * log (mapping%m))
	end subroutine sf_os_mapping_init

	@ %def sf_os_mapping_init
	@ Apply mapping. The [[x_free]] parameter rescales the total energy,
	which must be accounted for in the enclosed mapping.
	<<SF mappings: sf on-shell mapping: TBP>>=
	procedure :: compute => sf_os_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_os_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, p2
	integer :: j
	p2 = p(mapping%i)
	call map_on_shell (r2, f, p2, mapping%lm2, x_free)
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_os_mapping_compute

	@ %def sf_os_mapping_compute
	@ Apply inverse. The irrelevant parameter $p_1$ is always set zero.
	<<SF mappings: sf on-shell mapping: TBP>>=
	procedure :: inverse => sf_os_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_os_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: p2, r2
	r2 = r(mapping%i)
	call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free)
	p = r
	pb= rb
	p (mapping%i(1)) = p2(1)
	pb(mapping%i(1)) = 1 - p2(1)
	p (mapping%i(2)) = p2(2)
	pb(mapping%i(2)) = 1 - p2(2)
	end subroutine sf_os_mapping_inverse

	@ %def sf_os_mapping_inverse
	@
	\subsection{Implementation: on-shell single mapping}
	This is a degenerate version of the unit-interval mapping where the
	result $r$ is constant. The value is given by the rescaled squared
	mass. The input parameter $p_1$ is actually ignored, nothing depends
	on it.
	<<SF mappings: public>>=
	public :: sf_os_mapping_single_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_os_mapping_single_t
	real(default) :: m = 0
	real(default) :: lm2 = 0
	contains
	<<SF mappings: sf on-shell mapping single: TBP>>
	end type sf_os_mapping_single_t

	@ %def sf_os_mapping_single_t
	@ Output.
	<<SF mappings: sf on-shell mapping single: TBP>>=
	procedure :: write => sf_os_mapping_single_write
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_single_write (object, unit)
	class(sf_os_mapping_single_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")"
	end subroutine sf_os_mapping_single_write

	@ %def sf_os_mapping_single_write
	@ Initialize: index pair and dimensionless mass parameter.
	<<SF mappings: sf on-shell mapping single: TBP>>=
	procedure :: init => sf_os_mapping_single_init
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_single_init (mapping, m)
	class(sf_os_mapping_single_t), intent(out) :: mapping
	real(default), intent(in) :: m
	call mapping%base_init (1)
	mapping%m = m
	mapping%lm2 = abs (2 * log (mapping%m))
	end subroutine sf_os_mapping_single_init

	@ %def sf_os_mapping_single_init
	@ Apply mapping. The [[x_free]] parameter rescales the total energy,
	which must be accounted for in the enclosed mapping.
	<<SF mappings: sf on-shell mapping single: TBP>>=
	procedure :: compute => sf_os_mapping_single_compute
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_os_mapping_single_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(1) :: r2, p2
	integer :: j
	p2 = p(mapping%i)
	call map_on_shell_single (r2, f, p2, mapping%lm2, x_free)
	r = p
	rb= pb
	r (mapping%i(1)) = r2(1)
	rb(mapping%i(1)) = 1 - r2(1)
	end subroutine sf_os_mapping_single_compute

	@ %def sf_os_mapping_single_compute
	@ Apply inverse. The irrelevant parameter $p_1$ is always set zero.
	<<SF mappings: sf on-shell mapping single: TBP>>=
	procedure :: inverse => sf_os_mapping_single_inverse
	<<SF mappings: procedures>>=
	subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_os_mapping_single_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(1) :: p2, r2
	r2 = r(mapping%i)
	call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free)
	p = r
	pb= rb
	p (mapping%i(1)) = p2(1)
	pb(mapping%i(1)) = 1 - p2(1)
	end subroutine sf_os_mapping_single_inverse

	@ %def sf_os_mapping_single_inverse
	@
	\subsection{Implementation: endpoint mapping}
	This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
	while $p_2$ is related to the ratio. Furthermore, we enhance the
	region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
	$p_2=0,1$. The enhancement is such that any power-like singularity is
	caught. This is useful for beamstrahlung spectra.

	In addition, we allow for a delta-function singularity in $r_1$ and/or
	$r_2$. The singularity is smeared to an interval of width
	$\epsilon$. If nonzero, we distinguish the kinematical momentum
	fractions $r_i$ from effective values $x_i$, which should go into the
	structure-function evaluation. A bin of width $\epsilon$ in $r$ is
	mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped
	to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the
	logical [[in_peak]] allows for an unambiguous distinction.

	The delta-peak fraction is used only for the integration self-test.
	<<SF mappings: public>>=
	public :: sf_ep_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_ep_mapping_t
	real(default) :: a = 1
	contains
	<<SF mappings: sf endpoint mapping: TBP>>
	end type sf_ep_mapping_t

	@ %def sf_ep_mapping_t
	@ Output.
	<<SF mappings: sf endpoint mapping: TBP>>=
	procedure :: write => sf_ep_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_ep_mapping_write (object, unit)
	class(sf_ep_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")"
	end subroutine sf_ep_mapping_write

	@ %def sf_ep_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf endpoint mapping: TBP>>=
	procedure :: init => sf_ep_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_ep_mapping_init (mapping, a)
	class(sf_ep_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: a
	call mapping%base_init (2)
	if (present (a)) mapping%a = a
	end subroutine sf_ep_mapping_init

	@ %def sf_ep_mapping_init
	@ Apply mapping.
	<<SF mappings: sf endpoint mapping: TBP>>=
	procedure :: compute => sf_ep_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_ep_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, r2
	real(default) :: f1, f2
	integer :: j
	call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a)
	call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
	call map_unit_square (r2, f, px)
	f = f * f1 * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_ep_mapping_compute

	@ %def sf_ep_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf endpoint mapping: TBP>>=
	procedure :: inverse => sf_ep_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_ep_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, px, p2
	real(default) :: f1, f2
	integer :: j
	do j = 1, 2
	r2(j) = r(mapping%i(j))
	end do
	call map_unit_square_inverse (r2, f, px)
	call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a)
	call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
	f = f * f1 * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = 1 - p2(j)
	end do
	end subroutine sf_ep_mapping_inverse

	@ %def sf_ep_mapping_inverse
	@
	\subsection{Implementation: endpoint mapping with resonance}
	Like the endpoint mapping for $p_2$, but replace the endpoint mapping
	by a Breit-Wigner mapping for $p_1$. This covers resonance production
	in the presence of beamstrahlung.

	If the flag [[resonance]] is unset, we skip the resonance mapping, so
	the parameter $p_1$ remains equal to $r_1r_2$, as in the standard
	s-channel mapping.
	<<SF mappings: public>>=
	public :: sf_epr_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_epr_mapping_t
	real(default) :: a = 1
	real(default) :: m = 0
	real(default) :: w = 0
	logical :: resonance = .true.
	contains
	<<SF mappings: sf endpoint/res mapping: TBP>>
	end type sf_epr_mapping_t

	@ %def sf_epr_mapping_t
	@ Output.
	<<SF mappings: sf endpoint/res mapping: TBP>>=
	procedure :: write => sf_epr_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_epr_mapping_write (object, unit)
	class(sf_epr_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	if (object%resonance) then
	write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, &
	" \| ", object%m, object%w, ")"
	else
	write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")"
	end if
	end subroutine sf_epr_mapping_write

	@ %def sf_epr_mapping_write
	@ Initialize: if mass and width are not given, we initialize a
	non-resonant version of the mapping.
	<<SF mappings: sf endpoint/res mapping: TBP>>=
	procedure :: init => sf_epr_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_epr_mapping_init (mapping, a, m, w)
	class(sf_epr_mapping_t), intent(out) :: mapping
	real(default), intent(in) :: a
	real(default), intent(in), optional :: m, w
	call mapping%base_init (2)
	mapping%a = a
	if (present (m) .and. present (w)) then
	mapping%m = m
	mapping%w = w
	else
	mapping%resonance = .false.
	end if
	end subroutine sf_epr_mapping_init

	@ %def sf_epr_mapping_init
	@ Apply mapping.
	<<SF mappings: sf endpoint/res mapping: TBP>>=
	procedure :: compute => sf_epr_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_epr_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, r2
	real(default) :: f1, f2
	integer :: j
	if (mapping%resonance) then
	call map_breit_wigner &
	(px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
	else
	px(1) = p(mapping%i(1))
	f1 = 1
	end if
	call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
	call map_unit_square (r2, f, px)
	f = f * f1 * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_epr_mapping_compute

	@ %def sf_epr_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf endpoint/res mapping: TBP>>=
	procedure :: inverse => sf_epr_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_epr_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, p2
	real(default) :: f1, f2
	integer :: j
	call map_unit_square_inverse (r(mapping%i), f, px)
	if (mapping%resonance) then
	call map_breit_wigner_inverse &
	(px(1), f1, p2(1), mapping%m, mapping%w, x_free)
	else
	p2(1) = px(1)
	f1 = 1
	end if
	call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
	f = f * f1 * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = 1 - p2(j)
	end do
	end subroutine sf_epr_mapping_inverse

	@ %def sf_epr_mapping_inverse
	@
	\subsection{Implementation: endpoint mapping for on-shell particle}
	Analogous to the resonance mapping, but the $p_1$ input is ignored
	altogether. This covers on-shell particle production
	in the presence of beamstrahlung.
	<<SF mappings: public>>=
	public :: sf_epo_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_epo_mapping_t
	real(default) :: a = 1
	real(default) :: m = 0
	real(default) :: lm2 = 0
	contains
	<<SF mappings: sf endpoint/os mapping: TBP>>
	end type sf_epo_mapping_t

	@ %def sf_epo_mapping_t
	@ Output.
	<<SF mappings: sf endpoint/os mapping: TBP>>=
	procedure :: write => sf_epo_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_epo_mapping_write (object, unit)
	class(sf_epo_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, &
	" \| ", object%m, ")"
	end subroutine sf_epo_mapping_write

	@ %def sf_epo_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf endpoint/os mapping: TBP>>=
	procedure :: init => sf_epo_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_epo_mapping_init (mapping, a, m)
	class(sf_epo_mapping_t), intent(out) :: mapping
	real(default), intent(in) :: a, m
	call mapping%base_init (2)
	mapping%a = a
	mapping%m = m
	mapping%lm2 = abs (2 * log (mapping%m))
	end subroutine sf_epo_mapping_init

	@ %def sf_epo_mapping_init
	@ Apply mapping.
	<<SF mappings: sf endpoint/os mapping: TBP>>=
	procedure :: compute => sf_epo_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_epo_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, r2
	real(default) :: f2
	integer :: j
	px(1) = 0
	call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
	call map_on_shell (r2, f, px, mapping%lm2)
	f = f * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2(j)
	rb(mapping%i(j)) = 1 - r2(j)
	end do
	end subroutine sf_epo_mapping_compute

	@ %def sf_epo_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf endpoint/os mapping: TBP>>=
	procedure :: inverse => sf_epo_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_epo_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, p2
	real(default) :: f2
	integer :: j
	call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2)
	p2(1) = 0
	call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
	f = f * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = 1 - p2(j)
	end do
	end subroutine sf_epo_mapping_inverse

	@ %def sf_epo_mapping_inverse
	@
	\subsection{Implementation: ISR endpoint mapping}
	Similar to the endpoint mapping above: This maps the unit square
	($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
	related to the ratio. Furthermore, we enhance the region at $r_1=1$
	and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.

	The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
	flattened. This would be easy in one dimension, but becomes
	nontrivial in two dimensions.
	<<SF mappings: public>>=
	public :: sf_ip_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_ip_mapping_t
	real(default) :: eps = 0
	contains
	<<SF mappings: sf power mapping: TBP>>
	end type sf_ip_mapping_t

	@ %def sf_ip_mapping_t
	@ Output.
	<<SF mappings: sf power mapping: TBP>>=
	procedure :: write => sf_ip_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_ip_mapping_write (object, unit)
	class(sf_ip_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")"
	end subroutine sf_ip_mapping_write

	@ %def sf_ip_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf power mapping: TBP>>=
	procedure :: init => sf_ip_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_ip_mapping_init (mapping, eps)
	class(sf_ip_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: eps
	call mapping%base_init (2)
	if (present (eps)) mapping%eps = eps
	if (mapping%eps <= 0) &
	call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
	end subroutine sf_ip_mapping_init

	@ %def sf_ip_mapping_init
	@ Apply mapping.
	<<SF mappings: sf power mapping: TBP>>=
	procedure :: compute => sf_ip_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_ip_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, pxb, r2, r2b
	real(default) :: f1, f2, xb, y, yb
	integer :: j
	call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps)
	call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
	px(1) = 1 - xb
	pxb(1) = xb
	px(2) = y
	pxb(2) = yb
	call map_unit_square_prec (r2, r2b, f, px, pxb)
	f = f * f1 * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2 (j)
	rb(mapping%i(j)) = r2b(j)
	end do
	end subroutine sf_ip_mapping_compute

	@ %def sf_ip_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf power mapping: TBP>>=
	procedure :: inverse => sf_ip_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_ip_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
	real(default) :: f1, f2, xb, y, yb
	integer :: j
	do j = 1, 2
	r2 (j) = r (mapping%i(j))
	r2b(j) = rb(mapping%i(j))
	end do
	call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
	xb = pxb(1)
	if (px(1) > 0) then
	y = px(2)
	yb = pxb(2)
	else
	y = 0.5_default
	yb = 0.5_default
	end if
	call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps)
	call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
	p2 = 1 - p2b
	f = f * f1 * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = p2b(j)
	end do
	end subroutine sf_ip_mapping_inverse

	@ %def sf_ip_mapping_inverse
	@
	\subsection{Implementation: ISR endpoint mapping, resonant}
	Similar to the endpoint mapping above: This maps the unit square
	($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
	related to the ratio. Furthermore, we enhance the region at $r_1=1$
	and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.

	The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
	flattened. This would be easy in one dimension, but becomes
	nontrivial in two dimensions.

	The resonance can be turned off by the flag [[resonance]].
	<<SF mappings: public>>=
	public :: sf_ipr_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_ipr_mapping_t
	real(default) :: eps = 0
	real(default) :: m = 0
	real(default) :: w = 0
	logical :: resonance = .true.
	contains
	<<SF mappings: sf power/res mapping: TBP>>
	end type sf_ipr_mapping_t

	@ %def sf_ipr_mapping_t
	@ Output.
	<<SF mappings: sf power/res mapping: TBP>>=
	procedure :: write => sf_ipr_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_ipr_mapping_write (object, unit)
	class(sf_ipr_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	if (object%resonance) then
	write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", &
	object%eps, " \| ", object%m, object%w, ")"
	else
	write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")"
	end if
	end subroutine sf_ipr_mapping_write

	@ %def sf_ipr_mapping_write
	@ Initialize:
	<<SF mappings: sf power/res mapping: TBP>>=
	procedure :: init => sf_ipr_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_ipr_mapping_init (mapping, eps, m, w)
	class(sf_ipr_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: eps, m, w
	call mapping%base_init (2)
	if (present (eps)) mapping%eps = eps
	if (mapping%eps <= 0) &
	call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
	if (present (m) .and. present (w)) then
	mapping%m = m
	mapping%w = w
	else
	mapping%resonance = .false.
	end if
	end subroutine sf_ipr_mapping_init

	@ %def sf_ipr_mapping_init
	@ Apply mapping.
	<<SF mappings: sf power/res mapping: TBP>>=
	procedure :: compute => sf_ipr_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_ipr_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, pxb, r2, r2b
	real(default) :: f1, f2, y, yb
	integer :: j
	if (mapping%resonance) then
	call map_breit_wigner &
	(px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
	else
	px(1) = p(mapping%i(1))
	f1 = 1
	end if
	call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
	pxb(1) = 1 - px(1)
	px(2) = y
	pxb(2) = yb
	call map_unit_square_prec (r2, r2b, f, px, pxb)
	f = f * f1 * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2 (j)
	rb(mapping%i(j)) = r2b(j)
	end do
	end subroutine sf_ipr_mapping_compute

	@ %def sf_ipr_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf power/res mapping: TBP>>=
	procedure :: inverse => sf_ipr_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_ipr_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
	real(default) :: f1, f2, y, yb
	integer :: j
	do j = 1, 2
	r2 (j) = r (mapping%i(j))
	r2b(j) = rb(mapping%i(j))
	end do
	call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
	if (px(1) > 0) then
	y = px(2)
	yb = pxb(2)
	else
	y = 0.5_default
	yb = 0.5_default
	end if
	if (mapping%resonance) then
	call map_breit_wigner_inverse &
	(px(1), f1, p2(1), mapping%m, mapping%w, x_free)
	else
	p2(1) = px(1)
	f1 = 1
	end if
	call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
	p2b(1) = 1 - p2(1)
	p2 (2) = 1 - p2b(2)
	f = f * f1 * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = p2b(j)
	end do
	end subroutine sf_ipr_mapping_inverse

	@ %def sf_ipr_mapping_inverse
	@
	\subsection{Implementation: ISR on-shell mapping}
	Similar to the endpoint mapping above: This maps the unit square
	($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is
	constant. $p_2$ is related to the ratio. Furthermore, we enhance the
	region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
	$p_2=0,1$.

	The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
	flattened. This would be easy in one dimension, but becomes
	nontrivial in two dimensions.
	<<SF mappings: public>>=
	public :: sf_ipo_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_ipo_mapping_t
	real(default) :: eps = 0
	real(default) :: m = 0
	contains
	<<SF mappings: sf power/os mapping: TBP>>
	end type sf_ipo_mapping_t

	@ %def sf_ipo_mapping_t
	@ Output.
	<<SF mappings: sf power/os mapping: TBP>>=
	procedure :: write => sf_ipo_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_ipo_mapping_write (object, unit)
	class(sf_ipo_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,',',I0,')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, &
	" \| ", object%m, ")"
	end subroutine sf_ipo_mapping_write

	@ %def sf_ipo_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf power/os mapping: TBP>>=
	procedure :: init => sf_ipo_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_ipo_mapping_init (mapping, eps, m)
	class(sf_ipo_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: eps, m
	call mapping%base_init (2)
	if (present (eps)) mapping%eps = eps
	if (mapping%eps <= 0) &
	call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
	mapping%m = m
	end subroutine sf_ipo_mapping_init

	@ %def sf_ipo_mapping_init
	@ Apply mapping.
	<<SF mappings: sf power/os mapping: TBP>>=
	procedure :: compute => sf_ipo_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_ipo_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: px, pxb, r2, r2b
	real(default) :: f1, f2, y, yb
	integer :: j
	call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
	px(1) = mapping%m ** 2
	if (present (x_free)) px(1) = px(1) / x_free
	pxb(1) = 1 - px(1)
	px(2) = y
	pxb(2) = yb
	call map_unit_square_prec (r2, r2b, f1, px, pxb)
	f = f1 * f2
	r = p
	rb= pb
	do j = 1, 2
	r (mapping%i(j)) = r2 (j)
	rb(mapping%i(j)) = r2b(j)
	end do
	end subroutine sf_ipo_mapping_compute

	@ %def sf_ipo_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf power/os mapping: TBP>>=
	procedure :: inverse => sf_ipo_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_ipo_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
	real(default) :: f1, f2, y, yb
	integer :: j
	do j = 1, 2
	r2 (j) = r (mapping%i(j))
	r2b(j) = rb(mapping%i(j))
	end do
	call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb)
	y = px(2)
	yb = pxb(2)
	call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
	p2(1) = 0
	p2b(1)= 1
	p2(2) = 1 - p2b(2)
	f = f1 * f2
	p = r
	pb= rb
	do j = 1, 2
	p (mapping%i(j)) = p2(j)
	pb(mapping%i(j)) = p2b(j)
	end do
	end subroutine sf_ipo_mapping_inverse

	@ %def sf_ipo_mapping_inverse
	@
	\subsection{Implementation: Endpoint + ISR power mapping}
	This is a combination of endpoint (i.e., beamstrahlung) and ISR power
	mapping. The first two parameters apply to the beamstrahlung
	spectrum, the last two to the ISR function for the first and second
	beam, respectively.
	<<SF mappings: public>>=
	public :: sf_ei_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_ei_mapping_t
	type(sf_ep_mapping_t) :: ep
	type(sf_ip_mapping_t) :: ip
	contains
	<<SF mappings: sf ep-ip mapping: TBP>>
	end type sf_ei_mapping_t

	@ %def sf_ei_mapping_t
	@ Output.
	<<SF mappings: sf ep-ip mapping: TBP>>=
	procedure :: write => sf_ei_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_ei_mapping_write (object, unit)
	class(sf_ei_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,3(',',I0),')')", advance="no") object%i
	end if
	write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, &
	", eps =", object%ip%eps, ")"
	end subroutine sf_ei_mapping_write

	@ %def sf_ei_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf ep-ip mapping: TBP>>=
	procedure :: init => sf_ei_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_ei_mapping_init (mapping, a, eps)
	class(sf_ei_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: a, eps
	call mapping%base_init (4)
	call mapping%ep%init (a)
	call mapping%ip%init (eps)
	end subroutine sf_ei_mapping_init

	@ %def sf_ei_mapping_init
	@ Set an index value. We should communicate the appropriate indices to the
	enclosed sub-mappings, therefore override the method.
	<<SF mappings: sf ep-ip mapping: TBP>>=
	procedure :: set_index => sf_ei_mapping_set_index
	<<SF mappings: procedures>>=
	subroutine sf_ei_mapping_set_index (mapping, j, i)
	class(sf_ei_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: j, i
	mapping%i(j) = i
	select case (j)
	case (1:2); call mapping%ep%set_index (j, i)
	case (3:4); call mapping%ip%set_index (j-2, i)
	end select
	end subroutine sf_ei_mapping_set_index

	@ %def sf_mapping_set_index
	@ Apply mapping. Now, the beamstrahlung and ISR mappings are
	independent of each other. The parameter subsets that are actually
	used should not overlap. The Jacobians are multiplied.
	<<SF mappings: sf ep-ip mapping: TBP>>=
	procedure :: compute => sf_ei_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_ei_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: q, qb
	real(default) :: f1, f2
	call mapping%ep%compute (q, qb, f1, p, pb, x_free)
	call mapping%ip%compute (r, rb, f2, q, qb, x_free)
	f = f1 * f2
	end subroutine sf_ei_mapping_compute

	@ %def sf_ei_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf ep-ip mapping: TBP>>=
	procedure :: inverse => sf_ei_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_ei_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: q, qb
	real(default) :: f1, f2
	call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
	call mapping%ep%inverse (q, qb, f1, p, pb, x_free)
	f = f1 * f2
	end subroutine sf_ei_mapping_inverse

	@ %def sf_ei_mapping_inverse
	@
	\subsection{Implementation: Endpoint + ISR + resonance}
	This is a combination of endpoint (i.e., beamstrahlung) and ISR power
	mapping, adapted for an s-channel resonance. The first two internal
	parameters apply to the beamstrahlung spectrum, the last two to the
	ISR function for the first and second beam, respectively. The first
	and third parameters are the result of an overall resonance mapping,
	so on the outside, the first parameter is the total momentum fraction,
	the third one describes the distribution between beamstrahlung and ISR.
	<<SF mappings: public>>=
	public :: sf_eir_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_eir_mapping_t
	type(sf_res_mapping_t) :: res
	type(sf_epr_mapping_t) :: ep
	type(sf_ipr_mapping_t) :: ip
	contains
	<<SF mappings: sf ep-ip-res mapping: TBP>>
	end type sf_eir_mapping_t

	@ %def sf_eir_mapping_t
	@ Output.
	<<SF mappings: sf ep-ip-res mapping: TBP>>=
	procedure :: write => sf_eir_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_eir_mapping_write (object, unit)
	class(sf_eir_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,3(',',I0),')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") &
	": ep/isr/res (a =", object%ep%a, &
	", eps =", object%ip%eps, " \| ", object%res%m, object%res%w, ")"
	end subroutine sf_eir_mapping_write

	@ %def sf_eir_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf ep-ip-res mapping: TBP>>=
	procedure :: init => sf_eir_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_eir_mapping_init (mapping, a, eps, m, w)
	class(sf_eir_mapping_t), intent(out) :: mapping
	real(default), intent(in) :: a, eps, m, w
	call mapping%base_init (4)
	call mapping%res%init (m, w)
	call mapping%ep%init (a)
	call mapping%ip%init (eps)
	end subroutine sf_eir_mapping_init

	@ %def sf_eir_mapping_init
	@ Set an index value. We should communicate the appropriate indices to the
	enclosed sub-mappings, therefore override the method.
	<<SF mappings: sf ep-ip-res mapping: TBP>>=
	procedure :: set_index => sf_eir_mapping_set_index
	<<SF mappings: procedures>>=
	subroutine sf_eir_mapping_set_index (mapping, j, i)
	class(sf_eir_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: j, i
	mapping%i(j) = i
	select case (j)
	case (1); call mapping%res%set_index (1, i)
	case (3); call mapping%res%set_index (2, i)
	end select
	select case (j)
	case (1:2); call mapping%ep%set_index (j, i)
	case (3:4); call mapping%ip%set_index (j-2, i)
	end select
	end subroutine sf_eir_mapping_set_index

	@ %def sf_mapping_set_index
	@ Apply mapping. Now, the beamstrahlung and ISR mappings are
	independent of each other. The parameter subsets that are actually
	used should not overlap. The Jacobians are multiplied.
	<<SF mappings: sf ep-ip-res mapping: TBP>>=
	procedure :: compute => sf_eir_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_eir_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: px, pxb, q, qb
	real(default) :: f0, f1, f2
	call mapping%res%compute (px, pxb, f0, p, pb, x_free)
	call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
	call mapping%ip%compute (r, rb, f2, q, qb, x_free)
	f = f0 * f1 * f2
	end subroutine sf_eir_mapping_compute

	@ %def sf_eir_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf ep-ip-res mapping: TBP>>=
	procedure :: inverse => sf_eir_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_eir_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: px, pxb, q, qb
	real(default) :: f0, f1, f2
	call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
	call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
	call mapping%res%inverse (px, pxb, f0, p, pb, x_free)
	f = f0 * f1 * f2
	end subroutine sf_eir_mapping_inverse

	@ %def sf_eir_mapping_inverse
	@
	\subsection{Implementation: Endpoint + ISR power mapping, on-shell}
	This is a combination of endpoint (i.e., beamstrahlung) and ISR power
	mapping. The first two parameters apply to the beamstrahlung
	spectrum, the last two to the ISR function for the first and second
	beam, respectively. On top of that, we map the first and third parameter
	such that the product is constant. From the outside, the first
	parameter is irrelevant while the third parameter describes the
	distribution of energy (loss) among beamstrahlung and ISR.
	<<SF mappings: public>>=
	public :: sf_eio_mapping_t
	<<SF mappings: types>>=
	type, extends (sf_mapping_t) :: sf_eio_mapping_t
	type(sf_os_mapping_t) :: os
	type(sf_epr_mapping_t) :: ep
	type(sf_ipr_mapping_t) :: ip
	contains
	<<SF mappings: sf ep-ip-os mapping: TBP>>
	end type sf_eio_mapping_t

	@ %def sf_eio_mapping_t
	@ Output.
	<<SF mappings: sf ep-ip-os mapping: TBP>>=
	procedure :: write => sf_eio_mapping_write
	<<SF mappings: procedures>>=
	subroutine sf_eio_mapping_write (object, unit)
	class(sf_eio_mapping_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "map"
	if (any (object%i /= 0)) then
	write (u, "('(',I0,3(',',I0),')')", advance="no") object%i
	end if
	write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, &
	", eps =", object%ip%eps, " \| ", object%os%m, ")"
	end subroutine sf_eio_mapping_write

	@ %def sf_eio_mapping_write
	@ Initialize: no extra parameters.
	<<SF mappings: sf ep-ip-os mapping: TBP>>=
	procedure :: init => sf_eio_mapping_init
	<<SF mappings: procedures>>=
	subroutine sf_eio_mapping_init (mapping, a, eps, m)
	class(sf_eio_mapping_t), intent(out) :: mapping
	real(default), intent(in), optional :: a, eps, m
	call mapping%base_init (4)
	call mapping%os%init (m)
	call mapping%ep%init (a)
	call mapping%ip%init (eps)
	end subroutine sf_eio_mapping_init

	@ %def sf_eio_mapping_init
	@ Set an index value. We should communicate the appropriate indices to the
	enclosed sub-mappings, therefore override the method.
	<<SF mappings: sf ep-ip-os mapping: TBP>>=
	procedure :: set_index => sf_eio_mapping_set_index
	<<SF mappings: procedures>>=
	subroutine sf_eio_mapping_set_index (mapping, j, i)
	class(sf_eio_mapping_t), intent(inout) :: mapping
	integer, intent(in) :: j, i
	mapping%i(j) = i
	select case (j)
	case (1); call mapping%os%set_index (1, i)
	case (3); call mapping%os%set_index (2, i)
	end select
	select case (j)
	case (1:2); call mapping%ep%set_index (j, i)
	case (3:4); call mapping%ip%set_index (j-2, i)
	end select
	end subroutine sf_eio_mapping_set_index

	@ %def sf_mapping_set_index
	@ Apply mapping. Now, the beamstrahlung and ISR mappings are
	independent of each other. The parameter subsets that are actually
	used should not overlap. The Jacobians are multiplied.
	<<SF mappings: sf ep-ip-os mapping: TBP>>=
	procedure :: compute => sf_eio_mapping_compute
	<<SF mappings: procedures>>=
	subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free)
	class(sf_eio_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: px, pxb, q, qb
	real(default) :: f0, f1, f2
	call mapping%os%compute (px, pxb, f0, p, pb, x_free)
	call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
	call mapping%ip%compute (r, rb, f2, q, qb, x_free)
	f = f0 * f1 * f2
	end subroutine sf_eio_mapping_compute

	@ %def sf_eio_mapping_compute
	@ Apply inverse.
	<<SF mappings: sf ep-ip-os mapping: TBP>>=
	procedure :: inverse => sf_eio_mapping_inverse
	<<SF mappings: procedures>>=
	subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
	class(sf_eio_mapping_t), intent(inout) :: mapping
	real(default), dimension(:), intent(in) :: r, rb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: p, pb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(size(p)) :: px, pxb, q, qb
	real(default) :: f0, f1, f2
	call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
	call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
	call mapping%os%inverse (px, pxb, f0, p, pb, x_free)
	f = f0 * f1 * f2
	end subroutine sf_eio_mapping_inverse

	@ %def sf_eio_mapping_inverse
	@
	\subsection{Basic formulas}
	\subsubsection{Standard mapping of the unit square}
	This mapping of the unit square is appropriate in particular for
	structure functions which are concentrated at the lower end. Instead
	of a rectangular grid, one set of grid lines corresponds to constant
	parton c.m. energy. The other set is chosen such that the jacobian is
	only mildly singular ($\ln x$ which is zero at $x=1$), corresponding
	to an initial concentration of sampling points at the maximum energy.
	If [[power]] is greater than one (the default), points are also
	concentrated at the lower end.

	The formula is ([[power]]=$\alpha$):
	\begin{align}
	r_1 &= (p_1 ^ {p_2})^\alpha \\
	r_2 &= (p_1 ^ {1 - p_2})^\alpha\\
	f &= \alpha^2 p_1 ^ {\alpha - 1} \|\log p_1\|
	\end{align}
	and for the default case $\alpha=1$:
	\begin{align}
	r_1 &= p_1 ^ {p_2} \\
	r_2 &= p_1 ^ {1 - p_2} \\
	f &= \|\log p_1\|
	\end{align}
	<<SF mappings: procedures>>=
	subroutine map_unit_square (r, factor, p, power)
	real(default), dimension(2), intent(out) :: r
	real(default), intent(out) :: factor
	real(default), dimension(2), intent(in) :: p
	real(default), intent(in), optional :: power
	real(default) :: xx, yy
	factor = 1
	xx = p(1)
	yy = p(2)
	if (present(power)) then
	if (p(1) > 0 .and. power > 1) then
	xx = p(1)**power
	factor = factor * power * xx / p(1)
	end if
	end if
	if (.not. vanishes (xx)) then
	r(1) = xx ** yy
	r(2) = xx / r(1)
	factor = factor * abs (log (xx))
	else
	r = 0
	end if
	end subroutine map_unit_square

	@ %def map_unit_square
	@ This is the inverse mapping.
	<<SF mappings: procedures>>=
	subroutine map_unit_square_inverse (r, factor, p, power)
	real(kind=default), dimension(2), intent(in) :: r
	real(kind=default), intent(out) :: factor
	real(kind=default), dimension(2), intent(out) :: p
	real(kind=default), intent(in), optional :: power
	real(kind=default) :: lg, xx, yy
	factor = 1
	xx = r(1) * r(2)
	if (.not. vanishes (xx)) then
	lg = log (xx)
	if (.not. vanishes (lg)) then
	yy = log (r(1)) / lg
	else
	yy = 0
	end if
	p(2) = yy
	factor = factor * abs (lg)
	if (present(power)) then
	p(1) = xx**(1._default/power)
	factor = factor * power * xx / p(1)
	else
	p(1) = xx
	end if
	else
	p = 0
	end if
	end subroutine map_unit_square_inverse

	@ %def map_unit_square_inverse
	@
	\subsubsection{Precise mapping of the unit square}
	A more precise version (with unit power parameter). This version
	should be numerically stable near $x=1$ and $y=0,1$. The formulas are again
	\begin{equation}
	r_1 = p_1^{p_2}, \qquad
	r_2 = p_1^{\bar p_2}, \qquad
	f = - \log p_1
	\end{equation}
	but we compute both $r_i$ and $\bar r_i$ simultaneously and make
	direct use of both $p_i$ and $\bar p_i$ as appropriate.
	<<SF mappings: procedures>>=
	subroutine map_unit_square_prec (r, rb, factor, p, pb)
	real(default), dimension(2), intent(out) :: r
	real(default), dimension(2), intent(out) :: rb
	real(default), intent(out) :: factor
	real(default), dimension(2), intent(in) :: p
	real(default), dimension(2), intent(in) :: pb
	if (p(1) > 0.5_default) then
	call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2))
	call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2))
	factor = - log_prec (p(1), pb(1))
	else if (.not. vanishes (p(1))) then
	call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2))
	call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2))
	factor = - log_prec (p(1), pb(1))
	else
	r = 0
	rb = 1
	factor = 0
	end if
	end subroutine map_unit_square_prec

	@ %def map_unit_square_prec
	@ This is the inverse mapping.
	<<SF mappings: procedures>>=
	subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb)
	real(default), dimension(2), intent(in) :: r
	real(default), dimension(2), intent(in) :: rb
	real(default), intent(out) :: factor
	real(default), dimension(2), intent(out) :: p
	real(default), dimension(2), intent(out) :: pb
	call inverse_prec_x (r, rb, p(1), pb(1))
	if (all (r > 0)) then
	if (rb(1) < rb(2)) then
	call inverse_prec_y (r, rb, p(2), pb(2))
	else
	call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2))
	end if
	factor = - log_prec (p(1), pb(1))
	else
	p(1) = 0
	pb(1) = 1
	p(2) = 0.5_default
	pb(2) = 0.5_default
	factor = 0
	end if
	end subroutine map_unit_square_inverse_prec

	@ %def map_unit_square_prec_inverse
	@ This is an auxiliary function: evaluate the expression $\bar z = 1 -
	x^y$ in a numerically stable way. Instabilities occur for $y=0$ and
	$x=1$. The idea is to replace the bracket by the first terms of its
	Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$)
	\begin{equation}
	1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x +
	\frac16(2-y)(1-y)\bar x^2\right)
	\end{equation}
	whenever this is the better approximation. Actually, the relative
	numerical error of the exact formula is about $\eta/(y\bar x)$ where
	$\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error
	of the approximation is better than the last included term divided by
	$(y\bar x)$.

	The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log
	x$ should be expanded, the second one near $x=0$ where $\log x$ can be
	kept.
	<<SF mappings: procedures>>=
	subroutine compute_prec_xy_1 (z, zb, x, xb, y)
	real(default), intent(out) :: z, zb
	real(default), intent(in) :: x, xb, y
	real(default) :: a1, a2, a3
	a1 = y * xb
	a2 = a1 * (1 - y) * xb / 2
	a3 = a2 * (2 - y) * xb / 3
	if (abs (a3) < epsilon (a3)) then
	zb = a1 + a2 + a3
	z = 1 - zb
	else
	z = x ** y
	zb = 1 - z
	end if
	end subroutine compute_prec_xy_1

	subroutine compute_prec_xy_0 (z, zb, x, xb, y)
	real(default), intent(out) :: z, zb
	real(default), intent(in) :: x, xb, y
	real(default) :: a1, a2, a3, lx
	lx = -log (x)
	a1 = y * lx
	a2 = a1 * y * lx / 2
	a3 = a2 * y * lx / 3
	if (abs (a3) < epsilon (a3)) then
	zb = a1 + a2 + a3
	z = 1 - zb
	else
	z = x ** y
	zb = 1 - z
	end if
	end subroutine compute_prec_xy_0

	@ %def compute_prec_xy_1
	@ %def compute_prec_xy_0
	@ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way.
	Since it is just a polynomial, the expansion near $x=1$ is
	analytically exact, and we don't need to choose based on precision.
	<<SF mappings: procedures>>=
	subroutine inverse_prec_x (r, rb, x, xb)
	real(default), dimension(2), intent(in) :: r, rb
	real(default), intent(out) :: x, xb
	real(default) :: a0, a1
	a0 = rb(1) + rb(2)
	a1 = rb(1) * rb(2)
	if (a0 > 0.5_default) then
	xb = a0 - a1
	x = 1 - xb
	else
	x = r(1) * r(2)
	xb = 1 - x
	end if
	end subroutine inverse_prec_x

	@ %def inverse_prec_x
	@ The inverse calculation for the relative momentum fraction
	\begin{equation}
	y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}}
	\end{equation}
	is slightly more complicated. We should take the precise form of the
	logarithm, so we are safe near $r_i=1$. A series expansion is
	required if $r_1\ll r_2$, since then $y$ becomes small. (We assume
	$r_1<r_2$ here; for the opposite case, the arguments can be
	exchanged.)
	<<SF mappings: procedures>>=
	subroutine inverse_prec_y (r, rb, y, yb)
	real(default), dimension(2), intent(in) :: r, rb
	real(default), intent(out) :: y, yb
	real(default) :: log1, log2, a1, a2, a3
	log1 = log_prec (r(1), rb(1))
	log2 = log_prec (r(2), rb(2))
	if (abs (log2**3) < epsilon (one)) then
	if (abs(log1) < epsilon (one)) then
	y = zero
	else
	y = one / (one + log2 / log1)
	end if
	if (abs(log2) < epsilon (one)) then
	yb = zero
	else
	yb = one / (one + log1 / log2)
	end if
	return
	end if
	a1 = - rb(1) / log2
	a2 = - rb(1) ** 2 * (one / log2*2 + one / (2 log2))
	a3 = - rb(1) ** 3 * (one / log23 + one / log22 + one/(3 * log2))
	if (abs (a3) < epsilon (a3)) then
	y = a1 + a2 + a3
	yb = one - y
	else
	y = one / (one + log2 / log1)
	yb = one / (one + log1 / log2)
	end if
	end subroutine inverse_prec_y

	@ %def inverse_prec_y
	@
	\subsubsection{Mapping for on-shell s-channel}
	The limiting case, if the product $r_1r_2$ is fixed for on-shell
	production. The parameter $p_1$ is ignored. In the inverse mapping,
	it is returned zero.

	The parameter [[x_free]], if present, rescales the total energy. If
	it is less than one, the rescaled mass parameter $m^2$ should be increased
	accordingly.

	Public for access in unit test.
	<<SF mappings: public>>=
	public :: map_on_shell
	public :: map_on_shell_inverse
	<<SF mappings: procedures>>=
	subroutine map_on_shell (r, factor, p, lm2, x_free)
	real(default), dimension(2), intent(out) :: r
	real(default), intent(out) :: factor
	real(default), dimension(2), intent(in) :: p
	real(default), intent(in) :: lm2
	real(default), intent(in), optional :: x_free
	real(default) :: lx
	lx = lm2; if (present (x_free)) lx = lx + log (x_free)
	r(1) = exp (- p(2) * lx)
	r(2) = exp (- (1 - p(2)) * lx)
	factor = lx
	end subroutine map_on_shell

	subroutine map_on_shell_inverse (r, factor, p, lm2, x_free)
	real(default), dimension(2), intent(in) :: r
	real(default), intent(out) :: factor
	real(default), dimension(2), intent(out) :: p
	real(default), intent(in) :: lm2
	real(default), intent(in), optional :: x_free
	real(default) :: lx
	lx = lm2; if (present (x_free)) lx = lx + log (x_free)
	p(1) = 0
	p(2) = abs (log (r(1))) / lx
	factor = lx
	end subroutine map_on_shell_inverse

	@ %def map_on_shell
	@ %def map_on_shell_inverse
	@
	\subsubsection{Mapping for on-shell s-channel, single parameter}
	This is a pseudo-mapping which applies if there is actually just one
	parameter [[p]]. The output parameter [[r]] is fixed for on-shell
	production. The lone parameter $p_1$ is ignored. In the inverse mapping,
	it is returned zero.

	The parameter [[x_free]], if present, rescales the total energy. If
	it is less than one, the rescaled mass parameter $m^2$ should be increased
	accordingly.

	Public for access in unit test.
	<<SF mappings: public>>=
	public :: map_on_shell_single
	public :: map_on_shell_single_inverse
	<<SF mappings: procedures>>=
	subroutine map_on_shell_single (r, factor, p, lm2, x_free)
	real(default), dimension(1), intent(out) :: r
	real(default), intent(out) :: factor
	real(default), dimension(1), intent(in) :: p
	real(default), intent(in) :: lm2
	real(default), intent(in), optional :: x_free
	real(default) :: lx
	lx = lm2; if (present (x_free)) lx = lx + log (x_free)
	r(1) = exp (- lx)
	factor = 1
	end subroutine map_on_shell_single

	subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free)
	real(default), dimension(1), intent(in) :: r
	real(default), intent(out) :: factor
	real(default), dimension(1), intent(out) :: p
	real(default), intent(in) :: lm2
	real(default), intent(in), optional :: x_free
	real(default) :: lx
	lx = lm2; if (present (x_free)) lx = lx + log (x_free)
	p(1) = 0
	factor = 1
	end subroutine map_on_shell_single_inverse

	@ %def map_on_shell_single
	@ %def map_on_shell_single_inverse
	@
	\subsubsection{Mapping for a Breit-Wigner resonance}
	This is the standard Breit-Wigner mapping. We apply it to a single
	variable, independently of or in addition to a unit-square mapping. We
	assume here that the limits for the variable are 0 and 1, and that the
	mass $m$ and width $w$ are rescaled appropriately, so they are
	dimensionless and usually between 0 and 1.

	If [[x_free]] is set, it rescales the total energy and thus mass and
	width, since these are defined with respect to the total energy.
	<<SF mappings: procedures>>=
	subroutine map_breit_wigner (r, factor, p, m, w, x_free)
	real(default), intent(out) :: r
	real(default), intent(out) :: factor
	real(default), intent(in) :: p
	real(default), intent(in) :: m
	real(default), intent(in) :: w
	real(default), intent(in), optional :: x_free
	real(default) :: m2, mw, a1, a2, a3, z, tmp
	m2 = m ** 2
	mw = m * w
	if (present (x_free)) then
	m2 = m2 / x_free
	mw = mw / x_free
	end if
	a1 = atan (- m2 / mw)
	a2 = atan ((1 - m2) / mw)
	a3 = (a2 - a1) * mw
	z = (1-p) * a1 + p * a2
	if (-pi/2 < z .and. z < pi/2) then
	tmp = tan (z)
	r = max (m2 + mw * tmp, 0._default)
	factor = a3 * (1 + tmp ** 2)
	else
	r = 0
	factor = 0
	end if
	end subroutine map_breit_wigner

	subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free)
	real(default), intent(in) :: r
	real(default), intent(out) :: factor
	real(default), intent(out) :: p
	real(default), intent(in) :: m
	real(default), intent(in) :: w
	real(default) :: m2, mw, a1, a2, a3, tmp
	real(default), intent(in), optional :: x_free
	m2 = m ** 2
	mw = m * w
	if (present (x_free)) then
	m2 = m2 / x_free
	mw = mw / x_free
	end if
	a1 = atan (- m2 / mw)
	a2 = atan ((1 - m2) / mw)
	a3 = (a2 - a1) * mw
	tmp = (r - m2) / mw
	p = (atan (tmp) - a1) / (a2 - a1)
	factor = a3 * (1 + tmp ** 2)
	end subroutine map_breit_wigner_inverse

	@ %def map_breit_wigner
	@ %def map_breit_wigner_inverse
	@
	\subsubsection{Mapping with endpoint enhancement}
	This is a mapping which is close to the unit mapping, except that at
	the endpoint(s), the output values are exponentially enhanced.
	\begin{equation}
	y = \tanh (a \tan (\frac{\pi}{2}x))
	\end{equation}
	We have two variants: one covers endpoints at $0$ and $1$
	symmetrically, while the other one (which essentially maps one-half of
	the range), covers only the endpoint at $1$.
	<<SF mappings: procedures>>=
	subroutine map_endpoint_1 (x3, factor, x1, a)
	real(default), intent(out) :: x3, factor
	real(default), intent(in) :: x1
	real(default), intent(in) :: a
	real(default) :: x2
	if (abs (x1) < 1) then
	x2 = tan (x1 * pi / 2)
	x3 = tanh (a * x2)
	factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
	else
	x3 = x1
	factor = 0
	end if
	end subroutine map_endpoint_1

	subroutine map_endpoint_inverse_1 (x3, factor, x1, a)
	real(default), intent(in) :: x3
	real(default), intent(out) :: x1, factor
	real(default), intent(in) :: a
	real(default) :: x2
	if (abs (x3) < 1) then
	x2 = atanh (x3) / a
	x1 = 2 / pi * atan (x2)
	factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
	else
	x1 = x3
	factor = 0
	end if
	end subroutine map_endpoint_inverse_1

	subroutine map_endpoint_01 (x4, factor, x0, a)
	real(default), intent(out) :: x4, factor
	real(default), intent(in) :: x0
	real(default), intent(in) :: a
	real(default) :: x1, x3
	x1 = 2 * x0 - 1
	call map_endpoint_1 (x3, factor, x1, a)
	x4 = (x3 + 1) / 2
	end subroutine map_endpoint_01

	subroutine map_endpoint_inverse_01 (x4, factor, x0, a)
	real(default), intent(in) :: x4
	real(default), intent(out) :: x0, factor
	real(default), intent(in) :: a
	real(default) :: x1, x3
	x3 = 2 * x4 - 1
	call map_endpoint_inverse_1 (x3, factor, x1, a)
	x0 = (x1 + 1) / 2
	end subroutine map_endpoint_inverse_01

	@ %def map_endpoint_1
	@ %def map_endpoint_inverse_1
	@ %def map_endpoint_01
	@ %def map_endpoint_inverse_01
	@
	\subsubsection{Mapping with endpoint enhancement (ISR)}
	This is another endpoint mapping. It is designed to flatten the ISR
	singularity which is of power type at $x=1$, i.e., if
	\begin{equation}
	\sigma = \int_0^1 dx\,f(x)\,G(x)
	= \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x),
	\end{equation}
	we replace this by
	\begin{equation}
	r = x^\epsilon \quad\Longrightarrow\quad
	\sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}).
	\end{equation}
	We expect that $\epsilon$ is small.

	The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The
	Jacobian that we return is thus $1/f(x)$. We compute the mapping in
	terms of $\bar x\equiv 1 - x$, so we can achieve the required precision.
	Because some compilers show quite wild numeric fluctuations, we
	internally convert numeric types to explicit [[double]] precision.
	<<SF mappings: public>>=
	public :: map_power_1
	public :: map_power_inverse_1
	<<SF mappings: procedures>>=
	subroutine map_power_1 (xb, factor, rb, eps)
	real(default), intent(out) :: xb, factor
	real(default), intent(in) :: rb
	real(double) :: rb_db, factor_db, eps_db, xb_db
	real(default), intent(in) :: eps
	rb_db = real (rb, kind=double)
	eps_db = real (eps, kind=double)
	xb_db = rb_db ** (1 / eps_db)
	if (rb_db > 0) then
	factor_db = xb_db / rb_db / eps_db
	factor = real (factor_db, kind=default)
	else
	factor = 0
	end if
	xb = real (xb_db, kind=default)
	end subroutine map_power_1

	subroutine map_power_inverse_1 (xb, factor, rb, eps)
	real(default), intent(in) :: xb
	real(default), intent(out) :: rb, factor
	real(double) :: xb_db, factor_db, eps_db, rb_db
	real(default), intent(in) :: eps
	xb_db = real (xb, kind=double)
	eps_db = real (eps, kind=double)
	rb_db = xb_db ** eps_db
	if (xb_db > 0) then
	factor_db = xb_db / rb_db / eps_db
	factor = real (factor_db, kind=default)
	else
	factor = 0
	end if
	rb = real (rb_db, kind=default)
	end subroutine map_power_inverse_1

	@ %def map_power_1
	@ %def map_power_inverse_1
	@ Here we apply a power mapping to both endpoints. We divide the
	interval in two equal halves and apply the power mapping for the
	nearest endpoint, either $0$ or $1$.
	<<SF mappings: procedures>>=
	subroutine map_power_01 (y, yb, factor, r, eps)
	real(default), intent(out) :: y, yb, factor
	real(default), intent(in) :: r
	real(default), intent(in) :: eps
	real(default) :: u, ub, zp, zm
	u = 2 * r - 1
	if (u > 0) then
	ub = 2 * (1 - r)
	call map_power_1 (zm, factor, ub, eps)
	zp = 2 - zm
	else if (u < 0) then
	ub = 2 * r
	call map_power_1 (zp, factor, ub, eps)
	zm = 2 - zp
	else
	factor = 1 / eps
	zp = 1
	zm = 1
	end if
	y = zp / 2
	yb = zm / 2
	end subroutine map_power_01

	subroutine map_power_inverse_01 (y, yb, factor, r, eps)
	real(default), intent(in) :: y, yb
	real(default), intent(out) :: r, factor
	real(default), intent(in) :: eps
	real(default) :: ub, zp, zm
	zp = 2 * y
	zm = 2 * yb
	if (zm < zp) then
	call map_power_inverse_1 (zm, factor, ub, eps)
	r = 1 - ub / 2
	else if (zp < zm) then
	call map_power_inverse_1 (zp, factor, ub, eps)
	r = ub / 2
	else
	factor = 1 / eps
	ub = 1
	r = ub / 2
	end if
	end subroutine map_power_inverse_01

	@ %def map_power_01
	@ %def map_power_inverse_01
	@
	\subsubsection{Structure-function channels}
	A structure-function chain parameterization (channel) may contain a
	mapping that applies to multiple structure functions. This is
	described by an extension of the [[sf_mapping_t]] type. In addition,
	it may contain mappings that apply to (other) individual structure
	functions. The details of these mappings are implementation-specific.

	The [[sf_channel_t]] type combines this information. It contains an
	array of map codes, one for each structure-function entry. The code
	values are:
	\begin{description}
	\item[none] MC input parameters $r$ directly become energy fractions $x$
	\item[single] default mapping for a single structure-function entry
	\item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$
	\item[multi/resonance] as before, adapted to s-channel resonance
	\item[multi/on-shell] as before, adapted to an on-shell particle in
	the s channel
	\item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$
	\item[multi/endpoint/res] endpoint mapping with resonance
	\item[multi/endpoint/os] endpoint mapping for on-shell
	\item[multi/power/os] like multi/endpoint, regulating a power singularity
	\end{description}
	<<SF mappings: parameters>>=
	integer, parameter :: SFMAP_NONE = 0
	integer, parameter :: SFMAP_SINGLE = 1
	integer, parameter :: SFMAP_MULTI_S = 2
	integer, parameter :: SFMAP_MULTI_RES = 3
	integer, parameter :: SFMAP_MULTI_ONS = 4
	integer, parameter :: SFMAP_MULTI_EP = 5
	integer, parameter :: SFMAP_MULTI_EPR = 6
	integer, parameter :: SFMAP_MULTI_EPO = 7
	integer, parameter :: SFMAP_MULTI_IP = 8
	integer, parameter :: SFMAP_MULTI_IPR = 9
	integer, parameter :: SFMAP_MULTI_IPO = 10
	integer, parameter :: SFMAP_MULTI_EI = 11
	integer, parameter :: SFMAP_MULTI_SRS = 13
	integer, parameter :: SFMAP_MULTI_SON = 14

	@ %def SFMAP_NONE SFMAP_SINGLE
	@ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS
	@ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO
	@ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO
	@ %def SFMAP_MULTI_EI
	@ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON
	@ Then, it contains an allocatable entry for the multi mapping. This
	entry holds the MC-parameter indices on which the mapping applies
	(there may be more than one MC parameter per structure-function entry)
	and any parameters associated with the mapping.

	There can be only one multi-mapping per channel.
	<<SF mappings: public>>=
	public :: sf_channel_t
	<<SF mappings: types>>=
	type :: sf_channel_t
	integer, dimension(:), allocatable :: map_code
	class(sf_mapping_t), allocatable :: multi_mapping
	contains
	<<SF mappings: sf channel: TBP>>
	end type sf_channel_t

	@ %def sf_channel_t
	@ The output format prints a single character for each
	structure-function entry and, if applicable, an account of the mapping
	parameters.
	<<SF mappings: sf channel: TBP>>=
	procedure :: write => sf_channel_write
	<<SF mappings: procedures>>=
	subroutine sf_channel_write (object, unit)
	class(sf_channel_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	if (allocated (object%map_code)) then
	do i = 1, size (object%map_code)
	select case (object%map_code (i))
	case (SFMAP_NONE)
	write (u, "(1x,A)", advance="no") "-"
	case (SFMAP_SINGLE)
	write (u, "(1x,A)", advance="no") "+"
	case (SFMAP_MULTI_S)
	write (u, "(1x,A)", advance="no") "s"
	case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS)
	write (u, "(1x,A)", advance="no") "r"
	case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON)
	write (u, "(1x,A)", advance="no") "o"
	case (SFMAP_MULTI_EP)
	write (u, "(1x,A)", advance="no") "e"
	case (SFMAP_MULTI_EPR)
	write (u, "(1x,A)", advance="no") "p"
	case (SFMAP_MULTI_EPO)
	write (u, "(1x,A)", advance="no") "q"
	case (SFMAP_MULTI_IP)
	write (u, "(1x,A)", advance="no") "i"
	case (SFMAP_MULTI_IPR)
	write (u, "(1x,A)", advance="no") "i"
	case (SFMAP_MULTI_IPO)
	write (u, "(1x,A)", advance="no") "i"
	case (SFMAP_MULTI_EI)
	write (u, "(1x,A)", advance="no") "i"
	case default
	write (u, "(1x,A)", advance="no") "?"
	end select
	end do
	else
	write (u, "(1x,A)", advance="no") "-"
	end if
	if (allocated (object%multi_mapping)) then
	write (u, "(1x,'/')", advance="no")
	call object%multi_mapping%write (u)
	else
	write (u, *)
	end if
	end subroutine sf_channel_write

	@ %def sf_channel_write
	@ Initializer for a single [[sf_channel]] object.
	<<SF mappings: sf channel: TBP>>=
	procedure :: init => sf_channel_init
	<<SF mappings: procedures>>=
	subroutine sf_channel_init (channel, n_strfun)
	class(sf_channel_t), intent(out) :: channel
	integer, intent(in) :: n_strfun
	allocate (channel%map_code (n_strfun))
	channel%map_code = SFMAP_NONE
	end subroutine sf_channel_init

	@ %def sf_channel_init
	@ Assignment. This merely copies intrinsic assignment.
	<<SF mappings: sf channel: TBP>>=
	generic :: assignment (=) => sf_channel_assign
	procedure :: sf_channel_assign
	<<SF mappings: procedures>>=
	subroutine sf_channel_assign (copy, original)
	class(sf_channel_t), intent(out) :: copy
	type(sf_channel_t), intent(in) :: original
	allocate (copy%map_code (size (original%map_code)))
	copy%map_code = original%map_code
	if (allocated (original%multi_mapping)) then
	allocate (copy%multi_mapping, source = original%multi_mapping)
	end if
	end subroutine sf_channel_assign

	@ %def sf_channel_assign
	@ This initializer allocates an array of channels with common number of
	structure-function entries, therefore it is not a type-bound procedure.
	<<SF mappings: public>>=
	public :: allocate_sf_channels
	<<SF mappings: procedures>>=
	subroutine allocate_sf_channels (channel, n_channel, n_strfun)
	type(sf_channel_t), dimension(:), intent(out), allocatable :: channel
	integer, intent(in) :: n_channel
	integer, intent(in) :: n_strfun
	integer :: c
	allocate (channel (n_channel))
	do c = 1, n_channel
	call channel(c)%init (n_strfun)
	end do
	end subroutine allocate_sf_channels

	@ %def allocate_sf_channels
	@ This marks a given subset of indices as single-mapping.
	<<SF mappings: sf channel: TBP>>=
	procedure :: activate_mapping => sf_channel_activate_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_activate_mapping (channel, i_sf)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	channel%map_code(i_sf) = SFMAP_SINGLE
	end subroutine sf_channel_activate_mapping

	@ %def sf_channel_activate_mapping
	@ This sets an s-channel multichannel mapping. The parameter indices
	are not yet set.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_s_mapping => sf_channel_set_s_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_s_mapping (channel, i_sf, power)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: power
	channel%map_code(i_sf) = SFMAP_MULTI_S
	allocate (sf_s_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_s_mapping_t)
	call mapping%init (power)
	end select
	end subroutine sf_channel_set_s_mapping

	@ %def sf_channel_set_s_mapping
	@ This sets an s-channel resonance multichannel mapping.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_res_mapping => sf_channel_set_res_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in) :: m, w
	logical, intent(in) :: single
	if (single) then
	channel%map_code(i_sf) = SFMAP_MULTI_SRS
	allocate (sf_res_mapping_single_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_res_mapping_single_t)
	call mapping%init (m, w)
	end select
	else
	channel%map_code(i_sf) = SFMAP_MULTI_RES
	allocate (sf_res_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_res_mapping_t)
	call mapping%init (m, w)
	end select
	end if
	end subroutine sf_channel_set_res_mapping

	@ %def sf_channel_set_res_mapping
	@ This sets an s-channel on-shell multichannel mapping. The length of the
	[[i_sf]] array must be 2. (The first parameter actually becomes an
	irrelevant dummy.)
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_os_mapping => sf_channel_set_os_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_os_mapping (channel, i_sf, m, single)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in) :: m
	logical, intent(in) :: single
	if (single) then
	channel%map_code(i_sf) = SFMAP_MULTI_SON
	allocate (sf_os_mapping_single_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_os_mapping_single_t)
	call mapping%init (m)
	end select
	else
	channel%map_code(i_sf) = SFMAP_MULTI_ONS
	allocate (sf_os_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_os_mapping_t)
	call mapping%init (m)
	end select
	end if
	end subroutine sf_channel_set_os_mapping

	@ %def sf_channel_set_os_mapping
	@ This sets an s-channel endpoint mapping. The parameter $a$ is the
	slope parameter (default 1); increasing it moves the endpoint region
	(at $x=1$ to lower values in the input parameter.
	region even more.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_ep_mapping => sf_channel_set_ep_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_ep_mapping (channel, i_sf, a)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: a
	channel%map_code(i_sf) = SFMAP_MULTI_EP
	allocate (sf_ep_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_ep_mapping_t)
	call mapping%init (a = a)
	end select
	end subroutine sf_channel_set_ep_mapping

	@ %def sf_channel_set_ep_mapping
	@ This sets a resonant endpoint mapping.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_epr_mapping => sf_channel_set_epr_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in) :: a, m, w
	channel%map_code(i_sf) = SFMAP_MULTI_EPR
	allocate (sf_epr_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_epr_mapping_t)
	call mapping%init (a, m, w)
	end select
	end subroutine sf_channel_set_epr_mapping

	@ %def sf_channel_set_epr_mapping
	@ This sets an on-shell endpoint mapping.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_epo_mapping => sf_channel_set_epo_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in) :: a, m
	channel%map_code(i_sf) = SFMAP_MULTI_EPO
	allocate (sf_epo_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_epo_mapping_t)
	call mapping%init (a, m)
	end select
	end subroutine sf_channel_set_epo_mapping

	@ %def sf_channel_set_epo_mapping
	@ This sets an s-channel power mapping, regulating a singularity of
	type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the
	structure function.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_ip_mapping => sf_channel_set_ip_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_ip_mapping (channel, i_sf, eps)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: eps
	channel%map_code(i_sf) = SFMAP_MULTI_IP
	allocate (sf_ip_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_ip_mapping_t)
	call mapping%init (eps)
	end select
	end subroutine sf_channel_set_ip_mapping

	@ %def sf_channel_set_ip_mapping
	@ This sets an s-channel resonant power mapping, regulating a
	singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an
	s-channel resonance. The parameter $\epsilon$ depends on the
	structure function.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: eps, m, w
	channel%map_code(i_sf) = SFMAP_MULTI_IPR
	allocate (sf_ipr_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_ipr_mapping_t)
	call mapping%init (eps, m, w)
	end select
	end subroutine sf_channel_set_ipr_mapping

	@ %def sf_channel_set_ipr_mapping
	@ This sets an on-shell power mapping, regulating a
	singularity of type $(1-x)^{-1+\epsilon}$ for the production of a
	single on-shell particle.. The parameter $\epsilon$ depends on the
	structure function.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: eps, m
	channel%map_code(i_sf) = SFMAP_MULTI_IPO
	allocate (sf_ipo_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_ipo_mapping_t)
	call mapping%init (eps, m)
	end select
	end subroutine sf_channel_set_ipo_mapping

	@ %def sf_channel_set_ipo_mapping
	@ This sets a combined endpoint/ISR mapping.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_ei_mapping => sf_channel_set_ei_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: a, eps
	channel%map_code(i_sf) = SFMAP_MULTI_EI
	allocate (sf_ei_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_ei_mapping_t)
	call mapping%init (a, eps)
	end select
	end subroutine sf_channel_set_ei_mapping

	@ %def sf_channel_set_ei_mapping
	@ This sets a combined endpoint/ISR mapping with resonance.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_eir_mapping => sf_channel_set_eir_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: a, eps, m, w
	channel%map_code(i_sf) = SFMAP_MULTI_EI
	allocate (sf_eir_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_eir_mapping_t)
	call mapping%init (a, eps, m, w)
	end select
	end subroutine sf_channel_set_eir_mapping

	@ %def sf_channel_set_eir_mapping
	@ This sets a combined endpoint/ISR mapping, on-shell.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_eio_mapping => sf_channel_set_eio_mapping
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m)
	class(sf_channel_t), intent(inout) :: channel
	integer, dimension(:), intent(in) :: i_sf
	real(default), intent(in), optional :: a, eps, m
	channel%map_code(i_sf) = SFMAP_MULTI_EI
	allocate (sf_eio_mapping_t :: channel%multi_mapping)
	select type (mapping => channel%multi_mapping)
	type is (sf_eio_mapping_t)
	call mapping%init (a, eps, m)
	end select
	end subroutine sf_channel_set_eio_mapping

	@ %def sf_channel_set_eio_mapping
	@ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]].
	<<SF mappings: sf channel: TBP>>=
	procedure :: is_single_mapping => sf_channel_is_single_mapping
	<<SF mappings: procedures>>=
	function sf_channel_is_single_mapping (channel, i_sf) result (flag)
	class(sf_channel_t), intent(in) :: channel
	integer, intent(in) :: i_sf
	logical :: flag
	flag = channel%map_code(i_sf) == SFMAP_SINGLE
	end function sf_channel_is_single_mapping

	@ %def sf_channel_is_single_mapping
	@ Return true if the mapping code at position [[i_sf]] is any of the
	[[SFMAP_MULTI]] mappings.
	<<SF mappings: sf channel: TBP>>=
	procedure :: is_multi_mapping => sf_channel_is_multi_mapping
	<<SF mappings: procedures>>=
	function sf_channel_is_multi_mapping (channel, i_sf) result (flag)
	class(sf_channel_t), intent(in) :: channel
	integer, intent(in) :: i_sf
	logical :: flag
	select case (channel%map_code(i_sf))
	case (SFMAP_NONE, SFMAP_SINGLE)
	flag = .false.
	case default
	flag = .true.
	end select
	end function sf_channel_is_multi_mapping

	@ %def sf_channel_is_multi_mapping
	@ Return the number of parameters that the multi-mapping requires. The
	mapping object must be allocated.
	<<SF mappings: sf channel: TBP>>=
	procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par
	<<SF mappings: procedures>>=
	function sf_channel_get_multi_mapping_n_par (channel) result (n_par)
	class(sf_channel_t), intent(in) :: channel
	integer :: n_par
	if (allocated (channel%multi_mapping)) then
	n_par = channel%multi_mapping%get_n_dim ()
	else
	n_par = 0
	end if
	end function sf_channel_get_multi_mapping_n_par

	@ %def sf_channel_is_multi_mapping
	@ Return true if there is any nontrivial mapping in any of the channels.
	<<SF mappings: public>>=
	public :: any_sf_channel_has_mapping
	<<SF mappings: procedures>>=
	function any_sf_channel_has_mapping (channel) result (flag)
	type(sf_channel_t), dimension(:), intent(in) :: channel
	logical :: flag
	integer :: c
	flag = .false.
	do c = 1, size (channel)
	flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE)
	end do
	end function any_sf_channel_has_mapping

	@ %def any_sf_channel_has_mapping
	@ Set a parameter index for an active multi mapping. We assume that
	the index array is allocated properly.
	<<SF mappings: sf channel: TBP>>=
	procedure :: set_par_index => sf_channel_set_par_index
	<<SF mappings: procedures>>=
	subroutine sf_channel_set_par_index (channel, j, i_par)
	class(sf_channel_t), intent(inout) :: channel
	integer, intent(in) :: j
	integer, intent(in) :: i_par
	associate (mapping => channel%multi_mapping)
	if (j >= 1 .and. j <= mapping%get_n_dim ()) then
	if (mapping%get_index (j) == 0) then
	call channel%multi_mapping%set_index (j, i_par)
	else
	call msg_bug ("Structure-function setup: mapping index set twice")
	end if
	else
	call msg_bug ("Structure-function setup: mapping index out of range")
	end if
	end associate
	end subroutine sf_channel_set_par_index

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

	module sf_mappings_ut
	use unit_tests
	use sf_mappings_uti

	<<Standard module head>>

	<<SF mappings: public test>>

	contains

	<<SF mappings: test driver>>

	end module sf_mappings_ut
	@ %def sf_mappings_ut
	@
	<<[[sf_mappings_uti.f90]]>>=
	<<File header>>

	module sf_mappings_uti

	<<Use kinds>>
	use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16

	use sf_mappings

	<<Standard module head>>

	<<SF mappings: test declarations>>

	contains

	<<SF mappings: tests>>

	end module sf_mappings_uti
	@ %def sf_mappings_ut
	@ API: driver for the unit tests below.
	<<SF mappings: public test>>=
	public :: sf_mappings_test
	<<SF mappings: test driver>>=
	subroutine sf_mappings_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF mappings: execute tests>>
	end subroutine sf_mappings_test

	@ %def sf_mappings_test
	@
	\subsubsection{Check standard mapping}
	Probe the standard mapping of the unit square for different parameter
	values. Also calculates integrals. For a finite number of bins, they differ
	slightly from $1$, but the result is well-defined because we are not using
	random points.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_1, "sf_mappings_1", &
	"standard pair mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_1
	<<SF mappings: tests>>=
	subroutine sf_mappings_1 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_1"
	write (u, "(A)") "* Purpose: probe standard mapping"
	write (u, "(A)")

	allocate (sf_s_mapping_t :: mapping)
	select type (mapping)
	type is (sf_s_mapping_t)
	call mapping%init ()
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.1):"
	p = [0.1_default, 0.1_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)
	allocate (sf_s_mapping_t :: mapping)
	select type (mapping)
	type is (sf_s_mapping_t)
	call mapping%init (power=2._default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	write (u, *)
	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.1):"
	p = [0.1_default, 0.1_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

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

	end subroutine sf_mappings_1

	@ %def sf_mappings_1
	@
	\subsubsection{Channel entries}
	Construct channel entries and print them.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_2, "sf_mappings_2", &
	"structure-function mapping channels", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_2
	<<SF mappings: tests>>=
	subroutine sf_mappings_2 (u)
	integer, intent(in) :: u
	type(sf_channel_t), dimension(:), allocatable :: channel
	integer :: c

	write (u, "(A)") "* Test output: sf_mappings_2"
	write (u, "(A)") "* Purpose: construct and display &
	&mapping-channel objects"
	write (u, "(A)")

	call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2)
	call channel(2)%activate_mapping ([1])
	call channel(3)%set_s_mapping ([1,2])
	call channel(4)%set_s_mapping ([1,2], power=2._default)
	call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.)
	call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.)
	call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.)
	call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.)

	call channel(3)%set_par_index (1, 1)
	call channel(3)%set_par_index (2, 4)

	call channel(4)%set_par_index (1, 1)
	call channel(4)%set_par_index (2, 4)

	call channel(5)%set_par_index (1, 1)
	call channel(5)%set_par_index (2, 3)

	call channel(6)%set_par_index (1, 1)
	call channel(6)%set_par_index (2, 2)

	call channel(7)%set_par_index (1, 1)

	call channel(8)%set_par_index (1, 1)

	do c = 1, size (channel)
	write (u, "(I0,':')", advance="no") c
	call channel(c)%write (u)
	end do

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

	end subroutine sf_mappings_2

	@ %def sf_mappings_2
	@
	\subsubsection{Check resonance mapping}
	Probe the resonance mapping of the unit square for different parameter
	values. Also calculates integrals. For a finite number of bins, they differ
	slightly from $1$, but the result is well-defined because we are not using
	random points.

	The resonance mass is at $1/2$ the energy, the width is $1/10$.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_3, "sf_mappings_3", &
	"resonant pair mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_3
	<<SF mappings: tests>>=
	subroutine sf_mappings_3 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_3"
	write (u, "(A)") "* Purpose: probe resonance pair mapping"
	write (u, "(A)")

	allocate (sf_res_mapping_t :: mapping)
	select type (mapping)
	type is (sf_res_mapping_t)
	call mapping%init (0.5_default, 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.1):"
	p = [0.1_default, 0.1_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_3

	@ %def sf_mappings_3
	@
	\subsubsection{Check on-shell mapping}
	Probe the on-shell mapping of the unit square for different parameter
	values. Also calculates integrals. In this case, the Jacobian is
	constant and given by $\|\log m^2\|$, so this is also the value of the
	integral. The factor results from the variable change in the $\delta$
	function $\delta (m^2 - x_1x_2)$ which multiplies the cross section
	for the case at hand.

	For the test, the (rescaled) resonance mass is set at $1/2$ the
	energy.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_4, "sf_mappings_4", &
	"on-shell pair mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_4
	<<SF mappings: tests>>=
	subroutine sf_mappings_4 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_4"
	write (u, "(A)") "* Purpose: probe on-shell pair mapping"
	write (u, "(A)")

	allocate (sf_os_mapping_t :: mapping)
	select type (mapping)
	type is (sf_os_mapping_t)
	call mapping%init (0.5_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0,0.1):"
	p = [0._default, 0.1_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0,1.0):"
	p = [0._default, 1.0_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_4

	@ %def sf_mappings_4
	@
	\subsubsection{Check endpoint mapping}
	Probe the endpoint mapping of the unit square for different parameter
	values. Also calculates integrals. For a finite number of bins, they differ
	slightly from $1$, but the result is well-defined because we are not using
	random points.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_5, "sf_mappings_5", &
	"endpoint pair mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_5
	<<SF mappings: tests>>=
	subroutine sf_mappings_5 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_5"
	write (u, "(A)") "* Purpose: probe endpoint pair mapping"
	write (u, "(A)")

	allocate (sf_ep_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ep_mapping_t)
	call mapping%init ()
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_5

	@ %def sf_mappings_5
	@
	\subsubsection{Check endpoint resonant mapping}
	Probe the endpoint mapping with resonance. Also calculates integrals.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_6, "sf_mappings_6", &
	"endpoint resonant mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_6
	<<SF mappings: tests>>=
	subroutine sf_mappings_6 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_6"
	write (u, "(A)") "* Purpose: probe endpoint resonant mapping"
	write (u, "(A)")

	allocate (sf_epr_mapping_t :: mapping)
	select type (mapping)
	type is (sf_epr_mapping_t)
	call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

	write (u, "(A)")
	write (u, "(A)") "* Same mapping without resonance:"
	write (u, "(A)")

	allocate (sf_epr_mapping_t :: mapping)
	select type (mapping)
	type is (sf_epr_mapping_t)
	call mapping%init (a = 1._default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_6

	@ %def sf_mappings_6
	@
	\subsubsection{Check endpoint on-shell mapping}
	Probe the endpoint mapping with an on-shell particle. Also calculates
	integrals.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_7, "sf_mappings_7", &
	"endpoint on-shell mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_7
	<<SF mappings: tests>>=
	subroutine sf_mappings_7 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p

	write (u, "(A)") "* Test output: sf_mappings_7"
	write (u, "(A)") "* Purpose: probe endpoint on-shell mapping"
	write (u, "(A)")

	allocate (sf_epo_mapping_t :: mapping)
	select type (mapping)
	type is (sf_epo_mapping_t)
	call mapping%init (a = 1._default, m = 0.5_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0):"
	p = [0._default, 0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1,0.5):"
	p = [0.1_default, 0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_7

	@ %def sf_mappings_7
	@
	\subsubsection{Check power mapping}
	Probe the power mapping of the unit square for different parameter
	values. Also calculates integrals. For a finite number of bins, they differ
	slightly from $1$, but the result is well-defined because we are not using
	random points.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_8, "sf_mappings_8", &
	"power pair mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_8
	<<SF mappings: tests>>=
	subroutine sf_mappings_8 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_8"
	write (u, "(A)") "* Purpose: probe power pair mapping"
	write (u, "(A)")

	allocate (sf_ip_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ip_mapping_t)
	call mapping%init (eps = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.5):"
	p = [0._default, 0.5_default]
	pb= [1._default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9,0.5):"
	p = [0.9_default, 0.5_default]
	pb= [0.1_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	pb= [0.3_default, 0.8_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.8):"
	p = [0.7_default, 0.8_default]
	pb= [0.3_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.99,0.02):"
	p = [0.99_default, 0.02_default]
	pb= [0.01_default, 0.98_default]
	call mapping%check (u, p, pb, FMT_14, FMT_12)

	write (u, *)
	write (u, "(A)") "Probe at (0.99,0.98):"
	p = [0.99_default, 0.98_default]
	pb= [0.01_default, 0.02_default]
	call mapping%check (u, p, pb, FMT_14, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_8

	@ %def sf_mappings_8
	@
	\subsubsection{Check resonant power mapping}
	Probe the power mapping of the unit square, adapted for an s-channel
	resonance, for different parameter values. Also calculates integrals.
	For a finite number of bins, they differ slightly from $1$, but the
	result is well-defined because we are not using random points.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_9, "sf_mappings_9", &
	"power resonance mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_9
	<<SF mappings: tests>>=
	subroutine sf_mappings_9 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_9"
	write (u, "(A)") "* Purpose: probe power resonant pair mapping"
	write (u, "(A)")

	allocate (sf_ipr_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ipr_mapping_t)
	call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.5):"
	p = [0._default, 0.5_default]
	pb= [1._default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9,0.5):"
	p = [0.9_default, 0.5_default]
	pb= [0.1_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	pb= [0.3_default, 0.8_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.8):"
	p = [0.7_default, 0.8_default]
	pb= [0.3_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9999,0.02):"
	p = [0.9999_default, 0.02_default]
	pb= [0.0001_default, 0.98_default]
	call mapping%check (u, p, pb, FMT_11, FMT_12)

	write (u, *)
	write (u, "(A)") "Probe at (0.9999,0.98):"
	p = [0.9999_default, 0.98_default]
	pb= [0.0001_default, 0.02_default]
	call mapping%check (u, p, pb, FMT_11, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

	write (u, "(A)")
	write (u, "(A)") "* Same mapping without resonance:"
	write (u, "(A)")

	allocate (sf_ipr_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ipr_mapping_t)
	call mapping%init (eps = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.5):"
	p = [0._default, 0.5_default]
	pb= [1._default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.5,0.5):"
	p = [0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9,0.5):"
	p = [0.9_default, 0.5_default]
	pb= [0.1_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.2):"
	p = [0.7_default, 0.2_default]
	pb= [0.3_default, 0.8_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7,0.8):"
	p = [0.7_default, 0.8_default]
	pb= [0.3_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_9

	@ %def sf_mappings_9
	@
	\subsubsection{Check on-shell power mapping}
	Probe the power mapping of the unit square, adapted for
	single-particle production, for different parameter values. Also
	calculates integrals. For a finite number of bins, they differ
	slightly from $1$, but the result is well-defined because we are not
	using random points.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_10, "sf_mappings_10", &
	"power on-shell mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_10
	<<SF mappings: tests>>=
	subroutine sf_mappings_10 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(2) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_10"
	write (u, "(A)") "* Purpose: probe power on-shell mapping"
	write (u, "(A)")

	allocate (sf_ipo_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ipo_mapping_t)
	call mapping%init (eps = 0.1_default, m = 0.5_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.5):"
	p = [0._default, 0.5_default]
	pb= [1._default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.02):"
	p = [0._default, 0.02_default]
	pb= [1._default, 0.98_default]
	call mapping%check (u, p, pb, FMT_15, FMT_12)

	write (u, *)
	write (u, "(A)") "Probe at (0,0.98):"
	p = [0._default, 0.98_default]
	pb= [1._default, 0.02_default]
	call mapping%check (u, p, pb, FMT_15, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_10

	@ %def sf_mappings_10
	@
	\subsubsection{Check combined endpoint-power mapping}
	Probe the mapping for the beamstrahlung/ISR combination.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_11, "sf_mappings_11", &
	"endpoint/power combined mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_11
	<<SF mappings: tests>>=
	subroutine sf_mappings_11 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(4) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_11"
	write (u, "(A)") "* Purpose: probe power pair mapping"
	write (u, "(A)")

	allocate (sf_ei_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ei_mapping_t)
	call mapping%init (eps = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	call mapping%set_index (3, 3)
	call mapping%set_index (4, 4)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):"
	p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):"
	p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
	pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):"
	p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
	pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
	call mapping%check (u, p, pb, FMT_13, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_11

	@ %def sf_mappings_11
	@
	\subsubsection{Check resonant endpoint-power mapping}
	Probe the mapping for the beamstrahlung/ISR combination.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_12, "sf_mappings_12", &
	"endpoint/power resonant combined mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_12
	<<SF mappings: tests>>=
	subroutine sf_mappings_12 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(4) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_12"
	write (u, "(A)") "* Purpose: probe resonant combined mapping"
	write (u, "(A)")

	allocate (sf_eir_mapping_t :: mapping)
	select type (mapping)
	type is (sf_eir_mapping_t)
	call mapping%init (a = 1._default, &
	eps = 0.1_default, m = 0.5_default, w = 0.1_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	call mapping%set_index (3, 3)
	call mapping%set_index (4, 4)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):"
	p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):"
	p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
	pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):"
	p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
	pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
	call mapping%check (u, p, pb, FMT_15, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_12

	@ %def sf_mappings_12
	@
	\subsubsection{Check on-shell endpoint-power mapping}
	Probe the mapping for the beamstrahlung/ISR combination.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_13, "sf_mappings_13", &
	"endpoint/power on-shell combined mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_13
	<<SF mappings: tests>>=
	subroutine sf_mappings_13 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(4) :: p, pb

	write (u, "(A)") "* Test output: sf_mappings_13"
	write (u, "(A)") "* Purpose: probe on-shell combined mapping"
	write (u, "(A)")

	allocate (sf_eio_mapping_t :: mapping)
	select type (mapping)
	type is (sf_eio_mapping_t)
	call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default)
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	call mapping%set_index (3, 3)
	call mapping%set_index (4, 4)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):"
	p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):"
	p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
	pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
	call mapping%check (u, p, pb, FMT_16)

	write (u, *)
	write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):"
	p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
	pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
	call mapping%check (u, p, pb, FMT_14, FMT_12)

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_13

	@ %def sf_mappings_13
	@
	\subsubsection{Check rescaling}
	Check the rescaling factor in on-shell basic mapping.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_14, "sf_mappings_14", &
	"rescaled on-shell mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_14
	<<SF mappings: tests>>=
	subroutine sf_mappings_14 (u)
	integer, intent(in) :: u
	real(default), dimension(2) :: p2, r2
	real(default), dimension(1) :: p1, r1
	real(default) :: f, x_free, m2

	write (u, "(A)") "* Test output: sf_mappings_14"
	write (u, "(A)") "* Purpose: probe rescaling in os mapping"
	write (u, "(A)")

	x_free = 0.9_default
	m2 = 0.5_default

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

	p2 = [0.1_default, 0.2_default]

	call map_on_shell (r2, f, p2, -log (m2), x_free)

	write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2
	write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2
	write (u, "(A,9(1x," // FMT_14 // "))") "f =", f
	write (u, "(A,9(1x," // FMT_14 // "))") "r=", x_free product (r2)

	write (u, *)

	call map_on_shell_inverse (r2, f, p2, -log (m2), x_free)

	write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2
	write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2
	write (u, "(A,9(1x," // FMT_14 // "))") "f =", f
	write (u, "(A,9(1x," // FMT_14 // "))") "r=", x_free product (r2)

	write (u, "(A)")
	write (u, "(A)") "* One parameter"
	write (u, "(A)")

	p1 = [0.1_default]

	call map_on_shell_single (r1, f, p1, -log (m2), x_free)

	write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1
	write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1
	write (u, "(A,9(1x," // FMT_14 // "))") "f =", f
	write (u, "(A,9(1x," // FMT_14 // "))") "r=", x_free product (r1)

	write (u, *)

	call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free)

	write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1
	write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1
	write (u, "(A,9(1x," // FMT_14 // "))") "f =", f
	write (u, "(A,9(1x," // FMT_14 // "))") "r=", x_free product (r1)

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

	end subroutine sf_mappings_14

	@ %def sf_mappings_14
	@
	\subsubsection{Check single parameter resonance mapping}
	Probe the resonance mapping of the unit interval for different parameter
	values. Also calculates integrals.

	The resonance mass is at $1/2$ the energy, the width is $1/10$.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_15, "sf_mappings_15", &
	"resonant single mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_15
	<<SF mappings: tests>>=
	subroutine sf_mappings_15 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(1) :: p

	write (u, "(A)") "* Test output: sf_mappings_15"
	write (u, "(A)") "* Purpose: probe resonance single mapping"
	write (u, "(A)")

	allocate (sf_res_mapping_single_t :: mapping)
	select type (mapping)
	type is (sf_res_mapping_single_t)
	call mapping%init (0.5_default, 0.1_default)
	call mapping%set_index (1, 1)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0):"
	p = [0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5):"
	p = [0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.1):"
	p = [0.1_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_15

	@ %def sf_mappings_15
	@
	\subsubsection{Check single parameter on-shell mapping}
	Probe the on-shell (pseudo) mapping of the unit interval for different parameter
	values. Also calculates integrals.

	The resonance mass is at $1/2$ the energy.
	<<SF mappings: execute tests>>=
	call test (sf_mappings_16, "sf_mappings_16", &
	"on-shell single mapping", &
	u, results)
	<<SF mappings: test declarations>>=
	public :: sf_mappings_16
	<<SF mappings: tests>>=
	subroutine sf_mappings_16 (u)
	integer, intent(in) :: u
	class(sf_mapping_t), allocatable :: mapping
	real(default), dimension(1) :: p

	write (u, "(A)") "* Test output: sf_mappings_16"
	write (u, "(A)") "* Purpose: probe on-shell single mapping"
	write (u, "(A)")

	allocate (sf_os_mapping_single_t :: mapping)
	select type (mapping)
	type is (sf_os_mapping_single_t)
	call mapping%init (0.5_default)
	call mapping%set_index (1, 1)
	end select

	call mapping%write (u)

	write (u, *)
	write (u, "(A)") "Probe at (0):"
	p = [0._default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Probe at (0.5):"
	p = [0.5_default]
	call mapping%check (u, p, 1-p, "F7.5")

	write (u, *)
	write (u, "(A)") "Compute integral:"
	write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)

	deallocate (mapping)

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

	end subroutine sf_mappings_16

	@ %def sf_mappings_16
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Structure function base}

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

	module sf_base

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_utils, only: write_separator
	use format_defs, only: FMT_17, FMT_19
	use numeric_utils, only: pacify
	use diagnostics
	use lorentz
	use quantum_numbers
	use interactions
	use evaluators
	use pdg_arrays
	use beams
	use sf_aux
	use sf_mappings
	use constants, only: one, two
	use physics_defs, only: n_beams_rescaled

	<<Standard module head>>

	<<SF base: public>>

	<<SF base: parameters>>

	<<SF base: types>>

	<<SF base: interfaces>>

	contains

	<<SF base: procedures>>

	end module sf_base
	@ %def sf_base
	@
	\subsection{Abstract rescale data-type}

	NLO calculations require the treatment of initial state parton radiation.
	The radiation of a parton rescales the energy fraction which enters the hard process.
	We allow for different rescale settings by extending the abstract.
	[[sf_rescale_t]] data type.
	<<SF base: public>>=
	public :: sf_rescale_t
	<<SF base: types>>=
	type, abstract :: sf_rescale_t
	integer :: i_beam = 0
	contains
	<<SF base: rescaling function: TBP>>
	end type sf_rescale_t

	@ %def sf_rescale_t
	@
	<<SF base: rescaling function: TBP>>=
	procedure (sf_rescale_apply), deferred :: apply
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_rescale_apply (func, x)
	import
	class(sf_rescale_t), intent(in) :: func
	real(default), intent(inout) :: x
	end subroutine sf_rescale_apply
	end interface

	@ %def rescale_apply
	@
	<<SF base: rescaling function: TBP>>=
	procedure :: set_i_beam => sf_rescale_set_i_beam
	<<SF base: procedures>>=
	subroutine sf_rescale_set_i_beam (func, i_beam)
	class(sf_rescale_t), intent(inout) :: func
	integer, intent(in) :: i_beam
	func%i_beam = i_beam
	end subroutine sf_rescale_set_i_beam

	@ %def rescale_set_i_beam
	@
	<<SF base: public>>=
	public :: sf_rescale_collinear_t
	<<SF base: types>>=
	type, extends (sf_rescale_t) :: sf_rescale_collinear_t
	real(default) :: xi_tilde
	contains
	<<SF base: rescale collinear: TBP>>
	end type sf_rescale_collinear_t

	@ %def sf_rescale_collinear_t
	@ For the subtraction terms we need to rescale the Born $x$ of both beams in the
	collinear limit. This leaves one beam unaffected and rescales the other according to
	\begin{equation}
	x = \frac{\overline{x}}{1-\xi}
	\end{equation}
	which is the collinear limit of [[sf_rescale_real_apply]].
	<<SF base: rescale collinear: TBP>>=
	procedure :: apply => sf_rescale_collinear_apply
	<<SF base: procedures>>=
	subroutine sf_rescale_collinear_apply (func, x)
	class(sf_rescale_collinear_t), intent(in) :: func
	real(default), intent(inout) :: x
	real(default) :: xi
	if (debug2_active (D_BEAMS)) then
	print *, 'Rescaling function - Collinear: '
	print *, 'Input, unscaled x: ', x
	print *, 'xi_tilde: ', func%xi_tilde
	end if
	xi = func%xi_tilde * (one - x)
	x = x / (one - xi)
	if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x
	end subroutine sf_rescale_collinear_apply

	@ %def sf_rescale_collinear_apply
	@
	<<SF base: rescale collinear: TBP>>=
	procedure :: set => sf_rescale_collinear_set
	<<SF base: procedures>>=
	subroutine sf_rescale_collinear_set (func, xi_tilde)
	class(sf_rescale_collinear_t), intent(inout) :: func
	real(default), intent(in) :: xi_tilde
	func%xi_tilde = xi_tilde
	end subroutine sf_rescale_collinear_set

	@ %def sf_rescale_collinear_set
	@
	<<SF base: public>>=
	public :: sf_rescale_real_t
	<<SF base: types>>=
	type, extends (sf_rescale_t) :: sf_rescale_real_t
	real(default) :: xi, y
	contains
	<<SF base: rescale real: TBP>>
	end type sf_rescale_real_t

	@ %def sf_rescale_real_t
	@ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to
	\begin{equation}
	x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}}
	, \qquad
	x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}}
	\end{equation}
	Refs:
	\begin{itemize}
	\item[\textbullet] [0709.2092] Eq. (5.7).
	\item[\textbullet] [0907.4076] Eq. (2.21).
	\item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3).
	\end{itemize}
	<<SF base: rescale real: TBP>>=
	procedure :: apply => sf_rescale_real_apply
	<<SF base: procedures>>=
	subroutine sf_rescale_real_apply (func, x)
	class(sf_rescale_real_t), intent(in) :: func
	real(default), intent(inout) :: x
	real(default) :: onepy, onemy
	if (debug2_active (D_BEAMS)) then
	print *, 'Rescaling function - Real: '
	print *, 'Input, unscaled: ', x
	print *, 'Beam index: ', func%i_beam
	print *, 'xi: ', func%xi, 'y: ', func%y
	end if
	x = x / sqrt (one - func%xi)
	onepy = one + func%y; onemy = one - func%y
	if (func%i_beam == 1) then
	x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy))
	else if (func%i_beam == 2) then
	x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy))
	else
	call msg_fatal ("sf_rescale_real_apply - invalid beam index")
	end if
	if (debug2_active (D_BEAMS)) print *, 'rescaled x: ', x
	end subroutine sf_rescale_real_apply

	@ %def sf_rescale_real_apply
	@
	<<SF base: rescale real: TBP>>=
	procedure :: set => sf_rescale_real_set
	<<SF base: procedures>>=
	subroutine sf_rescale_real_set (func, xi, y)
	class(sf_rescale_real_t), intent(inout) :: func
	real(default), intent(in) :: xi, y
	func%xi = xi; func%y = y
	end subroutine sf_rescale_real_set

	@ %def sf_rescale_real_set
	<<SF base: public>>=
	public :: sf_rescale_dglap_t
	<<SF base: types>>=
	type, extends(sf_rescale_t) :: sf_rescale_dglap_t
	real(default), dimension(:), allocatable :: z
	contains
	<<SF base: rescale dglap: TBP>>
	end type sf_rescale_dglap_t

	@ %def sf_rescale_dglap_t
	@
	<<SF base: rescale dglap: TBP>>=
	procedure :: apply => sf_rescale_dglap_apply
	<<SF base: procedures>>=
	subroutine sf_rescale_dglap_apply (func, x)
	class(sf_rescale_dglap_t), intent(in) :: func
	real(default), intent(inout) :: x
	if (debug2_active (D_BEAMS)) then
	print *, "Rescaling function - DGLAP:"
	print *, "Input: ", x
	print *, "Beam index: ", func%i_beam
	print *, "z: ", func%z
	end if
	x = x / func%z(func%i_beam)
	if (debug2_active (D_BEAMS)) print *, "scaled x: ", x
	end subroutine sf_rescale_dglap_apply

	@ %def sf_rescale_dglap_apply
	@
	<<SF base: rescale dglap: TBP>>=
	procedure :: set => sf_rescale_dglap_set
	<<SF base: procedures>>=
	subroutine sf_rescale_dglap_set (func, z)
	class(sf_rescale_dglap_t), intent(inout) :: func
	real(default), dimension(:), intent(in) :: z
	! allocate-on-assginment
	func%z = z
	end subroutine sf_rescale_dglap_set

	@ %def sf_rescale_dglap_set
	@
	\subsection{Abstract structure-function data type}
	This type should hold all configuration data for a specific type of
	structure function. The base object is empty; the implementations
	will fill it.
	<<SF base: public>>=
	public :: sf_data_t
	<<SF base: types>>=
	type, abstract :: sf_data_t
	contains
	<<SF base: sf data: TBP>>
	end type sf_data_t

	@ %def sf_data_t
	@ Output.
	<<SF base: sf data: TBP>>=
	procedure (sf_data_write), deferred :: write
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_data_write (data, unit, verbose)
	import
	class(sf_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	end subroutine sf_data_write
	end interface

	@ %def sf_data_write
	@ Return true if this structure function is in generator mode. In
	that case, all parameters are free, otherwise bound. (We do not
	support mixed cases.) Default is: no generator.
	<<SF base: sf data: TBP>>=
	procedure :: is_generator => sf_data_is_generator
	<<SF base: procedures>>=
	function sf_data_is_generator (data) result (flag)
	class(sf_data_t), intent(in) :: data
	logical :: flag
	flag = .false.
	end function sf_data_is_generator

	@ %def sf_data_is_generator
	@ Return the number of input parameters that determine the
	structure function.
	<<SF base: sf data: TBP>>=
	procedure (sf_data_get_int), deferred :: get_n_par
	<<SF base: interfaces>>=
	abstract interface
	function sf_data_get_int (data) result (n)
	import
	class(sf_data_t), intent(in) :: data
	integer :: n
	end function sf_data_get_int
	end interface

	@ %def sf_data_get_int
	@ Return the outgoing particle PDG codes for the current setup. The codes can
	be an array of particles, for each beam.
	<<SF base: sf data: TBP>>=
	procedure (sf_data_get_pdg_out), deferred :: get_pdg_out
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_data_get_pdg_out (data, pdg_out)
	import
	class(sf_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	end subroutine sf_data_get_pdg_out
	end interface

	@ %def sf_data_get_pdg_out
	@ Allocate a matching structure function interaction object and
	properly initialize it.

	<<SF base: sf data: TBP>>=
	procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_data_allocate_sf_int (data, sf_int)
	import
	class(sf_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	end subroutine sf_data_allocate_sf_int
	end interface

	@ %def sf_data_allocate_sf_int
	@ Return the PDF set index, if applicable. We implement a default
	method which returns zero. The PDF (builtin and LHA) implementations
	will override this.
	<<SF base: sf data: TBP>>=
	procedure :: get_pdf_set => sf_data_get_pdf_set
	<<SF base: procedures>>=
	elemental function sf_data_get_pdf_set (data) result (pdf_set)
	class(sf_data_t), intent(in) :: data
	integer :: pdf_set
	pdf_set = 0
	end function sf_data_get_pdf_set

	@ %def sf_data_get_pdf_set
	@ Return the spectrum file, if applicable. We implement a default
	method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will
	override this.
	<<SF base: sf data: TBP>>=
	procedure :: get_beam_file => sf_data_get_beam_file
	<<SF base: procedures>>=
	function sf_data_get_beam_file (data) result (file)
	class(sf_data_t), intent(in) :: data
	type(string_t) :: file
	file = ""
	end function sf_data_get_beam_file

	@ %def sf_data_get_beam_file
	@
	\subsection{Structure-function chain configuration}
	This is the data type that the [[process]] module uses for setting
	up its structure-function chain. For each structure function described
	by the beam data, there is an entry. The [[i]] array indicates the
	beam(s) to which this structure function applies, and the [[data]]
	object contains the actual configuration data.
	<<SF base: public>>=
	public :: sf_config_t
	<<SF base: types>>=
	type :: sf_config_t
	integer, dimension(:), allocatable :: i
	class(sf_data_t), allocatable :: data
	contains
	<<SF base: sf config: TBP>>
	end type sf_config_t

	@ %def sf_config_t
	@ Output:
	<<SF base: sf config: TBP>>=
	procedure :: write => sf_config_write
	<<SF base: procedures>>=
	subroutine sf_config_write (object, unit, verbose)
	class(sf_config_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	if (allocated (object%i)) then
	write (u, "(1x,A,2(1x,I0))") "Structure-function configuration: &
	&beam(s)", object%i
	if (allocated (object%data)) &
	call object%data%write (u, verbose = verbose)
	else
	write (u, "(1x,A)") "Structure-function configuration: [undefined]"
	end if
	end subroutine sf_config_write

	@ %def sf_config_write
	@ Initialize.
	<<SF base: sf config: TBP>>=
	procedure :: init => sf_config_init
	<<SF base: procedures>>=
	subroutine sf_config_init (sf_config, i_beam, sf_data)
	class(sf_config_t), intent(out) :: sf_config
	integer, dimension(:), intent(in) :: i_beam
	class(sf_data_t), intent(in) :: sf_data
	allocate (sf_config%i (size (i_beam)), source = i_beam)
	allocate (sf_config%data, source = sf_data)
	end subroutine sf_config_init

	@ %def sf_config_init
	@ Return the PDF set, if any.
	<<SF base: sf config: TBP>>=
	procedure :: get_pdf_set => sf_config_get_pdf_set
	<<SF base: procedures>>=
	elemental function sf_config_get_pdf_set (sf_config) result (pdf_set)
	class(sf_config_t), intent(in) :: sf_config
	integer :: pdf_set
	pdf_set = sf_config%data%get_pdf_set ()
	end function sf_config_get_pdf_set

	@ %def sf_config_get_pdf_set
	@ Return the beam spectrum file, if any.
	<<SF base: sf config: TBP>>=
	procedure :: get_beam_file => sf_config_get_beam_file
	<<SF base: procedures>>=
	function sf_config_get_beam_file (sf_config) result (file)
	class(sf_config_t), intent(in) :: sf_config
	type(string_t) :: file
	file = sf_config%data%get_beam_file ()
	end function sf_config_get_beam_file

	@ %def sf_config_get_beam_file
	@
	\subsection{Structure-function instance}
	The [[sf_int_t]] data type contains an [[interaction_t]] object (it is
	an extension of this type) and a pointer to the [[sf_data_t]]
	configuration data. This interaction, or copies of it, is used to
	implement structure-function kinematics and dynamics in the context of
	process evaluation.

	The status code [[status]] tells whether the interaction is undefined,
	has defined kinematics (but matrix elements invalid), or is completely
	defined. There is also a status code for failure. The implementation
	is responsible for updating the status.

	The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared
	invariant masses of the incoming, radiated, and outgoing particle,
	respectively. They are supposed to be set upon initialization, but
	could also be varied event by event.

	If the radiated or outgoing mass is nonzero, we may need to apply an
	on-shell projection. The projection mode is stored as
	[[on_shell_mode]].

	The array [[beam_index]] is the list of beams on which this structure
	function applies ($1$, $2$, or both). The arrays [[incoming]],
	[[radiated]], and [[outgoing]] contain the indices of the respective
	particle sets within the interaction, for convenient lookup. The
	array [[par_index]] indicates the MC input parameters that this entry
	will use up in the structure-function chain. The first parameter (or
	the first two, for a spectrum) in this array determines the momentum
	fraction and is thus subject to global mappings.

	In the abstract base type, we do not implement the data pointer. This
	allows us to restrict its type in the implementations.
	<<SF base: public>>=
	public :: sf_int_t
	<<SF base: types>>=
	type, abstract, extends (interaction_t) :: sf_int_t
	integer :: status = SF_UNDEFINED
	real(default), dimension(:), allocatable :: mi2
	real(default), dimension(:), allocatable :: mr2
	real(default), dimension(:), allocatable :: mo2
	integer :: on_shell_mode = KEEP_ENERGY
	logical :: qmin_defined = .false.
	logical :: qmax_defined = .false.
	real(default), dimension(:), allocatable :: qmin
	real(default), dimension(:), allocatable :: qmax
	integer, dimension(:), allocatable :: beam_index
	integer, dimension(:), allocatable :: incoming
	integer, dimension(:), allocatable :: radiated
	integer, dimension(:), allocatable :: outgoing
	integer, dimension(:), allocatable :: par_index
	integer, dimension(:), allocatable :: par_primary
	contains
	<<SF base: sf int: TBP>>
	end type sf_int_t

	@ %def sf_int_t
	@ Status codes. The codes that refer to links, masks, and
	connections, apply to structure-function chains only.

	The status codes are public.
	<<SF base: parameters>>=
	integer, parameter, public :: SF_UNDEFINED = 0
	integer, parameter, public :: SF_INITIAL = 1
	integer, parameter, public :: SF_DONE_LINKS = 2
	integer, parameter, public :: SF_FAILED_MASK = 3
	integer, parameter, public :: SF_DONE_MASK = 4
	integer, parameter, public :: SF_FAILED_CONNECTIONS = 5
	integer, parameter, public :: SF_DONE_CONNECTIONS = 6
	integer, parameter, public :: SF_SEED_KINEMATICS = 10
	integer, parameter, public :: SF_FAILED_KINEMATICS = 11
	integer, parameter, public :: SF_DONE_KINEMATICS = 12
	integer, parameter, public :: SF_FAILED_EVALUATION = 13
	integer, parameter, public :: SF_EVALUATED = 20

	@ %def SF_UNDEFINED SF_INITIAL
	@ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS
	@ %def SF_DONE_KINEMATICS SF_EVALUATED
	@ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS
	@ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION
	@ Write a string version of the status code:
	<<SF base: procedures>>=
	subroutine write_sf_status (status, u)
	integer, intent(in) :: status
	integer, intent(in) :: u
	select case (status)
	case (SF_UNDEFINED)
	write (u, "(1x,'[',A,']')") "undefined"
	case (SF_INITIAL)
	write (u, "(1x,'[',A,']')") "initialized"
	case (SF_DONE_LINKS)
	write (u, "(1x,'[',A,']')") "links set"
	case (SF_FAILED_MASK)
	write (u, "(1x,'[',A,']')") "mask mismatch"
	case (SF_DONE_MASK)
	write (u, "(1x,'[',A,']')") "mask set"
	case (SF_FAILED_CONNECTIONS)
	write (u, "(1x,'[',A,']')") "connections failed"
	case (SF_DONE_CONNECTIONS)
	write (u, "(1x,'[',A,']')") "connections set"
	case (SF_SEED_KINEMATICS)
	write (u, "(1x,'[',A,']')") "incoming momenta set"
	case (SF_FAILED_KINEMATICS)
	write (u, "(1x,'[',A,']')") "kinematics failed"
	case (SF_DONE_KINEMATICS)
	write (u, "(1x,'[',A,']')") "kinematics set"
	case (SF_FAILED_EVALUATION)
	write (u, "(1x,'[',A,']')") "evaluation failed"
	case (SF_EVALUATED)
	write (u, "(1x,'[',A,']')") "evaluated"
	end select
	end subroutine write_sf_status

	@ %def write_sf_status
	@ This is the basic output routine. Display status and interaction.
	<<SF base: sf int: TBP>>=
	procedure :: base_write => sf_int_base_write
	<<SF base: procedures>>=
	subroutine sf_int_base_write (object, unit, testflag)
	class(sf_int_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "SF instance:"
	call write_sf_status (object%status, u)
	if (allocated (object%beam_index)) &
	write (u, "(3x,A,2(1x,I0))") "beam =", object%beam_index
	if (allocated (object%incoming)) &
	write (u, "(3x,A,2(1x,I0))") "incoming =", object%incoming
	if (allocated (object%radiated)) &
	write (u, "(3x,A,2(1x,I0))") "radiated =", object%radiated
	if (allocated (object%outgoing)) &
	write (u, "(3x,A,2(1x,I0))") "outgoing =", object%outgoing
	if (allocated (object%par_index)) &
	write (u, "(3x,A,2(1x,I0))") "parameter =", object%par_index
	if (object%qmin_defined) &
	write (u, "(3x,A,1x," // FMT_19 // ")") "q_min =", object%qmin
	if (object%qmax_defined) &
	write (u, "(3x,A,1x," // FMT_19 // ")") "q_max =", object%qmax
	call object%interaction_t%basic_write (u, testflag = testflag)
	end subroutine sf_int_base_write

	@ %def sf_int_base_write
	@ The type string identifies the structure function class, and possibly more
	details about the structure function.
	<<SF base: sf int: TBP>>=
	procedure (sf_int_type_string), deferred :: type_string
	<<SF base: interfaces>>=
	abstract interface
	function sf_int_type_string (object) result (string)
	import
	class(sf_int_t), intent(in) :: object
	type(string_t) :: string
	end function sf_int_type_string
	end interface

	@ %def sf_int_type_string
	@ Output of the concrete object. We should not forget to call the
	output routine for the base type.
	<<SF base: sf int: TBP>>=
	procedure (sf_int_write), deferred :: write
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_int_write (object, unit, testflag)
	import
	class(sf_int_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	end subroutine sf_int_write
	end interface

	@ %def sf_int_write
	@ Basic initialization: set the invariant masses for the particles and
	initialize the interaction. The caller should then add states to the
	interaction and freeze it.

	The dimension of the mask should be equal to the sum of the dimensions
	of the mass-squared arrays, which determine incoming, radiated, and
	outgoing particles, respectively.

	Optionally, we can define minimum and maximum values for the momentum
	transfer to the outgoing particle(s). If all masses are zero, this is
	actually required for non-collinear splitting.
	<<SF base: sf int: TBP>>=
	procedure :: base_init => sf_int_base_init
	<<SF base: procedures>>=
	subroutine sf_int_base_init &
	(sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock)
	class(sf_int_t), intent(out) :: sf_int
	type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask
	real(default), dimension(:), intent(in) :: mi2, mr2, mo2
	real(default), dimension(:), intent(in), optional :: qmin, qmax
	integer, dimension(:), intent(in), optional :: hel_lock
	allocate (sf_int%mi2 (size (mi2)))
	sf_int%mi2 = mi2
	allocate (sf_int%mr2 (size (mr2)))
	sf_int%mr2 = mr2
	allocate (sf_int%mo2 (size (mo2)))
	sf_int%mo2 = mo2
	if (present (qmin)) then
	sf_int%qmin_defined = .true.
	allocate (sf_int%qmin (size (qmin)))
	sf_int%qmin = qmin
	end if
	if (present (qmax)) then
	sf_int%qmax_defined = .true.
	allocate (sf_int%qmax (size (qmax)))
	sf_int%qmax = qmax
	end if
	call sf_int%interaction_t%basic_init &
	(size (mi2), 0, size (mr2) + size (mo2), &
	mask = mask, hel_lock = hel_lock, set_relations = .true.)
	end subroutine sf_int_base_init

	@ %def sf_int_base_init
	@ Set the indices of the incoming, radiated, and outgoing particles,
	respectively.
	<<SF base: sf int: TBP>>=
	procedure :: set_incoming => sf_int_set_incoming
	procedure :: set_radiated => sf_int_set_radiated
	procedure :: set_outgoing => sf_int_set_outgoing
	<<SF base: procedures>>=
	subroutine sf_int_set_incoming (sf_int, incoming)
	class(sf_int_t), intent(inout) :: sf_int
	integer, dimension(:), intent(in) :: incoming
	allocate (sf_int%incoming (size (incoming)))
	sf_int%incoming = incoming
	end subroutine sf_int_set_incoming

	subroutine sf_int_set_radiated (sf_int, radiated)
	class(sf_int_t), intent(inout) :: sf_int
	integer, dimension(:), intent(in) :: radiated
	allocate (sf_int%radiated (size (radiated)))
	sf_int%radiated = radiated
	end subroutine sf_int_set_radiated

	subroutine sf_int_set_outgoing (sf_int, outgoing)
	class(sf_int_t), intent(inout) :: sf_int
	integer, dimension(:), intent(in) :: outgoing
	allocate (sf_int%outgoing (size (outgoing)))
	sf_int%outgoing = outgoing
	end subroutine sf_int_set_outgoing

	@ %def sf_int_set_incoming
	@ %def sf_int_set_radiated
	@ %def sf_int_set_outgoing
	@ Initialization. This proceeds via an abstract data object, which
	for the actual implementation should have the matching concrete type.
	Since all implementations have the same signature, we can prepare a
	deferred procedure. The data object will become the target of a
	corresponding pointer within the [[sf_int_t]] implementation.

	This should call the previous procedure.
	<<SF base: sf int: TBP>>=
	procedure (sf_int_init), deferred :: init
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_int_init (sf_int, data)
	import
	class(sf_int_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	end subroutine sf_int_init
	end interface

	@ %def sf_int_init
	@ Complete initialization. This routine contains initializations that can
	only be performed after the interaction object got its final shape, i.e.,
	redundant helicities have been eliminated by matching with beams and process.

	The default implementation does nothing.

	The [[target]] attribute is formally required since some overriding
	implementations use a temporary pointer (iterator) to the state-matrix
	component. It doesn't appear to make a real difference, though.
	<<SF base: sf int: TBP>>=
	procedure :: setup_constants => sf_int_setup_constants
	<<SF base: procedures>>=
	subroutine sf_int_setup_constants (sf_int)
	class(sf_int_t), intent(inout), target :: sf_int
	end subroutine sf_int_setup_constants

	@ %def sf_int_setup_constants
	@ Set beam indices, i.e., the beam(s) on which
	this structure function applies.
	<<SF base: sf int: TBP>>=
	procedure :: set_beam_index => sf_int_set_beam_index
	<<SF base: procedures>>=
	subroutine sf_int_set_beam_index (sf_int, beam_index)
	class(sf_int_t), intent(inout) :: sf_int
	integer, dimension(:), intent(in) :: beam_index
	allocate (sf_int%beam_index (size (beam_index)))
	sf_int%beam_index = beam_index
	end subroutine sf_int_set_beam_index

	@ %def sf_int_set_beam_index
	@ Set parameter indices, indicating which MC input parameters are to
	be used for evaluating this structure function.
	<<SF base: sf int: TBP>>=
	procedure :: set_par_index => sf_int_set_par_index
	<<SF base: procedures>>=
	subroutine sf_int_set_par_index (sf_int, par_index)
	class(sf_int_t), intent(inout) :: sf_int
	integer, dimension(:), intent(in) :: par_index
	allocate (sf_int%par_index (size (par_index)))
	sf_int%par_index = par_index
	end subroutine sf_int_set_par_index

	@ %def sf_int_set_par_index
	@ Initialize the structure-function kinematics, setting incoming
	momenta. We assume that array shapes match.

	Three versions. The first version relies on the momenta being linked
	to another interaction. The second version sets the momenta
	explicitly. In the third version, we first compute momenta for the
	specified energies and store those.
	<<SF base: sf int: TBP>>=
	generic :: seed_kinematics => sf_int_receive_momenta
	generic :: seed_kinematics => sf_int_seed_momenta
	generic :: seed_kinematics => sf_int_seed_energies
	procedure :: sf_int_receive_momenta
	procedure :: sf_int_seed_momenta
	procedure :: sf_int_seed_energies
	<<SF base: procedures>>=
	subroutine sf_int_receive_momenta (sf_int)
	class(sf_int_t), intent(inout) :: sf_int
	if (sf_int%status >= SF_INITIAL) then
	call sf_int%receive_momenta ()
	sf_int%status = SF_SEED_KINEMATICS
	end if
	end subroutine sf_int_receive_momenta

	subroutine sf_int_seed_momenta (sf_int, k)
	class(sf_int_t), intent(inout) :: sf_int
	type(vector4_t), dimension(:), intent(in) :: k
	if (sf_int%status >= SF_INITIAL) then
	call sf_int%set_momenta (k, outgoing=.false.)
	sf_int%status = SF_SEED_KINEMATICS
	end if
	end subroutine sf_int_seed_momenta

	subroutine sf_int_seed_energies (sf_int, E)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: E
	type(vector4_t), dimension(:), allocatable :: k
	integer :: j
	if (sf_int%status >= SF_INITIAL) then
	allocate (k (size (E)))
	if (all (E**2 >= sf_int%mi2)) then
	do j = 1, size (E)
	k(j) = vector4_moving (E(j), &
	(3-2j) sqrt (E(j)**2 - sf_int%mi2(j)), 3)
	end do
	call sf_int%seed_kinematics (k)
	end if
	end if
	end subroutine sf_int_seed_energies

	@ %def sf_int_seed_momenta
	@ %def sf_int_seed_energies
	@ Tell if in generator mode. By default, this is false. To be
	overridden where appropriate; we may refer to the [[is_generator]]
	method of the [[data]] component in the concrete type.
	<<SF base: sf int: TBP>>=
	procedure :: is_generator => sf_int_is_generator
	<<SF base: procedures>>=
	function sf_int_is_generator (sf_int) result (flag)
	class(sf_int_t), intent(in) :: sf_int
	logical :: flag
	flag = .false.
	end function sf_int_is_generator

	@ %def sf_int_is_generator
	@ Generate free parameters [[r]]. Parameters are free if they do not
	correspond to integration parameters (i.e., are bound), but are
	generated by the structure function object itself. By default, all
	parameters are bound, and the output values of this procedure will be
	discarded. With free parameters, we have to override this procedure.

	The value [[x_free]] is the renormalization factor of the total energy
	that corresponds to the free parameters. If there are no free
	parameters, the procedure will not change its value, which starts as
	unity. Otherwise, the fraction is typically decreased, but may also
	be increased in some cases.
	<<SF base: sf int: TBP>>=
	procedure :: generate_free => sf_int_generate_free
	<<SF base: procedures>>=
	subroutine sf_int_generate_free (sf_int, r, rb, x_free)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free
	r = 0
	rb= 1
	end subroutine sf_int_generate_free

	@ %def sf_int_generate_free
	@ Complete the structure-function kinematics, derived from an input
	parameter (array) $r$ between 0 and 1. The interaction momenta are
	calculated, and we return $x$ (the momentum fraction), and $f$ (the
	Jacobian factor for the map $r\to x$), if [[map]] is set.

	If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will
	become unity. If it is set, the structure-function implementation chooses a
	convenient mapping from $r$ to $x$ with Jacobian $f$.

	In the [[inverse_kinematics]] variant, we exchange the intent of [[x]]
	and [[r]]. The momenta are calculated only if the optional flag
	[[set_momenta]] is present and set. Internal parameters of [[sf_int]]
	are calculated only if the optional flag [[set_x]] is present and set.

	Update 2018-08-22: Throughout this algorithm, we now carry
	[[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before.
	This allows us to handle unstable endpoint numerics wherever
	necessary. The only place where the changes actually did matter was
	for inverse kinematics in the ISR setup, with a very soft photon, but
	it might be most sensible to apply the extension with [[xb]] everywhere.
	<<SF base: sf int: TBP>>=
	procedure (sf_int_complete_kinematics), deferred :: complete_kinematics
	procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	import
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	end subroutine sf_int_complete_kinematics
	end interface

	abstract interface
	subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	import
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	end subroutine sf_int_inverse_kinematics
	end interface

	@ %def sf_int_complete_kinematics
	@ %def sf_int_inverse_kinematics
	@ Single splitting: compute momenta, given $x$ input parameters. We
	assume that the incoming momentum is set. The status code is set to
	[[SF_FAILED_KINEMATICS]] if
	the $x$ array does not correspond to a valid momentum configuration.
	Otherwise, it is updated to [[SF_DONE_KINEMATICS]].

	We force the outgoing particle on-shell. The on-shell projection is
	determined by the [[on_shell_mode]]. The radiated particle should already be
	on shell.
	<<SF base: sf int: TBP>>=
	procedure :: split_momentum => sf_int_split_momentum
	<<SF base: procedures>>=
	subroutine sf_int_split_momentum (sf_int, x, xb)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	type(splitting_data_t) :: sd
	real(default) :: E1, E2
	logical :: fail
	if (sf_int%status >= SF_SEED_KINEMATICS) then
	k = sf_int%get_momentum (1)
	call sd%init (k, &
	sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
	collinear = size (x) == 1)
	call sd%set_t_bounds (x(1), xb(1))
	select case (size (x))
	case (1)
	case (3)
	if (sf_int%qmax_defined) then
	if (sf_int%qmin_defined) then
	call sd%sample_t (x(2), &
	t0 = - sf_int%qmax(1) 2, t1 = - sf_int%qmin(1) 2)
	else
	call sd%sample_t (x(2), &
	t0 = - sf_int%qmax(1) ** 2)
	end if
	else
	if (sf_int%qmin_defined) then
	call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2)
	else
	call sd%sample_t (x(2))
	end if
	end if
	call sd%sample_phi (x(3))
	case default
	call msg_bug ("Structure function: impossible number of parameters")
	end select
	q = sd%split_momentum (k)
	call on_shell (q, [sf_int%mr2, sf_int%mo2], &
	sf_int%on_shell_mode)
	call sf_int%set_momenta (q, outgoing=.true.)
	E1 = energy (q(1))
	E2 = energy (q(2))
	fail = E1 < 0 .or. E2 < 0 &
	.or. E1 ** 2 < sf_int%mr2(1) &
	.or. E2 ** 2 < sf_int%mo2(1)
	if (fail) then
	sf_int%status = SF_FAILED_KINEMATICS
	else
	sf_int%status = SF_DONE_KINEMATICS
	end if
	end if
	end subroutine sf_int_split_momentum

	@ %def sf_test_split_momentum
	@ Pair splitting: two incoming momenta, two radiated, two outgoing.
	This is simple because we insist on all momenta being collinear.
	<<SF base: sf int: TBP>>=
	procedure :: split_momenta => sf_int_split_momenta
	<<SF base: procedures>>=
	subroutine sf_int_split_momenta (sf_int, x, xb)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	type(vector4_t), dimension(2) :: k
	type(vector4_t), dimension(4) :: q
	real(default), dimension(4) :: E
	logical :: fail
	if (sf_int%status >= SF_SEED_KINEMATICS) then
	select case (size (x))
	case (2)
	case default
	call msg_bug ("Pair structure function: recoil requested &
	&but not implemented yet")
	end select
	k(1) = sf_int%get_momentum (1)
	k(2) = sf_int%get_momentum (2)
	q(1:2) = xb * k
	q(3:4) = x * k
	select case (size (sf_int%mr2))
	case (2)
	call on_shell (q, &
	[sf_int%mr2(1), sf_int%mr2(2), &
	sf_int%mo2(1), sf_int%mo2(2)], &
	sf_int%on_shell_mode)
	call sf_int%set_momenta (q, outgoing=.true.)
	E = energy (q)
	fail = any (E < 0) &
	.or. any (E(1:2) ** 2 < sf_int%mr2) &
	.or. any (E(3:4) ** 2 < sf_int%mo2)
	case default; call msg_bug ("split momenta: incorrect use")
	end select
	if (fail) then
	sf_int%status = SF_FAILED_KINEMATICS
	else
	sf_int%status = SF_DONE_KINEMATICS
	end if
	end if
	end subroutine sf_int_split_momenta

	@ %def sf_int_split_momenta
	@ Pair spectrum: the reduced version of the previous splitting,
	without radiated momenta.
	<<SF base: sf int: TBP>>=
	procedure :: reduce_momenta => sf_int_reduce_momenta
	<<SF base: procedures>>=
	subroutine sf_int_reduce_momenta (sf_int, x)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	type(vector4_t), dimension(2) :: k
	type(vector4_t), dimension(2) :: q
	real(default), dimension(2) :: E
	logical :: fail
	if (sf_int%status >= SF_SEED_KINEMATICS) then
	select case (size (x))
	case (2)
	case default
	call msg_bug ("Pair spectrum: recoil requested &
	&but not implemented yet")
	end select
	k(1) = sf_int%get_momentum (1)
	k(2) = sf_int%get_momentum (2)
	q = x * k
	call on_shell (q, &
	[sf_int%mo2(1), sf_int%mo2(2)], &
	sf_int%on_shell_mode)
	call sf_int%set_momenta (q, outgoing=.true.)
	E = energy (q)
	fail = any (E < 0) &
	.or. any (E ** 2 < sf_int%mo2)
	if (fail) then
	sf_int%status = SF_FAILED_KINEMATICS
	else
	sf_int%status = SF_DONE_KINEMATICS
	end if
	end if
	end subroutine sf_int_reduce_momenta

	@ %def sf_int_reduce_momenta
	@ The inverse procedure: we compute the [[x]] array from the momentum
	configuration. In an overriding TBP, we may also set internal data
	that depend on this, for convenience.

	NOTE: Here and above, the single-particle case is treated in detail,
	allowing for non-collinearity and non-vanishing masses and nontrivial
	momentum-transfer bounds. For the pair case, we currently implement
	only collinear splitting and assume massless particles. This should
	be improved.

	Update 2017-08-22: recover also [[xb]], using the updated [[recover]]
	method of the splitting-data object. Th
	<<SF base: sf int: TBP>>=
	procedure :: recover_x => sf_int_recover_x
	procedure :: base_recover_x => sf_int_recover_x
	<<SF base: procedures>>=
	subroutine sf_int_recover_x (sf_int, x, xb, x_free)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	type(vector4_t), dimension(:), allocatable :: k
	type(vector4_t), dimension(:), allocatable :: q
	type(splitting_data_t) :: sd
	if (sf_int%status >= SF_SEED_KINEMATICS) then
	allocate (k (sf_int%interaction_t%get_n_in ()))
	allocate (q (sf_int%interaction_t%get_n_out ()))
	k = sf_int%get_momenta (outgoing=.false.)
	q = sf_int%get_momenta (outgoing=.true.)
	select case (size (k))
	case (1)
	call sd%init (k(1), &
	sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
	collinear = size (x) == 1)
	call sd%recover (k(1), q, sf_int%on_shell_mode)
	x(1) = sd%get_x ()
	xb(1) = sd%get_xb ()
	select case (size (x))
	case (1)
	case (3)
	if (sf_int%qmax_defined) then
	if (sf_int%qmin_defined) then
	call sd%inverse_t (x(2), &
	t0 = - sf_int%qmax(1) 2, t1 = - sf_int%qmin(1) 2)
	else
	call sd%inverse_t (x(2), &
	t0 = - sf_int%qmax(1) ** 2)
	end if
	else
	if (sf_int%qmin_defined) then
	call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2)
	else
	call sd%inverse_t (x(2))
	end if
	end if
	call sd%inverse_phi (x(3))
	xb(2:3) = 1 - x(2:3)
	case default
	call msg_bug ("Structure function: impossible number &
	&of parameters")
	end select
	case (2)
	select case (size (x))
	case (2)
	case default
	call msg_bug ("Pair structure function: recoil requested &
	&but not implemented yet")
	end select
	select case (sf_int%on_shell_mode)
	case (KEEP_ENERGY)
	select case (size (q))
	case (4)
	x = energy (q(3:4)) / energy (k)
	xb= energy (q(1:2)) / energy (k)
	case (2)
	x = energy (q) / energy (k)
	xb= 1 - x
	end select
	case (KEEP_MOMENTUM)
	select case (size (q))
	case (4)
	x = longitudinal_part (q(3:4)) / longitudinal_part (k)
	xb= longitudinal_part (q(1:2)) / longitudinal_part (k)
	case (2)
	x = longitudinal_part (q) / longitudinal_part (k)
	xb= 1 - x
	end select
	end select
	end select
	end if
	end subroutine sf_int_recover_x

	@ %def sf_int_recover_x
	@ Apply the structure function, i.e., evaluate the interaction. For
	the calculation, we may use the stored momenta, any further
	information stored inside the [[sf_int]] implementation during
	kinematics setup, and the given energy scale. It may happen that for
	the given kinematics the value is not defined. This should be
	indicated by the status code.
	<<SF base: sf int: TBP>>=
	procedure (sf_int_apply), deferred :: apply
	<<SF base: interfaces>>=
	abstract interface
	subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub)
	import
	class(sf_int_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	end subroutine sf_int_apply
	end interface

	@ %def sf_int_apply
	@
	\subsection{Accessing the structure function}
	Return metadata. Once [[interaction_t]] is rewritten in OO, some of this will
	be inherited.

	The number of outgoing particles is equal to the number of incoming particles.
	The radiated particles are the difference.
	<<SF base: sf int: TBP>>=
	procedure :: get_n_in => sf_int_get_n_in
	procedure :: get_n_rad => sf_int_get_n_rad
	procedure :: get_n_out => sf_int_get_n_out
	<<SF base: procedures>>=
	pure function sf_int_get_n_in (object) result (n_in)
	class(sf_int_t), intent(in) :: object
	integer :: n_in
	n_in = object%interaction_t%get_n_in ()
	end function sf_int_get_n_in

	pure function sf_int_get_n_rad (object) result (n_rad)
	class(sf_int_t), intent(in) :: object
	integer :: n_rad
	n_rad = object%interaction_t%get_n_out () &
	- object%interaction_t%get_n_in ()
	end function sf_int_get_n_rad

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

	@ %def sf_int_get_n_in
	@ %def sf_int_get_n_rad
	@ %def sf_int_get_n_out
	@ Number of matrix element entries in the interaction:
	<<SF base: sf int: TBP>>=
	procedure :: get_n_states => sf_int_get_n_states
	<<SF base: procedures>>=
	function sf_int_get_n_states (sf_int) result (n_states)
	class(sf_int_t), intent(in) :: sf_int
	integer :: n_states
	n_states = sf_int%get_n_matrix_elements ()
	end function sf_int_get_n_states

	@ %def sf_int_get_n_states
	@ Return a specific state as a quantum-number array.
	<<SF base: sf int: TBP>>=
	procedure :: get_state => sf_int_get_state
	<<SF base: procedures>>=
	function sf_int_get_state (sf_int, i) result (qn)
	class(sf_int_t), intent(in) :: sf_int
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer, intent(in) :: i
	allocate (qn (sf_int%get_n_tot ()))
	qn = sf_int%get_quantum_numbers (i)
	end function sf_int_get_state

	@ %def sf_int_get_state
	@ Return the matrix-element values for all states. We can assume that
	the matrix elements are real, so we take the real part.
	<<SF base: sf int: TBP>>=
	procedure :: get_values => sf_int_get_values
	<<SF base: procedures>>=
	subroutine sf_int_get_values (sf_int, value)
	class(sf_int_t), intent(in) :: sf_int
	real(default), dimension(:), intent(out) :: value
	integer :: i
	if (sf_int%status >= SF_EVALUATED) then
	do i = 1, size (value)
	value(i) = real (sf_int%get_matrix_element (i))
	end do
	else
	value = 0
	end if
	end subroutine sf_int_get_values

	@ %def sf_int_get_values
	@
	\subsection{Direct calculations}
	Compute a structure function value (array) directly, given an array of $x$
	values and a scale. If the energy is also given, we initialize the
	kinematics for that energy, otherwise take it from a previous run.

	We assume that the [[E]] array has dimension [[n_in]], and the [[x]]
	array has [[n_par]].

	Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case.
	<<SF base: sf int: TBP>>=
	procedure :: compute_values => sf_int_compute_values
	<<SF base: procedures>>=
	subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E)
	class(sf_int_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: value
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(in) :: scale
	real(default), dimension(:), intent(in), optional :: E
	real(default), dimension(size (x)) :: xx, xxb
	real(default) :: f
	if (present (E)) call sf_int%seed_kinematics (E)
	if (sf_int%status >= SF_SEED_KINEMATICS) then
	call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.)
	call sf_int%apply (scale)
	call sf_int%get_values (value)
	value = value * f
	else
	value = 0
	end if
	end subroutine sf_int_compute_values

	@ %def sf_int_compute_values
	@ Compute just a single value for one of the states, i.e., throw the
	others away.
	<<SF base: sf int: TBP>>=
	procedure :: compute_value => sf_int_compute_value
	<<SF base: procedures>>=
	subroutine sf_int_compute_value &
	(sf_int, i_state, value, x, xb, scale, E)
	class(sf_int_t), intent(inout) :: sf_int
	integer, intent(in) :: i_state
	real(default), intent(out) :: value
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(in) :: scale
	real(default), dimension(:), intent(in), optional :: E
	real(default), dimension(:), allocatable :: value_array
	if (sf_int%status >= SF_INITIAL) then
	allocate (value_array (sf_int%get_n_states ()))
	call sf_int%compute_values (value_array, x, xb, scale, E)
	value = value_array(i_state)
	else
	value = 0
	end if
	end subroutine sf_int_compute_value

	@ %def sf_int_compute_value
	@
	\subsection{Structure-function instance}
	This is a wrapper for [[sf_int_t]] objects, such that we can
	build an array with different structure-function types. The
	structure-function contains an array (a sequence) of [[sf_int_t]]
	objects.

	The object, it holds the evaluator that connects the preceding part of the
	structure-function chain to the current interaction.

	It also stores the input and output parameter values for the
	contained structure function. The [[r]] array has a second dimension,
	corresponding to the mapping channels in a multi-channel
	configuration. There is a Jacobian entry [[f]] for each channel. The
	corresponding logical array [[mapping]] tells whether we apply the
	mapping appropriate for the current structure function in this channel.
	The [[x]] parameter values (energy fractions) are common to all
	channels.
	<<SF base: types>>=
	type :: sf_instance_t
	class(sf_int_t), allocatable :: int
	type(evaluator_t) :: eval
	real(default), dimension(:,:), allocatable :: r
	real(default), dimension(:,:), allocatable :: rb
	real(default), dimension(:), allocatable :: f
	logical, dimension(:), allocatable :: m
	real(default), dimension(:), allocatable :: x
	real(default), dimension(:), allocatable :: xb
	end type sf_instance_t

	@ %def sf_instance_t
	@
	\subsection{Structure-function chain}
	A chain is an array of structure functions [[sf]], initiated by a beam setup.
	We do not use this directly for evaluation, but create instances with
	copies of the contained interactions.

	[[n_par]] is the total number of parameters that is necessary for
	completely determining the structure-function chain. [[n_bound]] is
	the number of MC input parameters that are requested from the
	integrator. The difference of [[n_par]] and [[n_bound]] is the number
	of free parameters, which are generated by a structure-function
	object in generator mode.
	<<SF base: public>>=
	public :: sf_chain_t
	<<SF base: types>>=
	type, extends (beam_t) :: sf_chain_t
	type(beam_data_t), pointer :: beam_data => null ()
	integer :: n_in = 0
	integer :: n_strfun = 0
	integer :: n_par = 0
	integer :: n_bound = 0
	type(sf_instance_t), dimension(:), allocatable :: sf
	logical :: trace_enable = .false.
	integer :: trace_unit = 0
	contains
	<<SF base: sf chain: TBP>>
	end type sf_chain_t

	@ %def sf_chain_t
	@ Finalizer.
	<<SF base: sf chain: TBP>>=
	procedure :: final => sf_chain_final
	<<SF base: procedures>>=
	subroutine sf_chain_final (object)
	class(sf_chain_t), intent(inout) :: object
	integer :: i
	call object%final_tracing ()
	if (allocated (object%sf)) then
	do i = 1, size (object%sf, 1)
	associate (sf => object%sf(i))
	if (allocated (sf%int)) then
	call sf%int%final ()
	end if
	end associate
	end do
	end if
	call beam_final (object%beam_t)
	end subroutine sf_chain_final

	@ %def sf_chain_final
	@ Output.
	<<SF base: sf chain: TBP>>=
	procedure :: write => sf_chain_write
	<<SF base: procedures>>=
	subroutine sf_chain_write (object, unit)
	class(sf_chain_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u, i
	u = given_output_unit (unit)
	write (u, "(1x,A)") "Incoming particles / structure-function chain:"
	if (associated (object%beam_data)) then
	write (u, "(3x,A,I0)") "n_in = ", object%n_in
	write (u, "(3x,A,I0)") "n_strfun = ", object%n_strfun
	write (u, "(3x,A,I0)") "n_par = ", object%n_par
	if (object%n_par /= object%n_bound) then
	write (u, "(3x,A,I0)") "n_bound = ", object%n_bound
	end if
	call object%beam_data%write (u)
	call write_separator (u)
	call beam_write (object%beam_t, u)
	if (allocated (object%sf)) then
	do i = 1, object%n_strfun
	associate (sf => object%sf(i))
	call write_separator (u)
	if (allocated (sf%int)) then
	call sf%int%write (u)
	else
	write (u, "(1x,A)") "SF instance: [undefined]"
	end if
	end associate
	end do
	end if
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine sf_chain_write

	@ %def sf_chain_write
	@ Initialize: setup beams. The [[beam_data]] target must remain valid
	for the lifetime of the chain, since we just establish a pointer. The
	structure-function configuration array is used to initialize the
	individual structure-function entries. The target attribute is needed
	because the [[sf_int]] entries establish pointers to the configuration data.
	<<SF base: sf chain: TBP>>=
	procedure :: init => sf_chain_init
	<<SF base: procedures>>=
	subroutine sf_chain_init (sf_chain, beam_data, sf_config)
	class(sf_chain_t), intent(out) :: sf_chain
	type(beam_data_t), intent(in), target :: beam_data
	type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config
	integer :: i
	sf_chain%beam_data => beam_data
	sf_chain%n_in = beam_data%get_n_in ()
	call beam_init (sf_chain%beam_t, beam_data)
	if (present (sf_config)) then
	sf_chain%n_strfun = size (sf_config)
	allocate (sf_chain%sf (sf_chain%n_strfun))
	do i = 1, sf_chain%n_strfun
	call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data)
	end do
	end if
	end subroutine sf_chain_init

	@ %def sf_chain_init
	@ Receive the beam momenta from a source to which the beam interaction
	is linked.
	<<SF base: sf chain: TBP>>=
	procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta
	<<SF base: procedures>>=
	subroutine sf_chain_receive_beam_momenta (sf_chain)
	class(sf_chain_t), intent(inout), target :: sf_chain
	type(interaction_t), pointer :: beam_int
	beam_int => sf_chain%get_beam_int_ptr ()
	call beam_int%receive_momenta ()
	end subroutine sf_chain_receive_beam_momenta

	@ %def sf_chain_receive_beam_momenta
	@ Explicitly set the beam momenta.
	<<SF base: sf chain: TBP>>=
	procedure :: set_beam_momenta => sf_chain_set_beam_momenta
	<<SF base: procedures>>=
	subroutine sf_chain_set_beam_momenta (sf_chain, p)
	class(sf_chain_t), intent(inout) :: sf_chain
	type(vector4_t), dimension(:), intent(in) :: p
	call beam_set_momenta (sf_chain%beam_t, p)
	end subroutine sf_chain_set_beam_momenta

	@ %def sf_chain_set_beam_momenta
	@ Set a structure-function entry. We use the [[data]] input to
	allocate the [[int]] structure-function instance with appropriate
	type, then initialize the entry. The entry establishes a pointer to
	[[data]].

	The index [[i]] is the structure-function index in the chain.
	<<SF base: sf chain: TBP>>=
	procedure :: set_strfun => sf_chain_set_strfun
	<<SF base: procedures>>=
	subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data)
	class(sf_chain_t), intent(inout) :: sf_chain
	integer, intent(in) :: i
	integer, dimension(:), intent(in) :: beam_index
	class(sf_data_t), intent(in), target :: data
	integer :: n_par, j
	n_par = data%get_n_par ()
	call data%allocate_sf_int (sf_chain%sf(i)%int)
	associate (sf_int => sf_chain%sf(i)%int)
	call sf_int%init (data)
	call sf_int%set_beam_index (beam_index)
	call sf_int%set_par_index &
	([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)])
	sf_chain%n_par = sf_chain%n_par + n_par
	if (.not. data%is_generator ()) then
	sf_chain%n_bound = sf_chain%n_bound + n_par
	end if
	end associate
	end subroutine sf_chain_set_strfun

	@ %def sf_chain_set_strfun
	@ Return the number of structure-function parameters.
	<<SF base: sf chain: TBP>>=
	procedure :: get_n_par => sf_chain_get_n_par
	procedure :: get_n_bound => sf_chain_get_n_bound
	<<SF base: procedures>>=
	function sf_chain_get_n_par (sf_chain) result (n)
	class(sf_chain_t), intent(in) :: sf_chain
	integer :: n
	n = sf_chain%n_par
	end function sf_chain_get_n_par

	function sf_chain_get_n_bound (sf_chain) result (n)
	class(sf_chain_t), intent(in) :: sf_chain
	integer :: n
	n = sf_chain%n_bound
	end function sf_chain_get_n_bound

	@ %def sf_chain_get_n_par
	@ %def sf_chain_get_n_bound
	@ Return a pointer to the beam interaction.
	<<SF base: sf chain: TBP>>=
	procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr
	<<SF base: procedures>>=
	function sf_chain_get_beam_int_ptr (sf_chain) result (int)
	type(interaction_t), pointer :: int
	class(sf_chain_t), intent(in), target :: sf_chain
	int => beam_get_int_ptr (sf_chain%beam_t)
	end function sf_chain_get_beam_int_ptr

	@ %def sf_chain_get_beam_int_ptr
	@ Enable the trace feature: record structure function data (input
	parameters, $x$ values, evaluation result) to an external file.
	<<SF base: sf chain: TBP>>=
	procedure :: setup_tracing => sf_chain_setup_tracing
	procedure :: final_tracing => sf_chain_final_tracing
	<<SF base: procedures>>=
	subroutine sf_chain_setup_tracing (sf_chain, file)
	class(sf_chain_t), intent(inout) :: sf_chain
	type(string_t), intent(in) :: file
	if (sf_chain%n_strfun > 0) then
	sf_chain%trace_enable = .true.
	sf_chain%trace_unit = free_unit ()
	open (sf_chain%trace_unit, file = char (file), action = "write", &
	status = "replace")
	call sf_chain%write_trace_header ()
	else
	call msg_error ("Beam structure: no structure functions, tracing &
	&disabled")
	end if
	end subroutine sf_chain_setup_tracing

	subroutine sf_chain_final_tracing (sf_chain)
	class(sf_chain_t), intent(inout) :: sf_chain
	if (sf_chain%trace_enable) then
	close (sf_chain%trace_unit)
	sf_chain%trace_enable = .false.
	end if
	end subroutine sf_chain_final_tracing

	@ %def sf_chain_setup_tracing
	@ %def sf_chain_final_tracing
	@ Write the header for the tracing file.
	<<SF base: sf chain: TBP>>=
	procedure :: write_trace_header => sf_chain_write_trace_header
	<<SF base: procedures>>=
	subroutine sf_chain_write_trace_header (sf_chain)
	class(sf_chain_t), intent(in) :: sf_chain
	integer :: u
	if (sf_chain%trace_enable) then
	u = sf_chain%trace_unit
	write (u, "('# ',A)") "WHIZARD output: &
	&structure-function sampling data"
	write (u, "('# ',A,1x,I0)") "Number of sf records:", sf_chain%n_strfun
	write (u, "('# ',A,1x,I0)") "Number of parameters:", sf_chain%n_par
	write (u, "('# ',A)") "Columns: channel, p(n_par), x(n_par), f, Jac * f"
	end if
	end subroutine sf_chain_write_trace_header

	@ %def sf_chain_write_trace_header
	@ Write a record which collects the structure function data for the
	current data point. For the selected channel, we print first the
	input integration parameters, then the $x$ values, then the
	structure-function value summed over all quantum numbers, then the
	structure function value times the mapping Jacobian.
	<<SF base: sf chain: TBP>>=
	procedure :: trace => sf_chain_trace
	<<SF base: procedures>>=
	subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum)
	class(sf_chain_t), intent(in) :: sf_chain
	integer, intent(in) :: c_sel
	real(default), dimension(:,:), intent(in) :: p
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: f
	real(default), intent(in) :: sf_sum
	real(default) :: sf_sum_pac, f_sf_sum_pac
	integer :: u, i
	if (sf_chain%trace_enable) then
	u = sf_chain%trace_unit
	write (u, "(1x,I0)", advance="no") c_sel
	write (u, "(2x)", advance="no")
	do i = 1, sf_chain%n_par
	write (u, "(1x," // FMT_17 // ")", advance="no") p(i,c_sel)
	end do
	write (u, "(2x)", advance="no")
	do i = 1, sf_chain%n_par
	write (u, "(1x," // FMT_17 // ")", advance="no") x(i)
	end do
	write (u, "(2x)", advance="no")
	sf_sum_pac = sf_sum
	f_sf_sum_pac = f(c_sel) * sf_sum
	call pacify (sf_sum_pac, 1.E-28_default)
	call pacify (f_sf_sum_pac, 1.E-28_default)
	write (u, "(2(1x," // FMT_17 // "))") sf_sum_pac, f_sf_sum_pac
	end if
	end subroutine sf_chain_trace

	@ %def sf_chain_trace
	@
	\subsection{Chain instances}
	A structure-function chain instance contains copies of the
	interactions in the configuration chain, suitably linked to each other
	and connected by evaluators.

	After initialization, [[out_sf]] should point, for each beam, to the
	last structure function that affects this beam. [[out_sf_i]] should
	indicate the index of the corresponding outgoing particle within that
	structure-function interaction.

	Analogously, [[out_eval]] is the last evaluator in the
	structure-function chain, which contains the complete set of outgoing
	particles. [[out_eval_i]] should indicate the index of the outgoing
	particles, within that evaluator, which will initiate the collision.

	When calculating actual kinematics, we fill the [[p]], [[r]], and
	[[x]] arrays and the [[f]] factor. The [[p]] array denotes the MC
	input parameters as they come from the random-number generator. The
	[[r]] array results from applying global mappings. The [[x]] array
	results from applying structure-function local mappings. The $x$
	values can be interpreted directly as momentum fractions (or angle
	fractions, where recoil is involved). The [[f]] factor is the
	Jacobian that results from applying all mappings.

	Update 2017-08-22: carry and output all complements ([[pb]], [[rb]],
	[[xb]]). Previously, [[xb]] was not included in the record, and the
	output did not contain either. It does become more verbose, however.

	The [[mapping]] entry may store a global mapping that is applied to a
	combination of $x$ values and structure functions, as opposed to mappings that
	affect only a single structure function. It is applied before the latter
	mappings, in the transformation from the [[p]] array to the [[r]] array. For
	parameters affected by this mapping, we should ensure that they are not
	involved in a local mapping.
	<<SF base: public>>=
	public :: sf_chain_instance_t
	<<SF base: types>>=
	type, extends (beam_t) :: sf_chain_instance_t
	type(sf_chain_t), pointer :: config => null ()
	integer :: status = SF_UNDEFINED
	type(sf_instance_t), dimension(:), allocatable :: sf
	integer, dimension(:), allocatable :: out_sf
	integer, dimension(:), allocatable :: out_sf_i
	integer :: out_eval = 0
	integer, dimension(:), allocatable :: out_eval_i
	integer :: selected_channel = 0
	real(default), dimension(:,:), allocatable :: p, pb
	real(default), dimension(:,:), allocatable :: r, rb
	real(default), dimension(:), allocatable :: f
	real(default), dimension(:), allocatable :: x, xb
	logical, dimension(:), allocatable :: bound
	real(default) :: x_free = 1
	type(sf_channel_t), dimension(:), allocatable :: channel
	contains
	<<SF base: sf chain instance: TBP>>
	end type sf_chain_instance_t

	@ %def sf_chain_instance_t
	@ Finalizer.
	<<SF base: sf chain instance: TBP>>=
	procedure :: final => sf_chain_instance_final
	<<SF base: procedures>>=
	subroutine sf_chain_instance_final (object)
	class(sf_chain_instance_t), intent(inout) :: object
	integer :: i
	if (allocated (object%sf)) then
	do i = 1, size (object%sf, 1)
	associate (sf => object%sf(i))
	if (allocated (sf%int)) then
	call sf%eval%final ()
	call sf%int%final ()
	end if
	end associate
	end do
	end if
	call beam_final (object%beam_t)
	end subroutine sf_chain_instance_final

	@ %def sf_chain_instance_final
	@ Output.
	<<SF base: sf chain instance: TBP>>=
	procedure :: write => sf_chain_instance_write
	<<SF base: procedures>>=
	subroutine sf_chain_instance_write (object, unit, col_verbose)
	class(sf_chain_instance_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: col_verbose
	integer :: u, i, c
	u = given_output_unit (unit)
	write (u, "(1x,A)", advance="no") "Structure-function chain instance:"
	call write_sf_status (object%status, u)
	if (allocated (object%out_sf)) then
	write (u, "(3x,A)", advance="no") "outgoing (interactions) ="
	do i = 1, size (object%out_sf)
	write (u, "(1x,I0,':',I0)", advance="no") &
	object%out_sf(i), object%out_sf_i(i)
	end do
	write (u, *)
	end if
	if (object%out_eval /= 0) then
	write (u, "(3x,A)", advance="no") "outgoing (evaluators) ="
	do i = 1, size (object%out_sf)
	write (u, "(1x,I0,':',I0)", advance="no") &
	object%out_eval, object%out_eval_i(i)
	end do
	write (u, *)
	end if
	if (allocated (object%sf)) then
	if (size (object%sf) /= 0) then
	write (u, "(1x,A)") "Structure-function parameters:"
	do c = 1, size (object%f)
	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,9(1x,F9.7))") "p =", object%p(:,c)
	write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c)
	write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c)
	write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c)
	write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c)
	write (u, "(3x,A)", advance="no") "m ="
	call object%channel(c)%write (u)
	end do
	write (u, "(3x,A,9(1x,F9.7))") "x =", object%x
	write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb
	if (.not. all (object%bound)) then
	write (u, "(3x,A,9(1x,L1))") "bound =", object%bound
	end if
	end if
	end if
	call write_separator (u)
	call beam_write (object%beam_t, u, col_verbose = col_verbose)
	if (allocated (object%sf)) then
	do i = 1, size (object%sf)
	associate (sf => object%sf(i))
	call write_separator (u)
	if (allocated (sf%int)) then
	if (allocated (sf%r)) then
	write (u, "(1x,A)") "Structure-function parameters:"
	do c = 1, size (sf%f)
	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,9(1x,F9.7))") "r =", sf%r(:,c)
	write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c)
	write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c)
	write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c)
	end do
	write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x
	write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb
	end if
	call sf%int%write(u)
	if (.not. sf%eval%is_empty ()) then
	call sf%eval%write (u, col_verbose = col_verbose)
	end if
	end if
	end associate
	end do
	end if
	end subroutine sf_chain_instance_write

	@ %def sf_chain_instance_write
	@ Initialize. This creates a copy of the interactions in the
	configuration chain, assumed to be properly initialized. In the copy,
	we allocate the [[p]] etc.\ arrays.

	The brute-force assignment of the [[sf]] component would be
	straightforward, but we provide a more fine-grained copy.
	In any case, the copy is deep as far as allocatables are concerned,
	but for the contained [[interaction_t]] objects the copy is shallow,
	as long as we do not bind defined assignment to the type. Therefore,
	we have to re-assign the [[interaction_t]] components explicitly, this
	time calling the proper defined assignment. Furthermore, we allocate
	the parameter arrays for each structure function.
	<<SF base: sf chain instance: TBP>>=
	procedure :: init => sf_chain_instance_init
	<<SF base: procedures>>=
	subroutine sf_chain_instance_init (chain, config, n_channel)
	class(sf_chain_instance_t), intent(out), target :: chain
	type(sf_chain_t), intent(in), target :: config
	integer, intent(in) :: n_channel
	integer :: i, j
	integer :: n_par_tot, n_par, n_strfun
	chain%config => config
	n_strfun = config%n_strfun
	chain%beam_t = config%beam_t
	allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in))
	allocate (chain%out_eval_i (config%n_in))
	chain%out_sf = 0
	chain%out_sf_i = [(i, i = 1, config%n_in)]
	chain%out_eval_i = chain%out_sf_i
	n_par_tot = 0
	if (n_strfun /= 0) then
	allocate (chain%sf (n_strfun))
	do i = 1, n_strfun
	associate (sf => chain%sf(i))
	allocate (sf%int, source=config%sf(i)%int)
	sf%int%interaction_t = config%sf(i)%int%interaction_t
	n_par = size (sf%int%par_index)
	allocate (sf%r (n_par, n_channel)); sf%r = 0
	allocate (sf%rb(n_par, n_channel)); sf%rb= 0
	allocate (sf%f (n_channel)); sf%f = 0
	allocate (sf%m (n_channel)); sf%m = .false.
	allocate (sf%x (n_par)); sf%x = 0
	allocate (sf%xb(n_par)); sf%xb= 0
	n_par_tot = n_par_tot + n_par
	end associate
	end do
	allocate (chain%p (n_par_tot, n_channel)); chain%p = 0
	allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0
	allocate (chain%r (n_par_tot, n_channel)); chain%r = 0
	allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0
	allocate (chain%f (n_channel)); chain%f = 0
	allocate (chain%x (n_par_tot)); chain%x = 0
	allocate (chain%xb(n_par_tot)); chain%xb= 0
	call allocate_sf_channels &
	(chain%channel, n_channel=n_channel, n_strfun=n_strfun)
	end if
	allocate (chain%bound (n_par_tot), source = .true.)
	do i = 1, n_strfun
	associate (sf => chain%sf(i))
	if (sf%int%is_generator ()) then
	do j = 1, size (sf%int%par_index)
	chain%bound(sf%int%par_index(j)) = .false.
	end do
	end if
	end associate
	end do
	chain%status = SF_INITIAL
	end subroutine sf_chain_instance_init

	@ %def sf_chain_instance_init
	@ Manually select a channel.
	<<SF base: sf chain instance: TBP>>=
	procedure :: select_channel => sf_chain_instance_select_channel
	<<SF base: procedures>>=
	subroutine sf_chain_instance_select_channel (chain, channel)
	class(sf_chain_instance_t), intent(inout) :: chain
	integer, intent(in), optional :: channel
	if (present (channel)) then
	chain%selected_channel = channel
	else
	chain%selected_channel = 0
	end if
	end subroutine sf_chain_instance_select_channel

	@ %def sf_chain_instance_select_channel
	@ Copy a channel-mapping object to the structure-function
	chain instance. We assume that assignment is sufficient, i.e., any
	non-static components of the [[channel]] object are allocatable und
	thus recursively copied.

	After the copy, we extract the single-entry mappings and activate them
	for the individual structure functions. If there is a multi-entry
	mapping, we obtain the corresponding MC parameter indices and set them
	in the copy of the channel object.
	<<SF base: sf chain instance: TBP>>=
	procedure :: set_channel => sf_chain_instance_set_channel
	<<SF base: procedures>>=
	subroutine sf_chain_instance_set_channel (chain, c, channel)
	class(sf_chain_instance_t), intent(inout) :: chain
	integer, intent(in) :: c
	type(sf_channel_t), intent(in) :: channel
	integer :: i, j, k
	if (chain%status >= SF_INITIAL) then
	chain%channel(c) = channel
	j = 0
	do i = 1, chain%config%n_strfun
	associate (sf => chain%sf(i))
	sf%m(c) = channel%is_single_mapping (i)
	if (channel%is_multi_mapping (i)) then
	do k = 1, size (sf%int%beam_index)
	j = j + 1
	call chain%channel(c)%set_par_index &
	(j, sf%int%par_index(k))
	end do
	end if
	end associate
	end do
	if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then
	print *, "index last filled = ", j
	print *, "number of parameters = ", &
	chain%channel(c)%get_multi_mapping_n_par ()
	call msg_bug ("Structure-function setup: mapping index mismatch")
	end if
	chain%status = SF_INITIAL
	end if
	end subroutine sf_chain_instance_set_channel

	@ %def sf_chain_instance_set_channel
	@ Link the interactions in the chain. First, link the beam instance
	to its template in the configuration chain, which should have the
	appropriate momenta fixed.

	Then, we follow the chain via the
	arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to)
	two-dimensional, the entries correspond to the beam particle(s).
	For each beam, the entry [[out_sf]] points to the last interaction
	that affected this beam, and [[out_sf_i]] is the
	out-particle index within that interaction. For the initial beam,
	[[out_sf]] is zero by definition.

	For each entry in the chain, we scan the affected beams (one or two).
	We look for [[out_sf]] and link the out-particle there to the
	corresponding in-particle in the current interaction. Then, we update
	the entry in [[out_sf]] and [[out_sf_i]] to point to the current
	interaction.
	<<SF base: sf chain instance: TBP>>=
	procedure :: link_interactions => sf_chain_instance_link_interactions
	<<SF base: procedures>>=
	subroutine sf_chain_instance_link_interactions (chain)
	class(sf_chain_instance_t), intent(inout), target :: chain
	type(interaction_t), pointer :: int
	integer :: i, j, b
	if (chain%status >= SF_INITIAL) then
	do b = 1, chain%config%n_in
	int => beam_get_int_ptr (chain%beam_t)
	call interaction_set_source_link (int, b, &
	chain%config%beam_t, b)
	end do
	if (allocated (chain%sf)) then
	do i = 1, size (chain%sf)
	associate (sf_int => chain%sf(i)%int)
	do j = 1, size (sf_int%beam_index)
	b = sf_int%beam_index(j)
	call link (sf_int%interaction_t, b, sf_int%incoming(j))
	chain%out_sf(b) = i
	chain%out_sf_i(b) = sf_int%outgoing(j)
	end do
	end associate
	end do
	end if
	chain%status = SF_DONE_LINKS
	end if
	contains
	subroutine link (int, b, in_index)
	type(interaction_t), intent(inout) :: int
	integer, intent(in) :: b, in_index
	integer :: i
	i = chain%out_sf(b)
	select case (i)
	case (0)
	call interaction_set_source_link (int, in_index, &
	chain%beam_t, chain%out_sf_i(b))
	case default
	call int%set_source_link (in_index, &
	chain%sf(i)%int, chain%out_sf_i(b))
	end select
	end subroutine link
	end subroutine sf_chain_instance_link_interactions

	@ %def sf_chain_instance_link_interactions
	@ Exchange the quantum-number masks between the interactions in the
	chain, so we can combine redundant entries and detect any obvious mismatch.

	We proceed first in the forward direction and then backwards again.

	After this is finished, we finalize initialization by calling the
	[[setup_constants]] method, which prepares constant data that depend on the
	matrix element structure.
	<<SF base: sf chain instance: TBP>>=
	procedure :: exchange_mask => sf_chain_exchange_mask
	<<SF base: procedures>>=
	subroutine sf_chain_exchange_mask (chain)
	class(sf_chain_instance_t), intent(inout), target :: chain
	type(interaction_t), pointer :: int
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	integer :: i
	if (chain%status >= SF_DONE_LINKS) then
	if (allocated (chain%sf)) then
	int => beam_get_int_ptr (chain%beam_t)
	allocate (mask (int%get_n_out ()))
	mask = int%get_mask ()
	if (size (chain%sf) /= 0) then
	do i = 1, size (chain%sf) - 1
	call interaction_exchange_mask (chain%sf(i)%int%interaction_t)
	end do
	do i = size (chain%sf), 1, -1
	call interaction_exchange_mask (chain%sf(i)%int%interaction_t)
	end do
	if (any (mask .neqv. int%get_mask ())) then
	chain%status = SF_FAILED_MASK
	return
	end if
	do i = 1, size (chain%sf)
	call chain%sf(i)%int%setup_constants ()
	end do
	end if
	end if
	chain%status = SF_DONE_MASK
	end if
	end subroutine sf_chain_exchange_mask

	@ %def sf_chain_exchange_mask
	@ Initialize the evaluators that connect the interactions in the
	chain.
	<<SF base: sf chain instance: TBP>>=
	procedure :: init_evaluators => sf_chain_instance_init_evaluators
	<<SF base: procedures>>=
	subroutine sf_chain_instance_init_evaluators (chain, extended_sf)
	class(sf_chain_instance_t), intent(inout), target :: chain
	logical, intent(in), optional :: extended_sf
	type(interaction_t), pointer :: int
	type(quantum_numbers_mask_t) :: mask
	integer :: i
	logical :: yorn
	yorn = .false.; if (present (extended_sf)) yorn = extended_sf
	if (chain%status >= SF_DONE_MASK) then
	if (allocated (chain%sf)) then
	if (size (chain%sf) /= 0) then
	mask = quantum_numbers_mask (.false., .false., .true.)
	int => beam_get_int_ptr (chain%beam_t)
	do i = 1, size (chain%sf)
	associate (sf => chain%sf(i))
	if (yorn) then
	if (int%get_n_sub () == 0) then
	call int%declare_subtraction (n_beams_rescaled)
	end if
	if (sf%int%interaction_t%get_n_sub () == 0) then
	call sf%int%interaction_t%declare_subtraction (n_beams_rescaled)
	end if
	end if
	call sf%eval%init_product (int, sf%int%interaction_t, mask,&
	& ignore_sub_for_qn = .true.)
	if (sf%eval%is_empty ()) then
	chain%status = SF_FAILED_CONNECTIONS
	return
	end if
	int => sf%eval%interaction_t
	end associate
	end do
	call find_outgoing_particles ()
	end if
	else if (chain%out_eval == 0) then
	int => beam_get_int_ptr (chain%beam_t)
	call int%tag_hard_process ()
	end if
	chain%status = SF_DONE_CONNECTIONS
	end if
	contains
	<<SF base: init evaluators: find outgoing particles>>
	end subroutine sf_chain_instance_init_evaluators

	@ %def sf_chain_instance_init_evaluators
	@ For debug purposes
	<<SF base: sf chain instance: TBP>>=
	procedure :: write_interaction => sf_chain_instance_write_interaction
	<<SF base: procedures>>=
	subroutine sf_chain_instance_write_interaction (chain, i_sf, i_int, unit)
	class(sf_chain_instance_t), intent(in) :: chain
	integer, intent(in) :: i_sf, i_int
	integer, intent(in) :: unit
	class(interaction_t), pointer :: int_in1 => null ()
	class(interaction_t), pointer :: int_in2 => null ()
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	if (chain%status >= SF_DONE_MASK) then
	if (allocated (chain%sf)) then
	int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1)
	int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2)
	if (int_in1%get_tag () == i_int) then
	call int_in1%basic_write (u)
	else if (int_in2%get_tag () == i_int) then
	call int_in2%basic_write (u)
	else
	write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int
	end if
	else
	write (u, "(A)") 'No sf_chain allocated!'
	end if
	else
	write (u, "(A)") 'sf_chain not ready!'
	end if
	end subroutine sf_chain_instance_write_interaction

	@ %def sf_chain_instance_write_interaction
	@ This is an internal subroutine of the previous one: After evaluators
	are set, trace the outgoing particles to the last evaluator. We only
	need the first channel, all channels are equivalent for this purpose.

	For each beam, the outgoing particle is located by [[out_sf]] (the
	structure-function object where it originates) and [[out_sf_i]] (the
	index within that object). This particle is referenced by the
	corresponding evaluator, which in turn is referenced by the next
	evaluator, until we are at the end of the chain. We can trace back
	references by [[interaction_find_link]]. Knowing that [[out_eval]] is
	the index of the last evaluator, we thus determine [[out_eval_i]], the
	index of the outgoing particle within that evaluator.
	<<SF base: init evaluators: find outgoing particles>>=
	subroutine find_outgoing_particles ()
	type(interaction_t), pointer :: int, int_next
	integer :: i, j, out_sf, out_i
	chain%out_eval = size (chain%sf)
	do j = 1, size (chain%out_eval_i)
	out_sf = chain%out_sf(j)
	out_i = chain%out_sf_i(j)
	if (out_sf == 0) then
	int => beam_get_int_ptr (chain%beam_t)
	out_sf = 1
	else
	int => chain%sf(out_sf)%int%interaction_t
	end if
	do i = out_sf, chain%out_eval
	int_next => chain%sf(i)%eval%interaction_t
	out_i = interaction_find_link (int_next, int, out_i)
	int => int_next
	end do
	chain%out_eval_i(j) = out_i
	end do
	call int%tag_hard_process (chain%out_eval_i)
	end subroutine find_outgoing_particles

	@ %def find_outgoing_particles
	@ Compute the kinematics in the chain instance. We can assume that
	the seed momenta are set in the configuration beams. Scanning the
	chain, we first transfer the incoming momenta. Then, the use up the MC input
	parameter array [[p]] to compute the radiated and outgoing momenta.

	In the multi-channel case, [[c_sel]] is the channel which we use for
	computing the kinematics and the [[x]] values. In the other channels,
	we invert the kinematics in order to recover the corresponding rows in
	the [[r]] array, and the Jacobian [[f]].

	We first apply any global mapping to transform the input [[p]] into
	the array [[r]]. This is then given to the structure functions which
	compute the final array [[x]] and Jacobian factors [[f]], which we
	multiply to obtain the overall Jacobian.
	<<SF base: sf chain instance: TBP>>=
	procedure :: compute_kinematics => sf_chain_instance_compute_kinematics
	<<SF base: procedures>>=
	subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in)
	class(sf_chain_instance_t), intent(inout), target :: chain
	integer, intent(in) :: c_sel
	real(default), dimension(:), intent(in) :: p_in
	type(interaction_t), pointer :: int
	real(default) :: f_mapping
	integer :: i, j, c
	if (chain%status >= SF_DONE_CONNECTIONS) then
	call chain%select_channel (c_sel)
	int => beam_get_int_ptr (chain%beam_t)
	call int%receive_momenta ()
	if (allocated (chain%sf)) then
	if (size (chain%sf) /= 0) then
	forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL
	chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default)
	chain%pb(:,c_sel) = 1 - chain%p(:,c_sel)
	chain%f = 1
	chain%x_free = 1
	do i = 1, size (chain%sf)
	associate (sf => chain%sf(i))
	call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), &
	chain%x_free)
	do j = 1, size (sf%x)
	if (.not. chain%bound(sf%int%par_index(j))) then
	chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel)
	chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel)
	end if
	end do
	end associate
	end do
	if (allocated (chain%channel(c_sel)%multi_mapping)) then
	call chain%channel(c_sel)%multi_mapping%compute &
	(chain%r(:,c_sel), chain%rb(:,c_sel), &
	f_mapping, &
	chain%p(:,c_sel), chain%pb(:,c_sel), &
	chain%x_free)
	chain%f(c_sel) = f_mapping
	else
	chain%r (:,c_sel) = chain%p (:,c_sel)
	chain%rb(:,c_sel) = chain%pb(:,c_sel)
	chain%f(c_sel) = 1
	end if
	do i = 1, size (chain%sf)
	associate (sf => chain%sf(i))
	call sf%int%seed_kinematics ()
	do j = 1, size (sf%x)
	sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel)
	sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel)
	end do
	call sf%int%complete_kinematics &
	(sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), &
	sf%m(c_sel))
	do j = 1, size (sf%x)
	chain%x(sf%int%par_index(j)) = sf%x(j)
	chain%xb(sf%int%par_index(j)) = sf%xb(j)
	end do
	if (sf%int%status <= SF_FAILED_KINEMATICS) then
	chain%status = SF_FAILED_KINEMATICS
	return
	end if
	do c = 1, size (sf%f)
	if (c /= c_sel) then
	call sf%int%inverse_kinematics &
	(sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c))
	do j = 1, size (sf%x)
	chain%r (sf%int%par_index(j),c) = sf%r (j,c)
	chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
	end do
	end if
	chain%f(c) = chain%f(c) * sf%f(c)
	end do
	if (.not. sf%eval%is_empty ()) then
	call sf%eval%receive_momenta ()
	end if
	end associate
	end do
	do c = 1, size (chain%f)
	if (c /= c_sel) then
	if (allocated (chain%channel(c)%multi_mapping)) then
	call chain%channel(c)%multi_mapping%inverse &
	(chain%r(:,c), chain%rb(:,c), &
	f_mapping, &
	chain%p(:,c), chain%pb(:,c), &
	chain%x_free)
	chain%f(c) = chain%f(c) * f_mapping
	else
	chain%p (:,c) = chain%r (:,c)
	chain%pb(:,c) = chain%rb(:,c)
	end if
	end if
	end do
	end if
	end if
	chain%status = SF_DONE_KINEMATICS
	end if
	end subroutine sf_chain_instance_compute_kinematics

	@ %def sf_chain_instance_compute_kinematics
	@ This is a variant of the previous procedure. We know the $x$ parameters and
	reconstruct the momenta and the MC input parameters [[p]]. We do not need to
	select a channel.

	Note: this is probably redundant, since the method we actually want
	starts from the momenta, recovers all $x$ parameters, and then
	inverts mappings. See below [[recover_kinematics]].
	<<SF base: sf chain instance: TBP>>=
	procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics
	<<SF base: procedures>>=
	subroutine sf_chain_instance_inverse_kinematics (chain, x, xb)
	class(sf_chain_instance_t), intent(inout), target :: chain
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	type(interaction_t), pointer :: int
	real(default) :: f_mapping
	integer :: i, j, c
	if (chain%status >= SF_DONE_CONNECTIONS) then
	call chain%select_channel ()
	int => beam_get_int_ptr (chain%beam_t)
	call int%receive_momenta ()
	if (allocated (chain%sf)) then
	chain%f = 1
	if (size (chain%sf) /= 0) then
	forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL
	chain%x = x
	chain%xb= xb
	do i = 1, size (chain%sf)
	associate (sf => chain%sf(i))
	call sf%int%seed_kinematics ()
	do j = 1, size (sf%x)
	sf%x(j) = chain%x(sf%int%par_index(j))
	sf%xb(j) = chain%xb(sf%int%par_index(j))
	end do
	do c = 1, size (sf%f)
	call sf%int%inverse_kinematics &
	(sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
	set_momenta = c==1)
	chain%f(c) = chain%f(c) * sf%f(c)
	do j = 1, size (sf%x)
	chain%r (sf%int%par_index(j),c) = sf%r (j,c)
	chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
	end do
	end do
	if (.not. sf%eval%is_empty ()) then
	call sf%eval%receive_momenta ()
	end if
	end associate
	end do
	do c = 1, size (chain%f)
	if (allocated (chain%channel(c)%multi_mapping)) then
	call chain%channel(c)%multi_mapping%inverse &
	(chain%r(:,c), chain%rb(:,c), &
	f_mapping, &
	chain%p(:,c), chain%pb(:,c), &
	chain%x_free)
	chain%f(c) = chain%f(c) * f_mapping
	else
	chain%p (:,c) = chain%r (:,c)
	chain%pb(:,c) = chain%rb(:,c)
	end if
	end do
	end if
	end if
	chain%status = SF_DONE_KINEMATICS
	end if
	end subroutine sf_chain_instance_inverse_kinematics

	@ %def sf_chain_instance_inverse_kinematics
	@ Recover the kinematics: assuming that the last evaluator has
	been filled with a valid set of momenta, we travel the momentum links
	backwards and fill the preceding evaluators and, as a side effect,
	interactions. We stop at the beam interaction.

	After all momenta are set, apply the [[inverse_kinematics]] procedure
	above, suitably modified, to recover the $x$ and $p$ parameters and
	the Jacobian factors.

	The [[c_sel]] (channel) argument is just used to mark a selected
	channel for the records, otherwise the recovery procedure is
	independent of this.
	<<SF base: sf chain instance: TBP>>=
	procedure :: recover_kinematics => sf_chain_instance_recover_kinematics
	<<SF base: procedures>>=
	subroutine sf_chain_instance_recover_kinematics (chain, c_sel)
	class(sf_chain_instance_t), intent(inout), target :: chain
	integer, intent(in) :: c_sel
	real(default) :: f_mapping
	integer :: i, j, c
	if (chain%status >= SF_DONE_CONNECTIONS) then
	call chain%select_channel (c_sel)
	if (allocated (chain%sf)) then
	do i = size (chain%sf), 1, -1
	associate (sf => chain%sf(i))
	if (.not. sf%eval%is_empty ()) then
	call interaction_send_momenta (sf%eval%interaction_t)
	end if
	end associate
	end do
	chain%f = 1
	if (size (chain%sf) /= 0) then
	forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL
	chain%x_free = 1
	do i = 1, size (chain%sf)
	associate (sf => chain%sf(i))
	call sf%int%seed_kinematics ()
	call sf%int%recover_x (sf%x, sf%xb, chain%x_free)
	do j = 1, size (sf%x)
	chain%x(sf%int%par_index(j)) = sf%x(j)
	chain%xb(sf%int%par_index(j)) = sf%xb(j)
	end do
	do c = 1, size (sf%f)
	call sf%int%inverse_kinematics &
	(sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
	set_momenta = .false.)
	chain%f(c) = chain%f(c) * sf%f(c)
	do j = 1, size (sf%x)
	chain%r (sf%int%par_index(j),c) = sf%r (j,c)
	chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
	end do
	end do
	end associate
	end do
	do c = 1, size (chain%f)
	if (allocated (chain%channel(c)%multi_mapping)) then
	call chain%channel(c)%multi_mapping%inverse &
	(chain%r(:,c), chain%rb(:,c), &
	f_mapping, &
	chain%p(:,c), chain%pb(:,c), &
	chain%x_free)
	chain%f(c) = chain%f(c) * f_mapping
	else
	chain%p (:,c) = chain%r (:,c)
	chain%pb(:,c) = chain%rb(:,c)
	end if
	end do
	end if
	end if
	chain%status = SF_DONE_KINEMATICS
	end if
	end subroutine sf_chain_instance_recover_kinematics

	@ %def sf_chain_instance_recover_kinematics
	@ Return the initial beam momenta to their source, thus completing
	kinematics recovery. Obviously, this works as a side effect.
	<<SF base: sf chain instance: TBP>>=
	procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta
	<<SF base: procedures>>=
	subroutine sf_chain_instance_return_beam_momenta (chain)
	class(sf_chain_instance_t), intent(in), target :: chain
	type(interaction_t), pointer :: int
	if (chain%status >= SF_DONE_KINEMATICS) then
	int => beam_get_int_ptr (chain%beam_t)
	call interaction_send_momenta (int)
	end if
	end subroutine sf_chain_instance_return_beam_momenta

	@ %def sf_chain_instance_return_beam_momenta
	@ Evaluate all interactions in the chain and the product evaluators.
	We provide a [[scale]] argument that is given to all structure
	functions in the chain.

	Hadronic NLO calculations involve rescaled fractions of the original beam
	momentum. In particular, we have to handle the following cases:
	\begin{itemize}
	\item normal evaluation (where [[i_sub = 0]]) for all terms except the
	real non-subtracted,
	\item rescaled momentum fraction for both beams in the case of the
	real non-subtracted term ([[i_sub = 0]]),
	\item and rescaled momentum fraction for one of both beams in the case of the
	subtraction and DGLAP component ([[i_sub = 1,2]]).
	\end{itemize}
	For the collinear final or intial state counter terms, we apply a rescaling to
	one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions.
	<<SF base: sf chain instance: TBP>>=
	procedure :: evaluate => sf_chain_instance_evaluate
	<<SF base: procedures>>=
	subroutine sf_chain_instance_evaluate (chain, scale, negative_sf, sf_rescale)
	class(sf_chain_instance_t), intent(inout), target :: chain
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(inout), optional :: sf_rescale
	type(interaction_t), pointer :: out_int
	real(default) :: sf_sum
	integer :: i_beam, i_sub, n_sub
	logical :: rescale
	n_sub = 0
	rescale = .false.; if (present (sf_rescale)) rescale = .true.
	if (rescale) then
	n_sub = chain%get_n_sub ()
	end if
	if (chain%status >= SF_DONE_KINEMATICS) then
	if (allocated (chain%sf)) then
	if (size (chain%sf) /= 0) then
	do i_beam = 1, size (chain%sf)
	associate (sf => chain%sf(i_beam))
	if (rescale) then
	call sf_rescale%set_i_beam (i_beam)
	do i_sub = 0, n_sub
	select case (i_sub)
	case (0)
	if (n_sub == 0) then
	call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
	else
	call sf%int%apply (scale, negative_sf, i_sub = i_sub)
	end if
	case default
	if (i_beam == i_sub) then
	call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
	else
	call sf%int%apply (scale, negative_sf, i_sub = i_sub)
	end if
	end select
	end do
	else
	call sf%int%apply (scale, negative_sf, i_sub = n_sub)
	end if
	if (sf%int%status <= SF_FAILED_EVALUATION) then
	chain%status = SF_FAILED_EVALUATION
	return
	end if
	if (.not. sf%eval%is_empty ()) call sf%eval%evaluate ()
	end associate
	end do
	out_int => chain%get_out_int_ptr ()
	sf_sum = real (out_int%sum ())
	call chain%config%trace &
	(chain%selected_channel, chain%p, chain%x, chain%f, sf_sum)
	end if
	end if
	chain%status = SF_EVALUATED
	end if
	end subroutine sf_chain_instance_evaluate

	@ %def sf_chain_instance_evaluate
	@
	\subsection{Access to the chain instance}
	Transfer the outgoing momenta to the array [[p]]. We assume that
	array sizes match.
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_out_momenta => sf_chain_instance_get_out_momenta
	<<SF base: procedures>>=
	subroutine sf_chain_instance_get_out_momenta (chain, p)
	class(sf_chain_instance_t), intent(in), target :: chain
	type(vector4_t), dimension(:), intent(out) :: p
	type(interaction_t), pointer :: int
	integer :: i, j
	if (chain%status >= SF_DONE_KINEMATICS) then
	do j = 1, size (chain%out_sf)
	i = chain%out_sf(j)
	select case (i)
	case (0)
	int => beam_get_int_ptr (chain%beam_t)
	case default
	int => chain%sf(i)%int%interaction_t
	end select
	p(j) = int%get_momentum (chain%out_sf_i(j))
	end do
	end if
	end subroutine sf_chain_instance_get_out_momenta

	@ %def sf_chain_instance_get_out_momenta
	@ Return a pointer to the last evaluator in the chain (to the interaction).
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr
	<<SF base: procedures>>=
	function sf_chain_instance_get_out_int_ptr (chain) result (int)
	class(sf_chain_instance_t), intent(in), target :: chain
	type(interaction_t), pointer :: int
	if (chain%out_eval == 0) then
	int => beam_get_int_ptr (chain%beam_t)
	else
	int => chain%sf(chain%out_eval)%eval%interaction_t
	end if
	end function sf_chain_instance_get_out_int_ptr

	@ %def sf_chain_instance_get_out_int_ptr
	@ Return the index of the [[j]]-th outgoing particle, within the last
	evaluator.
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_out_i => sf_chain_instance_get_out_i
	<<SF base: procedures>>=
	function sf_chain_instance_get_out_i (chain, j) result (i)
	class(sf_chain_instance_t), intent(in) :: chain
	integer, intent(in) :: j
	integer :: i
	i = chain%out_eval_i(j)
	end function sf_chain_instance_get_out_i

	@ %def sf_chain_instance_get_out_i
	@ Return the mask for the outgoing particle(s), within the last evaluator.
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_out_mask => sf_chain_instance_get_out_mask
	<<SF base: procedures>>=
	function sf_chain_instance_get_out_mask (chain) result (mask)
	class(sf_chain_instance_t), intent(in), target :: chain
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	type(interaction_t), pointer :: int
	allocate (mask (chain%config%n_in))
	int => chain%get_out_int_ptr ()
	mask = int%get_mask (chain%out_eval_i)
	end function sf_chain_instance_get_out_mask

	@ %def sf_chain_instance_get_out_mask
	@ Return the array of MC input parameters that corresponds to channel [[c]].
	This is the [[p]] array, the parameters before all mappings.

	The [[p]] array may be deallocated. This should correspond to a
	zero-size [[r]] argument, so nothing to do then.
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_mcpar => sf_chain_instance_get_mcpar
	<<SF base: procedures>>=
	subroutine sf_chain_instance_get_mcpar (chain, c, r)
	class(sf_chain_instance_t), intent(in) :: chain
	integer, intent(in) :: c
	real(default), dimension(:), intent(out) :: r
	if (allocated (chain%p)) r = pack (chain%p(:,c), chain%bound)
	end subroutine sf_chain_instance_get_mcpar

	@ %def sf_chain_instance_get_mcpar
	@ Return the Jacobian factor that corresponds to channel [[c]].
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_f => sf_chain_instance_get_f
	<<SF base: procedures>>=
	function sf_chain_instance_get_f (chain, c) result (f)
	class(sf_chain_instance_t), intent(in) :: chain
	integer, intent(in) :: c
	real(default) :: f
	if (allocated (chain%f)) then
	f = chain%f(c)
	else
	f = 1
	end if
	end function sf_chain_instance_get_f

	@ %def sf_chain_instance_get_f
	@ Return the evaluation status.
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_status => sf_chain_instance_get_status
	<<SF base: procedures>>=
	function sf_chain_instance_get_status (chain) result (status)
	class(sf_chain_instance_t), intent(in) :: chain
	integer :: status
	status = chain%status
	end function sf_chain_instance_get_status

	@ %def sf_chain_instance_get_status
	@
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements
	<<SF base: procedures>>=
	subroutine sf_chain_instance_get_matrix_elements (chain, i, ff)
	class(sf_chain_instance_t), intent(in) :: chain
	integer, intent(in) :: i
	real(default), intent(out), dimension(:), allocatable :: ff

	associate (sf => chain%sf(i))
	ff = real (sf%int%get_matrix_element ())
	end associate
	end subroutine sf_chain_instance_get_matrix_elements

	@ %def sf_chain_instance_get_matrix_elements
	@
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr
	<<SF base: procedures>>=
	function sf_chain_instance_get_beam_int_ptr (chain) result (int)
	type(interaction_t), pointer :: int
	class(sf_chain_instance_t), intent(in), target :: chain
	int => beam_get_int_ptr (chain%beam_t)
	end function sf_chain_instance_get_beam_int_ptr

	@ %def sf_chain_instance_get_beam_ptr
	@
	<<SF base: sf chain instance: TBP>>=
	procedure :: get_n_sub => sf_chain_instance_get_n_sub
	<<SF base: procedures>>=
	integer function sf_chain_instance_get_n_sub (chain) result (n_sub)
	type(interaction_t), pointer :: int
	class(sf_chain_instance_t), intent(in), target :: chain
	int => beam_get_int_ptr (chain%beam_t)
	n_sub = int%get_n_sub ()
	end function sf_chain_instance_get_n_sub

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

	module sf_base_ut
	use unit_tests
	use sf_base_uti

	<<Standard module head>>

	<<SF base: public test auxiliary>>

	<<SF base: public test>>

	contains

	<<SF base: test driver>>

	end module sf_base_ut
	@ %def sf_base_ut
	@
	<<[[sf_base_uti.f90]]>>=
	<<File header>>

	module sf_base_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_19
	use format_utils, only: write_separator
	use diagnostics
	use lorentz
	use pdg_arrays
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices, only: FM_IGNORE_HELICITY
	use interactions
	use particles
	use model_data
	use beams
	use sf_aux
	use sf_mappings

	use sf_base

	<<Standard module head>>

	<<SF base: test declarations>>

	<<SF base: public test auxiliary>>

	<<SF base: test types>>

	contains

	<<SF base: tests>>

	<<SF base: test auxiliary>>

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

	@ %def sf_base_test
	@
	\subsection{Test implementation: structure function}
	This is a template for the actual structure-function implementation
	which will be defined in separate modules.

	\subsubsection{Configuration data}
	The test structure function uses the [[Test]] model. It describes a
	scalar within an arbitrary initial particle, which is given in the
	initialization. The radiated particle is also a scalar, the same one,
	but we set its mass artificially to zero.
	<<SF base: public test auxiliary>>=
	public :: sf_test_data_t
	<<SF base: test types>>=
	type, extends (sf_data_t) :: sf_test_data_t
	class(model_data_t), pointer :: model => null ()
	integer :: mode = 0
	type(flavor_t) :: flv_in
	type(flavor_t) :: flv_out
	type(flavor_t) :: flv_rad
	real(default) :: m = 0
	logical :: collinear = .true.
	real(default), dimension(:), allocatable :: qbounds
	contains
	<<SF base: sf test data: TBP>>
	end type sf_test_data_t

	@ %def sf_test_data_t
	@ Output.
	<<SF base: sf test data: TBP>>=
	procedure :: write => sf_test_data_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_data_write (data, unit, verbose)
	class(sf_test_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "SF test data:"
	write (u, "(3x,A,A)") "model = ", char (data%model%get_name ())
	write (u, "(3x,A)", advance="no") "incoming = "
	call data%flv_in%write (u); write (u, *)
	write (u, "(3x,A)", advance="no") "outgoing = "
	call data%flv_out%write (u); write (u, *)
	write (u, "(3x,A)", advance="no") "radiated = "
	call data%flv_rad%write (u); write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m
	write (u, "(3x,A,L1)") "collinear = ", data%collinear
	if (.not. data%collinear .and. allocated (data%qbounds)) then
	write (u, "(3x,A," // FMT_19 // ")") "qmin = ", data%qbounds(1)
	write (u, "(3x,A," // FMT_19 // ")") "qmax = ", data%qbounds(2)
	end if
	end subroutine sf_test_data_write

	@ %def sf_test_data_write
	@ Initialization.
	<<SF base: sf test data: TBP>>=
	procedure :: init => sf_test_data_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode)
	class(sf_test_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	logical, intent(in), optional :: collinear
	real(default), dimension(2), intent(in), optional :: qbounds
	integer, intent(in), optional :: mode
	data%model => model
	if (present (mode)) data%mode = mode
	- if (pdg_array_get (pdg_in, 1) /= 25) then
	+ if (pdg_in%get (1) /= 25) then
	call msg_fatal ("Test spectrum function: input flavor must be 's'")
	end if
	call data%flv_in%init (25, model)
	data%m = data%flv_in%get_mass ()
	if (present (collinear)) data%collinear = collinear
	call data%flv_out%init (25, model)
	call data%flv_rad%init (25, model)
	if (present (qbounds)) then
	allocate (data%qbounds (2))
	data%qbounds = qbounds
	end if
	end subroutine sf_test_data_init

	@ %def sf_test_data_init
	@ Return the number of parameters: 1 if only consider collinear
	splitting, 3 otherwise.
	<<SF base: sf test data: TBP>>=
	procedure :: get_n_par => sf_test_data_get_n_par
	<<SF base: test auxiliary>>=
	function sf_test_data_get_n_par (data) result (n)
	class(sf_test_data_t), intent(in) :: data
	integer :: n
	if (data%collinear) then
	n = 1
	else
	n = 3
	end if
	end function sf_test_data_get_n_par

	@ %def sf_test_data_get_n_par
	@ Return the outgoing particle PDG code: 25
	<<SF base: sf test data: TBP>>=
	procedure :: get_pdg_out => sf_test_data_get_pdg_out
	<<SF base: test auxiliary>>=
	subroutine sf_test_data_get_pdg_out (data, pdg_out)
	class(sf_test_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	pdg_out(1) = 25
	end subroutine sf_test_data_get_pdg_out

	@ %def sf_test_data_get_pdg_out
	@ Allocate the matching interaction.
	<<SF base: sf test data: TBP>>=
	procedure :: allocate_sf_int => sf_test_data_allocate_sf_int
	<<SF base: test auxiliary>>=
	subroutine sf_test_data_allocate_sf_int (data, sf_int)
	class(sf_test_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	if (allocated (sf_int)) deallocate (sf_int)
	allocate (sf_test_t :: sf_int)
	end subroutine sf_test_data_allocate_sf_int

	@ %def sf_test_data_allocate_sf_int
	@
	\subsubsection{Interaction}
	<<SF base: test types>>=
	type, extends (sf_int_t) :: sf_test_t
	type(sf_test_data_t), pointer :: data => null ()
	real(default) :: x = 0
	contains
	<<SF base: sf test int: TBP>>
	end type sf_test_t

	@ %def sf_test_t
	@ Type string: constant
	<<SF base: sf test int: TBP>>=
	procedure :: type_string => sf_test_type_string
	<<SF base: test auxiliary>>=
	function sf_test_type_string (object) result (string)
	class(sf_test_t), intent(in) :: object
	type(string_t) :: string
	string = "Test"
	end function sf_test_type_string

	@ %def sf_test_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF base: sf test int: TBP>>=
	procedure :: write => sf_test_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_write (object, unit, testflag)
	class(sf_test_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "SF test data: [undefined]"
	end if
	end subroutine sf_test_write

	@ %def sf_test_write
	@ Initialize. We know that [[data]] will be of concrete type
	[[sf_test_data_t]], but we have to cast this explicitly.

	For this implementation, we set the incoming and outgoing masses equal
	to the physical particle mass, but keep the radiated mass zero.

	Optionally, we can provide minimum and maximum values for the momentum
	transfer.
	<<SF base: sf test int: TBP>>=
	procedure :: init => sf_test_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_init (sf_int, data)
	class(sf_test_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	type(helicity_t) :: hel0
	type(color_t) :: col0
	type(quantum_numbers_t), dimension(3) :: qn
	mask = quantum_numbers_mask (.false., .false., .false.)
	select type (data)
	type is (sf_test_data_t)
	if (allocated (data%qbounds)) then
	call sf_int%base_init (mask, &
	[data%m2], [0._default], [data%m2], &
	[data%qbounds(1)], [data%qbounds(2)])
	else
	call sf_int%base_init (mask, &
	[data%m2], [0._default], [data%m2])
	end if
	sf_int%data => data
	call hel0%init (0)
	call col0%init ()
	call qn(1)%init (data%flv_in, col0, hel0)
	call qn(2)%init (data%flv_rad, col0, hel0)
	call qn(3)%init (data%flv_out, col0, hel0)
	call sf_int%add_state (qn)
	call sf_int%freeze ()
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	end select
	sf_int%status = SF_INITIAL
	end subroutine sf_test_init

	@ %def sf_test_init
	@ Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ is trivial.

	If [[map]] is set, we are asked to provide an efficient mapping.
	For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
	<<SF base: sf test int: TBP>>=
	procedure :: complete_kinematics => sf_test_complete_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(sf_test_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	x(1) = r(1)**2
	f = 2 * r(1)
	else
	x(1) = r(1)
	f = 1
	end if
	xb(1) = 1 - x(1)
	if (size (x) == 3) then
	x(2:3) = r(2:3)
	xb(2:3) = rb(2:3)
	end if
	call sf_int%split_momentum (x, xb)
	sf_int%x = x(1)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end subroutine sf_test_complete_kinematics

	@ %def sf_test_complete_kinematics
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF base: sf test int: TBP>>=
	procedure :: inverse_kinematics => sf_test_inverse_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(sf_test_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	r(1) = sqrt (x(1))
	f = 2 * r(1)
	else
	r(1) = x(1)
	f = 1
	end if
	if (size (x) == 3) r(2:3) = x(2:3)
	rb = 1 - r
	sf_int%x = x(1)
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine sf_test_inverse_kinematics

	@ %def sf_test_inverse_kinematics
	@ Apply the structure function. The matrix element becomes unity and
	the application always succeeds.

	If the [[mode]] indicator is one, the matrix element is equal to the
	parameter~$x$.
	<<SF base: sf test int: TBP>>=
	procedure :: apply => sf_test_apply
	<<SF base: test auxiliary>>=
	subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(sf_test_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	select case (sf_int%data%mode)
	case (0)
	call sf_int%set_matrix_element &
	(cmplx (1._default, kind=default))
	case (1)
	call sf_int%set_matrix_element &
	(cmplx (sf_int%x, kind=default))
	end select
	sf_int%status = SF_EVALUATED
	end subroutine sf_test_apply

	@ %def sf_test_apply
	@
	\subsection{Test implementation: pair spectrum}
	Another template, this time for a incoming particle pair, splitting
	into two radiated and two outgoing particles.

	\subsubsection{Configuration data}
	For simplicity, the spectrum contains two mirror images of the
	previous structure-function configuration: the incoming and all
	outgoing particles are test scalars.

	We have two versions, one with radiated particles, one without.
	<<SF base: test types>>=
	type, extends (sf_data_t) :: sf_test_spectrum_data_t
	class(model_data_t), pointer :: model => null ()
	type(flavor_t) :: flv_in
	type(flavor_t) :: flv_out
	type(flavor_t) :: flv_rad
	logical :: with_radiation = .true.
	real(default) :: m = 0
	contains
	<<SF base: sf test spectrum data: TBP>>
	end type sf_test_spectrum_data_t

	@ %def sf_test_spectrum_data_t
	@ Output.
	<<SF base: sf test spectrum data: TBP>>=
	procedure :: write => sf_test_spectrum_data_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_data_write (data, unit, verbose)
	class(sf_test_spectrum_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "SF test spectrum data:"
	write (u, "(3x,A,A)") "model = ", char (data%model%get_name ())
	write (u, "(3x,A)", advance="no") "incoming = "
	call data%flv_in%write (u); write (u, *)
	write (u, "(3x,A)", advance="no") "outgoing = "
	call data%flv_out%write (u); write (u, *)
	write (u, "(3x,A)", advance="no") "radiated = "
	call data%flv_rad%write (u); write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m
	end subroutine sf_test_spectrum_data_write

	@ %def sf_test_spectrum_data_write
	@ Initialization.
	<<SF base: sf test spectrum data: TBP>>=
	procedure :: init => sf_test_spectrum_data_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation)
	class(sf_test_spectrum_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	logical, intent(in) :: with_radiation
	data%model => model
	data%with_radiation = with_radiation
	- if (pdg_array_get (pdg_in, 1) /= 25) then
	+ if (pdg_in%get (1) /= 25) then
	call msg_fatal ("Test structure function: input flavor must be 's'")
	end if
	call data%flv_in%init (25, model)
	data%m = data%flv_in%get_mass ()
	call data%flv_out%init (25, model)
	if (with_radiation) then
	call data%flv_rad%init (25, model)
	end if
	end subroutine sf_test_spectrum_data_init

	@ %def sf_test_spectrum_data_init
	@ Return the number of parameters: 2, since we have only collinear
	splitting here.
	<<SF base: sf test spectrum data: TBP>>=
	procedure :: get_n_par => sf_test_spectrum_data_get_n_par
	<<SF base: test auxiliary>>=
	function sf_test_spectrum_data_get_n_par (data) result (n)
	class(sf_test_spectrum_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function sf_test_spectrum_data_get_n_par

	@ %def sf_test_spectrum_data_get_n_par
	@ Return the outgoing particle PDG codes: 25
	<<SF base: sf test spectrum data: TBP>>=
	procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out)
	class(sf_test_spectrum_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	pdg_out(1) = 25
	pdg_out(2) = 25
	end subroutine sf_test_spectrum_data_get_pdg_out

	@ %def sf_test_spectrum_data_get_pdg_out
	@ Allocate the matching interaction.
	<<SF base: sf test spectrum data: TBP>>=
	procedure :: allocate_sf_int => &
	sf_test_spectrum_data_allocate_sf_int
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int)
	class(sf_test_spectrum_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (sf_test_spectrum_t :: sf_int)
	end subroutine sf_test_spectrum_data_allocate_sf_int

	@ %def sf_test_spectrum_data_allocate_sf_int
	@
	\subsubsection{Interaction}
	<<SF base: test types>>=
	type, extends (sf_int_t) :: sf_test_spectrum_t
	type(sf_test_spectrum_data_t), pointer :: data => null ()
	contains
	<<SF base: sf test spectrum: TBP>>
	end type sf_test_spectrum_t

	@ %def sf_test_spectrum_t
	<<SF base: sf test spectrum: TBP>>=
	procedure :: type_string => sf_test_spectrum_type_string
	<<SF base: test auxiliary>>=
	function sf_test_spectrum_type_string (object) result (string)
	class(sf_test_spectrum_t), intent(in) :: object
	type(string_t) :: string
	string = "Test Spectrum"
	end function sf_test_spectrum_type_string

	@ %def sf_test_spectrum_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF base: sf test spectrum: TBP>>=
	procedure :: write => sf_test_spectrum_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_write (object, unit, testflag)
	class(sf_test_spectrum_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "SF test spectrum data: [undefined]"
	end if
	end subroutine sf_test_spectrum_write

	@ %def sf_test_spectrum_write
	@ Initialize. We know that [[data]] will be of concrete type
	[[sf_test_spectrum_data_t]], but we have to cast this explicitly.

	For this implementation, we set the incoming and outgoing masses equal
	to the physical particle mass, but keep the radiated mass zero.

	Optionally, we can provide minimum and maximum values for the momentum
	transfer.
	<<SF base: sf test spectrum: TBP>>=
	procedure :: init => sf_test_spectrum_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_init (sf_int, data)
	class(sf_test_spectrum_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(6) :: mask
	type(helicity_t) :: hel0
	type(color_t) :: col0
	type(quantum_numbers_t), dimension(6) :: qn
	mask = quantum_numbers_mask (.false., .false., .false.)
	select type (data)
	type is (sf_test_spectrum_data_t)
	if (data%with_radiation) then
	call sf_int%base_init (mask(1:6), &
	[data%m2, data%m2], &
	[0._default, 0._default], &
	[data%m2, data%m2])
	sf_int%data => data
	call hel0%init (0)
	call col0%init ()
	call qn(1)%init (data%flv_in, col0, hel0)
	call qn(2)%init (data%flv_in, col0, hel0)
	call qn(3)%init (data%flv_rad, col0, hel0)
	call qn(4)%init (data%flv_rad, col0, hel0)
	call qn(5)%init (data%flv_out, col0, hel0)
	call qn(6)%init (data%flv_out, col0, hel0)
	call sf_int%add_state (qn(1:6))
	call sf_int%set_incoming ([1,2])
	call sf_int%set_radiated ([3,4])
	call sf_int%set_outgoing ([5,6])
	else
	call sf_int%base_init (mask(1:4), &
	[data%m2, data%m2], &
	[real(default) :: ], &
	[data%m2, data%m2])
	sf_int%data => data
	call hel0%init (0)
	call col0%init ()
	call qn(1)%init (data%flv_in, col0, hel0)
	call qn(2)%init (data%flv_in, col0, hel0)
	call qn(3)%init (data%flv_out, col0, hel0)
	call qn(4)%init (data%flv_out, col0, hel0)
	call sf_int%add_state (qn(1:4))
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	end if
	call sf_int%freeze ()
	end select
	sf_int%status = SF_INITIAL
	end subroutine sf_test_spectrum_init

	@ %def sf_test_spectrum_init
	@ Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ is trivial.

	If [[map]] is set, we are asked to provide an efficient mapping.
	For the test case, we set $x=r^2$ (as above) for both $x$ parameters
	and consequently $f(r)=4r_1r_2$.

	<<SF base: sf test spectrum: TBP>>=
	procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(sf_test_spectrum_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	real(default), dimension(2) :: xb1
	if (map) then
	x = r**2
	f = 4 * r(1) * r(2)
	else
	x = r
	f = 1
	end if
	xb = 1 - x
	if (sf_int%data%with_radiation) then
	call sf_int%split_momenta (x, xb)
	else
	call sf_int%reduce_momenta (x)
	end if
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end subroutine sf_test_spectrum_complete_kinematics

	@ %def sf_test_spectrum_complete_kinematics
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF base: sf test spectrum: TBP>>=
	procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_inverse_kinematics &
	(sf_int, x, xb, f, r, rb, map, set_momenta)
	class(sf_test_spectrum_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	real(default), dimension(2) :: xb1
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	r = sqrt (x)
	f = 4 * r(1) * r(2)
	else
	r = x
	f = 1
	end if
	rb = 1 - r
	if (set_mom) then
	if (sf_int%data%with_radiation) then
	call sf_int%split_momenta (x, xb)
	else
	call sf_int%reduce_momenta (x)
	end if
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine sf_test_spectrum_inverse_kinematics

	@ %def sf_test_spectrum_inverse_kinematics
	@ Apply the structure function. The matrix element becomes unity and
	the application always succeeds.
	<<SF base: sf test spectrum: TBP>>=
	procedure :: apply => sf_test_spectrum_apply
	<<SF base: test auxiliary>>=
	subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(sf_test_spectrum_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	call sf_int%set_matrix_element &
	(cmplx (1._default, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine sf_test_spectrum_apply

	@ %def sf_test_spectrum_apply
	@
	\subsection{Test implementation: generator spectrum}
	A generator for two beams, no radiation (for simplicity).

	\subsubsection{Configuration data}
	For simplicity, the spectrum contains two mirror images of the
	previous structure-function configuration: the incoming and all
	outgoing particles are test scalars.

	We have two versions, one with radiated particles, one without.
	<<SF base: test types>>=
	type, extends (sf_data_t) :: sf_test_generator_data_t
	class(model_data_t), pointer :: model => null ()
	type(flavor_t) :: flv_in
	type(flavor_t) :: flv_out
	type(flavor_t) :: flv_rad
	real(default) :: m = 0
	contains
	<<SF base: sf test generator data: TBP>>
	end type sf_test_generator_data_t

	@ %def sf_test_generator_data_t
	@ Output.
	<<SF base: sf test generator data: TBP>>=
	procedure :: write => sf_test_generator_data_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_data_write (data, unit, verbose)
	class(sf_test_generator_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit)
	write (u, "(1x,A)") "SF test generator data:"
	write (u, "(3x,A,A)") "model = ", char (data%model%get_name ())
	write (u, "(3x,A)", advance="no") "incoming = "
	call data%flv_in%write (u); write (u, *)
	write (u, "(3x,A)", advance="no") "outgoing = "
	call data%flv_out%write (u); write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m
	end subroutine sf_test_generator_data_write

	@ %def sf_test_generator_data_write
	@ Initialization.
	<<SF base: sf test generator data: TBP>>=
	procedure :: init => sf_test_generator_data_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_data_init (data, model, pdg_in)
	class(sf_test_generator_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	data%model => model
	- if (pdg_array_get (pdg_in, 1) /= 25) then
	+ if (pdg_in%get (1) /= 25) then
	call msg_fatal ("Test generator: input flavor must be 's'")
	end if
	call data%flv_in%init (25, model)
	data%m = data%flv_in%get_mass ()
	call data%flv_out%init (25, model)
	end subroutine sf_test_generator_data_init

	@ %def sf_test_generator_data_init
	@ This structure function is a generator.
	<<SF base: sf test generator data: TBP>>=
	procedure :: is_generator => sf_test_generator_data_is_generator
	<<SF base: test auxiliary>>=
	function sf_test_generator_data_is_generator (data) result (flag)
	class(sf_test_generator_data_t), intent(in) :: data
	logical :: flag
	flag = .true.
	end function sf_test_generator_data_is_generator

	@ %def sf_test_generator_data_is_generator
	@ Return the number of parameters: 2, since we have only collinear
	splitting here.
	<<SF base: sf test generator data: TBP>>=
	procedure :: get_n_par => sf_test_generator_data_get_n_par
	<<SF base: test auxiliary>>=
	function sf_test_generator_data_get_n_par (data) result (n)
	class(sf_test_generator_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function sf_test_generator_data_get_n_par

	@ %def sf_test_generator_data_get_n_par
	@ Return the outgoing particle PDG codes: 25
	<<SF base: sf test generator data: TBP>>=
	procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_data_get_pdg_out (data, pdg_out)
	class(sf_test_generator_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	pdg_out(1) = 25
	pdg_out(2) = 25
	end subroutine sf_test_generator_data_get_pdg_out

	@ %def sf_test_generator_data_get_pdg_out
	@ Allocate the matching interaction.
	<<SF base: sf test generator data: TBP>>=
	procedure :: allocate_sf_int => &
	sf_test_generator_data_allocate_sf_int
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_data_allocate_sf_int (data, sf_int)
	class(sf_test_generator_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (sf_test_generator_t :: sf_int)
	end subroutine sf_test_generator_data_allocate_sf_int

	@ %def sf_test_generator_data_allocate_sf_int
	@
	\subsubsection{Interaction}
	<<SF base: test types>>=
	type, extends (sf_int_t) :: sf_test_generator_t
	type(sf_test_generator_data_t), pointer :: data => null ()
	contains
	<<SF base: sf test generator: TBP>>
	end type sf_test_generator_t

	@ %def sf_test_generator_t
	<<SF base: sf test generator: TBP>>=
	procedure :: type_string => sf_test_generator_type_string
	<<SF base: test auxiliary>>=
	function sf_test_generator_type_string (object) result (string)
	class(sf_test_generator_t), intent(in) :: object
	type(string_t) :: string
	string = "Test Generator"
	end function sf_test_generator_type_string

	@ %def sf_test_generator_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF base: sf test generator: TBP>>=
	procedure :: write => sf_test_generator_write
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_write (object, unit, testflag)
	class(sf_test_generator_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "SF test generator data: [undefined]"
	end if
	end subroutine sf_test_generator_write

	@ %def sf_test_generator_write
	@ Initialize. We know that [[data]] will be of concrete type
	[[sf_test_generator_data_t]], but we have to cast this explicitly.

	For this implementation, we set the incoming and outgoing masses equal
	to the physical particle mass. No radiation.
	<<SF base: sf test generator: TBP>>=
	procedure :: init => sf_test_generator_init
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_init (sf_int, data)
	class(sf_test_generator_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(4) :: mask
	type(helicity_t) :: hel0
	type(color_t) :: col0
	type(quantum_numbers_t), dimension(4) :: qn
	mask = quantum_numbers_mask (.false., .false., .false.)
	select type (data)
	type is (sf_test_generator_data_t)
	call sf_int%base_init (mask(1:4), &
	[data%m2, data%m2], &
	[real(default) :: ], &
	[data%m2, data%m2])
	sf_int%data => data
	call hel0%init (0)
	call col0%init ()
	call qn(1)%init (data%flv_in, col0, hel0)
	call qn(2)%init (data%flv_in, col0, hel0)
	call qn(3)%init (data%flv_out, col0, hel0)
	call qn(4)%init (data%flv_out, col0, hel0)
	call sf_int%add_state (qn(1:4))
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	call sf_int%freeze ()
	end select
	sf_int%status = SF_INITIAL
	end subroutine sf_test_generator_init

	@ %def sf_test_generator_init
	@ This structure function is a generator.
	<<SF base: sf test generator: TBP>>=
	procedure :: is_generator => sf_test_generator_is_generator
	<<SF base: test auxiliary>>=
	function sf_test_generator_is_generator (sf_int) result (flag)
	class(sf_test_generator_t), intent(in) :: sf_int
	logical :: flag
	flag = sf_int%data%is_generator ()
	end function sf_test_generator_is_generator

	@ %def sf_test_generator_is_generator
	@ Generate free parameters. This mock generator always produces the
	nubmers 0.8 and 0.5.
	<<SF base: sf test generator: TBP>>=
	procedure :: generate_free => sf_test_generator_generate_free
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free)
	class(sf_test_generator_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free
	r = [0.8, 0.5]
	rb= 1 - r
	x_free = x_free * product (r)
	end subroutine sf_test_generator_generate_free

	@ %def sf_test_generator_generate_free
	@ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter.
	<<SF base: sf test generator: TBP>>=
	procedure :: recover_x => sf_test_generator_recover_x
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free)
	class(sf_test_generator_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb)
	if (present (x_free)) x_free = x_free * product (x)
	end subroutine sf_test_generator_recover_x

	@ %def sf_test_generator_recover_x
	@ Set kinematics. Since this is a generator, just transfer input to output.
	<<SF base: sf test generator: TBP>>=
	procedure :: complete_kinematics => sf_test_generator_complete_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(sf_test_generator_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	x = r
	xb= rb
	f = 1
	call sf_int%reduce_momenta (x)
	end subroutine sf_test_generator_complete_kinematics

	@ %def sf_test_generator_complete_kinematics
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF base: sf test generator: TBP>>=
	procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_inverse_kinematics &
	(sf_int, x, xb, f, r, rb, map, set_momenta)
	class(sf_test_generator_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	r = x
	rb= xb
	f = 1
	if (set_mom) call sf_int%reduce_momenta (x)
	end subroutine sf_test_generator_inverse_kinematics

	@ %def sf_test_generator_inverse_kinematics
	@ Apply the structure function. The matrix element becomes unity and
	the application always succeeds.
	<<SF base: sf test generator: TBP>>=
	procedure :: apply => sf_test_generator_apply
	<<SF base: test auxiliary>>=
	subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(sf_test_generator_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	call sf_int%set_matrix_element &
	(cmplx (1._default, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine sf_test_generator_apply

	@ %def sf_test_generator_apply
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF base: execute tests>>=
	call test (sf_base_1, "sf_base_1", &
	"structure function configuration", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_1
	<<SF base: tests>>=
	subroutine sf_base_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_base_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	call model%init_test ()
	pdg_in = 25

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle code:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_base_1

	@ %def sf_base_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the test
	structure function.
	<<SF base: execute tests>>=
	call test (sf_base_2, "sf_base_2", &
	"structure function instance", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_2
	<<SF base: tests>>=
	subroutine sf_base_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_base_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=1"
	write (u, "(A)")

	r = 1
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics with mapping for r=0.8"
	write (u, "(A)")

	r = 0.8_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

	write (u, "(A)")
	write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate"
	write (u, "(A)")

	x = 0.64_default
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
	call sf_int%apply (scale=0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "f =", f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_2

	@ %def sf_base_2
	@
	\subsubsection{Collinear kinematics}
	Scan over the possibilities for mass assignment and on-shell
	projections, collinear case.
	<<SF base: execute tests>>=
	call test (sf_base_3, "sf_base_3", &
	"alternatives for collinear kinematics", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_3
	<<SF base: tests>>=
	subroutine sf_base_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_base_3"
	write (u, "(A)") "* Purpose: check various kinematical setups"
	write (u, "(A)") "* for collinear structure-function splitting."
	write (u, "(A)") " (two masses equal, one zero)"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%write (u)

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"

	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set radiated mass to zero"

	sf_int%mr2 = 0
	sf_int%mo2 = sf_int%mi2

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping energy"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set outgoing mass to zero"

	sf_int%mr2 = sf_int%mi2
	sf_int%mo2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping energy"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set incoming mass to zero"

	k = vector4_moving (E, E, 3)
	call sf_int%seed_kinematics ([k])

	sf_int%mr2 = sf_int%mi2
	sf_int%mo2 = sf_int%mi2
	sf_int%mi2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping energy"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set all masses to zero"

	sf_int%mr2 = 0
	sf_int%mo2 = 0
	sf_int%mi2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping energy"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum"
	write (u, "(A)")

	r = 0.5_default
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_3

	@ %def sf_base_3
	@
	\subsubsection{Non-collinear kinematics}
	Scan over the possibilities for mass assignment and on-shell
	projections, non-collinear case.
	<<SF base: execute tests>>=
	call test (sf_base_4, "sf_base_4", &
	"alternatives for non-collinear kinematics", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_4
	<<SF base: tests>>=
	subroutine sf_base_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_base_4"
	write (u, "(A)") "* Purpose: check various kinematical setups"
	write (u, "(A)") "* for free structure-function splitting."
	write (u, "(A)") " (two masses equal, one zero)"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in, collinear=.false.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%write (u)

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"

	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set radiated mass to zero"

	sf_int%mr2 = 0
	sf_int%mo2 = sf_int%mi2

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set outgoing mass to zero"

	sf_int%mr2 = sf_int%mi2
	sf_int%mo2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set incoming mass to zero"

	k = vector4_moving (E, E, 3)
	call sf_int%seed_kinematics ([k])

	sf_int%mr2 = sf_int%mi2
	sf_int%mo2 = sf_int%mi2
	sf_int%mi2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set all masses to zero"

	sf_int%mr2 = 0
	sf_int%mo2 = 0
	sf_int%mi2 = 0

	write (u, "(A)")
	write (u, "(A)") "* Re-Initialize structure-function object with Q bounds"

	call reset_interaction_counter ()

	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in, collinear=.false., &
	qbounds = [1._default, 100._default])
	end select

	call sf_int%init (data)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
	write (u, "(A)")

	r = [0.5_default, 0.5_default, 0.125_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_MOMENTUM
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r"
	write (u, "(A)")

	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_4

	@ %def sf_base_4
	@
	\subsubsection{Pair spectrum}
	Construct and display a structure function object for a pair spectrum
	(a structure function involving two particles simultaneously).
	<<SF base: execute tests>>=
	call test (sf_base_5, "sf_base_5", &
	"pair spectrum with radiation", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_5
	<<SF base: tests>>=
	subroutine sf_base_5 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t), dimension(2) :: k
	type(vector4_t), dimension(4) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_base_5"
	write (u, "(A)") "* Purpose: initialize and fill &
	&a pair spectrum object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_spectrum_data_t :: data)
	select type (data)
	type is (sf_test_spectrum_data_t)
	call data%init (model, pdg_in, with_radiation=.true.)
	end select

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	write (u, "(A)")
	write (u, "(A)") "* Initialize spectrum object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momenta with sqrts=1000"

	E = 500
	k(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	k(2) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call sf_int%seed_kinematics (k)

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.4,0.8"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.4_default, 0.8_default]
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8"
	write (u, "(A)")

	r = [0.6_default, 0.8_default]
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call reset_interaction_counter ()
	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%seed_kinematics (k)
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

	write (u, "(A)")
	write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 &
	&and evaluate"
	write (u, "(A)")

	x = [0.36_default, 0.64_default]
	xb = 1 - x
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
	call sf_int%apply (scale=0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "f =", f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_5

	@ %def sf_base_5
	@
	\subsubsection{Pair spectrum without radiation}
	Construct and display a structure function object for a pair spectrum
	(a structure function involving two particles simultaneously).
	<<SF base: execute tests>>=
	call test (sf_base_6, "sf_base_6", &
	"pair spectrum without radiation", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_6
	<<SF base: tests>>=
	subroutine sf_base_6 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t), dimension(2) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_base_6"
	write (u, "(A)") "* Purpose: initialize and fill &
	&a pair spectrum object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_spectrum_data_t :: data)
	select type (data)
	type is (sf_test_spectrum_data_t)
	call data%init (model, pdg_in, with_radiation=.false.)
	end select

	write (u, "(A)") "* Initialize spectrum object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	write (u, "(A)") "* Initialize incoming momenta with sqrts=1000"

	E = 500
	k(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	k(2) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call sf_int%seed_kinematics (k)

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.4,0.8"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.4_default, 0.8_default]
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call reset_interaction_counter ()
	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%seed_kinematics (k)
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

	write (u, "(A)")
	write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 &
	&and evaluate"
	write (u, "(A)")

	x = [0.4_default, 0.8_default]
	xb = 1 - x
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%apply (scale=0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "f =", f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_6

	@ %def sf_base_6
	@
	\subsubsection{Direct access to structure function}
	Probe a structure function directly.
	<<SF base: execute tests>>=
	call test (sf_base_7, "sf_base_7", &
	"direct access", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_7
	<<SF base: tests>>=
	subroutine sf_base_7 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	real(default), dimension(:), allocatable :: value

	write (u, "(A)") "* Test output: sf_base_7"
	write (u, "(A)") "* Purpose: check direct access method"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in)
	end select

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	write (u, "(A)") "* Probe structure function: states"
	write (u, "(A)")

	write (u, "(A,I0)") "n_states = ", sf_int%get_n_states ()
	write (u, "(A,I0)") "n_in = ", sf_int%get_n_in ()
	write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad ()
	write (u, "(A,I0)") "n_out = ", sf_int%get_n_out ()
	write (u, "(A)")
	write (u, "(A)", advance="no") "state(1) = "
	call quantum_numbers_write (sf_int%get_state (1), u)
	write (u, *)

	allocate (value (sf_int%get_n_states ()))
	call sf_int%compute_values (value, &
	E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default)

	write (u, "(A)")
	write (u, "(A)", advance="no") "value (E=500, x=0.5) ="
	write (u, "(9(1x," // FMT_19 // "))") value

	call sf_int%compute_values (value, &
	x=[0.1_default], xb=[0.9_default], scale=0._default)

	write (u, "(A)")
	write (u, "(A)", advance="no") "value (E=500, x=0.1) ="
	write (u, "(9(1x," // FMT_19 // "))") value


	write (u, "(A)")
	write (u, "(A)") "* Initialize spectrum object"
	write (u, "(A)")

	deallocate (value)
	call sf_int%final ()
	deallocate (sf_int)
	deallocate (data)

	allocate (sf_test_spectrum_data_t :: data)
	select type (data)
	type is (sf_test_spectrum_data_t)
	call data%init (model, pdg_in, with_radiation=.false.)
	end select

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	write (u, "(A)") "* Probe spectrum: states"
	write (u, "(A)")

	write (u, "(A,I0)") "n_states = ", sf_int%get_n_states ()
	write (u, "(A,I0)") "n_in = ", sf_int%get_n_in ()
	write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad ()
	write (u, "(A,I0)") "n_out = ", sf_int%get_n_out ()
	write (u, "(A)")
	write (u, "(A)", advance="no") "state(1) = "
	call quantum_numbers_write (sf_int%get_state (1), u)
	write (u, *)

	allocate (value (sf_int%get_n_states ()))
	call sf_int%compute_value (1, value(1), &
	E = [500._default, 500._default], &
	x = [0.5_default, 0.6_default], &
	xb= [0.5_default, 0.4_default], &
	scale = 0._default)

	write (u, "(A)")
	write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) ="
	write (u, "(9(1x," // FMT_19 // "))") value

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_7

	@ %def sf_base_7
	@
	\subsubsection{Structure function chain configuration}
	<<SF base: execute tests>>=
	call test (sf_base_8, "sf_base_8", &
	"structure function chain configuration", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_8
	<<SF base: tests>>=
	subroutine sf_base_8 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data_strfun
	class(sf_data_t), allocatable, target :: data_spectrum
	type(sf_config_t), dimension(:), allocatable :: sf_config
	type(sf_chain_t) :: sf_chain

	write (u, "(A)") "* Test output: sf_base_8"
	write (u, "(A)") "* Purpose: set up a structure-function chain"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data_strfun)
	select type (data_strfun)
	type is (sf_test_data_t)
	call data_strfun%init (model, pdg_in)
	end select

	allocate (sf_test_spectrum_data_t :: data_spectrum)
	select type (data_spectrum)
	type is (sf_test_spectrum_data_t)
	call data_spectrum%init (model, pdg_in, with_radiation=.true.)
	end select

	write (u, "(A)") "* Set up chain with beams only"
	write (u, "(A)")

	call sf_chain%init (beam_data)
	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)") "* Set up chain with structure function"
	write (u, "(A)")

	allocate (sf_config (1))
	call sf_config(1)%init ([1], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)") "* Set up chain with spectrum and structure function"
	write (u, "(A)")

	deallocate (sf_config)
	allocate (sf_config (2))
	call sf_config(1)%init ([1,2], data_spectrum)
	call sf_config(2)%init ([2], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain%final ()

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

	call model%final ()

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

	end subroutine sf_base_8

	@ %def sf_base_8
	@
	\subsubsection{Structure function instance configuration}
	We create a structure-function chain instance which implements a
	configured structure-function chain. We link the momentum entries in
	the interactions and compute kinematics.

	We do not actually connect the interactions and create evaluators. We
	skip this step and manually advance the status of the chain instead.
	<<SF base: execute tests>>=
	call test (sf_base_9, "sf_base_9", &
	"structure function chain instance", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_9
	<<SF base: tests>>=
	subroutine sf_base_9 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data_strfun
	class(sf_data_t), allocatable, target :: data_spectrum
	type(sf_config_t), dimension(:), allocatable, target :: sf_config
	type(sf_chain_t), target :: sf_chain
	type(sf_chain_instance_t), target :: sf_chain_instance
	type(sf_channel_t), dimension(2) :: sf_channel
	type(vector4_t), dimension(2) :: p
	integer :: j

	write (u, "(A)") "* Test output: sf_base_9"
	write (u, "(A)") "* Purpose: set up a structure-function chain &
	&and create an instance"
	write (u, "(A)") "* compute kinematics"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data_strfun)
	select type (data_strfun)
	type is (sf_test_data_t)
	call data_strfun%init (model, pdg_in)
	end select

	allocate (sf_test_spectrum_data_t :: data_spectrum)
	select type (data_spectrum)
	type is (sf_test_spectrum_data_t)
	call data_spectrum%init (model, pdg_in, with_radiation=.true.)
	end select

	write (u, "(A)") "* Set up chain with beams only"
	write (u, "(A)")

	call sf_chain%init (beam_data)

	call sf_chain_instance%init (sf_chain, n_channel = 1)

	call sf_chain_instance%link_interactions ()
	sf_chain_instance%status = SF_DONE_CONNECTIONS
	call sf_chain_instance%compute_kinematics (1, [real(default) ::])

	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call sf_chain_instance%get_out_momenta (p)

	write (u, "(A)")
	write (u, "(A)") "* Outgoing momenta:"

	do j = 1, 2
	write (u, "(A)")
	call vector4_write (p(j), u)
	end do

	call sf_chain_instance%final ()
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)") "* Set up chain with structure function"
	write (u, "(A)")

	allocate (sf_config (1))
	call sf_config(1)%init ([1], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)

	call sf_channel(1)%init (1)
	call sf_channel(1)%activate_mapping ([1])
	call sf_chain_instance%set_channel (1, sf_channel(1))

	call sf_chain_instance%link_interactions ()
	sf_chain_instance%status = SF_DONE_CONNECTIONS
	call sf_chain_instance%compute_kinematics (1, [0.8_default])

	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call sf_chain_instance%get_out_momenta (p)

	write (u, "(A)")
	write (u, "(A)") "* Outgoing momenta:"

	do j = 1, 2
	write (u, "(A)")
	call vector4_write (p(j), u)
	end do

	call sf_chain_instance%final ()
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)") "* Set up chain with spectrum and structure function"
	write (u, "(A)")

	deallocate (sf_config)
	allocate (sf_config (2))
	call sf_config(1)%init ([1,2], data_spectrum)
	call sf_config(2)%init ([2], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)

	call sf_channel(2)%init (2)
	call sf_channel(2)%activate_mapping ([2])
	call sf_chain_instance%set_channel (1, sf_channel(2))

	call sf_chain_instance%link_interactions ()
	sf_chain_instance%status = SF_DONE_CONNECTIONS
	call sf_chain_instance%compute_kinematics &
	(1, [0.5_default, 0.6_default, 0.8_default])

	call write_separator (u, 2)
	call sf_chain%write (u)
	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call sf_chain_instance%get_out_momenta (p)

	write (u, "(A)")
	write (u, "(A)") "* Outgoing momenta:"

	do j = 1, 2
	write (u, "(A)")
	call vector4_write (p(j), u)
	end do

	call sf_chain_instance%final ()
	call sf_chain%final ()

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

	call model%final ()

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

	end subroutine sf_base_9

	@ %def sf_base_9
	@
	\subsubsection{Structure function chain mappings}
	Set up a structure function chain instance with a pair of
	single-particle structure functions. We test different global
	mappings for this setup.

	Again, we skip evaluators.
	<<SF base: execute tests>>=
	call test (sf_base_10, "sf_base_10", &
	"structure function chain mapping", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_10
	<<SF base: tests>>=
	subroutine sf_base_10 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data_strfun
	type(sf_config_t), dimension(:), allocatable, target :: sf_config
	type(sf_chain_t), target :: sf_chain
	type(sf_chain_instance_t), target :: sf_chain_instance
	type(sf_channel_t), dimension(2) :: sf_channel
	real(default), dimension(2) :: x_saved

	write (u, "(A)") "* Test output: sf_base_10"
	write (u, "(A)") "* Purpose: set up a structure-function chain"
	write (u, "(A)") "* and check mappings"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data_strfun)
	select type (data_strfun)
	type is (sf_test_data_t)
	call data_strfun%init (model, pdg_in)
	end select

	write (u, "(A)") "* Set up chain with structure function pair &
	&and standard mapping"
	write (u, "(A)")

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data_strfun)
	call sf_config(2)%init ([2], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)

	call sf_channel(1)%init (2)
	call sf_channel(1)%set_s_mapping ([1,2])
	call sf_chain_instance%set_channel (1, sf_channel(1))

	call sf_chain_instance%link_interactions ()
	sf_chain_instance%status = SF_DONE_CONNECTIONS
	call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	write (u, "(A)")
	write (u, "(A)") "* Invert the kinematics calculation"
	write (u, "(A)")

	x_saved = sf_chain_instance%x

	call sf_chain_instance%init (sf_chain, n_channel = 1)

	call sf_channel(2)%init (2)
	call sf_channel(2)%set_s_mapping ([1, 2])
	call sf_chain_instance%set_channel (1, sf_channel(2))

	call sf_chain_instance%link_interactions ()
	sf_chain_instance%status = SF_DONE_CONNECTIONS
	call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)


	call sf_chain_instance%final ()
	call sf_chain%final ()

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

	call model%final ()

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

	end subroutine sf_base_10

	@ %def sf_base_10
	@
	\subsubsection{Structure function chain evaluation}
	Here, we test the complete workflow for structure-function chains.
	First, we create the template chain, then initialize an instance. We
	set up links, mask, and evaluators. Finally, we set kinematics and
	evaluate the matrix elements and their products.
	<<SF base: execute tests>>=
	call test (sf_base_11, "sf_base_11", &
	"structure function chain evaluation", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_11
	<<SF base: tests>>=
	subroutine sf_base_11 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data_strfun
	class(sf_data_t), allocatable, target :: data_spectrum
	type(sf_config_t), dimension(:), allocatable, target :: sf_config
	type(sf_chain_t), target :: sf_chain
	type(sf_chain_instance_t), target :: sf_chain_instance
	type(sf_channel_t), dimension(2) :: sf_channel
	type(particle_set_t) :: pset
	type(interaction_t), pointer :: int
	logical :: ok

	write (u, "(A)") "* Test output: sf_base_11"
	write (u, "(A)") "* Purpose: set up a structure-function chain"
	write (u, "(A)") "* create an instance and evaluate"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data_strfun)
	select type (data_strfun)
	type is (sf_test_data_t)
	call data_strfun%init (model, pdg_in)
	end select

	allocate (sf_test_spectrum_data_t :: data_spectrum)
	select type (data_spectrum)
	type is (sf_test_spectrum_data_t)
	call data_spectrum%init (model, pdg_in, with_radiation=.true.)
	end select

	write (u, "(A)") "* Set up chain with beams only"
	write (u, "(A)")

	call sf_chain%init (beam_data)

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	call sf_chain_instance%compute_kinematics (1, [real(default) ::])
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
	[0._default, 0._default], .false., .true.)
	call sf_chain_instance%final ()

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover chain:"
	write (u, "(A)")

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%fill_interaction (int, 2, check_match=.false.)

	call sf_chain_instance%recover_kinematics (1)
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call pset%final ()
	call sf_chain_instance%final ()
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)")
	write (u, "(A)")
	write (u, "(A)") "* Set up chain with structure function"
	write (u, "(A)")

	allocate (sf_config (1))
	call sf_config(1)%init ([1], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_channel(1)%init (1)
	call sf_channel(1)%activate_mapping ([1])
	call sf_chain_instance%set_channel (1, sf_channel(1))
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	call sf_chain_instance%compute_kinematics (1, [0.8_default])
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
	[0._default, 0._default], .false., .true.)
	call sf_chain_instance%final ()

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover chain:"
	write (u, "(A)")

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_channel(1)%init (1)
	call sf_channel(1)%activate_mapping ([1])
	call sf_chain_instance%set_channel (1, sf_channel(1))
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%fill_interaction (int, 2, check_match=.false.)

	call sf_chain_instance%recover_kinematics (1)
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call pset%final ()
	call sf_chain_instance%final ()
	call sf_chain%final ()

	write (u, "(A)")
	write (u, "(A)")
	write (u, "(A)")
	write (u, "(A)") "* Set up chain with spectrum and structure function"
	write (u, "(A)")

	deallocate (sf_config)
	allocate (sf_config (2))
	call sf_config(1)%init ([1,2], data_spectrum)
	call sf_config(2)%init ([2], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_channel(2)%init (2)
	call sf_channel(2)%activate_mapping ([2])
	call sf_chain_instance%set_channel (1, sf_channel(2))
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	call sf_chain_instance%compute_kinematics &
	(1, [0.5_default, 0.6_default, 0.8_default])
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
	[0._default, 0._default], .false., .true.)
	call sf_chain_instance%final ()

	write (u, "(A)")
	write (u, "(A)") "* Particle content:"
	write (u, "(A)")

	call write_separator (u)
	call pset%write (u)
	call write_separator (u)

	write (u, "(A)")
	write (u, "(A)") "* Recover chain:"
	write (u, "(A)")

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_channel(2)%init (2)
	call sf_channel(2)%activate_mapping ([2])
	call sf_chain_instance%set_channel (1, sf_channel(2))
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	int => sf_chain_instance%get_out_int_ptr ()
	call pset%fill_interaction (int, 2, check_match=.false.)

	call sf_chain_instance%recover_kinematics (1)
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	call pset%final ()
	call sf_chain_instance%final ()
	call sf_chain%final ()

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

	call model%final ()

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

	end subroutine sf_base_11

	@ %def sf_base_11
	@
	\subsubsection{Multichannel case}
	We set up a structure-function chain as before, but with three
	different parameterizations. The first instance is without mappings,
	the second one with single-particle mappings, and the third one with
	two-particle mappings.
	<<SF base: execute tests>>=
	call test (sf_base_12, "sf_base_12", &
	"multi-channel structure function chain", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_12
	<<SF base: tests>>=
	subroutine sf_base_12 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data
	type(sf_config_t), dimension(:), allocatable, target :: sf_config
	type(sf_chain_t), target :: sf_chain
	type(sf_chain_instance_t), target :: sf_chain_instance
	real(default), dimension(2) :: x_saved
	real(default), dimension(2,3) :: p_saved
	type(sf_channel_t), dimension(:), allocatable :: sf_channel

	write (u, "(A)") "* Test output: sf_base_12"
	write (u, "(A)") "* Purpose: set up and evaluate a multi-channel &
	&structure-function chain"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data)
	select type (data)
	type is (sf_test_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Set up chain with structure function pair &
	&and three different mappings"
	write (u, "(A)")

	allocate (sf_config (2))
	call sf_config(1)%init ([1], data)
	call sf_config(2)%init ([2], data)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 3)

	call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2)

	! channel 1: no mapping
	call sf_chain_instance%set_channel (1, sf_channel(1))

	! channel 2: single-particle mappings
	call sf_channel(2)%activate_mapping ([1,2])
	! call sf_chain_instance%activate_mapping (2, [1,2])
	call sf_chain_instance%set_channel (2, sf_channel(2))

	! channel 3: two-particle mapping
	call sf_channel(3)%set_s_mapping ([1,2])
	! call sf_chain_instance%set_s_mapping (3, [1, 2])
	call sf_chain_instance%set_channel (3, sf_channel(3))

	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	write (u, "(A)") "* Compute kinematics in channel 1 and evaluate"
	write (u, "(A)")

	call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	write (u, "(A)")
	write (u, "(A)") "* Invert the kinematics calculation"
	write (u, "(A)")

	x_saved = sf_chain_instance%x

	call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	write (u, "(A)")
	write (u, "(A)") "* Compute kinematics in channel 2 and evaluate"
	write (u, "(A)")

	p_saved = sf_chain_instance%p

	call sf_chain_instance%compute_kinematics (2, p_saved(:,2))
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

	write (u, "(A)")
	write (u, "(A)") "* Compute kinematics in channel 3 and evaluate"
	write (u, "(A)")

	call sf_chain_instance%compute_kinematics (3, p_saved(:,3))
	call sf_chain_instance%evaluate (scale=0._default)

	call write_separator (u, 2)
	call sf_chain_instance%write (u)
	call write_separator (u, 2)

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

	call sf_chain_instance%final ()
	call sf_chain%final ()

	call model%final ()

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

	end subroutine sf_base_12

	@ %def sf_base_12
	@
	\subsubsection{Generated spectrum}
	Construct and evaluate a structure function object for a pair spectrum
	which is evaluated as a beam-event generator.
	<<SF base: execute tests>>=
	call test (sf_base_13, "sf_base_13", &
	"pair spectrum generator", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_13
	<<SF base: tests>>=
	subroutine sf_base_13 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t), dimension(2) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, x_free

	write (u, "(A)") "* Test output: sf_base_13"
	write (u, "(A)") "* Purpose: initialize and fill &
	&a pair generator object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	allocate (sf_test_generator_data_t :: data)
	select type (data)
	type is (sf_test_generator_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Initialize generator object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	write (u, "(A)") "* Generate free r values"
	write (u, "(A)")

	x_free = 1
	call sf_int%generate_free (r, rb, x_free)

	write (u, "(A)") "* Initialize incoming momenta with sqrts=1000"

	E = 500
	k(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	k(2) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call sf_int%seed_kinematics (k)

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

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call reset_interaction_counter ()
	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)

	call sf_int%seed_kinematics (k)
	call sf_int%set_momenta (q, outgoing=.true.)
	x_free = 1
	call sf_int%recover_x (x, xb, x_free)
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

	write (u, "(A)")
	write (u, "(A)") "* Compute inverse kinematics &
	&and evaluate"
	write (u, "(A)")

	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%apply (scale=0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "f =", f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_base_13

	@ %def sf_base_13
	@
	\subsubsection{Structure function chain evaluation}
	Here, we test the complete workflow for a structure-function chain
	with generator. First, we create the template chain, then initialize
	an instance. We set up links, mask, and evaluators. Finally, we set
	kinematics and evaluate the matrix elements and their products.
	<<SF base: execute tests>>=
	call test (sf_base_14, "sf_base_14", &
	"structure function generator evaluation", &
	u, results)
	<<SF base: test declarations>>=
	public :: sf_base_14
	<<SF base: tests>>=
	subroutine sf_base_14 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	type(beam_data_t), target :: beam_data
	class(sf_data_t), allocatable, target :: data_strfun
	class(sf_data_t), allocatable, target :: data_generator
	type(sf_config_t), dimension(:), allocatable, target :: sf_config
	real(default), dimension(:), allocatable :: p_in
	type(sf_chain_t), target :: sf_chain
	type(sf_chain_instance_t), target :: sf_chain_instance

	write (u, "(A)") "* Test output: sf_base_14"
	write (u, "(A)") "* Purpose: set up a structure-function chain"
	write (u, "(A)") "* create an instance and evaluate"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

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

	call reset_interaction_counter ()

	call beam_data%init_sqrts (1000._default, [flv, flv])

	allocate (sf_test_data_t :: data_strfun)
	select type (data_strfun)
	type is (sf_test_data_t)
	call data_strfun%init (model, pdg_in)
	end select

	allocate (sf_test_generator_data_t :: data_generator)
	select type (data_generator)
	type is (sf_test_generator_data_t)
	call data_generator%init (model, pdg_in)
	end select

	write (u, "(A)") "* Set up chain with generator and structure function"
	write (u, "(A)")

	allocate (sf_config (2))
	call sf_config(1)%init ([1,2], data_generator)
	call sf_config(2)%init ([2], data_strfun)
	call sf_chain%init (beam_data, sf_config)

	call sf_chain_instance%init (sf_chain, n_channel = 1)
	call sf_chain_instance%link_interactions ()
	call sf_chain_instance%exchange_mask ()
	call sf_chain_instance%init_evaluators ()

	write (u, "(A)") "* Inject integration parameter"
	write (u, "(A)")

	allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default)
	write (u, "(A,9(1x,F10.7))") "p_in =", p_in

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

	call sf_chain_instance%compute_kinematics (1, p_in)
	call sf_chain_instance%evaluate (scale=0._default)

	call sf_chain_instance%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Extract integration parameter"
	write (u, "(A)")

	call sf_chain_instance%get_mcpar (1, p_in)
	write (u, "(A,9(1x,F10.7))") "p_in =", p_in

	call sf_chain_instance%final ()
	call sf_chain%final ()

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

	call model%final ()

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

	end subroutine sf_base_14

	@ %def sf_base_14
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Photon radiation: ISR}

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

	module sf_isr

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use constants, only: pi
	use format_defs, only: FMT_15, FMT_19
	use numeric_utils
	use diagnostics
	use physics_defs, only: PHOTON
	use lorentz
	use sm_physics, only: Li2
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use polarizations
	use sf_aux
	use sf_mappings
	use sf_base
	use electron_pdfs

	<<Standard module head>>

	<<SF isr: public>>

	<<SF isr: parameters>>

	<<SF isr: types>>

	contains

	<<SF isr: procedures>>

	end module sf_isr
	@ %def sf_isr
	@
	\subsection{Physics}
	The ISR structure function is in the most crude approximation (LLA
	without $\alpha$ corrections, i.e. $\epsilon^0$)
	\begin{equation}
	f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad
	\epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2},
	\end{equation}
	where $m$ is the mass of the incoming (and outgoing) particle, which
	is initially assumed on-shell.

	In $f_0(x)$, there is an integrable singularity at $x=1$ which does
	not spoil the integration, but would lead to an unbounded $f_{\rm
	max}$. Therefore, we map this singularity like
	\begin{equation}\label{ISR-mapping}
	x = 1 - (1-x')^{1/\epsilon}
	\end{equation}
	such that
	\begin{equation}
	\int dx\,f_0(x) = \int dx'
	\end{equation}

	For the detailed form of the QED ISR structure function
	cf. Chap.~\ref{chap:qed_pdf}.

	\subsection{Implementation}

	In the concrete implementation, the zeroth order mapping
	(\ref{ISR-mapping}) is implemented, and the Jacobian is equal to
	$f_i(x)/f_0(x)$. This can be written as
	\begin{align}
	\frac{f_0(x)}{f_0(x)} &= 1 \\
	\frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\
	\begin{split}\label{ISR-f2}
	\frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
	+ \frac{27 - 8\pi^2}{96}\epsilon^2
	- \frac{1-x^2}{2(1-x')} \\
	&\quad - \frac{(1+3x^2)\ln x
	+ (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon
	\end{split}
	\end{align}
	%'
	For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to
	\begin{align}
	\frac{f_0(x)}{f_0(x)} &= 1 \\
	\frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\
	\frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
	+ \frac{27 - 8\pi^2}{96}\epsilon^2
	\end{align}
	The last line in (\ref{ISR-f2}) is zero for
	\begin{equation}
	x_{\rm min} = 0.00714053329734592839549879772019
	\end{equation}
	(Mathematica result), independent of $\epsilon$. For $x$ values less
	than this we ignore this correction because of the logarithmic
	singularity which should in principle be resummed.


	\subsection{The ISR data block}
	<<SF isr: public>>=
	public :: isr_data_t
	<<SF isr: types>>=
	type, extends (sf_data_t) :: isr_data_t
	private
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(:), allocatable :: flv_in
	type(qed_pdf_t) :: pdf
	real(default) :: alpha = 0
	real(default) :: q_max = 0
	real(default) :: real_mass = 0
	real(default) :: mass = 0
	real(default) :: eps = 0
	real(default) :: log = 0
	logical :: recoil = .false.
	logical :: keep_energy = .true.
	integer :: order = 3
	integer :: error = NONE
	contains
	<<SF isr: isr data: TBP>>
	end type isr_data_t

	@ %def isr_data_t
	@ Error codes
	<<SF isr: parameters>>=
	integer, parameter :: NONE = 0
	integer, parameter :: ZERO_MASS = 1
	integer, parameter :: Q_MAX_TOO_SMALL = 2
	integer, parameter :: EPS_TOO_LARGE = 3
	integer, parameter :: INVALID_ORDER = 4
	integer, parameter :: CHARGE_MIX = 5
	integer, parameter :: CHARGE_ZERO = 6
	integer, parameter :: MASS_MIX = 7
	@ Generate flavor-dependent ISR data:
	<<SF isr: isr data: TBP>>=
	procedure :: init => isr_data_init
	<<SF isr: procedures>>=
	subroutine isr_data_init (data, model, pdg_in, alpha, q_max, &
	mass, order, recoil, keep_energy)
	class(isr_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	real(default), intent(in) :: alpha
	real(default), intent(in) :: q_max
	real(default), intent(in), optional :: mass
	integer, intent(in), optional :: order
	logical, intent(in), optional :: recoil
	logical, intent(in), optional :: keep_energy
	integer :: i, n_flv
	real(default) :: charge
	data%model => model
	- n_flv = pdg_array_get_length (pdg_in)
	+ n_flv = pdg_in%get_length ()
	allocate (data%flv_in (n_flv))
	do i = 1, n_flv
	- call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
	+ call data%flv_in(i)%init (pdg_in%get (i), model)
	end do
	data%alpha = alpha
	data%q_max = q_max
	if (present (order)) then
	call data%set_order (order)
	end if
	if (present (recoil)) then
	data%recoil = recoil
	end if
	if (present (keep_energy)) then
	data%keep_energy = keep_energy
	end if
	data%real_mass = data%flv_in(1)%get_mass ()
	if (present (mass)) then
	if (mass > 0) then
	data%mass = mass
	else
	data%mass = data%real_mass
	if (any (data%flv_in%get_mass () /= data%mass)) then
	data%error = MASS_MIX; return
	end if
	end if
	else
	data%mass = data%real_mass
	if (any (data%flv_in%get_mass () /= data%mass)) then
	data%error = MASS_MIX; return
	end if
	end if
	if (vanishes (data%mass)) then
	data%error = ZERO_MASS; return
	else if (data%mass >= data%q_max) then
	data%error = Q_MAX_TOO_SMALL; return
	end if
	data%log = log (1 + (data%q_max / data%mass)**2)
	charge = data%flv_in(1)%get_charge ()
	if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then
	data%error = CHARGE_MIX; return
	else if (charge == 0) then
	data%error = CHARGE_ZERO; return
	end if
	data%eps = data%alpha / pi * charge ** 2 &
	* (2 * log (data%q_max / data%mass) - 1)
	if (data%eps > 1) then
	data%error = EPS_TOO_LARGE; return
	end if
	call data%pdf%init &
	(data%mass, data%alpha, charge, data%q_max, data%order)
	end subroutine isr_data_init

	@ %def isr_data_init
	@ Explicitly set ISR order
	<<SF isr: isr data: TBP>>=
	procedure :: set_order => isr_data_set_order
	<<SF isr: procedures>>=
	elemental subroutine isr_data_set_order (data, order)
	class(isr_data_t), intent(inout) :: data
	integer, intent(in) :: order
	if (order < 0 .or. order > 3) then
	data%error = INVALID_ORDER
	else
	data%order = order
	end if
	end subroutine isr_data_set_order

	@ %def isr_data_set_order
	@ Handle error conditions. Should always be done after
	initialization, unless we are sure everything is ok.
	<<SF isr: isr data: TBP>>=
	procedure :: check => isr_data_check
	<<SF isr: procedures>>=
	subroutine isr_data_check (data)
	class(isr_data_t), intent(in) :: data
	select case (data%error)
	case (ZERO_MASS)
	call msg_fatal ("ISR: Particle mass is zero")
	case (Q_MAX_TOO_SMALL)
	call msg_fatal ("ISR: Particle mass exceeds Qmax")
	case (EPS_TOO_LARGE)
	call msg_fatal ("ISR: Expansion parameter too large, " // &
	"perturbative expansion breaks down")
	case (INVALID_ORDER)
	call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)")
	case (MASS_MIX)
	call msg_fatal ("ISR: Incoming particle masses must be uniform")
	case (CHARGE_MIX)
	call msg_fatal ("ISR: Incoming particle charges must be uniform")
	case (CHARGE_ZERO)
	call msg_fatal ("ISR: Incoming particle must be charged")
	end select
	end subroutine isr_data_check

	@ %def isr_data_check
	@ Output
	<<SF isr: isr data: TBP>>=
	procedure :: write => isr_data_write
	<<SF isr: procedures>>=
	subroutine isr_data_write (data, unit, verbose)
	class(isr_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "ISR data:"
	if (allocated (data%flv_in)) then
	write (u, "(3x,A)", advance="no") " flavor = "
	do i = 1, size (data%flv_in)
	if (i > 1) write (u, "(',',1x)", advance="no")
	call data%flv_in(i)%write (u)
	end do
	write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha
	write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max
	write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass
	write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps
	write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log
	write (u, "(3x,A,I2)") " order = ", data%order
	write (u, "(3x,A,L2)") " recoil = ", data%recoil
	write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine isr_data_write

	@ %def isr_data_write
	@ For ISR, there is the option to generate transverse momentum is
	generated. Hence, there can be up to three parameters, $x$, and two
	angles.
	<<SF isr: isr data: TBP>>=
	procedure :: get_n_par => isr_data_get_n_par
	<<SF isr: procedures>>=
	function isr_data_get_n_par (data) result (n)
	class(isr_data_t), intent(in) :: data
	integer :: n
	if (data%recoil) then
	n = 3
	else
	n = 1
	end if
	end function isr_data_get_n_par

	@ %def isr_data_get_n_par
	@ Return the outgoing particles PDG codes. For ISR, these are
	identical to the incoming particles.
	<<SF isr: isr data: TBP>>=
	procedure :: get_pdg_out => isr_data_get_pdg_out
	<<SF isr: procedures>>=
	subroutine isr_data_get_pdg_out (data, pdg_out)
	class(isr_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	pdg_out(1) = data%flv_in%get_pdg ()
	end subroutine isr_data_get_pdg_out

	@ %def isr_data_get_pdg_out
	@ Return the [[eps]] value. We need it for an appropriate mapping of
	structure-function parameters.
	<<SF isr: isr data: TBP>>=
	procedure :: get_eps => isr_data_get_eps
	<<SF isr: procedures>>=
	function isr_data_get_eps (data) result (eps)
	class(isr_data_t), intent(in) :: data
	real(default) :: eps
	eps = data%eps
	end function isr_data_get_eps

	@ %def isr_data_get_eps
	@ Allocate the interaction record.
	<<SF isr: isr data: TBP>>=
	procedure :: allocate_sf_int => isr_data_allocate_sf_int
	<<SF isr: procedures>>=
	subroutine isr_data_allocate_sf_int (data, sf_int)
	class(isr_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (isr_t :: sf_int)
	end subroutine isr_data_allocate_sf_int

	@ %def isr_data_allocate_sf_int
	@
	\subsection{The ISR object}
	The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for
	single-photon emission only (but use the multi-photon resummed
	radiator function). The particles are ordered as (incoming, photon,
	outgoing).

	There is no need to handle several flavors (and data blocks) in
	parallel, since ISR is always applied immediately after beam
	collision. (ISR for partons is accounted for by the PDFs themselves.)
	Polarization is carried through, i.e., we retain the polarization of
	the incoming particle and treat the emitted photon as unpolarized.
	Color is trivially carried through. This implies that particles 1 and
	3 should be locked together. For ISR we don't need the q variable.
	<<SF isr: public>>=
	public :: isr_t
	<<SF isr: types>>=
	type, extends (sf_int_t) :: isr_t
	private
	type(isr_data_t), pointer :: data => null ()
	real(default) :: x = 0
	real(default) :: xb= 0
	contains
	<<SF isr: isr: TBP>>
	end type isr_t

	@ %def isr_t
	@ Type string: has to be here, but there is no string variable on which ISR
	depends. Hence, a dummy routine.
	<<SF isr: isr: TBP>>=
	procedure :: type_string => isr_type_string
	<<SF isr: procedures>>=
	function isr_type_string (object) result (string)
	class(isr_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "ISR: e+ e- ISR spectrum"
	else
	string = "ISR: [undefined]"
	end if
	end function isr_type_string

	@ %def isr_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF isr: isr: TBP>>=
	procedure :: write => isr_write
	<<SF isr: procedures>>=
	subroutine isr_write (object, unit, testflag)
	class(isr_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(1x,A)") "SF parameters:"
	write (u, "(3x,A," // FMT_15 // ")") "x =", object%x
	write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "ISR data: [undefined]"
	end if
	end subroutine isr_write

	@ %def isr_write
	@ Explicitly set ISR order (for unit test).
	<<SF isr: isr: TBP>>=
	procedure :: set_order => isr_set_order
	<<SF isr: procedures>>=
	subroutine isr_set_order (object, order)
	class(isr_t), intent(inout) :: object
	integer, intent(in) :: order
	call object%data%set_order (order)
	call object%data%pdf%set_order (order)
	end subroutine isr_set_order

	@ %def isr_set_order
	@
	\subsection{Kinematics}
	Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ were trivial. The ISR structure
	function allows for a straightforward mapping of the unit interval.
	So, to leading order, the structure function value is unity, but the
	$x$ value is transformed. Higher orders affect the function value.

	The structure function implementation applies the above mapping to the
	input (random) number [[r]] to generate the momentum fraction [[x]]
	and the function value [[f]]. For numerical stability reasons, we
	also output [[xb]], which is $\bar x=1-x$.

	For the ISR structure function, the mapping Jacobian cancels the
	structure function (to order zero). We apply the cancellation
	explicitly, therefore both the Jacobian [[f]] and the zeroth-order value
	(see the [[apply]] method) are unity if mapping is turned on. If
	mapping is turned off, the Jacobian [[f]] includes the value of the
	(zeroth-order) structure function, and strongly peaked.
	<<SF isr: isr: TBP>>=
	procedure :: complete_kinematics => isr_complete_kinematics
	<<SF isr: procedures>>=
	subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(isr_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	real(default) :: eps
	eps = sf_int%data%eps
	if (map) then
	call map_power_1 (sf_int%xb, f, rb(1), eps)
	else
	sf_int%xb = rb(1)
	if (rb(1) > 0) then
	f = 1
	else
	f = 0
	end if
	end if
	sf_int%x = 1 - sf_int%xb
	x(1) = sf_int%x
	xb(1) = sf_int%xb
	if (size (x) == 3) then
	x(2:3) = r(2:3)
	xb(2:3) = rb(2:3)
	end if
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS)
	sf_int%x = 0
	sf_int%xb= 0
	f = 0
	end select
	end subroutine isr_complete_kinematics

	@ %def isr_complete_kinematics
	@ Overriding the default method: we compute the [[x]] array from the
	momentum configuration. In the specific case of ISR, we also set the
	internally stored $x$ and $\bar x$ values, so they can be used in the
	following routine.
	<<SF isr: isr: TBP>>=
	procedure :: recover_x => sf_isr_recover_x
	<<SF isr: procedures>>=
	subroutine sf_isr_recover_x (sf_int, x, xb, x_free)
	class(isr_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb, x_free)
	sf_int%x = x(1)
	sf_int%xb = xb(1)
	end subroutine sf_isr_recover_x

	@ %def sf_isr_recover_x
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.

	For extracting $x$, we rely on the stored $\bar x$ value, since the
	$x$ value in the argument is likely imprecise. This means that either
	[[complete_kinematics]] or [[recover_x]] must be called first, for the
	current sampling point (but maybe another channel).
	<<SF isr: isr: TBP>>=
	procedure :: inverse_kinematics => isr_inverse_kinematics
	<<SF isr: procedures>>=
	subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(isr_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	real(default) :: eps
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	eps = sf_int%data%eps
	if (map) then
	call map_power_inverse_1 (xb(1), f, rb(1), eps)
	else
	rb(1) = xb(1)
	if (rb(1) > 0) then
	f = 1
	else
	f = 0
	end if
	end if
	r(1) = 1 - rb(1)
	if (size(r) == 3) then
	r(2:3) = x(2:3)
	rb(2:3)= xb(2:3)
	end if
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS)
	r = 0
	rb= 0
	f = 0
	end select
	end if
	end subroutine isr_inverse_kinematics

	@ %def isr_inverse_kinematics
	@
	<<SF isr: isr: TBP>>=
	procedure :: init => isr_init
	<<SF isr: procedures>>=
	subroutine isr_init (sf_int, data)
	class(isr_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	integer, dimension(3) :: hel_lock
	type(polarization_t), target :: pol
	type(quantum_numbers_t), dimension(1) :: qn_fc
	type(flavor_t) :: flv_photon
	type(color_t) :: col_photon
	type(quantum_numbers_t) :: qn_hel, qn_photon, qn
	type(polarization_iterator_t) :: it_hel
	real(default) :: m2
	integer :: i
	mask = quantum_numbers_mask (.false., .false., &
	mask_h = [.false., .true., .false.])
	hel_lock = [3, 0, 1]
	select type (data)
	type is (isr_data_t)
	m2 = data%mass**2
	call sf_int%base_init (mask, [m2], [0._default], [m2], &
	hel_lock = hel_lock)
	sf_int%data => data
	call flv_photon%init (PHOTON, data%model)
	call col_photon%init ()
	call qn_photon%init (flv_photon, col_photon)
	call qn_photon%tag_radiated ()
	do i = 1, size (data%flv_in)
	call pol%init_generic (data%flv_in(i))
	call qn_fc(1)%init (&
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i), 1))
	call it_hel%init (pol)
	do while (it_hel%is_valid ())
	qn_hel = it_hel%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc(1)
	call sf_int%add_state ([qn, qn_photon, qn])
	call it_hel%advance ()
	end do
	! call pol%final () !!! Obsolete
	end do
	call sf_int%freeze ()
	if (data%keep_energy) then
	sf_int%on_shell_mode = KEEP_ENERGY
	else
	sf_int%on_shell_mode = KEEP_MOMENTUM
	end if
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	sf_int%status = SF_INITIAL
	end select
	end subroutine isr_init

	@ %def isr_init
	@
	\subsection{ISR application}
	For ISR, we could in principle compute kinematics and function value
	in a single step. In order to be able to reweight matrix elements
	including structure functions we split kinematics and structure
	function calculation. The structure function works on a single beam,
	assuming that the input momentum has been set.

	For the structure-function evaluation, we rely on the fact that the
	power mapping, which we apply in the kinematics method (if the [[map]]
	flag is set), has a Jacobian which is just the inverse lowest-order
	structure function. With mapping active, the two should cancel
	exactly.

	After splitting momenta, we set the outgoing momenta on-shell. We
	choose to conserve momentum, so energy conservation may be violated.
	<<SF isr: isr: TBP>>=
	procedure :: apply => isr_apply
	<<SF isr: procedures>>=
	subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(isr_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: f, finv, x, xb, eps, rb
	real(default) :: log_x, log_xb, x_2
	associate (data => sf_int%data)
	eps = sf_int%data%eps
	x = sf_int%x
	xb = sf_int%xb
	call map_power_inverse_1 (xb, finv, rb, eps)
	if (finv > 0) then
	f = 1 / finv
	else
	f = 0
	end if
	call data%pdf%evolve_qed_pdf (x, xb, rb, f)
	end associate
	call sf_int%set_matrix_element (cmplx (f, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine isr_apply

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

	module sf_isr_ut
	use unit_tests
	use sf_isr_uti

	<<Standard module head>>

	<<SF isr: public test>>

	contains

	<<SF isr: test driver>>

	end module sf_isr_ut
	@ %def sf_isr_ut
	@
	<<[[sf_isr_uti.f90]]>>=
	<<File header>>

	module sf_isr_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_12
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use interactions, only: interaction_pacify_momenta
	use model_data
	use sf_aux, only: KEEP_ENERGY
	use sf_mappings
	use sf_base

	use sf_isr

	<<Standard module head>>

	<<SF isr: test declarations>>

	contains

	<<SF isr: tests>>

	end module sf_isr_uti
	@ %def sf_isr_ut
	@ API: driver for the unit tests below.
	<<SF isr: public test>>=
	public :: sf_isr_test
	<<SF isr: test driver>>=
	subroutine sf_isr_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF isr: execute tests>>
	end subroutine sf_isr_test

	@ %def sf_isr_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF isr: execute tests>>=
	call test (sf_isr_1, "sf_isr_1", &
	"structure function configuration", &
	u, results)
	<<SF isr: test declarations>>=
	public :: sf_isr_1
	<<SF isr: tests>>=
	subroutine sf_isr_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_isr_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in = ELECTRON

	allocate (isr_data_t :: data)
	call data%write (u)

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

	select type (data)
	type is (isr_data_t)
	call data%init (model, pdg_in, 1./137._default, 10._default, &
	0.000511_default, order = 3, recoil = .false.)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_isr_1

	@ %def sf_isr_1
	@
	\subsubsection{Structure function without mapping}
	Direct ISR evaluation. This is the use case for a double-beam
	structure function. The parameter pair is mapped in the calling program.
	<<SF isr: execute tests>>=
	call test (sf_isr_2, "sf_isr_2", &
	"no ISR mapping", &
	u, results)
	<<SF isr: test declarations>>=
	public :: sf_isr_2
	<<SF isr: tests>>=
	subroutine sf_isr_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(flavor_t) :: flv
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, f_isr

	write (u, "(A)") "* Test output: sf_isr_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in = ELECTRON
	call flv%init (ELECTRON, model)

	call reset_interaction_counter ()

	allocate (isr_data_t :: data)
	select type (data)
	type is (isr_data_t)
	call data%init (model, pdg_in, 1./137._default, 500._default, &
	0.000511_default, order = 3, recoil = .false.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, &
	&collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.9_default
	rb = 1 - r
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A)")
	write (u, "(A,9(1x," // FMT_12 // "))") "x =", x
	write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb
	write (u, "(A,9(1x," // FMT_12 // "))") "f =", f

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

	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb
	write (u, "(A,9(1x," // FMT_12 // "))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate ISR structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Structure-function value, default order"
	write (u, "(A)")

	f_isr = sf_int%get_matrix_element (1)

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f

	write (u, "(A)")
	write (u, "(A)") "* Re-evaluate structure function, leading order"
	write (u, "(A)")

	select type (sf_int)
	type is (isr_t)
	call sf_int%set_order (0)
	end select
	call sf_int%apply (scale = 100._default)
	f_isr = sf_int%get_matrix_element (1)

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_isr_2

	@ %def sf_isr_2
	@
	\subsubsection{Structure function with mapping}
	Apply the optimal ISR mapping. This is the use case for a single-beam
	structure function.
	<<SF isr: execute tests>>=
	call test (sf_isr_3, "sf_isr_3", &
	"ISR mapping", &
	u, results)
	<<SF isr: test declarations>>=
	public :: sf_isr_3
	<<SF isr: tests>>=
	subroutine sf_isr_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, f_isr

	write (u, "(A)") "* Test output: sf_isr_3"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	allocate (isr_data_t :: data)
	select type (data)
	type is (isr_data_t)
	call data%init (model, pdg_in, 1./137._default, 500._default, &
	0.000511_default, order = 3, recoil = .false.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, &
	&collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.7_default
	rb = 1 - r
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)

	write (u, "(A)")
	write (u, "(A,9(1x," // FMT_12 // "))") "x =", x
	write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb
	write (u, "(A,9(1x," // FMT_12 // "))") "f =", f

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

	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb
	write (u, "(A,9(1x," // FMT_12 // "))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate ISR structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Structure-function value, default order"
	write (u, "(A)")

	f_isr = sf_int%get_matrix_element (1)

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f

	write (u, "(A)")
	write (u, "(A)") "* Re-evaluate structure function, leading order"
	write (u, "(A)")

	select type (sf_int)
	type is (isr_t)
	call sf_int%set_order (0)
	end select
	call sf_int%apply (scale = 100._default)
	f_isr = sf_int%get_matrix_element (1)

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_isr_3

	@ %def sf_isr_3
	@
	\subsubsection{Non-collinear ISR splitting}
	Construct and display a structure function object based on the ISR
	structure function. We blank out numerical fluctuations for 32bit.
	<<SF isr: execute tests>>=
	call test (sf_isr_4, "sf_isr_4", &
	"ISR non-collinear", &
	u, results)
	<<SF isr: test declarations>>=
	public :: sf_isr_4
	<<SF isr: tests>>=
	subroutine sf_isr_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, f_isr
	character(len=80) :: buffer
	integer :: u_scratch, iostat

	write (u, "(A)") "* Test output: sf_isr_4"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	write (u, "(A)")
	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	allocate (isr_data_t :: data)
	select type (data)
	type is (isr_data_t)
	call data%init (model, pdg_in, 1./137._default, 500._default, &
	0.000511_default, order = 3, recoil = .true.)
	end select

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, "
	write (u, "(A)") " non-coll., keeping energy"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.5_default, 0.5_default, 0.25_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "r =", r

	write (u, "(A)")
	write (u, "(A)") "* Evaluate ISR structure function"
	write (u, "(A)")

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)
	call sf_int%apply (scale = 10._default)
	u_scratch = free_unit ()
	open (u_scratch, status="scratch", action = "readwrite")
	call sf_int%write (u_scratch, testflag = .true.)
	rewind (u_scratch)
	do
	read (u_scratch, "(A)", iostat=iostat) buffer
	if (iostat /= 0) exit
	if (buffer(1:25) == " P = 0.000000E+00 9.57") then
	buffer = replace (buffer, 26, "XXXX")
	end if
	if (buffer(1:25) == " P = 0.000000E+00 -9.57") then
	buffer = replace (buffer, 26, "XXXX")
	end if
	write (u, "(A)") buffer
	end do
	close (u_scratch)

	write (u, "(A)")
	write (u, "(A)") "* Structure-function value"
	write (u, "(A)")

	f_isr = sf_int%get_matrix_element (1)

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_isr_4

	@ %def sf_isr_4
	@
	\subsubsection{Structure function pair with mapping}
	Apply the ISR mapping for a ISR pair.
	structure function.
	<<SF isr: execute tests>>=
	call test (sf_isr_5, "sf_isr_5", &
	"ISR pair mapping", &
	u, results)
	<<SF isr: test declarations>>=
	public :: sf_isr_5
	<<SF isr: tests>>=
	subroutine sf_isr_5 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_mapping_t), allocatable :: mapping
	class(sf_int_t), dimension(:), allocatable :: sf_int
	type(vector4_t), dimension(2) :: k
	real(default) :: E, f_map
	real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb
	real(default), dimension(2) :: f, f_isr
	integer :: i

	write (u, "(A)") "* Test output: sf_isr_5"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	allocate (isr_data_t :: data)
	select type (data)
	type is (isr_data_t)
	call data%init (model, pdg_in, 1./137._default, 500._default, &
	0.000511_default, order = 3, recoil = .false.)
	end select

	allocate (sf_ip_mapping_t :: mapping)
	select type (mapping)
	type is (sf_ip_mapping_t)
	select type (data)
	type is (isr_data_t)
	call mapping%init (eps = data%get_eps ())
	end select
	call mapping%set_index (1, 1)
	call mapping%set_index (2, 2)
	end select

	call mapping%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	allocate (isr_t :: sf_int (2))

	do i = 1, 2
	call sf_int(i)%init (data)
	call sf_int(i)%set_beam_index ([i])
	end do

	write (u, "(A)") "* Initialize incoming momenta with E=500"
	write (u, "(A)")
	E = 500
	k(1) = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	k(2) = vector4_moving (E, - sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	do i = 1, 2
	call vector4_write (k(i), u)
	call sf_int(i)%seed_kinematics (k(i:i))
	end do

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear"
	write (u, "(A)")

	allocate (p (2 * data%get_n_par ()))
	allocate (pb(size (p)))
	allocate (r (size (p)))
	allocate (rb(size (p)))
	allocate (x (size (p)))
	allocate (xb(size (p)))

	p = [0.7_default, 0.4_default]
	pb= 1 - p
	call mapping%compute (r, rb, f_map, p, pb)

	write (u, "(A,9(1x," // FMT_12 // "))") "p =", p
	write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb
	write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map

	do i = 1, 2
	call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
	map=.false.)
	end do

	write (u, "(A)")
	write (u, "(A,9(1x," // FMT_12 // "))") "x =", x
	write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb
	write (u, "(A,9(1x," // FMT_12 // "))") "f =", f

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

	do i = 1, 2
	call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
	map=.false.)
	end do
	call mapping%inverse (r, rb, f_map, p, pb)

	write (u, "(A,9(1x," // FMT_12 // "))") "p =", p
	write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb
	write (u, "(A,9(1x," // FMT_12 // "))") "r =", r
	write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb
	write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map

	write (u, "(A)")
	write (u, "(A)") "* Evaluate ISR structure function"

	call sf_int(1)%apply (scale = 100._default)
	call sf_int(2)%apply (scale = 100._default)

	write (u, "(A)")
	write (u, "(A)") "* Structure function #1"
	write (u, "(A)")
	call sf_int(1)%write (u, testflag = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Structure function #2"
	write (u, "(A)")
	call sf_int(2)%write (u, testflag = .true.)

	write (u, "(A)")
	write (u, "(A)") "* Structure-function value, default order"
	write (u, "(A)")

	do i = 1, 2
	f_isr(i) = sf_int(i)%get_matrix_element (1)
	end do

	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", &
	product (f_isr)
	write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", &
	product (f_isr * f) * f_map

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

	do i = 1, 2
	call sf_int(i)%final ()
	end do
	call model%final ()

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

	end subroutine sf_isr_5

	@ %def sf_isr_5
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{EPA}

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

	module sf_epa

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use constants, only: pi
	use format_defs, only: FMT_17, FMT_19
	use numeric_utils
	use diagnostics
	use physics_defs, only: PHOTON
	use lorentz
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use interactions
	use sf_aux
	use sf_base

	<<Standard module head>>

	<<SF epa: public>>

	<<SF epa: parameters>>

	<<SF epa: types>>

	contains

	<<SF epa: procedures>>

	end module sf_epa
	@ %def sf_epa
	@
	\subsection{Physics}
	The EPA structure function for a photon inside an (elementary)
	particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g.,
	electron) is given by ($\bar x \equiv 1-x$)

	There are several variants of the EPA, which are steered by the
	[[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev
	et al. is given by
	%% %\cite{Budnev:1974de}
	%% \bibitem{Budnev:1974de}
	%% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo,
	%% %``The Two photon particle production mechanism. Physical problems.
	%% %Applications. Equivalent photon approximation,''
	%% Phys.\ Rept.\ {\bf 15} (1974) 181.
	%% %%CITATION = PRPLC,15,181;%%
	\begin{multline}
	\label{EPA_617}
	f(x) =
	\frac{\alpha}{\pi}\,q_p^2\,
	\frac{1}{x}\,
	\biggl[\left(\bar x + \frac{x^2}{2}\right)
	\ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
	\\
	- \left(1 - \frac{x}{2}\right)^2
	\ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}}
	{x^2+\frac{Q^2_{\rm min}}{E^2}}
	- x^2\frac{m^2}{Q^2_{\rm min}}
	\left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
	\biggr].
	\end{multline}
	If no explicit $Q$ bounds are provided, the kinematical bounds are
	\begin{align}
	-Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2,
	\\
	-Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2
	\approx
	-\frac{x^2}{\bar x}m^2.
	\end{align}

	The second and third terms in (\ref{EPA_617}) are negative definite (and
	subleading). Noting that $\bar x + x^2/2$ is bounded between
	$1/2$ and $1$, we derive that $f(x)$ is always smaller than
	\begin{equation}
	\bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x}
	\qquad\text{where}\qquad
	L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)},
	\end{equation}
	where we allow for explicit $Q$ bounds that narrow the kinematical range.
	Therefore, we generate this distribution:
	\begin{equation}\label{EPA-subst}
	\int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx'
	\end{equation}
	We set
	\begin{equation}\label{EPA-x(x')}
	\ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1)
	+ \bar x'\ln x_0(L-\ln x_0) \right]} \right\}
	\end{equation}
	such that $x(0)=x_0$ and $x(1)=x_1$ and
	\begin{equation}
	\frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1}
	x\frac{C(x_0,x_1)}{L - 2\ln x}
	\end{equation}
	with
	\begin{equation}
	C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln
	x_0(L-\ln x_0)\right]
	\end{equation}
	such that (\ref{EPA-subst}) is satisfied. Finally, we have
	\begin{equation}
	\int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\,
	\frac{f(x(x'))}{\bar f(x(x'))}
	\end{equation}
	where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}).

	The structure of the mapping is most obvious from:
	\begin{equation}
	x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)}
	{\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; .
	\end{equation}

	Taking the Eq. (6.16e) from the Budnev et al. report, and integrating
	it over $q^2$ yields the modified result
	\begin{equation}
	\label{EPA_616e}
	f(x) =
	\frac{\alpha}{\pi}\,q_p^2\,
	\frac{1}{x}\,
	\biggl[\left(\bar x + \frac{x^2}{2}\right)
	\ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
	- x^2\frac{m^2}{Q^2_{\rm min}}
	\left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
	\biggr].
	\end{equation}
	This is closer to many standard papers from LEP times, and to textbook
	formulae like e.g. in Peskin/Schroeder. For historical reasons, we
	keep Eq.~(\ref{EPA_617}) as the default in \whizard.


	\subsection{The EPA data block}
	The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and
	$x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG
	code as input; from this we can deduce the mass and charge.

	Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln
	x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming
	particle mass.
	<<SF epa: public>>=
	public :: EPA_MODE_DEFAULT
	public :: EPA_MODE_BUDNEV_617
	public :: EPA_MODE_BUDNEV_616E
	public :: EPA_MODE_LOG_POWER
	public :: EPA_MODE_LOG_SIMPLE
	public :: EPA_MODE_LOG
	<<SF epa: parameters>>=
	integer, parameter :: EPA_MODE_DEFAULT = 0
	integer, parameter :: EPA_MODE_BUDNEV_617 = 0
	integer, parameter :: EPA_MODE_BUDNEV_616E = 1
	integer, parameter :: EPA_MODE_LOG_POWER = 2
	integer, parameter :: EPA_MODE_LOG_SIMPLE = 3
	integer, parameter :: EPA_MODE_LOG = 4

	@ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E
	@ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG
	@
	<<SF epa: public>>=
	public :: epa_data_t
	<<SF epa: types>>=
	type, extends(sf_data_t) :: epa_data_t
	private
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(:), allocatable :: flv_in
	real(default) :: alpha
	real(default) :: x_min
	real(default) :: x_max
	real(default) :: q_min
	real(default) :: q_max
	real(default) :: E_max
	real(default) :: mass
	real(default) :: log
	real(default) :: a
	real(default) :: c0
	real(default) :: c1
	real(default) :: dc
	integer :: mode = EPA_MODE_DEFAULT
	integer :: error = NONE
	logical :: recoil = .false.
	logical :: keep_energy = .true.
	contains
	<<SF epa: epa data: TBP>>
	end type epa_data_t

	@ %def epa_data_t
	@ Error codes
	<<SF epa: parameters>>=
	integer, parameter :: NONE = 0
	integer, parameter :: ZERO_QMIN = 1
	integer, parameter :: Q_MAX_TOO_SMALL = 2
	integer, parameter :: ZERO_XMIN = 3
	integer, parameter :: MASS_MIX = 4
	integer, parameter :: NO_EPA = 5
	<<SF epa: epa data: TBP>>=
	procedure :: init => epa_data_init
	<<SF epa: procedures>>=
	subroutine epa_data_init (data, model, mode, pdg_in, alpha, &
	x_min, q_min, q_max, mass, recoil, keep_energy)
	class(epa_data_t), intent(inout) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	integer, intent(in) :: mode
	real(default), intent(in) :: alpha, x_min, q_min, q_max
	real(default), intent(in), optional :: mass
	logical, intent(in), optional :: recoil
	logical, intent(in), optional :: keep_energy
	integer :: n_flv, i
	data%model => model
	data%mode = mode
	- n_flv = pdg_array_get_length (pdg_in)
	+ n_flv = pdg_in%get_length ()
	allocate (data%flv_in (n_flv))
	do i = 1, n_flv
	- call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
	+ call data%flv_in(i)%init (pdg_in%get (i), model)
	end do
	data%alpha = alpha
	data%E_max = q_max / 2
	data%x_min = x_min
	data%x_max = 1
	if (vanishes (data%x_min)) then
	data%error = ZERO_XMIN; return
	end if
	data%q_min = q_min
	data%q_max = q_max
	select case (char (data%model%get_name ()))
	case ("QCD","Test")
	data%error = NO_EPA; return
	end select
	if (present (recoil)) then
	data%recoil = recoil
	end if
	if (present (keep_energy)) then
	data%keep_energy = keep_energy
	end if
	if (present (mass)) then
	data%mass = mass
	else
	data%mass = data%flv_in(1)%get_mass ()
	if (any (data%flv_in%get_mass () /= data%mass)) then
	data%error = MASS_MIX; return
	end if
	end if
	if (max (data%mass, data%q_min) == 0) then
	data%error = ZERO_QMIN; return
	else if (max (data%mass, data%q_min) >= data%E_max) then
	data%error = Q_MAX_TOO_SMALL; return
	end if
	data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 )
	data%a = data%alpha / pi
	data%c0 = log (data%x_min) * (data%log - log (data%x_min))
	data%c1 = log (data%x_max) * (data%log - log (data%x_max))
	data%dc = data%c1 - data%c0
	end subroutine epa_data_init

	@ %def epa_data_init
	@ Handle error conditions. Should always be done after
	initialization, unless we are sure everything is ok.
	<<SF epa: epa data: TBP>>=
	procedure :: check => epa_data_check
	<<SF epa: procedures>>=
	subroutine epa_data_check (data)
	class(epa_data_t), intent(in) :: data
	select case (data%error)
	case (NO_EPA)
	call msg_fatal ("EPA structure function not available for model " &
	// char (data%model%get_name ()) // ".")
	case (ZERO_QMIN)
	call msg_fatal ("EPA: Particle mass is zero")
	case (Q_MAX_TOO_SMALL)
	call msg_fatal ("EPA: Particle mass exceeds Qmax")
	case (ZERO_XMIN)
	call msg_fatal ("EPA: x_min must be larger than zero")
	case (MASS_MIX)
	call msg_fatal ("EPA: incoming particle masses must be uniform")
	end select
	end subroutine epa_data_check

	@ %def epa_data_check
	@ Output
	<<SF epa: epa data: TBP>>=
	procedure :: write => epa_data_write
	<<SF epa: procedures>>=
	subroutine epa_data_write (data, unit, verbose)
	class(epa_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "EPA data:"
	if (allocated (data%flv_in)) then
	write (u, "(3x,A)", advance="no") " flavor = "
	do i = 1, size (data%flv_in)
	if (i > 1) write (u, "(',',1x)", advance="no")
	call data%flv_in(i)%write (u)
	end do
	write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha
	write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min
	write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max
	write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min
	write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max
	write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max
	write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass
	write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a
	write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0
	write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1
	write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log
	write (u, "(3x,A,L2)") " recoil = ", data%recoil
	write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine epa_data_write

	@ %def epa_data_write
	@ The number of kinematic parameters.
	<<SF epa: epa data: TBP>>=
	procedure :: get_n_par => epa_data_get_n_par
	<<SF epa: procedures>>=
	function epa_data_get_n_par (data) result (n)
	class(epa_data_t), intent(in) :: data
	integer :: n
	if (data%recoil) then
	n = 3
	else
	n = 1
	end if
	end function epa_data_get_n_par

	@ %def epa_data_get_n_par
	@ Return the outgoing particles PDG codes. The outgoing particle is always
	the photon while the radiated particle is identical to the incoming one.
	<<SF epa: epa data: TBP>>=
	procedure :: get_pdg_out => epa_data_get_pdg_out
	<<SF epa: procedures>>=
	subroutine epa_data_get_pdg_out (data, pdg_out)
	class(epa_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	pdg_out(1) = PHOTON
	end subroutine epa_data_get_pdg_out

	@ %def epa_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF epa: epa data: TBP>>=
	procedure :: allocate_sf_int => epa_data_allocate_sf_int
	<<SF epa: procedures>>=
	subroutine epa_data_allocate_sf_int (data, sf_int)
	class(epa_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (epa_t :: sf_int)
	end subroutine epa_data_allocate_sf_int

	@ %def epa_data_allocate_sf_int
	@
	\subsection{The EPA object}
	The [[epa_t]] data type is a $1\to 2$ interaction. We should be able
	to handle several flavors in parallel, since EPA is not necessarily
	applied immediately after beam collision: Photons may be radiated
	from quarks. In that case, the partons are massless and $q_{\rm min}$
	applies instead, so we do not need to generate several kinematical
	configurations in parallel.

	The squared charge values multiply the matrix elements, depending on the
	flavour. We scan the interaction after building it, so we have the correct
	assignments.

	The particles are ordered as (incoming, radiated, photon), where the
	photon initiates the hard interaction.

	We generate an unpolarized photon and transfer initial polarization to
	the radiated parton. Color is transferred in the same way.
	<<SF epa: types>>=
	type, extends (sf_int_t) :: epa_t
	type(epa_data_t), pointer :: data => null ()
	real(default) :: x = 0
	real(default) :: xb = 0
	real(default) :: E = 0
	real(default), dimension(:), allocatable :: charge2
	contains
	<<SF epa: epa: TBP>>
	end type epa_t

	@ %def epa_t
	@ Type string: has to be here, but there is no string variable on which EPA
	depends. Hence, a dummy routine.
	<<SF epa: epa: TBP>>=
	procedure :: type_string => epa_type_string
	<<SF epa: procedures>>=
	function epa_type_string (object) result (string)
	class(epa_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "EPA: equivalent photon approx."
	else
	string = "EPA: [undefined]"
	end if
	end function epa_type_string

	@ %def epa_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF epa: epa: TBP>>=
	procedure :: write => epa_write
	<<SF epa: procedures>>=
	subroutine epa_write (object, unit, testflag)
	class(epa_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(1x,A)") "SF parameters:"
	write (u, "(3x,A," // FMT_17 // ")") "x =", object%x
	if (object%status >= SF_FAILED_EVALUATION) then
	write (u, "(3x,A," // FMT_17 // ")") "E =", object%E
	end if
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "EPA data: [undefined]"
	end if
	end subroutine epa_write

	@ %def epa_write
	@ Prepare the interaction object. We have to construct transition matrix
	elements for all flavor and helicity combinations.
	<<SF epa: epa: TBP>>=
	procedure :: init => epa_init
	<<SF epa: procedures>>=
	subroutine epa_init (sf_int, data)
	class(epa_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	integer, dimension(3) :: hel_lock
	type(polarization_t), target :: pol
	type(quantum_numbers_t), dimension(1) :: qn_fc
	type(flavor_t) :: flv_photon
	type(color_t) :: col_photon
	type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad
	type(polarization_iterator_t) :: it_hel
	integer :: i
	mask = quantum_numbers_mask (.false., .false., &
	mask_h = [.false., .false., .true.])
	hel_lock = [2, 1, 0]
	select type (data)
	type is (epa_data_t)
	call sf_int%base_init (mask, [data%mass**2], &
	[data%mass**2], [0._default], hel_lock = hel_lock)
	sf_int%data => data
	call flv_photon%init (PHOTON, data%model)
	call col_photon%init ()
	call qn_photon%init (flv_photon, col_photon)
	do i = 1, size (data%flv_in)
	call pol%init_generic (data%flv_in(i))
	call qn_fc(1)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i), 1))
	call it_hel%init (pol)
	do while (it_hel%is_valid ())
	qn_hel = it_hel%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc(1)
	qn_rad = qn
	call qn_rad%tag_radiated ()
	call sf_int%add_state ([qn, qn_rad, qn_photon])
	call it_hel%advance ()
	end do
	! call pol%final ()
	end do
	call sf_int%freeze ()
	if (data%keep_energy) then
	sf_int%on_shell_mode = KEEP_ENERGY
	else
	sf_int%on_shell_mode = KEEP_MOMENTUM
	end if
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	end select
	end subroutine epa_init

	@ %def epa_init
	@ Prepare the charge array. This is separate from the previous routine since
	the state matrix may be helicity-contracted.
	<<SF epa: epa: TBP>>=
	procedure :: setup_constants => epa_setup_constants
	<<SF epa: procedures>>=
	subroutine epa_setup_constants (sf_int)
	class(epa_t), intent(inout), target :: sf_int
	type(state_iterator_t) :: it
	type(flavor_t) :: flv
	integer :: i, n_me
	n_me = sf_int%get_n_matrix_elements ()
	allocate (sf_int%charge2 (n_me))
	call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
	do while (it%is_valid ())
	i = it%get_me_index ()
	flv = it%get_flavor (1)
	sf_int%charge2(i) = flv%get_charge () ** 2
	call it%advance ()
	end do
	sf_int%status = SF_INITIAL
	end subroutine epa_setup_constants

	@ %def epa_setup_constants
	@
	\subsection{Kinematics}
	Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ is trivial.

	The EPA structure function allows for a straightforward mapping of the
	unit interval. The $x$ value is transformed, and the mapped structure
	function becomes unity at its upper boundary.

	The structure function implementation applies the above mapping to the
	input (random) number [[r]] to generate the momentum fraction [[x]]
	and the function value [[f]]. For numerical stability reasons, we
	also output [[xb]], which is $\bar x=1-x$.
	<<SF epa: epa: TBP>>=
	procedure :: complete_kinematics => epa_complete_kinematics
	<<SF epa: procedures>>=
	subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(epa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	real(default) :: delta, sqrt_delta, lx
	if (map) then
	associate (data => sf_int%data)
	delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0)
	if (delta > 0) then
	sqrt_delta = sqrt (delta)
	lx = (data%log - sqrt_delta) / 2
	else
	sf_int%status = SF_FAILED_KINEMATICS
	f = 0
	return
	end if
	x(1) = exp (lx)
	f = x(1) * data%dc / sqrt_delta
	end associate
	else
	x(1) = r(1)
	if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
	f = 1
	else
	sf_int%status = SF_FAILED_KINEMATICS
	f = 0
	return
	end if
	end if
	xb(1) = 1 - x(1)
	if (size(x) == 3) then
	x(2:3) = r(2:3)
	xb(2:3) = rb(2:3)
	end if
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_DONE_KINEMATICS)
	sf_int%x = x(1)
	sf_int%xb= xb(1)
	sf_int%E = energy (sf_int%get_momentum (1))
	case (SF_FAILED_KINEMATICS)
	sf_int%x = 0
	sf_int%xb= 0
	f = 0
	end select
	end subroutine epa_complete_kinematics

	@ %def epa_complete_kinematics
	@ Overriding the default method: we compute the [[x]] array from the
	momentum configuration. In the specific case of EPA, we also set the
	internally stored $x$ and $\bar x$ values, so they can be used in the
	following routine.

	Note: the extraction of $\bar x$ is not numerically safe, but it cannot
	be as long as the base [[recover_x]] is not.
	<<SF epa: epa: TBP>>=
	procedure :: recover_x => sf_epa_recover_x
	<<SF epa: procedures>>=
	subroutine sf_epa_recover_x (sf_int, x, xb, x_free)
	class(epa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb, x_free)
	sf_int%x = x(1)
	sf_int%xb = xb(1)
	end subroutine sf_epa_recover_x

	@ %def sf_epa_recover_x
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF epa: epa: TBP>>=
	procedure :: inverse_kinematics => epa_inverse_kinematics
	<<SF epa: procedures>>=
	subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(epa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	real(default) :: lx, delta, sqrt_delta, c
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	associate (data => sf_int%data)
	lx = log (x(1))
	sqrt_delta = data%log - 2 * lx
	delta = sqrt_delta ** 2
	c = (data%log ** 2 - delta) / 4
	r (1) = (c - data%c0) / data%dc
	rb(1) = (data%c1 - c) / data%dc
	f = x(1) * data%dc / sqrt_delta
	end associate
	else
	r (1) = x(1)
	rb(1) = xb(1)
	if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
	f = 1
	else
	f = 0
	end if
	end if
	if (size(r) == 3) then
	r (2:3) = x(2:3)
	rb(2:3) = xb(2:3)
	end if
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	sf_int%E = energy (sf_int%get_momentum (1))
	end subroutine epa_inverse_kinematics

	@ %def epa_inverse_kinematics
	@
	\subsection{EPA application}
	For EPA, we can in principle compute kinematics and function value in
	a single step. In order to be able to reweight events, kinematics and
	structure function application are separated. This function works on a
	single beam, assuming that the input momentum has been set. We need
	three random numbers as input: one for $x$, and two for the polar and
	azimuthal angles. Alternatively, for the no-recoil case, we can skip
	$p_T$ generation; in this case, we only need one.

	For obtaining splitting kinematics, we rely on the assumption that all
	in-particles are mass-degenerate (or there is only one), so the
	generated $x$ values are identical.

	Fix 2020-03-10: Divide by two if there is polarization.
	In the polarized case, the outgoing electron/positron
	retains the incoming polarization. The latter is summed over
	when convoluting with the beam, but there are still two
	states with different outgoing polarization but identical
	structure-function value. This leads to double-counting for the
	overall cross section.
	<<SF epa: epa: TBP>>=
	procedure :: apply => epa_apply
	<<SF epa: procedures>>=
	subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(epa_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: x, xb, qminsq, qmaxsq, f, E, m2
	associate (data => sf_int%data)
	x = sf_int%x
	xb= sf_int%xb
	E = sf_int%E
	m2 = data%mass ** 2
	qminsq = max (x ** 2 / xb * data%mass 2, data%q_min 2)
	select case (data%mode)
	case (0)
	qmaxsq = min (4 * xb * E 2, data%q_max 2)
	if (qminsq < qmaxsq) then
	f = data%a / x &
	* ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
	- (1 - x / 2) ** 2 &
	* log ((x2 + qmaxsq / E 2) / (x2 + qminsq / E 2)) &
	- x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
	else
	f = 0
	end if
	case (1)
	qmaxsq = min (4 * xb * E 2, data%q_max 2)
	if (qminsq < qmaxsq) then
	f = data%a / x &
	* ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
	- x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
	else
	f = 0
	end if
	case (2)
	qmaxsq = data%q_max ** 2
	if (data%mass ** 2 < qmaxsq) then
	f = data%a / x &
	* ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
	- x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
	else
	f = 0
	end if
	case (3)
	qmaxsq = data%q_max ** 2
	if (data%mass ** 2 < qmaxsq) then
	f = data%a / x &
	* ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
	- x ** 2 * (1 - m2 / qmaxsq))
	else
	f = 0
	end if
	case (4)
	qmaxsq = data%q_max ** 2
	if (data%mass ** 2 < qmaxsq) then
	f = data%a / x &
	* ((xb + x ** 2 / 2) * log (qmaxsq / m2))
	else
	f = 0
	end if
	end select
	f = f / sf_int%get_n_matrix_elements ()
	call sf_int%set_matrix_element &
	(cmplx (f, kind=default) * sf_int%charge2)
	end associate
	sf_int%status = SF_EVALUATED
	end subroutine epa_apply

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

	module sf_epa_ut
	use unit_tests
	use sf_epa_uti

	<<Standard module head>>

	<<SF epa: public test>>

	contains

	<<SF epa: test driver>>

	end module sf_epa_ut
	@ %def sf_epa_ut
	@
	<<[[sf_epa_uti.f90]]>>=
	<<File header>>

	module sf_epa_uti

	<<Use kinds>>
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use interactions, only: interaction_pacify_momenta
	use model_data
	use sf_aux
	use sf_base

	use sf_epa

	<<Standard module head>>

	<<SF epa: test declarations>>

	contains

	<<SF epa: tests>>

	end module sf_epa_uti
	@ %def sf_epa_ut
	@ API: driver for the unit tests below.
	<<SF epa: public test>>=
	public :: sf_epa_test
	<<SF epa: test driver>>=
	subroutine sf_epa_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF epa: execute tests>>
	end subroutine sf_epa_test

	@ %def sf_epa_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF epa: execute tests>>=
	call test (sf_epa_1, "sf_epa_1", &
	"structure function configuration", &
	u, results)
	<<SF epa: test declarations>>=
	public :: sf_epa_1
	<<SF epa: tests>>=
	subroutine sf_epa_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_epa_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in = ELECTRON

	allocate (epa_data_t :: data)
	call data%write (u)

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

	select type (data)
	type is (epa_data_t)
	call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
	10._default, 100._default, 0.000511_default, recoil = .false.)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_epa_1

	@ %def sf_epa_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the EPA
	structure function.
	<<SF epa: execute tests>>=
	call test (sf_epa_2, "sf_epa_2", &
	"structure function instance", &
	u, results)
	<<SF epa: test declarations>>=
	public :: sf_epa_2
	<<SF epa: tests>>=
	subroutine sf_epa_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_epa_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	allocate (epa_data_t :: data)
	select type (data)
	type is (epa_data_t)
	call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
	10._default, 100._default, 0.000511_default, recoil = .false.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
	set_momenta=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EPA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_epa_2

	@ %def sf_epa_2
	@
	\subsubsection{Standard mapping}
	Construct and display a structure function object based on the EPA
	structure function, applying the standard single-particle mapping.
	<<SF epa: execute tests>>=
	call test (sf_epa_3, "sf_epa_3", &
	"apply mapping", &
	u, results)
	<<SF epa: test declarations>>=
	public :: sf_epa_3
	<<SF epa: tests>>=
	subroutine sf_epa_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_epa_3"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	allocate (epa_data_t :: data)
	select type (data)
	type is (epa_data_t)
	call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
	10._default, 100._default, 0.000511_default, recoil = .false.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
	set_momenta=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EPA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_epa_3

	@ %def sf_epa_3
	@
	\subsubsection{Non-collinear case}
	Construct and display a structure function object based on the EPA
	structure function.
	<<SF epa: execute tests>>=
	call test (sf_epa_4, "sf_epa_4", &
	"non-collinear", &
	u, results)
	<<SF epa: test declarations>>=
	public :: sf_epa_4
	<<SF epa: tests>>=
	subroutine sf_epa_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E, m
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_epa_4"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv%init (ELECTRON, model)
	pdg_in = ELECTRON

	call reset_interaction_counter ()

	allocate (epa_data_t :: data)
	select type (data)
	type is (epa_data_t)
	call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
	10._default, 100._default, 5.0_default, recoil = .true.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV"
	write (u, "(A)")
	E = 500
	m = 5
	k = vector4_moving (E, sqrt (E2 - m2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, "
	write (u, "(A)") " non-coll., keeping energy, me = 5 GeV"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.5_default, 0.5_default, 0.25_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
	set_momenta=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EPA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u, testflag = .true.)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_epa_4

	@ %def sf_epa_4
	@
	\subsubsection{Structure function for multiple flavors}
	Construct and display a structure function object based on the EPA
	structure function. The incoming state has multiple particles with
	non-uniform charge.
	<<SF epa: execute tests>>=
	call test (sf_epa_5, "sf_epa_5", &
	"multiple flavors", &
	u, results)
	<<SF epa: test declarations>>=
	public :: sf_epa_5
	<<SF epa: tests>>=
	subroutine sf_epa_5 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_epa_5"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_sm_test ()
	call flv%init (1, model)
	pdg_in = [1, 2, -1, -2]

	call reset_interaction_counter ()

	allocate (epa_data_t :: data)
	select type (data)
	type is (epa_data_t)
	call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
	10._default, 100._default, 0.000511_default, recoil = .false.)
	call data%check ()
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EPA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_epa_5

	@ %def sf_epa_5
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{EWA}

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

	module sf_ewa

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use constants, only: pi
	use format_defs, only: FMT_17, FMT_19
	use numeric_utils
	use diagnostics
	use physics_defs, only: W_BOSON, Z_BOSON
	use lorentz
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use interactions
	use sf_aux
	use sf_base

	<<Standard module head>>

	<<SF ewa: public>>

	<<SF ewa: parameters>>

	<<SF ewa: types>>

	contains

	<<SF ewa: procedures>>

	end module sf_ewa
	@ %def sf_ewa
	@
	\subsection{Physics}
	The EWA structure function for a $Z$ or $W$ inside a fermion (lepton
	or quark) depends on the vector-boson polarization. We distinguish
	transversal ($\pm$) and longitudinal ($0$) polarization.
	\begin{align}
	F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x}
	\left[
	\ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
	-
	\frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
	\right]
	\\
	F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x}
	\left[
	\ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
	-
	\frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
	\right]
	\\
	F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\,
	\frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
	\end{align}
	where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is
	the vector-boson mass, $v$ and $a$ are the vector and axial-vector
	couplings, and $\bar x\equiv 1-x$. Note that the longitudinal
	structure function is finite for large cutoff, while the transversal
	structure function is logarithmically divergent.

	The maximal transverse momentum is given by the kinematical limit, it is
	\begin{equation}
	p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2.
	\end{equation}
	The vector and axial couplings for a fermion branching into a $W$ are
	\begin{align}
	v_W &= \frac{g}{2\sqrt 2},
	& a_W &= \frac{g}{2\sqrt 2}.
	\end{align}
	For $Z$ emission, this is replaced by
	\begin{align}
	v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right),
	& a_Z &= \frac{g}{2\cos\theta_w}t_3,
	\end{align}
	where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge.

	For an initial antifermion, the signs of the axial couplings are
	inverted. Note that a common sign change of $v$ and $a$ is
	irrelevant.

	%% Differentiating with respect to the cutoff, we get structure functions
	%% \begin{align}
	%% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\,
	%% \frac{1+\bar x^2}{x}
	%% \frac{p_\perp}{p_\perp^2 + \bar x M^2}
	%% \\
	%% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\,
	%% \frac{2\bar x}{x}\,
	%% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
	%% \\
	%% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}
	%% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
	%% \frac{1+\bar x^2}{x}
	%% \frac{p_\perp}{p_\perp^2 + \bar x M^2}
	%% \\
	%% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\,
	%% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
	%% \frac{2\bar x}{x}\,
	%% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
	%% \end{align}
	%% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion
	%% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the
	%% positron charge.

	The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and
	$M_Z$. These can all be taken from the SM input, and the prefactors
	are calculated from those and the incoming particle type.

	Since these structure functions have a $1/x$ singularity (which is not
	really relevant in practice, however, since the vector boson mass is
	finite), we map this singularity allowing for nontrivial $x$ bounds:
	\begin{equation}
	x = \exp(\bar r\ln x_0 + r\ln x_1)
	\end{equation}
	such that
	\begin{equation}
	\int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr.
	\end{equation}

	As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$.
	The divergence $1/x$ also requires a $x_0$ cutoff; and for
	completeness we introduce a corresponding $x_1$. Physically, the
	minimal sensible value of $x$ is $M^2/s$, although the approximation
	loses its value already at higher $x$ values.


	\subsection{The EWA data block}
	The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and
	$m$. Instead of $m$ we can use the incoming particle PDG code as
	input; from this we can deduce the mass and charges. In the
	initialization phase it is not yet determined whether a $W$ or a $Z$
	is radiated, hence we set the vector and axial-vector couplings equal
	to the common prefactors $g/2 = e/2/\sin\theta_W$.

	In principle, for EWA it would make sense to allow the user to also
	set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here.
	<<SF ewa: public>>=
	public :: ewa_data_t
	<<SF ewa: types>>=
	type, extends(sf_data_t) :: ewa_data_t
	private
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(:), allocatable :: flv_in
	type(flavor_t), dimension(:), allocatable :: flv_out
	real(default) :: pt_max
	real(default) :: sqrts
	real(default) :: x_min
	real(default) :: x_max
	real(default) :: mass
	real(default) :: m_out
	real(default) :: q_min
	real(default) :: cv
	real(default) :: ca
	real(default) :: costhw
	real(default) :: sinthw
	real(default) :: mW
	real(default) :: mZ
	real(default) :: coeff
	logical :: mass_set = .false.
	logical :: recoil = .false.
	logical :: keep_energy = .false.
	integer :: id = 0
	integer :: error = NONE
	contains
	<<SF ewa: ewa data: TBP>>
	end type ewa_data_t

	@ %def ewa_data_t
	@ Error codes
	<<SF ewa: parameters>>=
	integer, parameter :: NONE = 0
	integer, parameter :: ZERO_QMIN = 1
	integer, parameter :: Q_MAX_TOO_SMALL = 2
	integer, parameter :: ZERO_XMIN = 3
	integer, parameter :: MASS_MIX = 4
	integer, parameter :: ZERO_SW = 5
	integer, parameter :: ISOSPIN_MIX = 6
	integer, parameter :: WRONG_PRT = 7
	integer, parameter :: MASS_MIX_OUT = 8
	integer, parameter :: NO_EWA = 9
	<<SF ewa: ewa data: TBP>>=
	procedure :: init => ewa_data_init
	<<SF ewa: procedures>>=
	subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, &
	sqrts, recoil, keep_energy, mass)
	class(ewa_data_t), intent(inout) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	real(default), intent(in) :: x_min, pt_max, sqrts
	logical, intent(in) :: recoil, keep_energy
	real(default), intent(in), optional :: mass
	real(default) :: g, ee
	integer :: n_flv, i
	data%model => model
	if (.not. any (pdg_in .match. &
	[1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then
	data%error = WRONG_PRT; return
	end if
	- n_flv = pdg_array_get_length (pdg_in)
	+ n_flv = pdg_in%get_length ()
	allocate (data%flv_in (n_flv))
	allocate (data%flv_out(n_flv))
	do i = 1, n_flv
	- call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model)
	+ call data%flv_in(i)%init (pdg_in%get (i), model)
	end do
	data%pt_max = pt_max
	data%sqrts = sqrts
	data%x_min = x_min
	data%x_max = 1
	if (vanishes (data%x_min)) then
	data%error = ZERO_XMIN; return
	end if
	select case (char (data%model%get_name ()))
	case ("QCD","QED","Test")
	data%error = NO_EWA; return
	end select
	ee = data%model%get_real (var_str ("ee"))
	data%sinthw = data%model%get_real (var_str ("sw"))
	data%costhw = data%model%get_real (var_str ("cw"))
	data%mZ = data%model%get_real (var_str ("mZ"))
	data%mW = data%model%get_real (var_str ("mW"))
	if (data%sinthw /= 0) then
	g = ee / data%sinthw
	else
	data%error = ZERO_SW; return
	end if
	data%cv = g / 2._default
	data%ca = g / 2._default
	data%coeff = 1._default / (8._default * PI**2)
	data%recoil = recoil
	data%keep_energy = keep_energy
	if (present (mass)) then
	data%mass = mass
	data%m_out = mass
	data%mass_set = .true.
	else
	data%mass = data%flv_in(1)%get_mass ()
	if (any (data%flv_in%get_mass () /= data%mass)) then
	data%error = MASS_MIX; return
	end if
	end if
	end subroutine ewa_data_init

	@ %def ewa_data_init
	@ Set the vector boson ID for distinguishing $W$ and $Z$ bosons.
	<<SF ewa: ewa data: TBP>>=
	procedure :: set_id => ewa_set_id
	<<SF ewa: procedures>>=
	subroutine ewa_set_id (data, id)
	class(ewa_data_t), intent(inout) :: data
	integer, intent(in) :: id
	integer :: i, isospin, pdg
	if (.not. allocated (data%flv_in)) &
	call msg_bug ("EWA: incoming particles not set")
	data%id = id
	select case (data%id)
	case (23)
	data%m_out = data%mass
	data%flv_out = data%flv_in
	case (24)
	do i = 1, size (data%flv_in)
	pdg = data%flv_in(i)%get_pdg ()
	isospin = data%flv_in(i)%get_isospin_type ()
	if (isospin > 0) then
	!!! up-type quark or neutrinos
	if (data%flv_in(i)%is_antiparticle ()) then
	call data%flv_out(i)%init (pdg + 1, data%model)
	else
	call data%flv_out(i)%init (pdg - 1, data%model)
	end if
	else
	!!! down-type quark or lepton
	if (data%flv_in(i)%is_antiparticle ()) then
	call data%flv_out(i)%init (pdg - 1, data%model)
	else
	call data%flv_out(i)%init (pdg + 1, data%model)
	end if
	end if
	end do
	if (.not. data%mass_set) then
	data%m_out = data%flv_out(1)%get_mass ()
	if (any (data%flv_out%get_mass () /= data%m_out)) then
	data%error = MASS_MIX_OUT; return
	end if
	end if
	end select
	end subroutine ewa_set_id

	@ %def ewa_set_id
	@ Handle error conditions. Should always be done after
	initialization, unless we are sure everything is ok.
	<<SF ewa: ewa data: TBP>>=
	procedure :: check => ewa_data_check
	<<SF ewa: procedures>>=
	subroutine ewa_data_check (data)
	class(ewa_data_t), intent(in) :: data
	select case (data%error)
	case (WRONG_PRT)
	call msg_fatal ("EWA structure function only accessible for " &
	// "SM quarks and leptons.")
	case (NO_EWA)
	call msg_fatal ("EWA structure function not available for model " &
	// char (data%model%get_name ()))
	case (ZERO_SW)
	call msg_fatal ("EWA: Vanishing value of sin(theta_w)")
	case (ZERO_QMIN)
	call msg_fatal ("EWA: Particle mass is zero")
	case (Q_MAX_TOO_SMALL)
	call msg_fatal ("EWA: Particle mass exceeds Qmax")
	case (ZERO_XMIN)
	call msg_fatal ("EWA: x_min must be larger than zero")
	case (MASS_MIX)
	call msg_fatal ("EWA: incoming particle masses must be uniform")
	case (MASS_MIX_OUT)
	call msg_fatal ("EWA: outgoing particle masses must be uniform")
	case (ISOSPIN_MIX)
	call msg_fatal ("EWA: incoming particle isospins must be uniform")
	end select
	end subroutine ewa_data_check

	@ %def ewa_data_check
	@ Output
	<<SF ewa: ewa data: TBP>>=
	procedure :: write => ewa_data_write
	<<SF ewa: procedures>>=
	subroutine ewa_data_write (data, unit, verbose)
	class(ewa_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "EWA data:"
	if (allocated (data%flv_in) .and. allocated (data%flv_out)) then
	write (u, "(3x,A)", advance="no") " flavor(in) = "
	do i = 1, size (data%flv_in)
	if (i > 1) write (u, "(',',1x)", advance="no")
	call data%flv_in(i)%write (u)
	end do
	write (u, *)
	write (u, "(3x,A)", advance="no") " flavor(out) = "
	do i = 1, size (data%flv_out)
	if (i > 1) write (u, "(',',1x)", advance="no")
	call data%flv_out(i)%write (u)
	end do
	write (u, *)
	write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min
	write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max
	write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max
	write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts
	write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass
	write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv
	write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca
	write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff
	write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw
	write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw
	write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ
	write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW
	write (u, "(3x,A,L2)") " recoil = ", data%recoil
	write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy
	write (u, "(3x,A,I2)") " PDG (VB) = ", data%id
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine ewa_data_write

	@ %def ewa_data_write
	@ The number of parameters is one for collinear splitting, in case the
	[[recoil]] option is set, we take the recoil into account.
	<<SF ewa: ewa data: TBP>>=
	procedure :: get_n_par => ewa_data_get_n_par
	<<SF ewa: procedures>>=
	function ewa_data_get_n_par (data) result (n)
	class(ewa_data_t), intent(in) :: data
	integer :: n
	if (data%recoil) then
	n = 3
	else
	n = 1
	end if
	end function ewa_data_get_n_par

	@ %def ewa_data_get_n_par
	@ Return the outgoing particles PDG codes. This depends, whether this
	is a charged-current or neutral-current interaction.
	<<SF ewa: ewa data: TBP>>=
	procedure :: get_pdg_out => ewa_data_get_pdg_out
	<<SF ewa: procedures>>=
	subroutine ewa_data_get_pdg_out (data, pdg_out)
	class(ewa_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	integer :: i, n_flv
	if (allocated (data%flv_out)) then
	n_flv = size (data%flv_out)
	else
	n_flv = 0
	end if
	allocate (pdg1 (n_flv))
	do i = 1, n_flv
	pdg1(i) = data%flv_out(i)%get_pdg ()
	end do
	pdg_out(1) = pdg1
	end subroutine ewa_data_get_pdg_out

	@ %def ewa_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF ewa: ewa data: TBP>>=
	procedure :: allocate_sf_int => ewa_data_allocate_sf_int
	<<SF ewa: procedures>>=
	subroutine ewa_data_allocate_sf_int (data, sf_int)
	class(ewa_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (ewa_t :: sf_int)
	end subroutine ewa_data_allocate_sf_int

	@ %def ewa_data_allocate_sf_int
	@
	\subsection{The EWA object}
	The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able
	to handle several flavors in parallel, since EWA is not necessarily
	applied immediately after beam collision: $W/Z$ bosons may be radiated
	from quarks. In that case, the partons are massless and $q_{\rm min}$
	applies instead, so we do not need to generate several kinematical
	configurations in parallel.

	The particles are ordered as (incoming, radiated, W/Z), where the
	W/Z initiates the hard interaction.

	In the case of EPA, we generated an unpolarized photon and transferred
	initial polarization to the radiated parton. Color is transferred in
	the same way. I do not know whether the same can/should be done for
	EWA, as the structure functions depend on the W/Z polarization. If we
	are having $Z$ bosons, both up- and down-type fermions can
	participate. Otherwise, with a $W^+$ an up-type fermion is transferred
	to a down-type fermion, and the other way round.
	<<SF ewa: types>>=
	type, extends (sf_int_t) :: ewa_t
	type(ewa_data_t), pointer :: data => null ()
	real(default) :: x = 0
	real(default) :: xb = 0
	integer :: n_me = 0
	real(default), dimension(:), allocatable :: cv
	real(default), dimension(:), allocatable :: ca
	contains
	<<SF ewa: ewa: TBP>>
	end type ewa_t

	@ %def ewa_t
	@ Type string: has to be here, but there is no string variable on which EWA
	depends. Hence, a dummy routine.
	<<SF ewa: ewa: TBP>>=
	procedure :: type_string => ewa_type_string
	<<SF ewa: procedures>>=
	function ewa_type_string (object) result (string)
	class(ewa_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "EWA: equivalent W/Z approx."
	else
	string = "EWA: [undefined]"
	end if
	end function ewa_type_string

	@ %def ewa_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF ewa: ewa: TBP>>=
	procedure :: write => ewa_write
	<<SF ewa: procedures>>=
	subroutine ewa_write (object, unit, testflag)
	class(ewa_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(1x,A)") "SF parameters:"
	write (u, "(3x,A," // FMT_17 // ")") "x =", object%x
	write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "EWA data: [undefined]"
	end if
	end subroutine ewa_write

	@ %def ewa_write
	@ The current implementation requires uniform isospin for all incoming
	particles, therefore we need to probe only the first one.
	<<SF ewa: ewa: TBP>>=
	procedure :: init => ewa_init
	<<SF ewa: procedures>>=
	subroutine ewa_init (sf_int, data)
	class(ewa_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	integer, dimension(3) :: hel_lock
	type(polarization_t), target :: pol
	type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin
	type(flavor_t) :: flv_z, flv_wp, flv_wm
	type(color_t) :: col0
	type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w
	type(polarization_iterator_t) :: it_hel
	integer :: i, isospin
	select type (data)
	type is (ewa_data_t)
	mask = quantum_numbers_mask (.false., .false., &
	mask_h = [.false., .false., .true.])
	hel_lock = [2, 1, 0]
	call col0%init ()
	select case (data%id)
	case (23)
	!!! Z boson, flavor is not changing
	call sf_int%base_init (mask, [data%mass2], [data%mass2], &
	[data%mZ**2], hel_lock = hel_lock)
	sf_int%data => data
	call flv_z%init (Z_BOSON, data%model)
	call qn_z%init (flv_z, col0)
	do i = 1, size (data%flv_in)
	call pol%init_generic (data%flv_in(i))
	call qn_fc(1)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i), 1))
	call it_hel%init (pol)
	do while (it_hel%is_valid ())
	qn_hel = it_hel%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc(1)
	qn_rad = qn
	call qn_rad%tag_radiated ()
	call sf_int%add_state ([qn, qn_rad, qn_z])
	call it_hel%advance ()
	end do
	! call pol%final ()
	end do
	case (24)
	call sf_int%base_init (mask, [data%mass2], [data%m_out2], &
	[data%mW**2], hel_lock = hel_lock)
	sf_int%data => data
	call flv_wp%init (W_BOSON, data%model)
	call flv_wm%init (- W_BOSON, data%model)
	call qn_wp%init (flv_wp, col0)
	call qn_wm%init (flv_wm, col0)
	do i = 1, size (data%flv_in)
	isospin = data%flv_in(i)%get_isospin_type ()
	if (isospin > 0) then
	!!! up-type quark or neutrinos
	if (data%flv_in(i)%is_antiparticle ()) then
	qn_w = qn_wm
	else
	qn_w = qn_wp
	end if
	else
	!!! down-type quark or lepton
	if (data%flv_in(i)%is_antiparticle ()) then
	qn_w = qn_wp
	else
	qn_w = qn_wm
	end if
	end if
	call pol%init_generic (data%flv_in(i))
	call qn_fc(1)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i), 1))
	call qn_fc_fin(1)%init ( &
	flv = data%flv_out(i), &
	col = color_from_flavor (data%flv_out(i), 1))
	call it_hel%init (pol)
	do while (it_hel%is_valid ())
	qn_hel = it_hel%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc(1)
	qn_rad = qn_hel .merge. qn_fc_fin(1)
	call qn_rad%tag_radiated ()
	call sf_int%add_state ([qn, qn_rad, qn_w])
	call it_hel%advance ()
	end do
	! call pol%final ()
	end do
	case default
	call msg_fatal ("EWA initialization failed: wrong particle type.")
	end select
	call sf_int%freeze ()
	if (data%keep_energy) then
	sf_int%on_shell_mode = KEEP_ENERGY
	else
	sf_int%on_shell_mode = KEEP_MOMENTUM
	end if
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	end select
	end subroutine ewa_init

	@ %def ewa_init
	@ Prepare the coupling arrays. This is separate from the previous routine since
	the state matrix may be helicity-contracted.
	<<SF ewa: ewa: TBP>>=
	procedure :: setup_constants => ewa_setup_constants
	<<SF ewa: procedures>>=
	subroutine ewa_setup_constants (sf_int)
	class(ewa_t), intent(inout), target :: sf_int
	type(state_iterator_t) :: it
	type(flavor_t) :: flv
	real(default) :: q, t3
	integer :: i
	sf_int%n_me = sf_int%get_n_matrix_elements ()
	allocate (sf_int%cv (sf_int%n_me))
	allocate (sf_int%ca (sf_int%n_me))
	associate (data => sf_int%data)
	select case (data%id)
	case (23)
	call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
	do while (it%is_valid ())
	i = it%get_me_index ()
	flv = it%get_flavor (1)
	q = flv%get_charge ()
	t3 = flv%get_isospin ()
	if (flv%is_antiparticle ()) then
	sf_int%cv(i) = - data%cv &
	* (t3 - 2._default * q * data%sinthw**2) / data%costhw
	sf_int%ca(i) = data%ca * t3 / data%costhw
	else
	sf_int%cv(i) = data%cv &
	* (t3 - 2._default * q * data%sinthw**2) / data%costhw
	sf_int%ca(i) = data%ca * t3 / data%costhw
	end if
	call it%advance ()
	end do
	case (24)
	call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
	do while (it%is_valid ())
	i = it%get_me_index ()
	flv = it%get_flavor (1)
	if (flv%is_antiparticle ()) then
	sf_int%cv(i) = data%cv / sqrt(2._default)
	sf_int%ca(i) = - data%ca / sqrt(2._default)
	else
	sf_int%cv(i) = data%cv / sqrt(2._default)
	sf_int%ca(i) = data%ca / sqrt(2._default)
	end if
	call it%advance ()
	end do
	end select
	end associate
	sf_int%status = SF_INITIAL
	end subroutine ewa_setup_constants

	@ %def ewa_setup_constants
	@
	\subsection{Kinematics}
	Set kinematics. The EWA structure function allows for a
	straightforward mapping of the unit interval. So, to leading order,
	the structure function value is unity, but the $x$ value is
	transformed. Higher orders affect the function value.
	If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian
	$f(r)$ is trivial.

	If [[map]] is set, the exponential mapping for the $1/x$ singularity
	discussed above is applied.
	<<SF ewa: ewa: TBP>>=
	procedure :: complete_kinematics => ewa_complete_kinematics
	<<SF ewa: procedures>>=
	subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(ewa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	real(default) :: e_1
	real(default) :: x0, x1, lx0, lx1, lx
	e_1 = energy (sf_int%get_momentum (1))
	if (sf_int%data%recoil) then
	select case (sf_int%data%id)
	case (23)
	x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
	case (24)
	x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
	end select
	else
	x0 = sf_int%data%x_min
	end if
	x1 = sf_int%data%x_max
	if ( x0 >= x1) then
	f = 0
	sf_int%status = SF_FAILED_KINEMATICS
	return
	end if
	if (map) then
	lx0 = log (x0)
	lx1 = log (x1)
	lx = lx1 * r(1) + lx0 * rb(1)
	x(1) = exp(lx)
	f = x(1) * (lx1 - lx0)
	else
	x(1) = r(1)
	if (x0 < x(1) .and. x(1) < x1) then
	f = 1
	else
	sf_int%status = SF_FAILED_KINEMATICS
	f = 0
	return
	end if
	end if
	xb(1) = 1 - x(1)
	if (size(x) == 3) then
	x(2:3) = r(2:3)
	xb(2:3) = rb(2:3)
	end if
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_DONE_KINEMATICS)
	sf_int%x = x(1)
	sf_int%xb = xb(1)
	case (SF_FAILED_KINEMATICS)
	sf_int%x = 0
	sf_int%xb = 0
	f = 0
	end select
	end subroutine ewa_complete_kinematics

	@ %def ewa_complete_kinematics
	@ Overriding the default method: we compute the [[x]] array from the
	momentum configuration. In the specific case of EWA, we also set the
	internally stored $x$ and $\bar x$ values, so they can be used in the
	following routine.
	<<SF ewa: ewa: TBP>>=
	procedure :: recover_x => sf_ewa_recover_x
	<<SF ewa: procedures>>=
	subroutine sf_ewa_recover_x (sf_int, x, xb, x_free)
	class(ewa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb, x_free)
	sf_int%x = x(1)
	sf_int%xb = xb(1)
	end subroutine sf_ewa_recover_x

	@ %def sf_ewa_recover_x
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF ewa: ewa: TBP>>=
	procedure :: inverse_kinematics => ewa_inverse_kinematics
	<<SF ewa: procedures>>=
	subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(ewa_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	real(default) :: x0, x1, lx0, lx1, lx, e_1
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	e_1 = energy (sf_int%get_momentum (1))
	if (sf_int%data%recoil) then
	select case (sf_int%data%id)
	case (23)
	x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
	case (24)
	x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
	end select
	else
	x0 = sf_int%data%x_min
	end if
	x1 = sf_int%data%x_max
	if (map) then
	lx0 = log (x0)
	lx1 = log (x1)
	lx = log (x(1))
	r(1) = (lx - lx0) / (lx1 - lx0)
	rb(1) = (lx1 - lx) / (lx1 - lx0)
	f = x(1) * (lx1 - lx0)
	else
	r (1) = x(1)
	rb(1) = 1 - x(1)
	if (x0 < x(1) .and. x(1) < x1) then
	f = 1
	else
	f = 0
	end if
	end if
	if (size(r) == 3) then
	r (2:3) = x(2:3)
	rb(2:3) = xb(2:3)
	end if
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine ewa_inverse_kinematics

	@ %def ewa_inverse_kinematics
	@
	\subsection{EWA application}
	For EWA, we can compute kinematics and function value in a single
	step. This function works on a single beam, assuming that the input
	momentum has been set. We need four random numbers as input: one for
	$x$, one for $Q^2$, and two for the polar and azimuthal angles.
	Alternatively, we can skip $p_T$ generation; in this case, we only
	need one.

	For obtaining splitting kinematics, we rely on the assumption that all
	in-particles are mass-degenerate (or there is only one), so the
	generated $x$ values are identical.
	<<SF ewa: ewa: TBP>>=
	procedure :: apply => ewa_apply
	<<SF ewa: procedures>>=
	subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(ewa_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: x, xb, pt2, c1, c2
	real(default) :: cv, ca
	real(default) :: f, fm, fp, fL
	integer :: i
	associate (data => sf_int%data)
	x = sf_int%x
	xb = sf_int%xb
	pt2 = min ((data%pt_max)*2, (xb data%sqrts / 2)**2)
	select case (data%id)
	case (23)
	!!! Z boson structure function
	c1 = log (1 + pt2 / (xb * (data%mZ)**2))
	c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2)
	case (24)
	!!! W boson structure function
	c1 = log (1 + pt2 / (xb * (data%mW)**2))
	c2 = 1 / (1 + (xb * (data%mW)**2) / pt2)
	end select
	do i = 1, sf_int%n_me
	cv = sf_int%cv(i)
	ca = sf_int%ca(i)
	fm = data%coeff * &
	((cv + ca)*2 + ((cv - ca) xb)*2) (c1 - c2) / (2 * x)
	fp = data%coeff * &
	((cv - ca)*2 + ((cv + ca) xb)*2) (c1 - c2) / (2 * x)
	fL = data%coeff * &
	(cv2 + ca2) * (2 * xb / x) * c2
	f = fp + fm + fL
	if (.not. vanishes (f)) then
	fp = fp / f
	fm = fm / f
	fL = fL / f
	end if
	call sf_int%set_matrix_element (i, cmplx (f, kind=default))
	end do
	end associate
	sf_int%status = SF_EVALUATED
	end subroutine ewa_apply

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

	module sf_ewa_ut
	use unit_tests
	use sf_ewa_uti

	<<Standard module head>>

	<<SF ewa: public test>>

	contains

	<<SF ewa: test driver>>

	end module sf_ewa_ut
	@ %def sf_ewa_ut
	@
	<<[[sf_ewa_uti.f90]]>>=
	<<File header>>

	module sf_ewa_uti

	<<Use kinds>>
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use interactions, only: interaction_pacify_momenta
	use model_data
	use sf_aux
	use sf_base

	use sf_ewa

	<<Standard module head>>

	<<SF ewa: test declarations>>

	contains

	<<SF ewa: tests>>

	end module sf_ewa_uti
	@ %def sf_ewa_ut
	@ API: driver for the unit tests below.
	<<SF ewa: public test>>=
	public :: sf_ewa_test
	<<SF ewa: test driver>>=
	subroutine sf_ewa_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF ewa: execute tests>>
	end subroutine sf_ewa_test

	@ %def sf_ewa_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF ewa: execute tests>>=
	call test (sf_ewa_1, "sf_ewa_1", &
	"structure function configuration", &
	u, results)
	<<SF ewa: test declarations>>=
	public :: sf_ewa_1
	<<SF ewa: tests>>=
	subroutine sf_ewa_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_ewa_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call model%init_sm_test ()
	pdg_in = 2

	allocate (ewa_data_t :: data)
	call data%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize for Z boson"
	write (u, "(A)")

	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 5000._default, .false., .false.)
	call data%set_id (23)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	write (u, "(A)")
	write (u, "(A)") "* Initialize for W boson"
	write (u, "(A)")

	deallocate (data)
	allocate (ewa_data_t :: data)
	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 5000._default, .false., .false.)
	call data%set_id (24)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_ewa_1

	@ %def sf_ewa_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the EWA
	structure function.
	<<SF ewa: execute tests>>=
	call test (sf_ewa_2, "sf_ewa_2", &
	"structure function instance", &
	u, results)
	<<SF ewa: test declarations>>=
	public :: sf_ewa_2
	<<SF ewa: tests>>=
	subroutine sf_ewa_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_ewa_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_sm_test ()
	call flv%init (2, model)
	pdg_in = 2

	call reset_interaction_counter ()

	allocate (ewa_data_t :: data)
	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 3000._default, .false., .true.)
	call data%set_id (24)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=1500"
	write (u, "(A)")
	E = 1500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
	set_momenta=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EWA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_ewa_2

	@ %def sf_ewa_2
	@
	\subsubsection{Standard mapping}
	Construct and display a structure function object based on the EWA
	structure function, applying the standard single-particle mapping.
	<<SF ewa: execute tests>>=
	call test (sf_ewa_3, "sf_ewa_3", &
	"apply mapping", &
	u, results)
	<<SF ewa: test declarations>>=
	public :: sf_ewa_3
	<<SF ewa: tests>>=
	subroutine sf_ewa_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_ewa_3"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_sm_test ()
	call flv%init (2, model)
	pdg_in = 2

	call reset_interaction_counter ()

	allocate (ewa_data_t :: data)
	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 3000._default, .false., .true.)
	call data%set_id (24)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=1500"
	write (u, "(A)")
	E = 1500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
	set_momenta=.true.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EWA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_ewa_3

	@ %def sf_ewa_3
	@
	\subsubsection{Non-collinear case}
	Construct and display a structure function object based on the EPA
	structure function.
	<<SF ewa: execute tests>>=
	call test (sf_ewa_4, "sf_ewa_4", &
	"non-collinear", &
	u, results)
	<<SF ewa: test declarations>>=
	public :: sf_ewa_4
	<<SF ewa: tests>>=
	subroutine sf_ewa_4 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_ewa_4"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call modeL%init_sm_test ()
	call flv%init (2, model)
	pdg_in = 2

	call reset_interaction_counter ()

	allocate (ewa_data_t :: data)
	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 3000.0_default, .true., .true.)
	call data%set_id (24)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	write (u, "(A)") "* Initialize incoming momentum with E=1500"
	write (u, "(A)")
	E = 1500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, "
	write (u, "(A)") " non-coll., keeping energy"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.5_default, 0.5_default, 0.25_default]
	rb = 1 - r
	sf_int%on_shell_mode = KEEP_ENERGY
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x and r from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
	set_momenta=.true.)
	call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EWA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 1500._default)
	call sf_int%write (u, testflag = .true.)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_ewa_4

	@ %def sf_ewa_4
	@
	\subsubsection{Structure function for multiple flavors}
	Construct and display a structure function object based on the EWA
	structure function. The incoming state has multiple particles with
	non-uniform quantum numbers.
	<<SF ewa: execute tests>>=
	call test (sf_ewa_5, "sf_ewa_5", &
	"structure function instance", &
	u, results)
	<<SF ewa: test declarations>>=
	public :: sf_ewa_5
	<<SF ewa: tests>>=
	subroutine sf_ewa_5 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_ewa_5"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_sm_test ()
	call flv%init (2, model)
	pdg_in = [1, 2, -1, -2]

	call reset_interaction_counter ()

	allocate (ewa_data_t :: data)
	select type (data)
	type is (ewa_data_t)
	call data%init (model, pdg_in, 0.01_default, &
	500._default, 3000._default, .false., .true.)
	call data%set_id (24)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])
	call sf_int%setup_constants ()

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=1500"
	write (u, "(A)")
	E = 1500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call pacify (k, 1e-10_default)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.4_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Evaluate EWA structure function"
	write (u, "(A)")

	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_ewa_5

	@ %def sf_ewa_5
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{Energy-scan spectrum}

	This spectrum is actually a trick that allows us to plot the c.m.\ energy
	dependence of a cross section without scanning the input energy. We
	start with the observation that a spectrum $f(x)$, applied to one of
	the incoming beams only, results in a cross section
	\begin{equation}
	\sigma = \int dx\,f(x)\,\hat\sigma(xs).
	\end{equation}
	We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e.,
	\begin{equation}
	\frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx}
	= \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs),
	\end{equation}
	so if we set
	\begin{equation}
	f(x) = \frac{\sqrt{s}}{2\sqrt{x}},
	\end{equation}
	we get the distribution
	\begin{equation}
	\frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2).
	\end{equation}
	We implement this as a spectrum with a single parameter $x$. The
	parameters for the individual beams are computed as $x_i=\sqrt{x}$, so
	they are equal and the kinematics is always symmetric.
	<<[[sf_escan.f90]]>>=
	<<File header>>

	module sf_escan

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_12
	use numeric_utils
	use diagnostics
	use lorentz
	use pdg_arrays
	use model_data
	use flavors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base

	<<Standard module head>>

	<<SF escan: public>>

	<<SF escan: types>>

	contains

	<<SF escan: procedures>>

	end module sf_escan
	@ %def sf_escan
	@
	\subsection{Data type}
	The [[norm]] is unity if the total cross section should be normalized
	to one, and $\sqrt{s}$ if it should be normalized to the total
	energy. In the latter case, the differential distribution
	$d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section
	$\hat\sigma$ as a function of $\sqrt{\hat s}$.
	<<SF escan: public>>=
	public :: escan_data_t
	<<SF escan: types>>=
	type, extends(sf_data_t) :: escan_data_t
	private
	type(flavor_t), dimension(:,:), allocatable :: flv_in
	integer, dimension(2) :: n_flv = 0
	real(default) :: norm = 1
	contains
	<<SF escan: escan data: TBP>>
	end type escan_data_t

	@ %def escan_data_t
	<<SF escan: escan data: TBP>>=
	procedure :: init => escan_data_init
	<<SF escan: procedures>>=
	subroutine escan_data_init (data, model, pdg_in, norm)
	class(escan_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(2), intent(in) :: pdg_in
	real(default), intent(in), optional :: norm
	real(default), dimension(2) :: m2
	integer :: i, j
	- data%n_flv = pdg_array_get_length (pdg_in)
	+ data%n_flv = pdg_in%get_length ()
	allocate (data%flv_in (maxval (data%n_flv), 2))
	do i = 1, 2
	do j = 1, data%n_flv(i)
	- call data%flv_in(j, i)%init (pdg_array_get (pdg_in(i), j), model)
	+ call data%flv_in(j, i)%init (pdg_in(i)%get (j), model)
	end do
	end do
	m2 = data%flv_in(1,:)%get_mass ()
	do i = 1, 2
	if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then
	call msg_fatal ("Energy scan: incoming particle mass must be uniform")
	end if
	end do
	if (present (norm)) data%norm = norm
	end subroutine escan_data_init

	@ %def escan_data_init
	@ Output
	<<SF escan: escan data: TBP>>=
	procedure :: write => escan_data_write
	<<SF escan: procedures>>=
	subroutine escan_data_write (data, unit, verbose)
	class(escan_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, i, j
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "Energy-scan data:"
	write (u, "(3x,A)", advance="no") "prt_in = "
	do i = 1, 2
	if (i > 1) write (u, "(',',1x)", advance="no")
	do j = 1, data%n_flv(i)
	if (j > 1) write (u, "(':')", advance="no")
	write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ())
	end do
	end do
	write (u, *)
	write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm
	end subroutine escan_data_write

	@ %def escan_data_write
	@ Kinematics is completely collinear, hence there is only one
	parameter for a pair spectrum.
	<<SF escan: escan data: TBP>>=
	procedure :: get_n_par => escan_data_get_n_par
	<<SF escan: procedures>>=
	function escan_data_get_n_par (data) result (n)
	class(escan_data_t), intent(in) :: data
	integer :: n
	n = 1
	end function escan_data_get_n_par

	@ %def escan_data_get_n_par
	@ Return the outgoing particles PDG codes. This is always the same as
	the incoming particle, where we use two indices for the two beams.
	<<SF escan: escan data: TBP>>=
	procedure :: get_pdg_out => escan_data_get_pdg_out
	<<SF escan: procedures>>=
	subroutine escan_data_get_pdg_out (data, pdg_out)
	class(escan_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer :: i, n
	n = 2
	do i = 1, n
	pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg ()
	end do
	end subroutine escan_data_get_pdg_out

	@ %def escan_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF escan: escan data: TBP>>=
	procedure :: allocate_sf_int => escan_data_allocate_sf_int
	<<SF escan: procedures>>=
	subroutine escan_data_allocate_sf_int (data, sf_int)
	class(escan_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (escan_t :: sf_int)
	end subroutine escan_data_allocate_sf_int

	@ %def escan_data_allocate_sf_int
	@
	\subsection{The Energy-scan object}
	This is a spectrum, not a radiation. We create an interaction with
	two incoming and two outgoing particles, flavor, color, and helicity
	being carried through. $x$ nevertheless is only one-dimensional, as we
	are always using only one beam parameter.
	<<SF escan: types>>=
	type, extends (sf_int_t) :: escan_t
	type(escan_data_t), pointer :: data => null ()
	contains
	<<SF escan: escan: TBP>>
	end type escan_t

	@ %def escan_t
	@ Type string: for the energy scan this is just a dummy function.
	<<SF escan: escan: TBP>>=
	procedure :: type_string => escan_type_string
	<<SF escan: procedures>>=
	function escan_type_string (object) result (string)
	class(escan_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "Escan: energy scan"
	else
	string = "Escan: [undefined]"
	end if
	end function escan_type_string

	@ %def escan_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF escan: escan: TBP>>=
	procedure :: write => escan_write
	<<SF escan: procedures>>=
	subroutine escan_write (object, unit, testflag)
	class(escan_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "Energy scan data: [undefined]"
	end if
	end subroutine escan_write

	@ %def escan_write
	@
	<<SF escan: escan: TBP>>=
	procedure :: init => escan_init
	<<SF escan: procedures>>=
	subroutine escan_init (sf_int, data)
	class(escan_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(4) :: mask
	integer, dimension(4) :: hel_lock
	real(default), dimension(2) :: m2
	real(default), dimension(0) :: mr2
	type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
	type(polarization_t), target :: pol1, pol2
	type(polarization_iterator_t) :: it_hel1, it_hel2
	integer :: j1, j2
	select type (data)
	type is (escan_data_t)
	hel_lock = [3, 4, 1, 2]
	m2 = data%flv_in(1,:)%get_mass ()
	call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
	sf_int%data => data
	do j1 = 1, data%n_flv(1)
	call qn_fc(1)%init ( &
	flv = data%flv_in(j1,1), &
	col = color_from_flavor (data%flv_in(j1,1)))
	call qn_fc(3)%init ( &
	flv = data%flv_in(j1,1), &
	col = color_from_flavor (data%flv_in(j1,1)))
	call pol1%init_generic (data%flv_in(j1,1))
	do j2 = 1, data%n_flv(2)
	call qn_fc(2)%init ( &
	flv = data%flv_in(j2,2), &
	col = color_from_flavor (data%flv_in(j2,2)))
	call qn_fc(4)%init ( &
	flv = data%flv_in(j2,2), &
	col = color_from_flavor (data%flv_in(j2,2)))
	call pol2%init_generic (data%flv_in(j2,2))
	call it_hel1%init (pol1)
	do while (it_hel1%is_valid ())
	qn_hel(1) = it_hel1%get_quantum_numbers ()
	qn_hel(3) = it_hel1%get_quantum_numbers ()
	call it_hel2%init (pol2)
	do while (it_hel2%is_valid ())
	qn_hel(2) = it_hel2%get_quantum_numbers ()
	qn_hel(4) = it_hel2%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc
	call sf_int%add_state (qn)
	call it_hel2%advance ()
	end do
	call it_hel1%advance ()
	end do
	! call pol2%final ()
	end do
	! call pol1%final ()
	end do
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	call sf_int%freeze ()
	sf_int%status = SF_INITIAL
	end select
	end subroutine escan_init

	@ %def escan_init
	@
	\subsection{Kinematics}
	Set kinematics. We have a single parameter, but reduce both beams.
	The [[map]] flag is ignored.
	<<SF escan: escan: TBP>>=
	procedure :: complete_kinematics => escan_complete_kinematics
	<<SF escan: procedures>>=
	subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(escan_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default) :: sqrt_x
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	x = r
	xb= rb
	sqrt_x = sqrt (x(1))
	if (sqrt_x > 0) then
	f = 1 / (2 * sqrt_x)
	else
	f = 0
	sf_int%status = SF_FAILED_KINEMATICS
	return
	end if
	call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
	end subroutine escan_complete_kinematics

	@ %def escan_complete_kinematics
	@ Recover $x$. The base procedure should return two momentum
	fractions for the two beams, while we have only one parameter. This
	is the product of the extracted momentum fractions.
	<<SF escan: escan: TBP>>=
	procedure :: recover_x => escan_recover_x
	<<SF escan: procedures>>=
	subroutine escan_recover_x (sf_int, x, xb, x_free)
	class(escan_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	real(default), dimension(2) :: xi, xib
	call sf_int%base_recover_x (xi, xib, x_free)
	x = product (xi)
	xb= 1 - x
	end subroutine escan_recover_x

	@ %def escan_recover_x
	@ Compute inverse kinematics.
	<<SF escan: escan: TBP>>=
	procedure :: inverse_kinematics => escan_inverse_kinematics
	<<SF escan: procedures>>=
	subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(escan_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	real(default) :: sqrt_x
	logical :: set_mom

	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	sqrt_x = sqrt (x(1))
	if (sqrt_x > 0) then
	f = 1 / (2 * sqrt_x)
	else
	f = 0
	sf_int%status = SF_FAILED_KINEMATICS
	return
	end if
	r = x
	rb = xb
	if (set_mom) then
	call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
	end if
	end subroutine escan_inverse_kinematics

	@ %def escan_inverse_kinematics
	@
	\subsection{Energy scan application}
	Here, we insert the predefined norm.
	<<SF escan: escan: TBP>>=
	procedure :: apply => escan_apply
	<<SF escan: procedures>>=
	subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(escan_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: f
	associate (data => sf_int%data)
	f = data%norm
	end associate
	call sf_int%set_matrix_element (cmplx (f, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine escan_apply

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

	module sf_escan_ut
	use unit_tests
	use sf_escan_uti

	<<Standard module head>>

	<<SF escan: public test>>

	contains

	<<SF escan: test driver>>

	end module sf_escan_ut
	@ %def sf_escan_ut
	@
	<<[[sf_escan_uti.f90]]>>=
	<<File header>>

	module sf_escan_uti

	<<Use kinds>>
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use sf_aux
	use sf_base

	use sf_escan

	<<Standard module head>>

	<<SF escan: test declarations>>

	contains

	<<SF escan: tests>>

	end module sf_escan_uti
	@ %def sf_escan_ut
	@ API: driver for the unit tests below.
	<<SF escan: public test>>=
	public :: sf_escan_test
	<<SF escan: test driver>>=
	subroutine sf_escan_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF escan: execute tests>>
	end subroutine sf_escan_test

	@ %def sf_escan_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF escan: execute tests>>=
	call test (sf_escan_1, "sf_escan_1", &
	"structure function configuration", &
	u, results)
	<<SF escan: test declarations>>=
	public :: sf_escan_1
	<<SF escan: tests>>=
	subroutine sf_escan_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_escan_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&energy-scan structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	allocate (escan_data_t :: data)
	select type (data)
	type is (escan_data_t)
	call data%init (model, pdg_in, norm = 2._default)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	call model%final ()

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

	end subroutine sf_escan_1

	@ %def sf_escan_1
	g@
	\subsubsection{Probe the structure-function object}
	Active the beam event reader, generate an event.
	<<SF escan: execute tests>>=
	call test (sf_escan_2, "sf_escan_2", &
	"generate event", &
	u, results)
	<<SF escan: test declarations>>=
	public :: sf_escan_2
	<<SF escan: tests>>=
	subroutine sf_escan_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: x_free, f

	write (u, "(A)") "* Test output: sf_escan_2"
	write (u, "(A)") "* Purpose: initialize and display &
	&beam-events structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv(1)%init (ELECTRON, model)
	call flv(2)%init (-ELECTRON, model)
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	call reset_interaction_counter ()

	allocate (escan_data_t :: data)
	select type (data)
	type is (escan_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Set dummy parameters and generate x"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.8
	rb = 1 - r
	x_free = 1

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%recover_x (x, xb, x_free)
	call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_escan_2

	@ %def sf_escan_2
	@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Gaussian beam spread}

	Instead of an analytic beam description, beam data may be provided in
	form of an event file. In its most simple form, the event file
	contains pairs of $x$ values, relative to nominal beam energies. More
	advanced formats may include polarization, etc. The current
	implementation carries beam polarization through, if specified.

	The code is very similar to the energy scan described above.

	However, we must include a file-handle manager for the beam-event
	files. Two different processes may access a given beam-event file at
	the same time (i.e., serially but alternating). Accessing an open
	file from two different units is non-standard and not supported by all
	compilers. Therefore, we keep a global registry of open files,
	associated units, and reference counts. The [[gaussian_t]] objects
	act as proxies to this registry.
	<<[[sf_gaussian.f90]]>>=
	<<File header>>

	module sf_gaussian

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_12
	use file_registries
	use diagnostics
	use lorentz
	use rng_base
	use pdg_arrays
	use model_data
	use flavors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base

	<<Standard module head>>

	<<SF gaussian: public>>

	<<SF gaussian: types>>

	contains

	<<SF gaussian: procedures>>

	end module sf_gaussian
	@ %def sf_gaussian
	@
	\subsection{The beam-data file registry}
	We manage data files via the [[file_registries]] module. To this end,
	we keep the registry as a private module variable here.
	<<CCC SF gaussian: variables>>=
	type(file_registry_t), save :: beam_file_registry

	@ %def beam_file_registry
	@
	\subsection{Data type}
	We store the spread for each beam, as a relative number related to the beam
	energy. For the actual generation, we include an (abstract) random-number
	generator factory.
	<<SF gaussian: public>>=
	public :: gaussian_data_t
	<<SF gaussian: types>>=
	type, extends(sf_data_t) :: gaussian_data_t
	private
	type(flavor_t), dimension(2) :: flv_in
	real(default), dimension(2) :: spread
	class(rng_factory_t), allocatable :: rng_factory
	contains
	<<SF gaussian: gaussian data: TBP>>
	end type gaussian_data_t

	@ %def gaussian_data_t
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: init => gaussian_data_init
	<<SF gaussian: procedures>>=
	subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory)
	class(gaussian_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(2), intent(in) :: pdg_in
	real(default), dimension(2), intent(in) :: spread
	class(rng_factory_t), intent(inout), allocatable :: rng_factory
	if (any (spread < 0)) then
	call msg_fatal ("Gaussian beam spread: must not be negative")
	end if
	- call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
	- call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
	+ call data%flv_in(1)%init (pdg_in(1)%get (1), model)
	+ call data%flv_in(2)%init (pdg_in(2)%get (1), model)
	data%spread = spread
	call move_alloc (from = rng_factory, to = data%rng_factory)
	end subroutine gaussian_data_init

	@ %def gaussian_data_init
	@ Return true since this spectrum is always in generator mode.
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: is_generator => gaussian_data_is_generator
	<<SF gaussian: procedures>>=
	function gaussian_data_is_generator (data) result (flag)
	class(gaussian_data_t), intent(in) :: data
	logical :: flag
	flag = .true.
	end function gaussian_data_is_generator

	@ %def gaussian_data_is_generator
	@ The number of parameters is two. They are free parameters.
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: get_n_par => gaussian_data_get_n_par
	<<SF gaussian: procedures>>=
	function gaussian_data_get_n_par (data) result (n)
	class(gaussian_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function gaussian_data_get_n_par

	@ %def gaussian_data_get_n_par
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: get_pdg_out => gaussian_data_get_pdg_out
	<<SF gaussian: procedures>>=
	subroutine gaussian_data_get_pdg_out (data, pdg_out)
	class(gaussian_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer :: i, n
	n = 2
	do i = 1, n
	pdg_out(i) = data%flv_in(i)%get_pdg ()
	end do
	end subroutine gaussian_data_get_pdg_out

	@ %def gaussian_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: allocate_sf_int => gaussian_data_allocate_sf_int
	<<SF gaussian: procedures>>=
	subroutine gaussian_data_allocate_sf_int (data, sf_int)
	class(gaussian_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (gaussian_t :: sf_int)
	end subroutine gaussian_data_allocate_sf_int

	@ %def gaussian_data_allocate_sf_int
	@ Output
	<<SF gaussian: gaussian data: TBP>>=
	procedure :: write => gaussian_data_write
	<<SF gaussian: procedures>>=
	subroutine gaussian_data_write (data, unit, verbose)
	class(gaussian_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "Gaussian beam spread data:"
	write (u, "(3x,A,A,A,A)") "prt_in = ", &
	char (data%flv_in(1)%get_name ()), &
	", ", char (data%flv_in(2)%get_name ())
	write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread
	call data%rng_factory%write (u)
	end subroutine gaussian_data_write

	@ %def gaussian_data_write
	@
	\subsection{The gaussian object}
	Flavor and polarization carried through, no radiated particles. The generator
	needs a random-number generator, obviously.
	<<SF gaussian: public>>=
	public :: gaussian_t
	<<SF gaussian: types>>=
	type, extends (sf_int_t) :: gaussian_t
	type(gaussian_data_t), pointer :: data => null ()
	class(rng_t), allocatable :: rng
	contains
	<<SF gaussian: gaussian: TBP>>
	end type gaussian_t

	@ %def gaussian_t
	@ Type string: show gaussian file.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: type_string => gaussian_type_string
	<<SF gaussian: procedures>>=
	function gaussian_type_string (object) result (string)
	class(gaussian_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "Gaussian: gaussian beam-energy spread"
	else
	string = "Gaussian: [undefined]"
	end if
	end function gaussian_type_string

	@ %def gaussian_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: write => gaussian_write
	<<SF gaussian: procedures>>=
	subroutine gaussian_write (object, unit, testflag)
	class(gaussian_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%rng%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "gaussian data: [undefined]"
	end if
	end subroutine gaussian_write

	@ %def gaussian_write
	@
	<<SF gaussian: gaussian: TBP>>=
	procedure :: init => gaussian_init
	<<SF gaussian: procedures>>=
	subroutine gaussian_init (sf_int, data)
	class(gaussian_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	real(default), dimension(2) :: m2
	real(default), dimension(0) :: mr2
	type(quantum_numbers_mask_t), dimension(4) :: mask
	integer, dimension(4) :: hel_lock
	type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
	type(polarization_t), target :: pol1, pol2
	type(polarization_iterator_t) :: it_hel1, it_hel2
	integer :: i
	select type (data)
	type is (gaussian_data_t)
	m2 = data%flv_in%get_mass () ** 2
	hel_lock = [3, 4, 1, 2]
	mask = quantum_numbers_mask (.false., .false., .false.)
	call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
	sf_int%data => data
	do i = 1, 2
	call qn_fc(i)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i)))
	call qn_fc(i+2)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i)))
	end do
	call pol1%init_generic (data%flv_in(1))
	call it_hel1%init (pol1)
	do while (it_hel1%is_valid ())
	qn_hel(1) = it_hel1%get_quantum_numbers ()
	qn_hel(3) = it_hel1%get_quantum_numbers ()
	call pol2%init_generic (data%flv_in(2))
	call it_hel2%init (pol2)
	do while (it_hel2%is_valid ())
	qn_hel(2) = it_hel2%get_quantum_numbers ()
	qn_hel(4) = it_hel2%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc
	call sf_int%add_state (qn)
	call it_hel2%advance ()
	end do
	! call pol2%final ()
	call it_hel1%advance ()
	end do
	! call pol1%final ()
	call sf_int%freeze ()
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	sf_int%status = SF_INITIAL
	end select
	call sf_int%data%rng_factory%make (sf_int%rng)
	end subroutine gaussian_init

	@ %def gaussian_init
	@ This spectrum type needs a finalizer, which closes the data file.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: final => sf_gaussian_final
	<<SF gaussian: procedures>>=
	subroutine sf_gaussian_final (object)
	class(gaussian_t), intent(inout) :: object
	call object%interaction_t%final ()
	end subroutine sf_gaussian_final

	@ %def sf_gaussian_final
	@
	\subsection{Kinematics}
	Refer to the [[data]] component.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: is_generator => gaussian_is_generator
	<<SF gaussian: procedures>>=
	function gaussian_is_generator (sf_int) result (flag)
	class(gaussian_t), intent(in) :: sf_int
	logical :: flag
	flag = sf_int%data%is_generator ()
	end function gaussian_is_generator

	@ %def gaussian_is_generator
	@ Generate free parameters. The $x$ value should be distributed with mean $1$
	and $\sigma$ given by the spread. We reject negative $x$ values. (This
	cut slightly biases the distribution, but for reasonable (small)
	spreads negative $r$ should not occur.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: generate_free => gaussian_generate_free
	<<SF gaussian: procedures>>=
	subroutine gaussian_generate_free (sf_int, r, rb, x_free)
	class(gaussian_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free
	real(default), dimension(size(r)) :: z
	associate (data => sf_int%data)
	do
	call sf_int%rng%generate_gaussian (z)
	rb = z * data%spread
	r = 1 - rb
	x_free = x_free * product (r)
	if (all (r > 0)) exit
	end do
	end associate
	end subroutine gaussian_generate_free

	@ %def gaussian_generate_free
	@ Set kinematics. Trivial transfer since this is a pure generator.
	The [[map]] flag doesn't apply.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: complete_kinematics => gaussian_complete_kinematics
	<<SF gaussian: procedures>>=
	subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(gaussian_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	call msg_fatal ("gaussian: map flag not supported")
	else
	x = r
	xb= rb
	f = 1
	end if
	call sf_int%reduce_momenta (x)
	end subroutine gaussian_complete_kinematics

	@ %def gaussian_complete_kinematics
	@ Compute inverse kinematics. Trivial in this case.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: inverse_kinematics => gaussian_inverse_kinematics
	<<SF gaussian: procedures>>=
	subroutine gaussian_inverse_kinematics &
	(sf_int, x, xb, f, r, rb, map, set_momenta)
	class(gaussian_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	call msg_fatal ("gaussian: map flag not supported")
	else
	r = x
	rb= xb
	f = 1
	end if
	if (set_mom) then
	call sf_int%reduce_momenta (x)
	end if
	end subroutine gaussian_inverse_kinematics

	@ %def gaussian_inverse_kinematics
	@
	\subsection{gaussian application}
	Trivial, just set the unit weight.
	<<SF gaussian: gaussian: TBP>>=
	procedure :: apply => gaussian_apply
	<<SF gaussian: procedures>>=
	subroutine gaussian_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(gaussian_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: f
	f = 1
	call sf_int%set_matrix_element (cmplx (f, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine gaussian_apply

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

	module sf_gaussian_ut
	use unit_tests
	use sf_gaussian_uti

	<<Standard module head>>

	<<SF gaussian: public test>>

	contains

	<<SF gaussian: test driver>>

	end module sf_gaussian_ut
	@ %def sf_gaussian_ut
	@
	<<[[sf_gaussian_uti.f90]]>>=
	<<File header>>

	module sf_gaussian_uti

	<<Use kinds>>
	use numeric_utils, only: pacify
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use rng_base
	use sf_aux
	use sf_base

	use sf_gaussian

	use rng_base_ut, only: rng_test_factory_t

	<<Standard module head>>

	<<SF gaussian: test declarations>>

	contains

	<<SF gaussian: tests>>

	end module sf_gaussian_uti
	@ %def sf_gaussian_ut
	@ API: driver for the unit tests below.
	<<SF gaussian: public test>>=
	public :: sf_gaussian_test
	<<SF gaussian: test driver>>=
	subroutine sf_gaussian_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF gaussian: execute tests>>
	end subroutine sf_gaussian_test

	@ %def sf_gaussian_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF gaussian: execute tests>>=
	call test (sf_gaussian_1, "sf_gaussian_1", &
	"structure function configuration", &
	u, results)
	<<SF gaussian: test declarations>>=
	public :: sf_gaussian_1
	<<SF gaussian: tests>>=
	subroutine sf_gaussian_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	class(sf_data_t), allocatable :: data
	class(rng_factory_t), allocatable :: rng_factory

	write (u, "(A)") "* Test output: sf_gaussian_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&gaussian-spread structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	allocate (gaussian_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)
	select type (data)
	type is (gaussian_data_t)
	call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	call model%final ()

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

	end subroutine sf_gaussian_1

	@ %def sf_gaussian_1
	@
	\subsubsection{Probe the structure-function object}
	Active the beam event reader, generate an event.
	<<SF gaussian: execute tests>>=
	call test (sf_gaussian_2, "sf_gaussian_2", &
	"generate event", &
	u, results)
	<<SF gaussian: test declarations>>=
	public :: sf_gaussian_2
	<<SF gaussian: tests>>=
	subroutine sf_gaussian_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(rng_factory_t), allocatable :: rng_factory
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: x_free, f
	integer :: i

	write (u, "(A)") "* Test output: sf_gaussian_2"
	write (u, "(A)") "* Purpose: initialize and display &
	&gaussian-spread structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv(1)%init (ELECTRON, model)
	call flv(2)%init (-ELECTRON, model)
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	call reset_interaction_counter ()

	allocate (gaussian_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)
	select type (data)
	type is (gaussian_data_t)
	call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Set dummy parameters and generate x."
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 0
	x_free = 1
	call sf_int%generate_free (r, rb, x_free)
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call pacify (rb, 1.e-8_default)
	call pacify (xb, 1.e-8_default)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate more events"
	write (u, "(A)")

	select type (sf_int)
	type is (gaussian_t)
	do i = 1, 3
	call sf_int%generate_free (r, rb, x_free)
	write (u, "(A,9(1x,F10.7))") "r =", r
	end do
	end select

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_gaussian_2

	@ %def sf_gaussian_2
	@
	\clearpage
	@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Using beam event data}

	Instead of an analytic beam description, beam data may be provided in
	form of an event file. In its most simple form, the event file
	contains pairs of $x$ values, relative to nominal beam energies. More
	advanced formats may include polarization, etc. The current
	implementation carries beam polarization through, if specified.

	The code is very similar to the energy scan described above.

	However, we must include a file-handle manager for the beam-event
	files. Two different processes may access a given beam-event file at
	the same time (i.e., serially but alternating). Accessing an open
	file from two different units is non-standard and not supported by all
	compilers. Therefore, we keep a global registry of open files,
	associated units, and reference counts. The [[beam_events_t]] objects
	act as proxies to this registry.
	<<[[sf_beam_events.f90]]>>=
	<<File header>>

	module sf_beam_events

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use file_registries
	use diagnostics
	use lorentz
	use pdg_arrays
	use model_data
	use flavors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base

	<<Standard module head>>

	<<SF beam events: public>>

	<<SF beam events: types>>

	<<SF beam events: variables>>

	contains

	<<SF beam events: procedures>>

	end module sf_beam_events
	@ %def sf_beam_events
	@
	\subsection{The beam-data file registry}
	We manage data files via the [[file_registries]] module. To this end,
	we keep the registry as a private module variable here.

	This is public only for the unit tests.
	<<SF beam events: public>>=
	public :: beam_file_registry
	<<SF beam events: variables>>=
	type(file_registry_t), save :: beam_file_registry

	@ %def beam_file_registry
	@
	\subsection{Data type}
	<<SF beam events: public>>=
	public :: beam_events_data_t
	<<SF beam events: types>>=
	type, extends(sf_data_t) :: beam_events_data_t
	private
	type(flavor_t), dimension(2) :: flv_in
	type(string_t) :: dir
	type(string_t) :: file
	type(string_t) :: fqn
	integer :: unit = 0
	logical :: warn_eof = .true.
	contains
	<<SF beam events: beam events data: TBP>>
	end type beam_events_data_t

	@ %def beam_events_data_t
	<<SF beam events: beam events data: TBP>>=
	procedure :: init => beam_events_data_init
	<<SF beam events: procedures>>=
	subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof)
	class(beam_events_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(2), intent(in) :: pdg_in
	type(string_t), intent(in) :: dir
	type(string_t), intent(in) :: file
	logical, intent(in), optional :: warn_eof
	- if (any (pdg_array_get_length (pdg_in) /= 1)) then
	+ if (any (pdg_in%get_length () /= 1)) then
	call msg_fatal ("Beam events: incoming beam particles must be unique")
	end if
	- call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
	- call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
	+ call data%flv_in(1)%init (pdg_in(1)%get (1), model)
	+ call data%flv_in(2)%init (pdg_in(2)%get (1), model)
	data%dir = dir
	data%file = file
	if (present (warn_eof)) data%warn_eof = warn_eof
	end subroutine beam_events_data_init

	@ %def beam_events_data_init
	@ Return true since this spectrum is always in generator mode.
	<<SF beam events: beam events data: TBP>>=
	procedure :: is_generator => beam_events_data_is_generator
	<<SF beam events: procedures>>=
	function beam_events_data_is_generator (data) result (flag)
	class(beam_events_data_t), intent(in) :: data
	logical :: flag
	flag = .true.
	end function beam_events_data_is_generator

	@ %def beam_events_data_is_generator
	@ The number of parameters is two. They are free parameters.
	<<SF beam events: beam events data: TBP>>=
	procedure :: get_n_par => beam_events_data_get_n_par
	<<SF beam events: procedures>>=
	function beam_events_data_get_n_par (data) result (n)
	class(beam_events_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function beam_events_data_get_n_par

	@ %def beam_events_data_get_n_par
	<<SF beam events: beam events data: TBP>>=
	procedure :: get_pdg_out => beam_events_data_get_pdg_out
	<<SF beam events: procedures>>=
	subroutine beam_events_data_get_pdg_out (data, pdg_out)
	class(beam_events_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer :: i, n
	n = 2
	do i = 1, n
	pdg_out(i) = data%flv_in(i)%get_pdg ()
	end do
	end subroutine beam_events_data_get_pdg_out

	@ %def beam_events_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF beam events: beam events data: TBP>>=
	procedure :: allocate_sf_int => beam_events_data_allocate_sf_int
	<<SF beam events: procedures>>=
	subroutine beam_events_data_allocate_sf_int (data, sf_int)
	class(beam_events_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (beam_events_t :: sf_int)
	end subroutine beam_events_data_allocate_sf_int

	@ %def beam_events_data_allocate_sf_int
	@ Output
	<<SF beam events: beam events data: TBP>>=
	procedure :: write => beam_events_data_write
	<<SF beam events: procedures>>=
	subroutine beam_events_data_write (data, unit, verbose)
	class(beam_events_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "Beam-event file data:"
	write (u, "(3x,A,A,A,A)") "prt_in = ", &
	char (data%flv_in(1)%get_name ()), &
	", ", char (data%flv_in(2)%get_name ())
	write (u, "(3x,A,A,A)") "file = '", char (data%file), "'"
	write (u, "(3x,A,I0)") "unit = ", data%unit
	write (u, "(3x,A,L1)") "warn = ", data%warn_eof
	end subroutine beam_events_data_write

	@ %def beam_events_data_write
	@ The data file needs to be opened and closed explicitly. The
	open/close message is communicated to the file handle registry, which
	does the actual work.

	We determine first whether to look in the local directory or in the
	given system directory.
	<<SF beam events: beam events data: TBP>>=
	procedure :: open => beam_events_data_open
	procedure :: close => beam_events_data_close
	<<SF beam events: procedures>>=
	subroutine beam_events_data_open (data)
	class(beam_events_data_t), intent(inout) :: data
	logical :: exist
	if (data%unit == 0) then
	data%fqn = data%file
	if (data%fqn == "") &
	call msg_fatal ("Beam events: $beam_events_file is not set")
	inquire (file = char (data%fqn), exist = exist)
	if (.not. exist) then
	data%fqn = data%dir // "/" // data%file
	inquire (file = char (data%fqn), exist = exist)
	if (.not. exist) then
	data%fqn = ""
	call msg_fatal ("Beam events: file '" &
	// char (data%file) // "' not found")
	return
	end if
	end if
	call msg_message ("Beam events: reading from file '" &
	// char (data%file) // "'")
	call beam_file_registry%open (data%fqn, data%unit)
	else
	call msg_bug ("Beam events: file '" &
	// char (data%file) // "' is already open")
	end if
	end subroutine beam_events_data_open

	subroutine beam_events_data_close (data)
	class(beam_events_data_t), intent(inout) :: data
	if (data%unit /= 0) then
	call beam_file_registry%close (data%fqn)
	call msg_message ("Beam events: closed file '" &
	// char (data%file) // "'")
	data%unit = 0
	end if
	end subroutine beam_events_data_close

	@ %def beam_events_data_close
	@ Return the beam event file.
	<<SF beam events: beam events data: TBP>>=
	procedure :: get_beam_file => beam_events_data_get_beam_file
	<<SF beam events: procedures>>=
	function beam_events_data_get_beam_file (data) result (file)
	class(beam_events_data_t), intent(in) :: data
	type(string_t) :: file
	file = "Beam events: " // data%file
	end function beam_events_data_get_beam_file

	@ %def beam_events_data_get_beam_file
	@
	\subsection{The beam events object}
	Flavor and polarization carried through, no radiated particles.
	<<SF beam events: public>>=
	public :: beam_events_t
	<<SF beam events: types>>=
	type, extends (sf_int_t) :: beam_events_t
	type(beam_events_data_t), pointer :: data => null ()
	integer :: count = 0
	contains
	<<SF beam events: beam events: TBP>>
	end type beam_events_t

	@ %def beam_events_t
	@ Type string: show beam events file.
	<<SF beam events: beam events: TBP>>=
	procedure :: type_string => beam_events_type_string
	<<SF beam events: procedures>>=
	function beam_events_type_string (object) result (string)
	class(beam_events_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "Beam events: " // object%data%file
	else
	string = "Beam events: [undefined]"
	end if
	end function beam_events_type_string

	@ %def beam_events_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF beam events: beam events: TBP>>=
	procedure :: write => beam_events_write
	<<SF beam events: procedures>>=
	subroutine beam_events_write (object, unit, testflag)
	class(beam_events_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "Beam events data: [undefined]"
	end if
	end subroutine beam_events_write

	@ %def beam_events_write
	@
	<<SF beam events: beam events: TBP>>=
	procedure :: init => beam_events_init
	<<SF beam events: procedures>>=
	subroutine beam_events_init (sf_int, data)
	class(beam_events_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	real(default), dimension(2) :: m2
	real(default), dimension(0) :: mr2
	type(quantum_numbers_mask_t), dimension(4) :: mask
	integer, dimension(4) :: hel_lock
	type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
	type(polarization_t), target :: pol1, pol2
	type(polarization_iterator_t) :: it_hel1, it_hel2
	integer :: i
	select type (data)
	type is (beam_events_data_t)
	m2 = data%flv_in%get_mass () ** 2
	hel_lock = [3, 4, 1, 2]
	mask = quantum_numbers_mask (.false., .false., .false.)
	call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
	sf_int%data => data
	do i = 1, 2
	call qn_fc(i)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i)))
	call qn_fc(i+2)%init ( &
	flv = data%flv_in(i), &
	col = color_from_flavor (data%flv_in(i)))
	end do
	call pol1%init_generic (data%flv_in(1))
	call it_hel1%init (pol1)
	do while (it_hel1%is_valid ())
	qn_hel(1) = it_hel1%get_quantum_numbers ()
	qn_hel(3) = it_hel1%get_quantum_numbers ()
	call pol2%init_generic (data%flv_in(2))
	call it_hel2%init (pol2)
	do while (it_hel2%is_valid ())
	qn_hel(2) = it_hel2%get_quantum_numbers ()
	qn_hel(4) = it_hel2%get_quantum_numbers ()
	qn = qn_hel .merge. qn_fc
	call sf_int%add_state (qn)
	call it_hel2%advance ()
	end do
	! call pol2%final ()
	call it_hel1%advance ()
	end do
	! call pol1%final ()
	call sf_int%freeze ()
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	call sf_int%data%open ()
	sf_int%status = SF_INITIAL
	end select
	end subroutine beam_events_init

	@ %def beam_events_init
	@ This spectrum type needs a finalizer, which closes the data file.
	<<SF beam events: beam events: TBP>>=
	procedure :: final => sf_beam_events_final
	<<SF beam events: procedures>>=
	subroutine sf_beam_events_final (object)
	class(beam_events_t), intent(inout) :: object
	call object%data%close ()
	call object%interaction_t%final ()
	end subroutine sf_beam_events_final

	@ %def sf_beam_events_final
	@
	\subsection{Kinematics}
	Refer to the [[data]] component.
	<<SF beam events: beam events: TBP>>=
	procedure :: is_generator => beam_events_is_generator
	<<SF beam events: procedures>>=
	function beam_events_is_generator (sf_int) result (flag)
	class(beam_events_t), intent(in) :: sf_int
	logical :: flag
	flag = sf_int%data%is_generator ()
	end function beam_events_is_generator

	@ %def beam_events_is_generator
	@ Generate free parameters. We read them from file.
	<<SF beam events: beam events: TBP>>=
	procedure :: generate_free => beam_events_generate_free
	<<SF beam events: procedures>>=
	recursive subroutine beam_events_generate_free (sf_int, r, rb, x_free)
	class(beam_events_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free
	integer :: iostat
	associate (data => sf_int%data)
	if (data%unit /= 0) then
	read (data%unit, fmt=*, iostat=iostat) r
	if (iostat > 0) then
	write (msg_buffer, "(A,I0,A)") &
	"Beam events: I/O error after reading ", sf_int%count, &
	" events"
	call msg_fatal ()
	else if (iostat < 0) then
	if (sf_int%count == 0) then
	call msg_fatal ("Beam events: file is empty")
	else if (sf_int%data%warn_eof) then
	write (msg_buffer, "(A,I0,A)") &
	"Beam events: End of file after reading ", sf_int%count, &
	" events, rewinding"
	call msg_warning ()
	end if
	rewind (data%unit)
	sf_int%count = 0
	call sf_int%generate_free (r, rb, x_free)
	else
	sf_int%count = sf_int%count + 1
	rb = 1 - r
	x_free = x_free * product (r)
	end if
	else
	call msg_bug ("Beam events: file is not open for reading")
	end if
	end associate
	end subroutine beam_events_generate_free

	@ %def beam_events_generate_free
	@ Set kinematics. Trivial transfer since this is a pure generator.
	The [[map]] flag doesn't apply.
	<<SF beam events: beam events: TBP>>=
	procedure :: complete_kinematics => beam_events_complete_kinematics
	<<SF beam events: procedures>>=
	subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(beam_events_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	call msg_fatal ("Beam events: map flag not supported")
	else
	x = r
	xb= rb
	f = 1
	end if
	call sf_int%reduce_momenta (x)
	end subroutine beam_events_complete_kinematics

	@ %def beam_events_complete_kinematics
	@ Compute inverse kinematics. Trivial in this case.
	<<SF beam events: beam events: TBP>>=
	procedure :: inverse_kinematics => beam_events_inverse_kinematics
	<<SF beam events: procedures>>=
	subroutine beam_events_inverse_kinematics &
	(sf_int, x, xb, f, r, rb, map, set_momenta)
	class(beam_events_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	call msg_fatal ("Beam events: map flag not supported")
	else
	r = x
	rb= xb
	f = 1
	end if
	if (set_mom) then
	call sf_int%reduce_momenta (x)
	end if
	end subroutine beam_events_inverse_kinematics

	@ %def beam_events_inverse_kinematics
	@
	\subsection{Beam events application}
	Trivial, just set the unit weight.
	<<SF beam events: beam events: TBP>>=
	procedure :: apply => beam_events_apply
	<<SF beam events: procedures>>=
	subroutine beam_events_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(beam_events_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: f
	f = 1
	call sf_int%set_matrix_element (cmplx (f, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine beam_events_apply

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

	module sf_beam_events_ut
	use unit_tests
	use sf_beam_events_uti

	<<Standard module head>>

	<<SF beam events: public test>>

	contains

	<<SF beam events: test driver>>

	end module sf_beam_events_ut
	@ %def sf_beam_events_ut
	@
	<<[[sf_beam_events_uti.f90]]>>=
	<<File header>>

	module sf_beam_events_uti

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use numeric_utils, only: pacify
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use sf_aux
	use sf_base

	use sf_beam_events

	<<Standard module head>>

	<<SF beam events: test declarations>>

	contains

	<<SF beam events: tests>>

	end module sf_beam_events_uti
	@ %def sf_beam_events_ut
	@ API: driver for the unit tests below.
	<<SF beam events: public test>>=
	public :: sf_beam_events_test
	<<SF beam events: test driver>>=
	subroutine sf_beam_events_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF beam events: execute tests>>
	end subroutine sf_beam_events_test

	@ %def sf_beam_events_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF beam events: execute tests>>=
	call test (sf_beam_events_1, "sf_beam_events_1", &
	"structure function configuration", &
	u, results)
	<<SF beam events: test declarations>>=
	public :: sf_beam_events_1
	<<SF beam events: tests>>=
	subroutine sf_beam_events_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_beam_events_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&beam-events structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	allocate (beam_events_data_t :: data)
	select type (data)
	type is (beam_events_data_t)
	call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat"))
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	call model%final ()

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

	end subroutine sf_beam_events_1

	@ %def sf_beam_events_1
	@
	\subsubsection{Probe the structure-function object}
	Active the beam event reader, generate an event.
	<<SF beam events: execute tests>>=
	call test (sf_beam_events_2, "sf_beam_events_2", &
	"generate event", &
	u, results)
	<<SF beam events: test declarations>>=
	public :: sf_beam_events_2
	<<SF beam events: tests>>=
	subroutine sf_beam_events_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: x_free, f
	integer :: i

	write (u, "(A)") "* Test output: sf_beam_events_2"
	write (u, "(A)") "* Purpose: initialize and display &
	&beam-events structure function data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv(1)%init (ELECTRON, model)
	call flv(2)%init (-ELECTRON, model)
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	call reset_interaction_counter ()

	allocate (beam_events_data_t :: data)
	select type (data)
	type is (beam_events_data_t)
	call data%init (model, pdg_in, &
	var_str (""), var_str ("test_beam_events.dat"))
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Set dummy parameters and generate x."
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 0
	x_free = 1
	call sf_int%generate_free (r, rb, x_free)
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,9(1x,F10.7))") "rb=", rb
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free
	select type (sf_int)
	type is (beam_events_t)
	write (u, "(A,1x,I0)") "count =", sf_int%count
	end select

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Generate more events, rewind"
	write (u, "(A)")

	select type (sf_int)
	type is (beam_events_t)
	do i = 1, 3
	call sf_int%generate_free (r, rb, x_free)
	write (u, "(A,9(1x,F10.7))") "r =", r
	write (u, "(A,1x,I0)") "count =", sf_int%count
	end do
	end select

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_beam_events_2

	@ %def sf_beam_events_2
	@
	\subsubsection{Check the file handle registry}
	Open and close some files, checking the registry contents.
	<<SF beam events: execute tests>>=
	call test (sf_beam_events_3, "sf_beam_events_3", &
	"check registry", &
	u, results)
	<<SF beam events: test declarations>>=
	public :: sf_beam_events_3
	<<SF beam events: tests>>=
	subroutine sf_beam_events_3 (u)
	integer, intent(in) :: u
	integer :: u1

	write (u, "(A)") "* Test output: sf_beam_events_2"
	write (u, "(A)") "* Purpose: check file handle registry"
	write (u, "(A)")

	write (u, "(A)") "* Create some empty files"
	write (u, "(A)")

	u1 = free_unit ()
	open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new")
	close (u1)
	open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new")
	close (u1)
	open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new")
	close (u1)

	write (u, "(A)") "* Empty registry"
	write (u, "(A)")

	call beam_file_registry%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Insert three entries"
	write (u, "(A)")

	call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp"))
	call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
	call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp"))
	call beam_file_registry%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Open a second channel"
	write (u, "(A)")

	call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
	call beam_file_registry%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Close second entry twice"
	write (u, "(A)")

	call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
	call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
	call beam_file_registry%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Close last entry"
	write (u, "(A)")

	call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp"))
	call beam_file_registry%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Close remaining entry"
	write (u, "(A)")

	call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp"))
	call beam_file_registry%write (u)

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

	open (u1, file = "sf_beam_events_f1.tmp", action="write")
	close (u1, status = "delete")
	open (u1, file = "sf_beam_events_f2.tmp", action="write")
	close (u1, status = "delete")
	open (u1, file = "sf_beam_events_f3.tmp", action="write")
	close (u1, status = "delete")

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

	end subroutine sf_beam_events_3

	@ %def sf_beam_events_3
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{Lepton collider beamstrahlung: CIRCE1}

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

	module sf_circe1

	<<Use kinds>>
	use kinds, only: double
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_17, FMT_19
	use diagnostics
	use physics_defs, only: ELECTRON, PHOTON
	use lorentz
	use rng_base
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_mappings
	use sf_base
	use circe1, circe1_rng_t => rng_type !NODEP!

	<<Standard module head>>

	<<SF circe1: public>>

	<<SF circe1: types>>

	contains

	<<SF circe1: procedures>>

	end module sf_circe1
	@ %def sf_circe1
	@
	\subsection{Physics}
	Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has
	a single structure function for both beams (which makes sense since it
	has to be switched on or off for both beams simultaneously).
	Nevertheless it is factorized:

	The functional form in the [[CIRCE1]] parameterization is defined for
	electrons or photons
	\begin{equation}
	f(x) = \alpha\,x^\beta\,(1-x)^\gamma
	\end{equation}
	for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the
	remaining interval, the standard form is zero, with a delta
	singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be
	distributed uniformly among this interval. This latter form is
	implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and
	is used here.

	The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]]
	structure function. Its default value is $10^{-5}$.
	The other parameters are the parameterization version and revision
	number, the accelerator type, and the $\sqrt{s}$ value used by
	[[CIRCE1]]. The chattiness can also be set.

	Since the energy is distributed in a narrow region around unity (for
	electrons) or zero (for photons), it is advantageous to map the
	interval first. The mapping is controlled by the parameter
	[[circe1\_epsilon]] which is taken from the [[CIRCE1]]
	internal data structure.

	The $\sqrt{s}$ value, if not explicitly set, is taken from the
	process data. Note that interpolating $\sqrt{s}$ is not recommended;
	one should rather choose one of the distinct values known to [[CIRCE1]].

	\subsection{The CIRCE1 data block}
	The CIRCE1 parameters are: The incoming flavors, the flags whether the photon
	or the lepton is the parton in the hard interaction, the flags for the
	generation mode (generator/mapping/no mapping), the mapping parameter
	$\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]],
	[[rev]], [[acc]], [[chat]].

	In generator mode, the $x$ values are actually discarded and a random number
	generator is used instead.
	<<SF circe1: public>>=
	public :: circe1_data_t
	<<SF circe1: types>>=
	type, extends (sf_data_t) :: circe1_data_t
	private
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(2) :: flv_in
	integer, dimension(2) :: pdg_in
	real(default), dimension(2) :: m_in = 0
	logical, dimension(2) :: photon = .false.
	logical :: generate = .false.
	class(rng_factory_t), allocatable :: rng_factory
	real(default) :: sqrts = 0
	real(default) :: eps = 0
	integer :: ver = 0
	integer :: rev = 0
	character(6) :: acc = "?"
	integer :: chat = 0
	logical :: with_radiation = .false.
	contains
	<<SF circe1: circe1 data: TBP>>
	end type circe1_data_t

	@ %def circe1_data_t
	@
	<<SF circe1: circe1 data: TBP>>=
	procedure :: init => circe1_data_init
	<<SF circe1: procedures>>=
	subroutine circe1_data_init &
	(data, model, pdg_in, sqrts, eps, out_photon, &
	ver, rev, acc, chat, with_radiation)
	class(circe1_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(2), intent(in) :: pdg_in
	real(default), intent(in) :: sqrts
	real(default), intent(in) :: eps
	logical, dimension(2), intent(in) :: out_photon
	character(*), intent(in) :: acc
	integer, intent(in) :: ver, rev, chat
	logical, intent(in) :: with_radiation
	data%model => model
	- if (any (pdg_array_get_length (pdg_in) /= 1)) then
	+ if (any (pdg_in%get_length () /= 1)) then
	call msg_fatal ("CIRCE1: incoming beam particles must be unique")
	end if
	- call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
	- call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
	+ call data%flv_in(1)%init (pdg_in(1)%get (1), model)
	+ call data%flv_in(2)%init (pdg_in(2)%get (1), model)
	data%pdg_in = data%flv_in%get_pdg ()
	data%m_in = data%flv_in%get_mass ()
	data%sqrts = sqrts
	data%eps = eps
	data%photon = out_photon
	data%ver = ver
	data%rev = rev
	data%acc = acc
	data%chat = chat
	data%with_radiation = with_radiation
	call data%check ()
	call circex (0.d0, 0.d0, dble (data%sqrts), &
	data%acc, data%ver, data%rev, data%chat)
	end subroutine circe1_data_init

	@ %def circe1_data_init
	@ Activate the generator mode. We import a RNG factory into the data
	type, which can then spawn RNG generator objects.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: set_generator_mode => circe1_data_set_generator_mode
	<<SF circe1: procedures>>=
	subroutine circe1_data_set_generator_mode (data, rng_factory)
	class(circe1_data_t), intent(inout) :: data
	class(rng_factory_t), intent(inout), allocatable :: rng_factory
	data%generate = .true.
	call move_alloc (from = rng_factory, to = data%rng_factory)
	end subroutine circe1_data_set_generator_mode

	@ %def circe1_data_set_generator_mode
	@ Handle error conditions.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: check => circe1_data_check
	<<SF circe1: procedures>>=
	subroutine circe1_data_check (data)
	class(circe1_data_t), intent(in) :: data
	type(flavor_t) :: flv_electron, flv_photon
	call flv_electron%init (ELECTRON, data%model)
	call flv_photon%init (PHOTON, data%model)
	if (.not. flv_electron%is_defined () &
	.or. .not. flv_photon%is_defined ()) then
	call msg_fatal ("CIRCE1: model must contain photon and electron")
	end if
	if (any (abs (data%pdg_in) /= ELECTRON) &
	.or. (data%pdg_in(1) /= - data%pdg_in(2))) then
	call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions")
	end if
	if (data%eps <= 0) then
	call msg_error ("CIRCE1: circe1_eps = 0: integration will &
	&miss x=1 peak")
	end if
	end subroutine circe1_data_check

	@ %def circe1_data_check
	@ Output
	<<SF circe1: circe1 data: TBP>>=
	procedure :: write => circe1_data_write
	<<SF circe1: procedures>>=
	subroutine circe1_data_write (data, unit, verbose)
	class(circe1_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "CIRCE1 data:"
	write (u, "(3x,A,2(1x,A))") "prt_in =", &
	char (data%flv_in(1)%get_name ()), &
	char (data%flv_in(2)%get_name ())
	write (u, "(3x,A,2(1x,L1))") "photon =", data%photon
	write (u, "(3x,A,L1)") "generate = ", data%generate
	write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in =", data%m_in
	write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts
	write (u, "(3x,A," // FMT_19 // ")") "eps = ", data%eps
	write (u, "(3x,A,I0)") "ver = ", data%ver
	write (u, "(3x,A,I0)") "rev = ", data%rev
	write (u, "(3x,A,A)") "acc = ", data%acc
	write (u, "(3x,A,I0)") "chat = ", data%chat
	write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation
	if (data%generate) then
	if (verb) then
	call data%rng_factory%write (u)
	end if
	end if
	end subroutine circe1_data_write

	@ %def circe1_data_write
	@ Return true if this structure function is in generator mode. In
	that case, all parameters are free, otherwise bound. (We do not
	support mixed cases.) Default is: no generator.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: is_generator => circe1_data_is_generator
	<<SF circe1: procedures>>=
	function circe1_data_is_generator (data) result (flag)
	class(circe1_data_t), intent(in) :: data
	logical :: flag
	flag = data%generate
	end function circe1_data_is_generator

	@ %def circe1_data_is_generator
	@ The number of parameters is two, collinear splitting for the two beams.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: get_n_par => circe1_data_get_n_par
	<<SF circe1: procedures>>=
	function circe1_data_get_n_par (data) result (n)
	class(circe1_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function circe1_data_get_n_par

	@ %def circe1_data_get_n_par
	@ Return the outgoing particles PDG codes. This is either the incoming
	particle (if a photon is radiated), or the photon if that is the particle
	of the hard interaction. The latter is determined via the [[photon]]
	flag. There are two entries for the two beams.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: get_pdg_out => circe1_data_get_pdg_out
	<<SF circe1: procedures>>=
	subroutine circe1_data_get_pdg_out (data, pdg_out)
	class(circe1_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer :: i, n
	n = 2
	do i = 1, n
	if (data%photon(i)) then
	pdg_out(i) = PHOTON
	else
	pdg_out(i) = data%pdg_in(i)
	end if
	end do
	end subroutine circe1_data_get_pdg_out

	@ %def circe1_data_get_pdg_out
	@ This variant is not inherited, it returns integers.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: get_pdg_int => circe1_data_get_pdg_int
	<<SF circe1: procedures>>=
	function circe1_data_get_pdg_int (data) result (pdg)
	class(circe1_data_t), intent(in) :: data
	integer, dimension(2) :: pdg
	integer :: i
	do i = 1, 2
	if (data%photon(i)) then
	pdg(i) = PHOTON
	else
	pdg(i) = data%pdg_in(i)
	end if
	end do
	end function circe1_data_get_pdg_int

	@ %def circe1_data_get_pdg_int
	@ Allocate the interaction record.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: allocate_sf_int => circe1_data_allocate_sf_int
	<<SF circe1: procedures>>=
	subroutine circe1_data_allocate_sf_int (data, sf_int)
	class(circe1_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (circe1_t :: sf_int)
	end subroutine circe1_data_allocate_sf_int

	@ %def circe1_data_allocate_sf_int
	@ Return the accelerator type.
	<<SF circe1: circe1 data: TBP>>=
	procedure :: get_beam_file => circe1_data_get_beam_file
	<<SF circe1: procedures>>=
	function circe1_data_get_beam_file (data) result (file)
	class(circe1_data_t), intent(in) :: data
	type(string_t) :: file
	file = "CIRCE1: " // data%acc
	end function circe1_data_get_beam_file

	@ %def circe1_data_get_beam_file
	@
	\subsection{Random Number Generator for CIRCE}
	The CIRCE implementation now supports a generic random-number
	generator object that allows for a local state as a component. To
	support this, we must extend the abstract type provided by CIRCE and
	delegate the generator call to the (also abstract) RNG used by WHIZARD.
	<<SF circe1: types>>=
	type, extends (circe1_rng_t) :: rng_obj_t
	class(rng_t), allocatable :: rng
	contains
	procedure :: generate => rng_obj_generate
	end type rng_obj_t

	@ %def rng_obj_t
	<<SF circe1: procedures>>=
	subroutine rng_obj_generate (rng_obj, u)
	class(rng_obj_t), intent(inout) :: rng_obj
	real(double), intent(out) :: u
	real(default) :: x
	call rng_obj%rng%generate (x)
	u = x
	end subroutine rng_obj_generate

	@ %def rng_obj_generate
	@
	\subsection{The CIRCE1 object}
	This is a $2\to 4$ interaction, where, depending on the parameters, any two of
	the four outgoing particles are connected to the hard interactions, the others
	are radiated. Knowing that all particles are colorless, we do not have to
	deal with color.

	The flavors are sorted such that the first two particles are the incoming
	leptons, the next two are the radiated particles, and the last two are the
	partons initiating the hard interaction.

	CIRCE1 does not support polarized beams explicitly. For simplicity, we
	nevertheless carry beam polarization through to the outgoing electrons and
	make the photons unpolarized.

	In the case that no radiated particle is kept (which actually is the
	default), polarization is always transferred to the electrons, too. If
	there is a recoil photon in the event, the radiated particles are 3
	and 4, respectively, and 5 and 6 are the outgoing ones (triggering the
	hard scattering process), while in the case of no radiation, the
	outgoing particles are 3 and 4, respectively. In the case of the
	electron being the radiated particle, helicity is not kept.
	<<SF circe1: public>>=
	public :: circe1_t
	<<SF circe1: types>>=
	type, extends (sf_int_t) :: circe1_t
	type(circe1_data_t), pointer :: data => null ()
	real(default), dimension(2) :: x = 0
	real(default), dimension(2) :: xb= 0
	real(default) :: f = 0
	logical, dimension(2) :: continuum = .true.
	logical, dimension(2) :: peak = .true.
	type(rng_obj_t) :: rng_obj
	contains
	<<SF circe1: circe1: TBP>>
	end type circe1_t

	@ %def circe1_t
	@ Type string: has to be here, but there is no string variable on which CIRCE1
	depends. Hence, a dummy routine.
	<<SF circe1: circe1: TBP>>=
	procedure :: type_string => circe1_type_string
	<<SF circe1: procedures>>=
	function circe1_type_string (object) result (string)
	class(circe1_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "CIRCE1: beamstrahlung"
	else
	string = "CIRCE1: [undefined]"
	end if
	end function circe1_type_string

	@ %def circe1_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF circe1: circe1: TBP>>=
	procedure :: write => circe1_write
	<<SF circe1: procedures>>=
	subroutine circe1_write (object, unit, testflag)
	class(circe1_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%data%generate) call object%rng_obj%rng%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(3x,A,2(1x," // FMT_17 // "))") "x =", object%x
	write (u, "(3x,A,2(1x," // FMT_17 // "))") "xb=", object%xb
	if (object%status >= SF_FAILED_EVALUATION) then
	write (u, "(3x,A,1x," // FMT_17 // ")") "f =", object%f
	end if
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "CIRCE1 data: [undefined]"
	end if
	end subroutine circe1_write

	@ %def circe1_write
	@
	<<SF circe1: circe1: TBP>>=
	procedure :: init => circe1_init
	<<SF circe1: procedures>>=
	subroutine circe1_init (sf_int, data)
	class(circe1_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	logical, dimension(6) :: mask_h
	type(quantum_numbers_mask_t), dimension(6) :: mask
	integer, dimension(6) :: hel_lock
	type(polarization_t), target :: pol1, pol2
	type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2
	type(flavor_t) :: flv_photon
	type(color_t) :: col0
	real(default), dimension(2) :: mi2, mr2, mo2
	type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2
	type(quantum_numbers_t), dimension(6) :: qn
	type(polarization_iterator_t) :: it_hel1, it_hel2
	hel_lock = 0
	mask_h = .false.
	select type (data)
	type is (circe1_data_t)
	mi2 = data%m_in**2
	if (data%with_radiation) then
	if (data%photon(1)) then
	hel_lock(1) = 3; hel_lock(3) = 1; mask_h(5) = .true.
	mr2(1) = mi2(1)
	mo2(1) = 0._default
	else
	hel_lock(1) = 5; hel_lock(5) = 1; mask_h(3) = .true.
	mr2(1) = 0._default
	mo2(1) = mi2(1)
	end if
	if (data%photon(2)) then
	hel_lock(2) = 4; hel_lock(4) = 2; mask_h(6) = .true.
	mr2(2) = mi2(2)
	mo2(2) = 0._default
	else
	hel_lock(2) = 6; hel_lock(6) = 2; mask_h(4) = .true.
	mr2(2) = 0._default
	mo2(2) = mi2(2)
	end if
	mask = quantum_numbers_mask (.false., .false., mask_h)
	call sf_int%base_init (mask, mi2, mr2, mo2, &
	hel_lock = hel_lock)
	sf_int%data => data
	call flv_photon%init (PHOTON, data%model)
	call col0%init ()
	call qn_photon%init (flv_photon, col0)
	call pol1%init_generic (data%flv_in(1))
	call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
	call pol2%init_generic (data%flv_in(2))
	call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
	call it_hel1%init (pol1)

	do while (it_hel1%is_valid ())
	qn_hel1 = it_hel1%get_quantum_numbers ()
	qn1 = qn_hel1 .merge. qn_fc1(1)
	qn(1) = qn1
	if (data%photon(1)) then
	qn(3) = qn1; qn(5) = qn_photon
	else
	qn(3) = qn_photon; qn(5) = qn1
	end if
	call it_hel2%init (pol2)
	do while (it_hel2%is_valid ())
	qn_hel2 = it_hel2%get_quantum_numbers ()
	qn2 = qn_hel2 .merge. qn_fc2(1)
	qn(2) = qn2
	if (data%photon(2)) then
	qn(4) = qn2; qn(6) = qn_photon
	else
	qn(4) = qn_photon; qn(6) = qn2
	end if
	call qn(3:4)%tag_radiated ()
	call sf_int%add_state (qn)
	call it_hel2%advance ()
	end do
	call it_hel1%advance ()
	end do
	! call pol1%final ()
	! call pol2%final ()
	call sf_int%freeze ()
	call sf_int%set_incoming ([1,2])
	call sf_int%set_radiated ([3,4])
	call sf_int%set_outgoing ([5,6])
	else
	if (data%photon(1)) then
	mask_h(3) = .true.
	mo2(1) = 0._default
	else
	hel_lock(1) = 3; hel_lock(3) = 1
	mo2(1) = mi2(1)
	end if
	if (data%photon(2)) then
	mask_h(4) = .true.
	mo2(2) = 0._default
	else
	hel_lock(2) = 4; hel_lock(4) = 2
	mo2(2) = mi2(2)
	end if
	mask = quantum_numbers_mask (.false., .false., mask_h)
	call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, &
	hel_lock = hel_lock(1:4))
	sf_int%data => data
	call flv_photon%init (PHOTON, data%model)
	call col0%init ()
	call qn_photon%init (flv_photon, col0)
	call pol1%init_generic (data%flv_in(1))
	call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
	call pol2%init_generic (data%flv_in(2))
	call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
	call it_hel1%init (pol1)

	do while (it_hel1%is_valid ())
	qn_hel1 = it_hel1%get_quantum_numbers ()
	qn1 = qn_hel1 .merge. qn_fc1(1)
	qn(1) = qn1
	if (data%photon(1)) then
	qn(3) = qn_photon
	else
	qn(3) = qn1
	end if
	call it_hel2%init (pol2)
	do while (it_hel2%is_valid ())
	qn_hel2 = it_hel2%get_quantum_numbers ()
	qn2 = qn_hel2 .merge. qn_fc2(1)
	qn(2) = qn2
	if (data%photon(2)) then
	qn(4) = qn_photon
	else
	qn(4) = qn2
	end if
	call sf_int%add_state (qn(1:4))
	call it_hel2%advance ()
	end do
	call it_hel1%advance ()
	end do
	! call pol1%final ()
	! call pol2%final ()
	call sf_int%freeze ()
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	end if
	sf_int%status = SF_INITIAL
	end select
	if (sf_int%data%generate) then
	call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
	end if
	end subroutine circe1_init

	@ %def circe1_init
	@
	\subsection{Kinematics}
	Refer to the [[data]] component.
	<<SF circe1: circe1: TBP>>=
	procedure :: is_generator => circe1_is_generator
	<<SF circe1: procedures>>=
	function circe1_is_generator (sf_int) result (flag)
	class(circe1_t), intent(in) :: sf_int
	logical :: flag
	flag = sf_int%data%is_generator ()
	end function circe1_is_generator

	@ %def circe1_is_generator
	@ Generate free parameters, if generator mode is on. Otherwise, the
	parameters will be discarded.
	<<SF circe1: circe1: TBP>>=
	procedure :: generate_free => circe1_generate_free
	<<SF circe1: procedures>>=
	subroutine circe1_generate_free (sf_int, r, rb, x_free)
	class(circe1_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free

	if (sf_int%data%generate) then
	call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj)
	rb = 1 - r
	x_free = x_free * product (r)
	else
	r = 0
	rb= 1
	end if
	end subroutine circe1_generate_free

	@ %def circe1_generate_free
	@ Generator mode: depending on the particle codes, call one of the
	available [[girce]] generators. Illegal particle code combinations
	should have been caught during data initialization.
	<<SF circe1: procedures>>=
	subroutine circe_generate (x, pdg, rng_obj)
	real(default), dimension(2), intent(out) :: x
	integer, dimension(2), intent(in) :: pdg
	class(rng_obj_t), intent(inout) :: rng_obj
	real(double) :: xc1, xc2
	select case (abs (pdg(1)))
	case (ELECTRON)
	select case (abs (pdg(2)))
	case (ELECTRON)
	call gircee (xc1, xc2, rng_obj = rng_obj)
	case (PHOTON)
	call girceg (xc1, xc2, rng_obj = rng_obj)
	end select
	case (PHOTON)
	select case (abs (pdg(2)))
	case (ELECTRON)
	call girceg (xc2, xc1, rng_obj = rng_obj)
	case (PHOTON)
	call gircgg (xc1, xc2, rng_obj = rng_obj)
	end select
	end select
	x = [xc1, xc2]
	end subroutine circe_generate

	@ %def circe_generate
	@ Set kinematics. The $r$ values (either from integration or from the
	generator call above) are copied to $x$ unchanged, and $f$ is unity.
	We store the $x$ values, so we can use them for the evaluation later.
	<<SF circe1: circe1: TBP>>=
	procedure :: complete_kinematics => circe1_complete_kinematics
	<<SF circe1: procedures>>=
	subroutine circe1_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(circe1_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	x = r
	xb = rb
	sf_int%x = x
	sf_int%xb= xb
	f = 1
	if (sf_int%data%with_radiation) then
	call sf_int%split_momenta (x, xb)
	else
	call sf_int%reduce_momenta (x)
	end if
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end subroutine circe1_complete_kinematics

	@ %def circe1_complete_kinematics
	@ Compute inverse kinematics. In generator mode, the $r$ values are
	meaningless, but we copy them anyway.
	<<SF circe1: circe1: TBP>>=
	procedure :: inverse_kinematics => circe1_inverse_kinematics
	<<SF circe1: procedures>>=
	subroutine circe1_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(circe1_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	r = x
	rb = xb
	sf_int%x = x
	sf_int%xb= xb
	f = 1
	if (set_mom) then
	call sf_int%split_momenta (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine circe1_inverse_kinematics

	@ %def circe1_inverse_kinematics
	@
	\subsection{CIRCE1 application}
	CIRCE is applied for the two beams at once. We can safely assume that no
	structure functions are applied before this, so the incoming particles are
	on-shell electrons/positrons.

	The scale is ignored.
	<<SF circe1: circe1: TBP>>=
	procedure :: apply => circe1_apply
	<<SF circe1: procedures>>=
	subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(circe1_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default), dimension(2) :: xb
	real(double), dimension(2) :: xc
	real(double), parameter :: one = 1
	associate (data => sf_int%data)
	xc = sf_int%x
	xb = sf_int%xb
	if (data%generate) then
	sf_int%f = 1
	else
	sf_int%f = 0
	if (all (sf_int%continuum)) then
	sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2))
	end if
	if (sf_int%continuum(2) .and. sf_int%peak(1)) then
	sf_int%f = sf_int%f &
	+ circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) &
	* peak (xb(1), data%eps)
	end if
	if (sf_int%continuum(1) .and. sf_int%peak(2)) then
	sf_int%f = sf_int%f &
	+ circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) &
	* peak (xb(2), data%eps)
	end if
	if (all (sf_int%peak)) then
	sf_int%f = sf_int%f &
	+ circe (one, one, data%pdg_in(1), data%pdg_in(2)) &
	* peak (xb(1), data%eps) * peak (xb(2), data%eps)
	end if
	end if
	end associate
	call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default))
	sf_int%status = SF_EVALUATED
	end subroutine circe1_apply

	@ %def circe1_apply
	@ This is a smeared delta peak at zero, as an endpoint singularity.
	We choose an exponentially decreasing function, starting at zero, with
	integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$,
	this reduces to one.
	<<SF circe1: procedures>>=
	function peak (x, eps) result (f)
	real(default), intent(in) :: x, eps
	real(default) :: f
	f = exp (-x / eps) / eps
	end function peak

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

	module sf_circe1_ut
	use unit_tests
	use sf_circe1_uti

	<<Standard module head>>

	<<SF circe1: public test>>

	contains

	<<SF circe1: test driver>>

	end module sf_circe1_ut
	@ %def sf_circe1_ut
	@
	<<[[sf_circe1_uti.f90]]>>=
	<<File header>>

	module sf_circe1_uti

	<<Use kinds>>
	use physics_defs, only: ELECTRON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use rng_base
	use sf_aux
	use sf_base

	use sf_circe1

	use rng_base_ut, only: rng_test_factory_t

	<<Standard module head>>

	<<SF circe1: test declarations>>

	contains

	<<SF circe1: tests>>

	end module sf_circe1_uti
	@ %def sf_circe1_ut
	@ API: driver for the unit tests below.
	<<SF circe1: public test>>=
	public :: sf_circe1_test
	<<SF circe1: test driver>>=
	subroutine sf_circe1_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF circe1: execute tests>>
	end subroutine sf_circe1_test

	@ %def sf_circe1_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF circe1: execute tests>>=
	call test (sf_circe1_1, "sf_circe1_1", &
	"structure function configuration", &
	u, results)
	<<SF circe1: test declarations>>=
	public :: sf_circe1_1
	<<SF circe1: tests>>=
	subroutine sf_circe1_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_circe1_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&CIRCE structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call model%init_qed_test ()
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	allocate (circe1_data_t :: data)
	call data%write (u)

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

	select type (data)
	type is (circe1_data_t)
	call data%init (model, pdg_in, &
	sqrts = 500._default, &
	eps = 1e-6_default, &
	out_photon = [.false., .false.], &
	ver = 0, &
	rev = 0, &
	acc = "SBAND", &
	chat = 0, &
	with_radiation = .true.)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	call model%final ()

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

	end subroutine sf_circe1_1

	@ %def sf_circe1_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the PDF builtin
	structure function.
	<<SF circe1: execute tests>>=
	call test (sf_circe1_2, "sf_circe1_2", &
	"structure function instance", &
	u, results)
	<<SF circe1: test declarations>>=
	public :: sf_circe1_2
	<<SF circe1: tests>>=
	subroutine sf_circe1_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	type(vector4_t), dimension(4) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_circe1_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&circe1 structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv(1)%init (ELECTRON, model)
	call flv(2)%init (-ELECTRON, model)
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	call reset_interaction_counter ()

	allocate (circe1_data_t :: data)
	select type (data)
	type is (circe1_data_t)
	call data%init (model, pdg_in, &
	sqrts = 500._default, &
	eps = 1e-6_default, &
	out_photon = [.false., .false.], &
	ver = 0, &
	rev = 0, &
	acc = "SBAND", &
	chat = 0, &
	with_radiation = .true.)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.95,0.85."
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = [0.9_default, 0.8_default]
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1, 2])

	call sf_int%seed_kinematics ([k1, k2])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

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

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_circe1_2

	@ %def sf_circe1_2
	@
	\subsubsection{Generator mode}
	Construct and evaluate a structure function object in generator mode.
	<<SF circe1: execute tests>>=
	call test (sf_circe1_3, "sf_circe1_3", &
	"generator mode", &
	u, results)
	<<SF circe1: test declarations>>=
	public :: sf_circe1_3
	<<SF circe1: tests>>=
	subroutine sf_circe1_3 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(rng_factory_t), allocatable :: rng_factory
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, x_free

	write (u, "(A)") "* Test output: sf_circe1_3"
	write (u, "(A)") "* Purpose: initialize and fill &
	&circe1 structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_qed_test ()
	call flv(1)%init (ELECTRON, model)
	call flv(2)%init (-ELECTRON, model)
	pdg_in(1) = ELECTRON
	pdg_in(2) = -ELECTRON

	call reset_interaction_counter ()

	allocate (circe1_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)
	select type (data)
	type is (circe1_data_t)
	call data%init (model, pdg_in, &
	sqrts = 500._default, &
	eps = 1e-6_default, &
	out_photon = [.false., .false.], &
	ver = 0, &
	rev = 0, &
	acc = "SBAND", &
	chat = 0, &
	with_radiation = .true.)
	call data%set_generator_mode (rng_factory)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])
	select type (sf_int)
	type is (circe1_t)
	call sf_int%rng_obj%rng%init (3)
	end select

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Generate x"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 0
	x_free = 1
	call sf_int%generate_free (r, rb, x_free)
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_circe1_3

	@ %def sf_circe1_3
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2}

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

	module sf_circe2

	<<Use kinds>>
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_19
	use numeric_utils
	use diagnostics
	use os_interface
	use physics_defs, only: PHOTON, ELECTRON
	use lorentz
	use rng_base
	use selectors
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base
	use circe2, circe2_rng_t => rng_type !NODEP!

	<<Standard module head>>

	<<SF circe2: public>>

	<<SF circe2: types>>

	contains

	<<SF circe2: procedures>>

	end module sf_circe2
	@ %def sf_circe2
	@
	\subsection{Physics}
	[[CIRCE2]] describes photon spectra
	Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has
	a single structure function for both beams (which makes sense since it
	has to be switched on or off for both beams simultaneously).


	\subsection{The CIRCE2 data block}
	The CIRCE2 parameters are: file and collider specification, incoming
	(= outgoing) particles. The luminosity is returned by [[circe2_luminosity]].
	<<SF circe2: public>>=
	public :: circe2_data_t
	<<SF circe2: types>>=
	type, extends (sf_data_t) :: circe2_data_t
	private
	class(model_data_t), pointer :: model => null ()
	type(flavor_t), dimension(2) :: flv_in
	integer, dimension(2) :: pdg_in
	real(default) :: sqrts = 0
	logical :: polarized = .false.
	logical :: beams_polarized = .false.
	class(rng_factory_t), allocatable :: rng_factory
	type(string_t) :: filename
	type(string_t) :: file
	type(string_t) :: design
	real(default) :: lumi = 0
	real(default), dimension(4) :: lumi_hel_frac = 0
	integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1]
	integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1]
	integer :: error = 1
	contains
	<<SF circe2: circe2 data: TBP>>
	end type circe2_data_t

	@ %def circe2_data_t
	<<SF circe2: types>>=
	type(circe2_state) :: circe2_global_state

	@
	<<SF circe2: circe2 data: TBP>>=
	procedure :: init => circe2_data_init
	<<SF circe2: procedures>>=
	subroutine circe2_data_init (data, os_data, model, pdg_in, &
	sqrts, polarized, beam_pol, file, design)
	class(circe2_data_t), intent(out) :: data
	type(os_data_t), intent(in) :: os_data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), dimension(2), intent(in) :: pdg_in
	real(default), intent(in) :: sqrts
	logical, intent(in) :: polarized, beam_pol
	type(string_t), intent(in) :: file, design
	integer :: h
	data%model => model
	- if (any (pdg_array_get_length (pdg_in) /= 1)) then
	+ if (any (pdg_in%get_length () /= 1)) then
	call msg_fatal ("CIRCE2: incoming beam particles must be unique")
	end if
	- call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model)
	- call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model)
	+ call data%flv_in(1)%init (pdg_in(1)%get (1), model)
	+ call data%flv_in(2)%init (pdg_in(2)%get (1), model)
	data%pdg_in = data%flv_in%get_pdg ()
	data%sqrts = sqrts
	data%polarized = polarized
	data%beams_polarized = beam_pol
	data%filename = file
	data%design = design
	call data%check_file (os_data)
	call circe2_load (circe2_global_state, trim (char(data%file)), &
	trim (char(data%design)), data%sqrts, data%error)
	call data%check ()
	data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0])
	if (vanishes (data%lumi)) then
	call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.")
	end if
	if (data%polarized) then
	do h = 1, 4
	data%lumi_hel_frac(h) = &
	circe2_luminosity (circe2_global_state, data%pdg_in, &
	[data%h1(h), data%h2(h)]) &
	/ data%lumi
	end do
	end if
	end subroutine circe2_data_init

	@ %def circe2_data_init
	@ Activate the generator mode. We import a RNG factory into the data
	type, which can then spawn RNG generator objects.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: set_generator_mode => circe2_data_set_generator_mode
	<<SF circe2: procedures>>=
	subroutine circe2_data_set_generator_mode (data, rng_factory)
	class(circe2_data_t), intent(inout) :: data
	class(rng_factory_t), intent(inout), allocatable :: rng_factory
	call move_alloc (from = rng_factory, to = data%rng_factory)
	end subroutine circe2_data_set_generator_mode

	@ %def circe2_data_set_generator_mode
	@ Check whether the requested data file is in the system directory or
	in the current directory.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: check_file => circe2_check_file
	<<SF circe2: procedures>>=
	subroutine circe2_check_file (data, os_data)
	class(circe2_data_t), intent(inout) :: data
	type(os_data_t), intent(in) :: os_data
	logical :: exist
	type(string_t) :: file
	file = data%filename
	if (file == "") &
	call msg_fatal ("CIRCE2: $circe2_file is not set")
	inquire (file = char (file), exist = exist)
	if (exist) then
	data%file = file
	else
	file = os_data%whizard_circe2path // "/" // data%filename
	inquire (file = char (file), exist = exist)
	if (exist) then
	data%file = file
	else
	call msg_fatal ("CIRCE2: data file '" // char (data%filename) &
	// "' not found")
	end if
	end if
	end subroutine circe2_check_file

	@ %def circe2_check_file
	@ Handle error conditions.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: check => circe2_data_check
	<<SF circe2: procedures>>=
	subroutine circe2_data_check (data)
	class(circe2_data_t), intent(in) :: data
	type(flavor_t) :: flv_photon, flv_electron
	call flv_photon%init (PHOTON, data%model)
	if (.not. flv_photon%is_defined ()) then
	call msg_fatal ("CIRCE2: model must contain photon")
	end if
	call flv_electron%init (ELECTRON, data%model)
	if (.not. flv_electron%is_defined ()) then
	call msg_fatal ("CIRCE2: model must contain electron")
	end if
	if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) &
	then
	call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions")
	end if
	select case (data%error)
	case (-1)
	call msg_fatal ("CIRCE2: data file not found.")
	case (-2)
	call msg_fatal ("CIRCE2: beam setup does not match data file.")
	case (-3)
	call msg_fatal ("CIRCE2: invalid format of data file.")
	case (-4)
	call msg_fatal ("CIRCE2: data file too large.")
	end select
	end subroutine circe2_data_check

	@ %def circe2_data_check
	@ Output
	<<SF circe2: circe2 data: TBP>>=
	procedure :: write => circe2_data_write
	<<SF circe2: procedures>>=
	subroutine circe2_data_write (data, unit, verbose)
	class(circe2_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u, h
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	u = given_output_unit (unit)
	write (u, "(1x,A)") "CIRCE2 data:"
	write (u, "(3x,A,A)") "file = ", char(data%filename)
	write (u, "(3x,A,A)") "design = ", char(data%design)
	write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts
	write (u, "(3x,A,A,A,A)") "prt_in = ", &
	char (data%flv_in(1)%get_name ()), &
	", ", char (data%flv_in(2)%get_name ())
	write (u, "(3x,A,L1)") "polarized = ", data%polarized
	write (u, "(3x,A,L1)") "beams pol. = ", data%beams_polarized
	write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi
	if (data%polarized) then
	do h = 1, 4
	write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") &
	data%h1(h), data%h2(h)
	write (u, "(6x, " // FMT_19 // ")") data%lumi_hel_frac(h)
	end do
	end if
	if (verb) then
	call data%rng_factory%write (u)
	end if
	end subroutine circe2_data_write

	@ %def circe2_data_write
	@ This is always in generator mode.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: is_generator => circe2_data_is_generator
	<<SF circe2: procedures>>=
	function circe2_data_is_generator (data) result (flag)
	class(circe2_data_t), intent(in) :: data
	logical :: flag
	flag = .true.
	end function circe2_data_is_generator

	@ %def circe2_data_is_generator
	@ The number of parameters is two, collinear splitting for
	the two beams.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: get_n_par => circe2_data_get_n_par
	<<SF circe2: procedures>>=
	function circe2_data_get_n_par (data) result (n)
	class(circe2_data_t), intent(in) :: data
	integer :: n
	n = 2
	end function circe2_data_get_n_par

	@ %def circe2_data_get_n_par
	@ Return the outgoing particles PDG codes. They are equal to the
	incoming ones.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: get_pdg_out => circe2_data_get_pdg_out
	<<SF circe2: procedures>>=
	subroutine circe2_data_get_pdg_out (data, pdg_out)
	class(circe2_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer :: i, n
	n = 2
	do i = 1, n
	pdg_out(i) = data%pdg_in(i)
	end do
	end subroutine circe2_data_get_pdg_out

	@ %def circe2_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: allocate_sf_int => circe2_data_allocate_sf_int
	<<SF circe2: procedures>>=
	subroutine circe2_data_allocate_sf_int (data, sf_int)
	class(circe2_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (circe2_t :: sf_int)
	end subroutine circe2_data_allocate_sf_int

	@ %def circe2_data_allocate_sf_int
	@ Return the beam file.
	<<SF circe2: circe2 data: TBP>>=
	procedure :: get_beam_file => circe2_data_get_beam_file
	<<SF circe2: procedures>>=
	function circe2_data_get_beam_file (data) result (file)
	class(circe2_data_t), intent(in) :: data
	type(string_t) :: file
	file = "CIRCE2: " // data%filename
	end function circe2_data_get_beam_file

	@ %def circe2_data_get_beam_file
	@
	\subsection{Random Number Generator for CIRCE}
	The CIRCE implementation now supports a generic random-number
	generator object that allows for a local state as a component. To
	support this, we must extend the abstract type provided by CIRCE and
	delegate the generator call to the (also abstract) RNG used by WHIZARD.
	<<SF circe2: types>>=
	type, extends (circe2_rng_t) :: rng_obj_t
	class(rng_t), allocatable :: rng
	contains
	procedure :: generate => rng_obj_generate
	end type rng_obj_t

	@ %def rng_obj_t
	<<SF circe2: procedures>>=
	subroutine rng_obj_generate (rng_obj, u)
	class(rng_obj_t), intent(inout) :: rng_obj
	real(default), intent(out) :: u
	real(default) :: x
	call rng_obj%rng%generate (x)
	u = x
	end subroutine rng_obj_generate

	@ %def rng_obj_generate
	@
	\subsection{The CIRCE2 object}
	For CIRCE2 spectra it does not make sense to describe the state matrix
	as a radiation interaction, even if photons originate from laser
	backscattering. Instead, it is a $2\to 2$ interaction where the
	incoming particles are identical to the outgoing ones.

	The current implementation of CIRCE2 does support polarization and
	classical correlations, but no entanglement, so the density matrix of
	the outgoing particles is diagonal. The incoming particles are
	unpolarized (user-defined polarization for beams is meaningless, since
	polarization is described by the data file). The outgoing particles
	are polarized or polarization-averaged, depending on user request.

	When assigning matrix elements, we scan the previously initialized
	state matrix. For each entry, we extract helicity and call the
	structure function. In the unpolarized case, the helicity is
	undefined and replaced by value zero. In the polarized case, there
	are four entries. If the generator is used, only one entry is nonzero
	in each call. Which one, is determined by comparing with a previously
	(randomly, distributed by relative luminosity) selected pair of
	helicities.
	<<SF circe2: public>>=
	public :: circe2_t
	<<SF circe2: types>>=
	type, extends (sf_int_t) :: circe2_t
	type(circe2_data_t), pointer :: data => null ()
	type(rng_obj_t) :: rng_obj
	type(selector_t) :: selector
	integer :: h_sel = 0
	contains
	<<SF circe2: circe2: TBP>>
	end type circe2_t

	@ %def circe2_t
	@ Type string: show file and design of [[CIRCE2]] structure function.
	<<SF circe2: circe2: TBP>>=
	procedure :: type_string => circe2_type_string
	<<SF circe2: procedures>>=
	function circe2_type_string (object) result (string)
	class(circe2_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "CIRCE2: " // object%data%design
	else
	string = "CIRCE2: [undefined]"
	end if
	end function circe2_type_string

	@ %def circe2_type_string
	@
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF circe2: circe2: TBP>>=
	procedure :: write => circe2_write
	<<SF circe2: procedures>>=
	subroutine circe2_write (object, unit, testflag)
	class(circe2_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "CIRCE2 data: [undefined]"
	end if
	end subroutine circe2_write

	@ %def circe2_write
	@
	<<SF circe2: circe2: TBP>>=
	procedure :: init => circe2_init
	<<SF circe2: procedures>>=
	subroutine circe2_init (sf_int, data)
	class(circe2_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	logical, dimension(4) :: mask_h
	real(default), dimension(2) :: m2_array
	real(default), dimension(0) :: null_array
	type(quantum_numbers_mask_t), dimension(4) :: mask
	type(quantum_numbers_t), dimension(4) :: qn
	type(helicity_t) :: hel
	type(color_t) :: col0
	integer :: h
	select type (data)
	type is (circe2_data_t)
	if (data%polarized .and. data%beams_polarized) then
	call msg_fatal ("CIRCE2: Beam polarization can't be set &
	&for polarized data file")
	else if (data%beams_polarized) then
	call msg_warning ("CIRCE2: User-defined beam polarization set &
	&for unpolarized CIRCE2 data file")
	end if
	mask_h(1:2) = .not. data%beams_polarized
	mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized)
	mask = quantum_numbers_mask (.false., .false., mask_h)
	m2_array(:) = (data%flv_in(:)%get_mass ())**2
	call sf_int%base_init (mask, m2_array, null_array, m2_array)
	sf_int%data => data
	if (data%polarized) then
	if (vanishes (sum (data%lumi_hel_frac)) .or. &
	any (data%lumi_hel_frac < 0)) then
	call msg_fatal ("CIRCE2: Helicity-dependent lumi " &
	// "fractions all vanish or", &
	[var_str ("are negative: Please inspect the " &
	// "CIRCE2 file or "), &
	var_str ("switch off the polarized" // &
	" option for CIRCE2.")])
	else
	call sf_int%selector%init (data%lumi_hel_frac)
	end if
	end if
	call col0%init ()
	if (data%beams_polarized) then
	do h = 1, 4
	call hel%init (data%h1(h))
	call qn(1)%init &
	(flv = data%flv_in(1), col = col0, hel = hel)
	call qn(3)%init &
	(flv = data%flv_in(1), col = col0, hel = hel)
	call hel%init (data%h2(h))
	call qn(2)%init &
	(flv = data%flv_in(2), col = col0, hel = hel)
	call qn(4)%init &
	(flv = data%flv_in(2), col = col0, hel = hel)
	call sf_int%add_state (qn)
	end do
	else if (data%polarized) then
	call qn(1)%init (flv = data%flv_in(1), col = col0)
	call qn(2)%init (flv = data%flv_in(2), col = col0)
	do h = 1, 4
	call hel%init (data%h1(h))
	call qn(3)%init &
	(flv = data%flv_in(1), col = col0, hel = hel)
	call hel%init (data%h2(h))
	call qn(4)%init &
	(flv = data%flv_in(2), col = col0, hel = hel)
	call sf_int%add_state (qn)
	end do
	else
	call qn(1)%init (flv = data%flv_in(1), col = col0)
	call qn(2)%init (flv = data%flv_in(2), col = col0)
	call qn(3)%init (flv = data%flv_in(1), col = col0)
	call qn(4)%init (flv = data%flv_in(2), col = col0)
	call sf_int%add_state (qn)
	end if
	call sf_int%freeze ()
	call sf_int%set_incoming ([1,2])
	call sf_int%set_outgoing ([3,4])
	call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
	sf_int%status = SF_INITIAL
	end select
	end subroutine circe2_init

	@ %def circe2_init
	@
	\subsection{Kinematics}
	Refer to the [[data]] component.
	<<SF circe2: circe2: TBP>>=
	procedure :: is_generator => circe2_is_generator
	<<SF circe2: procedures>>=
	function circe2_is_generator (sf_int) result (flag)
	class(circe2_t), intent(in) :: sf_int
	logical :: flag
	flag = sf_int%data%is_generator ()
	end function circe2_is_generator

	@ %def circe2_is_generator
	@ Generate free parameters. We first select a helicity, which we have
	to store, then generate $x$ values for that helicity.
	<<SF circe2: circe2: TBP>>=
	procedure :: generate_free => circe2_generate_whizard_free
	<<SF circe2: procedures>>=
	subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free)
	class(circe2_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: r, rb
	real(default), intent(inout) :: x_free
	integer :: h_sel
	if (sf_int%data%polarized) then
	call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel)
	else
	h_sel = 0
	end if
	sf_int%h_sel = h_sel
	call circe2_generate_whizard (r, sf_int%data%pdg_in, &
	[sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], &
	sf_int%rng_obj)
	rb = 1 - r
	x_free = x_free * product (r)
	end subroutine circe2_generate_whizard_free

	@ %def circe2_generate_whizard_free
	@ Generator mode: call the CIRCE2 generator for the given particles
	and helicities. (For unpolarized generation, helicities are zero.)
	<<SF circe2: procedures>>=
	subroutine circe2_generate_whizard (x, pdg, hel, rng_obj)
	real(default), dimension(2), intent(out) :: x
	integer, dimension(2), intent(in) :: pdg
	integer, dimension(2), intent(in) :: hel
	class(rng_obj_t), intent(inout) :: rng_obj
	call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel)
	end subroutine circe2_generate_whizard

	@ %def circe2_generate_whizard
	@ Set kinematics. Trivial here.
	<<SF circe2: circe2: TBP>>=
	procedure :: complete_kinematics => circe2_complete_kinematics
	<<SF circe2: procedures>>=
	subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(circe2_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	call msg_fatal ("CIRCE2: map flag not supported")
	else
	x = r
	xb= rb
	f = 1
	end if
	call sf_int%reduce_momenta (x)
	end subroutine circe2_complete_kinematics

	@ %def circe2_complete_kinematics
	@ Compute inverse kinematics.
	<<SF circe2: circe2: TBP>>=
	procedure :: inverse_kinematics => circe2_inverse_kinematics
	<<SF circe2: procedures>>=
	subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(circe2_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	call msg_fatal ("CIRCE2: map flag not supported")
	else
	r = x
	rb= xb
	f = 1
	end if
	if (set_mom) then
	call sf_int%reduce_momenta (x)
	end if
	end subroutine circe2_inverse_kinematics

	@ %def circe2_inverse_kinematics
	@
	\subsection{CIRCE2 application}
	This function works on both beams. In polarized mode, we set only the
	selected helicity. In unpolarized mode,
	the interaction has only one entry, and the factor is unity.
	<<SF circe2: circe2: TBP>>=
	procedure :: apply => circe2_apply
	<<SF circe2: procedures>>=
	subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(circe2_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	complex(default) :: f
	associate (data => sf_int%data)
	f = 1
	if (data%beams_polarized) then
	call sf_int%set_matrix_element (f)
	else if (data%polarized) then
	call sf_int%set_matrix_element (sf_int%h_sel, f)
	else
	call sf_int%set_matrix_element (1, f)
	end if
	end associate
	sf_int%status = SF_EVALUATED
	end subroutine circe2_apply

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

	module sf_circe2_ut
	use unit_tests
	use sf_circe2_uti

	<<Standard module head>>

	<<SF circe2: public test>>

	contains

	<<SF circe2: test driver>>

	end module sf_circe2_ut
	@ %def sf_circe2_ut
	@
	<<[[sf_circe2_uti.f90]]>>=
	<<File header>>

	module sf_circe2_uti

	<<Use kinds>>
	<<Use strings>>
	use os_interface
	use physics_defs, only: PHOTON
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use rng_base
	use sf_aux
	use sf_base

	use sf_circe2

	use rng_base_ut, only: rng_test_factory_t

	<<Standard module head>>

	<<SF circe2: test declarations>>

	contains

	<<SF circe2: tests>>

	end module sf_circe2_uti
	@ %def sf_circe2_ut
	@ API: driver for the unit tests below.
	<<SF circe2: public test>>=
	public :: sf_circe2_test
	<<SF circe2: test driver>>=
	subroutine sf_circe2_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF circe2: execute tests>>
	end subroutine sf_circe2_test

	@ %def sf_circe2_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF circe2: execute tests>>=
	call test (sf_circe2_1, "sf_circe2_1", &
	"structure function configuration", &
	u, results)
	<<SF circe2: test declarations>>=
	public :: sf_circe2_1
	<<SF circe2: tests>>=
	subroutine sf_circe2_1 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(2) :: pdg_out
	integer, dimension(:), allocatable :: pdg1, pdg2
	class(sf_data_t), allocatable :: data
	class(rng_factory_t), allocatable :: rng_factory

	write (u, "(A)") "* Test output: sf_circe2_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&CIRCE structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call os_data%init ()
	call model%init_qed_test ()
	pdg_in(1) = PHOTON
	pdg_in(2) = PHOTON

	allocate (circe2_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)

	write (u, "(A)")
	write (u, "(A)") "* Initialize (unpolarized)"
	write (u, "(A)")

	select type (data)
	type is (circe2_data_t)
	call data%init (os_data, model, pdg_in, &
	sqrts = 500._default, &
	polarized = .false., &
	beam_pol = .false., &
	file = var_str ("teslagg_500_polavg.circe"), &
	design = var_str ("TESLA/GG"))
	call data%set_generator_mode (rng_factory)
	end select

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

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	pdg2 = pdg_out(2)
	write (u, "(2x,99(1x,I0))") pdg1, pdg2

	write (u, "(A)")
	write (u, "(A)") "* Initialize (polarized)"
	write (u, "(A)")

	allocate (rng_test_factory_t :: rng_factory)

	select type (data)
	type is (circe2_data_t)
	call data%init (os_data, model, pdg_in, &
	sqrts = 500._default, &
	polarized = .true., &
	beam_pol = .false., &
	file = var_str ("teslagg_500.circe"), &
	design = var_str ("TESLA/GG"))
	call data%set_generator_mode (rng_factory)
	end select

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

	call model%final ()

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

	end subroutine sf_circe2_1

	@ %def sf_circe2_1
	@
	\subsubsection{Generator mode, unpolarized}
	Construct and evaluate a structure function object in generator mode.
	<<SF circe2: execute tests>>=
	call test (sf_circe2_2, "sf_circe2_2", &
	"generator, unpolarized", &
	u, results)
	<<SF circe2: test declarations>>=
	public :: sf_circe2_2
	<<SF circe2: tests>>=
	subroutine sf_circe2_2 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(rng_factory_t), allocatable :: rng_factory
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, x_free

	write (u, "(A)") "* Test output: sf_circe2_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&circe2 structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call os_data%init ()
	call model%init_qed_test ()
	call flv(1)%init (PHOTON, model)
	call flv(2)%init (PHOTON, model)
	pdg_in(1) = PHOTON
	pdg_in(2) = PHOTON

	call reset_interaction_counter ()

	allocate (circe2_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)
	select type (data)
	type is (circe2_data_t)
	call data%init (os_data, model, pdg_in, &
	sqrts = 500._default, &
	polarized = .false., &
	beam_pol = .false., &
	file = var_str ("teslagg_500_polavg.circe"), &
	design = var_str ("TESLA/GG"))
	call data%set_generator_mode (rng_factory)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])
	select type (sf_int)
	type is (circe2_t)
	call sf_int%rng_obj%rng%init (3)
	end select

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Generate x"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 0
	x_free = 1
	call sf_int%generate_free (r, rb, x_free)
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_circe2_2

	@ %def sf_circe2_2
	@
	\subsubsection{Generator mode, polarized}
	Construct and evaluate a structure function object in generator mode.
	<<SF circe2: execute tests>>=
	call test (sf_circe2_3, "sf_circe2_3", &
	"generator, polarized", &
	u, results)
	<<SF circe2: test declarations>>=
	public :: sf_circe2_3
	<<SF circe2: tests>>=
	subroutine sf_circe2_3 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(flavor_t), dimension(2) :: flv
	type(pdg_array_t), dimension(2) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(rng_factory_t), allocatable :: rng_factory
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k1, k2
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f, x_free

	write (u, "(A)") "* Test output: sf_circe2_3"
	write (u, "(A)") "* Purpose: initialize and fill &
	&circe2 structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call os_data%init ()
	call model%init_qed_test ()
	call flv(1)%init (PHOTON, model)
	call flv(2)%init (PHOTON, model)
	pdg_in(1) = PHOTON
	pdg_in(2) = PHOTON

	call reset_interaction_counter ()

	allocate (circe2_data_t :: data)
	allocate (rng_test_factory_t :: rng_factory)
	select type (data)
	type is (circe2_data_t)
	call data%init (os_data, model, pdg_in, &
	sqrts = 500._default, &
	polarized = .true., &
	beam_pol = .false., &
	file = var_str ("teslagg_500.circe"), &
	design = var_str ("TESLA/GG"))
	call data%set_generator_mode (rng_factory)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1,2])
	select type (sf_int)
	type is (circe2_t)
	call sf_int%rng_obj%rng%init (3)
	end select

	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 250
	k1 = vector4_moving (E, sqrt (E2 - flv(1)%get_mass ()2), 3)
	k2 = vector4_moving (E,-sqrt (E2 - flv(2)%get_mass ()2), 3)
	call vector4_write (k1, u)
	call vector4_write (k2, u)
	call sf_int%seed_kinematics ([k1, k2])

	write (u, "(A)")
	write (u, "(A)") "* Generate x"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0
	rb = 0
	x_free = 1
	call sf_int%generate_free (r, rb, x_free)
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f
	write (u, "(A,9(1x,F10.7))") "xf=", x_free

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

	call sf_int%apply (scale = 0._default)
	call sf_int%write (u)

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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_circe2_3

	@ %def sf_circe2_3
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{HOPPET interface}
	Interface to the HOPPET wrapper necessary to perform
	the LO vs. NLO matching of processes containing an initial
	b quark.
	<<[[hoppet_interface.f90]]>>=
	<<File header>>

	module hoppet_interface
	use lhapdf !NODEP!

	<<Standard module head>>

	public :: hoppet_init, hoppet_eval

	contains

	subroutine hoppet_init (pdf_builtin, pdf, pdf_id)
	logical, intent(in) :: pdf_builtin
	type(lhapdf_pdf_t), intent(inout), optional :: pdf
	integer, intent(in), optional :: pdf_id
	external InitForWhizard
	call InitForWhizard (pdf_builtin, pdf, pdf_id)
	end subroutine hoppet_init

	subroutine hoppet_eval (x, q, f)
	double precision, intent(in) :: x, q
	double precision, intent(out) :: f(-6:6)
	external EvalForWhizard
	call EvalForWhizard (x, q, f)
	end subroutine hoppet_eval

	end module hoppet_interface
	@ %def hoppet_interface
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{Builtin PDF sets}
	For convenience in order not to depend on the external package LHAPDF,
	we ship some PDFs with WHIZARD.
	@
	\subsection{The module}
	<<[[sf_pdf_builtin.f90]]>>=
	<<File header>>

	module sf_pdf_builtin

	<<Use kinds>>
	use kinds, only: double
	<<Use strings>>
	use io_units
	use format_defs, only: FMT_17
	use diagnostics
	use os_interface
	use physics_defs, only: PROTON, PHOTON, GLUON
	use physics_defs, only: HADRON_REMNANT_SINGLET
	use physics_defs, only: HADRON_REMNANT_TRIPLET
	use physics_defs, only: HADRON_REMNANT_OCTET
	use sm_qcd
	use lorentz
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base
	use pdf_builtin !NODEP!
	use hoppet_interface

	<<Standard module head>>

	<<SF pdf builtin: public>>

	<<SF pdf builtin: types>>

	<<SF pdf builtin: parameters>>

	contains

	<<SF pdf builtin: procedures>>

	end module sf_pdf_builtin
	@ %def sf_pdf_builtin
	@
	\subsection{Codes for default PDF sets}
	<<SF pdf builtin: parameters>>=
	character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L"
	! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION = "NONE"
	! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp"
	@ %def PDF_BUILTIN_DEFAULT_SET
	@
	\subsection{The PDF builtin data block}
	The data block holds the incoming flavor (which has to be proton,
	pion, or photon), the corresponding pointer to the global access data
	(1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
	bounds as returned by LHAPDF for the specified set, and a mask that
	determines which partons will be actually in use.
	<<SF pdf builtin: public>>=
	public :: pdf_builtin_data_t
	<<SF pdf builtin: types>>=
	type, extends (sf_data_t) :: pdf_builtin_data_t
	private
	integer :: id = -1
	type (string_t) :: name
	class(model_data_t), pointer :: model => null ()
	type(flavor_t) :: flv_in
	logical :: invert
	logical :: has_photon
	logical :: photon
	logical, dimension(-6:6) :: mask
	logical :: mask_photon
	logical :: hoppet_b_matching = .false.
	contains
	<<SF pdf builtin: pdf builtin data: TBP>>
	end type pdf_builtin_data_t

	@ %def pdf_builtin_data_t
	@ Generate PDF data and initialize the requested set. Pion and photon PDFs
	are disabled at the moment until we ship appropiate structure functions.
	needed.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: init => pdf_builtin_data_init
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_data_init (data, &
	model, pdg_in, name, path, hoppet_b_matching)
	class(pdf_builtin_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	type(string_t), intent(in) :: name
	type(string_t), intent(in) :: path
	logical, intent(in), optional :: hoppet_b_matching
	data%model => model
	- if (pdg_array_get_length (pdg_in) /= 1) &
	+ if (pdg_in%get_length () /= 1) &
	call msg_fatal ("PDF: incoming particle must be unique")
	- call data%flv_in%init (pdg_array_get (pdg_in, 1), model)
	+ call data%flv_in%init (pdg_in%get (1), model)
	data%mask = .true.
	data%mask_photon = .true.
	- select case (pdg_array_get (pdg_in, 1))
	+ select case (pdg_in%get (1))
	case (PROTON)
	data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
	data%invert = .false.
	data%photon = .false.
	case (-PROTON)
	data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
	data%invert = .true.
	data%photon = .false.
	! case (PIPLUS)
	! data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
	! data%invert = .false.
	! data%photon = .false.
	! case (-PIPLUS)
	! data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
	! data%invert = .true.
	! data%photon = .false.
	! case (PHOTON)
	! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON)
	! data%invert = .false.
	! data%photon = .true.
	case default
	call msg_fatal ("PDF: " &
	// "incoming particle must either proton or antiproton.")
	return
	end select
	data%name = name
	data%id = pdf_get_id (data%name)
	if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name))
	data%has_photon = pdf_provides_photon (data%id)
	if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching
	call pdf_init (data%id, path)
	if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id)
	end subroutine pdf_builtin_data_init

	@ %def pdf_builtin_data_init
	@ Enable/disable partons explicitly. If a mask entry is true,
	applying the PDF will generate the corresponding flavor on output.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: set_mask => pdf_builtin_data_set_mask
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_data_set_mask (data, mask)
	class(pdf_builtin_data_t), intent(inout) :: data
	logical, dimension(-6:6), intent(in) :: mask
	data%mask = mask
	end subroutine pdf_builtin_data_set_mask

	@ %def pdf_builtin_data_set_mask
	@ Output.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: write => pdf_builtin_data_write
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_data_write (data, unit, verbose)
	class(pdf_builtin_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "PDF builtin data:"
	if (data%id < 0) then
	write (u, "(3x,A)") "[undefined]"
	return
	end if
	write (u, "(3x,A)", advance="no") "flavor = "
	call data%flv_in%write (u); write (u, *)
	write (u, "(3x,A,A)") "name = ", char (data%name)
	write (u, "(3x,A,L1)") "invert = ", data%invert
	write (u, "(3x,A,L1)") "has photon = ", data%has_photon
	write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
	"mask =", &
	data%mask(-6:-1), "", data%mask(0), "", data%mask(1:6)
	write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon
	write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching
	end subroutine pdf_builtin_data_write

	@ %def pdf_builtin_data_write
	@ The number of parameters is one. We do not generate transverse momentum.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: get_n_par => pdf_builtin_data_get_n_par
	<<SF pdf builtin: procedures>>=
	function pdf_builtin_data_get_n_par (data) result (n)
	class(pdf_builtin_data_t), intent(in) :: data
	integer :: n
	n = 1
	end function pdf_builtin_data_get_n_par

	@ %def pdf_builtin_data_get_n_par
	@ Return the outgoing particle PDG codes. This is based on the mask.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_data_get_pdg_out (data, pdg_out)
	class(pdf_builtin_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	integer :: n, np, i
	n = count (data%mask)
	np = 0; if (data%has_photon .and. data%mask_photon) np = 1
	allocate (pdg1 (n + np))
	pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
	if (np == 1) pdg1(n+np) = PHOTON
	pdg_out(1) = pdg1
	end subroutine pdf_builtin_data_get_pdg_out

	@ %def pdf_builtin_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_data_allocate_sf_int (data, sf_int)
	class(pdf_builtin_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (pdf_builtin_t :: sf_int)
	end subroutine pdf_builtin_data_allocate_sf_int

	@ %def pdf_builtin_data_allocate_sf_int
	@ Return the numerical PDF set index.
	<<SF pdf builtin: pdf builtin data: TBP>>=
	procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set
	<<SF pdf builtin: procedures>>=
	elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set)
	class(pdf_builtin_data_t), intent(in) :: data
	integer :: pdf_set
	pdf_set = data%id
	end function pdf_builtin_data_get_pdf_set

	@ %def pdf_builtin_data_get_pdf_set
	@
	\subsection{The PDF object}
	The PDF $1\to 2$ interaction which describes
	the splitting of an (anti)proton into a parton and a beam remnant. We
	stay in the strict forward-splitting limit, but allow some invariant
	mass for the beam remnant such that the outgoing parton is exactly
	massless. For a real event, we would replace this by a parton
	cascade, where the outgoing partons have virtuality as dictated by
	parton-shower kinematics, and transverse momentum is generated.

	The PDF application is a $1\to 2$ splitting process, where the
	particles are ordered as (hadron, remnant, parton).

	Polarization is ignored completely. The beam particle is colorless,
	while partons and beam remnant carry color. The remnant gets a
	special flavor code.
	<<SF pdf builtin: public>>=
	public :: pdf_builtin_t
	<<SF pdf builtin: types>>=
	type, extends (sf_int_t) :: pdf_builtin_t
	type(pdf_builtin_data_t), pointer :: data => null ()
	real(default) :: x = 0
	real(default) :: q = 0
	contains
	<<SF pdf builtin: pdf builtin: TBP>>
	end type pdf_builtin_t

	@ %def pdf_builtin_t
	@ Type string: display the chosen PDF set.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: type_string => pdf_builtin_type_string
	<<SF pdf builtin: procedures>>=
	function pdf_builtin_type_string (object) result (string)
	class(pdf_builtin_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "PDF builtin: " // object%data%name
	else
	string = "PDF builtin: [undefined]"
	end if
	end function pdf_builtin_type_string

	@ %def pdf_builtin_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: write => pdf_builtin_write
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_write (object, unit, testflag)
	class(pdf_builtin_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(1x,A)") "SF parameters:"
	write (u, "(3x,A," // FMT_17 // ")") "x =", object%x
	if (object%status >= SF_FAILED_EVALUATION) then
	write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q
	end if
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "PDF builtin data: [undefined]"
	end if
	end subroutine pdf_builtin_write

	@ %def pdf_builtin_write
	@ Initialize. We know that [[data]] will be of concrete type
	[[sf_test_data_t]], but we have to cast this explicitly.

	For this implementation, we set the incoming and outgoing masses equal
	to the physical particle mass, but keep the radiated mass zero.

	Optionally, we can provide minimum and maximum values for the momentum
	transfer.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: init => pdf_builtin_init
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_init (sf_int, data)
	class(pdf_builtin_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	type(flavor_t) :: flv, flv_remnant
	type(color_t) :: col0
	type(quantum_numbers_t), dimension(3) :: qn
	integer :: i
	select type (data)
	type is (pdf_builtin_data_t)
	mask = quantum_numbers_mask (.false., .false., .true.)
	call col0%init ()
	call sf_int%base_init (mask, [0._default], [0._default], [0._default])
	sf_int%data => data
	do i = -6, 6
	if (data%mask(i)) then
	call qn(1)%init (data%flv_in, col = col0)
	if (i == 0) then
	call flv%init (GLUON, data%model)
	call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
	else
	call flv%init (i, data%model)
	call flv_remnant%init &
	(sign (HADRON_REMNANT_TRIPLET, -i), data%model)
	end if
	call qn(2)%init ( &
	flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
	call qn(2)%tag_radiated ()
	call qn(3)%init ( &
	flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
	call sf_int%add_state (qn)
	end if
	end do
	if (data%has_photon .and. data%mask_photon) then
	call flv%init (PHOTON, data%model)
	call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
	call qn(2)%init (flv = flv_remnant, &
	col = color_from_flavor (flv_remnant, 1))
	call qn(2)%tag_radiated ()
	call qn(3)%init (flv = flv, &
	col = color_from_flavor (flv, 1, reverse = .true.))
	call sf_int%add_state (qn)
	end if
	call sf_int%freeze ()
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	sf_int%status = SF_INITIAL
	end select
	end subroutine pdf_builtin_init

	@ %def pdf_builtin_init
	@
	\subsection{Kinematics}
	Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ is trivial.

	If [[map]] is set, we are asked to provide an efficient mapping.
	For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: complete_kinematics => pdf_builtin_complete_kinematics
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(pdf_builtin_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	call msg_fatal ("PDF builtin: map flag not supported")
	else
	x(1) = r(1)
	xb(1)= rb(1)
	f = 1
	end if
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_DONE_KINEMATICS)
	sf_int%x = x(1)
	case (SF_FAILED_KINEMATICS)
	sf_int%x = 0
	f = 0
	end select
	end subroutine pdf_builtin_complete_kinematics

	@ %def pdf_builtin_complete_kinematics
	@ Overriding the default method: we compute the [[x]] value from the
	momentum configuration. In this specific case, we also set the
	internally stored $x$ value, so it can be used in the
	following routine.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: recover_x => pdf_builtin_recover_x
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free)
	class(pdf_builtin_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb, x_free)
	sf_int%x = x(1)
	end subroutine pdf_builtin_recover_x

	@ %def sf_pdf_builtin_recover_x
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(pdf_builtin_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	call msg_fatal ("PDF builtin: map flag not supported")
	else
	r(1) = x(1)
	rb(1)= xb(1)
	f = 1
	end if
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine pdf_builtin_inverse_kinematics

	@ %def pdf_builtin_inverse_kinematics
	@
	\subsection{Structure function}
	Once the scale is also known, we can actually call the PDF and
	set the values. Contrary to LHAPDF, the wrapper already takes care of
	adjusting to the $x$ and $Q$ bounds. Account for the Jacobian.

	The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values.
	The class [[rescale]] gives rescaling prescription for NLO convolution of the
	structure function in combination with [[i_sub]].
	<<SF pdf builtin: pdf builtin: TBP>>=
	procedure :: apply => pdf_builtin_apply
	<<SF pdf builtin: procedures>>=
	subroutine pdf_builtin_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(pdf_builtin_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default), dimension(-6:6) :: ff
	real(double), dimension(-6:6) :: ff_dbl
	real(default) :: x, fph
	real(double) :: xx, qq
	complex(default), dimension(:), allocatable :: fc
	integer :: i, j_sub, i_sub_opt
	logical :: negative_sf_opt
	i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
	negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
	associate (data => sf_int%data)
	sf_int%q = scale
	x = sf_int%x
	if (present (rescale)) call rescale%apply (x)
	if (debug2_active (D_BEAMS)) then
	call msg_debug2 (D_BEAMS, "pdf_builtin_apply")
	call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
	call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
	call msg_debug2 (D_BEAMS, "x: ", x)
	end if
	xx = x
	qq = scale
	if (data%invert) then
	if (data%has_photon) then
	call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph)
	else
	if (data%hoppet_b_matching) then
	call hoppet_eval (xx, qq, ff_dbl(6:-6:-1))
	ff = ff_dbl
	else
	call pdf_evolve (data%id, x, scale, ff(6:-6:-1))
	end if
	end if
	else
	if (data%has_photon) then
	call pdf_evolve (data%id, x, scale, ff, fph)
	else
	if (data%hoppet_b_matching) then
	call hoppet_eval (xx, qq, ff_dbl)
	ff = ff_dbl
	else
	call pdf_evolve (data%id, x, scale, ff)
	end if
	end if
	end if
	if (data%has_photon) then
	allocate (fc (count ([data%mask, data%mask_photon])))
	if (negative_sf_opt) then
	fc = pack ([ff, fph], [data%mask, data%mask_photon])
	else
	fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default)
	end if
	else
	allocate (fc (count (data%mask)))
	if (negative_sf_opt) then
	fc = pack (ff, data%mask)
	else
	fc = max( pack (ff, data%mask), 0._default)
	end if
	end if
	end associate
	if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
	call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
	sf_int%status = SF_EVALUATED
	end subroutine pdf_builtin_apply

	@ %def pdf_builtin_apply
	@
	\subsection{Strong Coupling}
	Since the PDF codes provide a function for computing the running
	$\alpha_s$ value, we make this available as an implementation of the
	abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
	<<SF pdf builtin: public>>=
	public :: alpha_qcd_pdf_builtin_t
	<<SF pdf builtin: types>>=
	type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t
	type(string_t) :: pdfset_name
	integer :: pdfset_id = -1
	contains
	<<SF pdf builtin: alpha qcd: TBP>>
	end type alpha_qcd_pdf_builtin_t

	@ %def alpha_qcd_pdf_builtin_t
	@ Output.
	<<SF pdf builtin: alpha qcd: TBP>>=
	procedure :: write => alpha_qcd_pdf_builtin_write
	<<SF pdf builtin: procedures>>=
	subroutine alpha_qcd_pdf_builtin_write (object, unit)
	class(alpha_qcd_pdf_builtin_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(3x,A)") "QCD parameters (pdf_builtin):"
	write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_name)
	write (u, "(5x,A,I0)") "PDF ID = ", object%pdfset_id
	end subroutine alpha_qcd_pdf_builtin_write

	@ %def alpha_qcd_pdf_builtin_write
	@ Calculation: the numeric ID selects the correct PDF set, which must
	be properly initialized.
	<<SF pdf builtin: alpha qcd: TBP>>=
	procedure :: get => alpha_qcd_pdf_builtin_get
	<<SF pdf builtin: procedures>>=
	function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha)
	class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd
	real(default), intent(in) :: scale
	real(default) :: alpha
	alpha = pdf_alphas (alpha_qcd%pdfset_id, scale)
	end function alpha_qcd_pdf_builtin_get

	@ %def alpha_qcd_pdf_builtin_get
	@
	Initialization. We need to access the global initialization status.
	<<SF pdf builtin: alpha qcd: TBP>>=
	procedure :: init => alpha_qcd_pdf_builtin_init
	<<SF pdf builtin: procedures>>=
	subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path)
	class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd
	type(string_t), intent(in) :: name
	type(string_t), intent(in) :: path
	alpha_qcd%pdfset_name = name
	alpha_qcd%pdfset_id = pdf_get_id (name)
	if (alpha_qcd%pdfset_id < 0) &
	call msg_fatal ("QCD parameter initialization: PDF set " &
	// char (name) // " is unknown")
	call pdf_init (alpha_qcd%pdfset_id, path)
	end subroutine alpha_qcd_pdf_builtin_init

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

	module sf_pdf_builtin_ut
	use unit_tests
	use sf_pdf_builtin_uti

	<<Standard module head>>

	<<SF pdf builtin: public test>>

	contains

	<<SF pdf builtin: test driver>>

	end module sf_pdf_builtin_ut
	@ %def sf_pdf_builtin_ut
	@
	<<[[sf_pdf_builtin_uti.f90]]>>=
	<<File header>>

	module sf_pdf_builtin_uti

	<<Use kinds>>
	<<Use strings>>
	use os_interface
	use physics_defs, only: PROTON
	use sm_qcd
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use sf_base

	use sf_pdf_builtin

	<<Standard module head>>

	<<SF pdf builtin: test declarations>>

	contains

	<<SF pdf builtin: tests>>

	end module sf_pdf_builtin_uti
	@ %def sf_pdf_builtin_ut
	@ API: driver for the unit tests below.
	<<SF pdf builtin: public test>>=
	public :: sf_pdf_builtin_test
	<<SF pdf builtin: test driver>>=
	subroutine sf_pdf_builtin_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF pdf builtin: execute tests>>
	end subroutine sf_pdf_builtin_test

	@ %def sf_pdf_builtin_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF pdf builtin: execute tests>>=
	call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", &
	"structure function configuration", &
	u, results)
	<<SF pdf builtin: test declarations>>=
	public :: sf_pdf_builtin_1
	<<SF pdf builtin: tests>>=
	subroutine sf_pdf_builtin_1 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data
	type(string_t) :: name

	write (u, "(A)") "* Test output: sf_pdf_builtin_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call os_data%init ()

	call model%init_sm_test ()
	pdg_in = PROTON

	allocate (pdf_builtin_data_t :: data)
	call data%write (u)

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

	name = "CTEQ6L"

	select type (data)
	type is (pdf_builtin_data_t)
	call data%init (model, pdg_in, name, &
	os_data%pdf_builtin_datapath)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_pdf_builtin_1

	@ %def sf_pdf_builtin_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the PDF builtin
	structure function.
	<<SF pdf builtin: execute tests>>=
	call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", &
	"structure function instance", &
	u, results)
	<<SF pdf builtin: test declarations>>=
	public :: sf_pdf_builtin_2
	<<SF pdf builtin: tests>>=
	subroutine sf_pdf_builtin_2 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(string_t) :: name
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_pdf_builtin_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call os_data%init ()
	call model%init_sm_test ()
	call flv%init (PROTON, model)
	pdg_in = PROTON

	call reset_interaction_counter ()

	name = "CTEQ6L"

	allocate (pdf_builtin_data_t :: data)
	select type (data)
	type is (pdf_builtin_data_t)
	call data%init (model, pdg_in, name, &
	os_data%pdf_builtin_datapath)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.5_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for Q = 100 GeV"
	write (u, "(A)")

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%apply (scale = 100._default)
	call sf_int%write (u)


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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_pdf_builtin_2

	@ %def sf_pdf_builtin_2
	@
	\subsubsection{Strong Coupling}
	Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
	type.
	<<SF pdf builtin: execute tests>>=
	call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", &
	"running alpha_s", &
	u, results)
	<<SF pdf builtin: test declarations>>=
	public :: sf_pdf_builtin_3
	<<SF pdf builtin: tests>>=
	subroutine sf_pdf_builtin_3 (u)
	integer, intent(in) :: u
	type(os_data_t) :: os_data
	type(qcd_t) :: qcd
	type(string_t) :: name

	write (u, "(A)") "* Test output: sf_pdf_builtin_3"
	write (u, "(A)") "* Purpose: initialize and evaluate alpha_s"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call os_data%init ()

	name = "CTEQ6L"

	write (u, "(A)") "* Initialize qcd object"
	write (u, "(A)")

	allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
	select type (alpha => qcd%alpha)
	type is (alpha_qcd_pdf_builtin_t)
	call alpha%init (name, os_data%pdf_builtin_datapath)
	end select
	call qcd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for Q = 100"
	write (u, "(A)")

	write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default)

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

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

	end subroutine sf_pdf_builtin_3

	@ %def sf_pdf_builtin_3
	@
	\clearpage
	%------------------------------------------------------------------------
	\section{LHAPDF}
	Parton distribution functions (PDFs) are available via an interface to
	the LHAPDF standard library.
	@
	\subsection{The module}
	<<[[sf_lhapdf.f90]]>>=
	<<File header>>

	module sf_lhapdf

	<<Use kinds>>
	<<Use strings>>
	use format_defs, only: FMT_17, FMT_19
	use io_units
	use system_dependencies, only: LHAPDF_PDFSETS_PATH
	use system_dependencies, only: LHAPDF5_AVAILABLE
	use system_dependencies, only: LHAPDF6_AVAILABLE
	use diagnostics
	use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON
	use physics_defs, only: HADRON_REMNANT_SINGLET
	use physics_defs, only: HADRON_REMNANT_TRIPLET
	use physics_defs, only: HADRON_REMNANT_OCTET
	use lorentz
	use sm_qcd
	use pdg_arrays
	use model_data
	use flavors
	use colors
	use quantum_numbers
	use state_matrices
	use polarizations
	use sf_base
	use lhapdf !NODEP!
	use hoppet_interface

	<<Standard module head>>

	<<SF lhapdf: public>>

	<<SF lhapdf: types>>

	<<SF lhapdf: parameters>>

	<<SF lhapdf: variables>>

	<<SF lhapdf: interfaces>>

	contains

	<<SF lhapdf: procedures>>

	end module sf_lhapdf
	@ %def sf_lhapdf
	@
	\subsection{Codes for default PDF sets}
	The default PDF for protons set is chosen to be CTEQ6ll (LO fit with
	LO $\alpha_s$).
	<<SF lhapdf: parameters>>=
	character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf"
	character(*), parameter :: LHAPDF5_DEFAULT_PION = "ABFKWPI.LHgrid"
	character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid"
	character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10"
	@ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION
	@ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON
	@
	\subsection{LHAPDF library interface}
	Here we specify explicit interfaces for all LHAPDF routines that we
	use below.
	<<SF lhapdf: interfaces>>=
	interface
	subroutine InitPDFsetM (set, file)
	integer, intent(in) :: set
	character(*), intent(in) :: file
	end subroutine InitPDFsetM
	end interface

	@ %def InitPDFsetM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine InitPDFM (set, mem)
	integer, intent(in) :: set, mem
	end subroutine InitPDFM
	end interface

	@ %def InitPDFM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine numberPDFM (set, n_members)
	integer, intent(in) :: set
	integer, intent(out) :: n_members
	end subroutine numberPDFM
	end interface

	@ %def numberPDFM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine evolvePDFM (set, x, q, ff)
	integer, intent(in) :: set
	double precision, intent(in) :: x, q
	double precision, dimension(-6:6), intent(out) :: ff
	end subroutine evolvePDFM
	end interface

	@ %def evolvePDFM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine evolvePDFphotonM (set, x, q, ff, fphot)
	integer, intent(in) :: set
	double precision, intent(in) :: x, q
	double precision, dimension(-6:6), intent(out) :: ff
	double precision, intent(out) :: fphot
	end subroutine evolvePDFphotonM
	end interface

	@ %def evolvePDFphotonM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine evolvePDFpM (set, x, q, s, scheme, ff)
	integer, intent(in) :: set
	double precision, intent(in) :: x, q, s
	integer, intent(in) :: scheme
	double precision, dimension(-6:6), intent(out) :: ff
	end subroutine evolvePDFpM
	end interface

	@ %def evolvePDFpM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine GetXminM (set, mem, xmin)
	integer, intent(in) :: set, mem
	double precision, intent(out) :: xmin
	end subroutine GetXminM
	end interface

	@ %def GetXminM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine GetXmaxM (set, mem, xmax)
	integer, intent(in) :: set, mem
	double precision, intent(out) :: xmax
	end subroutine GetXmaxM
	end interface

	@ %def GetXmaxM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine GetQ2minM (set, mem, q2min)
	integer, intent(in) :: set, mem
	double precision, intent(out) :: q2min
	end subroutine GetQ2minM
	end interface

	@ %def GetQ2minM
	<<SF lhapdf: interfaces>>=
	interface
	subroutine GetQ2maxM (set, mem, q2max)
	integer, intent(in) :: set, mem
	double precision, intent(out) :: q2max
	end subroutine GetQ2maxM
	end interface

	@ %def GetQ2maxM
	<<SF lhapdf: interfaces>>=
	interface
	function has_photon () result(flag)
	logical :: flag
	end function has_photon
	end interface

	@ %def has_photon
	@
	\subsection{The LHAPDF status}
	This type holds the initialization status of the LHAPDF system. Entry
	1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs.

	Since it is connected to the external LHAPDF library, this is a truly
	global object. We implement it as a a private module variable. To
	access it from elsewhere, the caller has to create and initialize an
	object of type [[lhapdf_status_t]], which acts as a proxy.
	<<SF lhapdf: types>>=
	type :: lhapdf_global_status_t
	private
	logical, dimension(3) :: initialized = .false.
	end type lhapdf_global_status_t

	@ %def lhapdf_global_status_t
	<<SF lhapdf: variables>>=
	type(lhapdf_global_status_t), save :: lhapdf_global_status
	@ %def lhapdf_global_status
	<<SF lhapdf: procedures>>=
	function lhapdf_global_status_is_initialized (set) result (flag)
	logical :: flag
	integer, intent(in), optional :: set
	if (present (set)) then
	select case (set)
	case (1:3); flag = lhapdf_global_status%initialized(set)
	case default; flag = .false.
	end select
	else
	flag = any (lhapdf_global_status%initialized)
	end if
	end function lhapdf_global_status_is_initialized

	@ %def lhapdf_global_status_is_initialized
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_global_status_set_initialized (set)
	integer, intent(in) :: set
	lhapdf_global_status%initialized(set) = .true.
	end subroutine lhapdf_global_status_set_initialized

	@ %def lhapdf_global_status_set_initialized
	@ This is the only public procedure, it tells the system to forget
	about previous initialization, allowing for changing the chosen PDF
	set. Note that such a feature works only if the global program flow
	is serial, so no two distinct sets are accessed simultaneously. But
	this applies to LHAPDF anyway.
	<<SF lhapdf: public>>=
	public :: lhapdf_global_reset
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_global_reset ()
	lhapdf_global_status%initialized = .false.
	end subroutine lhapdf_global_reset

	@ %def lhapdf_global_status_reset
	@
	\subsection{LHAPDF initialization}
	Before using LHAPDF, we have to initialize it with a particular data
	set and member. This applies not just if we use structure functions,
	but also if we just use an $\alpha_s$ formula. The integer [[set]]
	should be $1$ for proton, $2$ for pion, and $3$ for photon, but this
	is just convention.

	It appears as if LHAPDF does not allow for multiple data sets being
	used concurrently (?), so multi-threaded usage with different sets
	(e.g., a scan) is excluded. The current setup with a global flag that
	indicates initialization is fine as long as Whizard itself is run in
	serial mode at the Sindarin level. If we introduce multithreading in
	any form from Sindarin, we have to rethink the implementation of the
	LHAPDF interface. (The same considerations apply to builtin PDFs.)

	If the particular set has already been initialized, do nothing. This
	implies that whenever we want to change the setup for a particular
	set, we have to reset the LHAPDF status.
	[[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]],
	the reason it works for [[pdf_builtin]] is that there things are
	outsourced to a separate module (inc. [[lhapdf_status]] etc.).
	<<SF lhapdf: public>>=
	public :: lhapdf_initialize
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_initialize (set, prefix, file, member, pdf, b_match)
	integer, intent(in) :: set
	type(string_t), intent(inout) :: prefix
	type(string_t), intent(inout) :: file
	type(lhapdf_pdf_t), intent(inout), optional :: pdf
	integer, intent(inout) :: member
	logical, intent(in), optional :: b_match
	if (prefix == "") prefix = LHAPDF_PDFSETS_PATH
	if (LHAPDF5_AVAILABLE) then
	if (lhapdf_global_status_is_initialized (set)) return
	if (file == "") then
	select case (set)
	case (1); file = LHAPDF5_DEFAULT_PROTON
	case (2); file = LHAPDF5_DEFAULT_PION
	case (3); file = LHAPDF5_DEFAULT_PHOTON
	end select
	end if
	if (data_file_exists (prefix // "/" // file)) then
	call InitPDFsetM (set, char (prefix // "/" // file))
	else
	call msg_fatal ("LHAPDF: Data file '" &
	// char (file) // "' not found in '" // char (prefix) // "'.")
	return
	end if
	if (.not. dataset_member_exists (set, member)) then
	call msg_error (" LHAPDF: Chosen member does not exist for set '" &
	// char (file) // "', using default.")
	member = 0
	end if
	call InitPDFM (set, member)
	else if (LHAPDF6_AVAILABLE) then
	! TODO: (bcn 2015-07-07) we should have a closer look why this global
	! check must not be executed
	! if (lhapdf_global_status_is_initialized (set) .and. &
	! pdf%is_associated ()) return
	if (file == "") then
	select case (set)
	case (1); file = LHAPDF6_DEFAULT_PROTON
	case (2);
	call msg_fatal ("LHAPDF6: no pion PDFs supported")
	case (3);
	call msg_fatal ("LHAPDF6: no photon PDFs supported")
	end select
	end if
	if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then
	call pdf%init (char (file), member)
	else
	call msg_fatal ("LHAPDF: Data file '" &
	// char (file) // "' not found in '" // char (prefix) // "'.")
	return
	end if
	end if
	if (present (b_match)) then
	if (b_match) then
	if (LHAPDF5_AVAILABLE) then
	call hoppet_init (.false.)
	else if (LHAPDF6_AVAILABLE) then
	call hoppet_init (.false., pdf)
	end if
	end if
	end if
	call lhapdf_global_status_set_initialized (set)
	contains
	function data_file_exists (fq_name) result (exist)
	type(string_t), intent(in) :: fq_name
	logical :: exist
	inquire (file = char(fq_name), exist = exist)
	end function data_file_exists
	function dataset_member_exists (set, member) result (exist)
	integer, intent(in) :: set, member
	logical :: exist
	integer :: n_members
	call numberPDFM (set, n_members)
	exist = member >= 0 .and. member <= n_members
	end function dataset_member_exists
	end subroutine lhapdf_initialize

	@ %def lhapdf_initialize
	@
	\subsection{Kinematics}
	Set kinematics. If [[map]] is unset, the $r$ and $x$ values
	coincide, and the Jacobian $f(r)$ is trivial.

	If [[map]] is set, we are asked to provide an efficient mapping.
	For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: complete_kinematics => lhapdf_complete_kinematics
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_complete_kinematics (sf_int, x, xb, f, r, rb, map)
	class(lhapdf_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(in) :: r
	real(default), dimension(:), intent(in) :: rb
	logical, intent(in) :: map
	if (map) then
	call msg_fatal ("LHAPDF: map flag not supported")
	else
	x(1) = r(1)
	xb(1)= rb(1)
	f = 1
	end if
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_DONE_KINEMATICS)
	sf_int%x = x(1)
	case (SF_FAILED_KINEMATICS)
	sf_int%x = 0
	f = 0
	end select
	end subroutine lhapdf_complete_kinematics

	@ %def lhapdf_complete_kinematics
	@ Overriding the default method: we compute the [[x]] value from the
	momentum configuration. In this specific case, we also set the
	internally stored $x$ value, so it can be used in the
	following routine.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: recover_x => lhapdf_recover_x
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_recover_x (sf_int, x, xb, x_free)
	class(lhapdf_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(out) :: x
	real(default), dimension(:), intent(out) :: xb
	real(default), intent(inout), optional :: x_free
	call sf_int%base_recover_x (x, xb, x_free)
	sf_int%x = x(1)
	end subroutine lhapdf_recover_x

	@ %def lhapdf_recover_x
	@ Compute inverse kinematics. Here, we start with the $x$ array and
	compute the ``input'' $r$ values and the Jacobian $f$. After this, we
	can set momenta by the same formula as for normal kinematics.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: inverse_kinematics => lhapdf_inverse_kinematics
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
	class(lhapdf_t), intent(inout) :: sf_int
	real(default), dimension(:), intent(in) :: x
	real(default), dimension(:), intent(in) :: xb
	real(default), intent(out) :: f
	real(default), dimension(:), intent(out) :: r
	real(default), dimension(:), intent(out) :: rb
	logical, intent(in) :: map
	logical, intent(in), optional :: set_momenta
	logical :: set_mom
	set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta
	if (map) then
	call msg_fatal ("LHAPDF: map flag not supported")
	else
	r(1) = x(1)
	rb(1)= xb(1)
	f = 1
	end if
	if (set_mom) then
	call sf_int%split_momentum (x, xb)
	select case (sf_int%status)
	case (SF_FAILED_KINEMATICS); f = 0
	end select
	end if
	end subroutine lhapdf_inverse_kinematics

	@ %def lhapdf_inverse_kinematics
	@
	\subsection{The LHAPDF data block}
	The data block holds the incoming flavor (which has to be proton,
	pion, or photon), the corresponding pointer to the global access data
	(1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
	bounds as returned by LHAPDF for the specified set, and a mask that
	determines which partons will be actually in use.
	<<SF lhapdf: public>>=
	public :: lhapdf_data_t
	<<SF lhapdf: types>>=
	type, extends (sf_data_t) :: lhapdf_data_t
	private
	type(string_t) :: prefix
	type(string_t) :: file
	type(lhapdf_pdf_t) :: pdf
	integer :: member = 0
	class(model_data_t), pointer :: model => null ()
	type(flavor_t) :: flv_in
	integer :: set = 0
	logical :: invert = .false.
	logical :: photon = .false.
	logical :: has_photon = .false.
	integer :: photon_scheme = 0
	real(default) :: xmin = 0, xmax = 0
	real(default) :: qmin = 0, qmax = 0
	logical, dimension(-6:6) :: mask = .true.
	logical :: mask_photon = .true.
	logical :: hoppet_b_matching = .false.
	contains
	<<SF lhapdf: lhapdf data: TBP>>
	end type lhapdf_data_t

	@ %def lhapdf_data_t
	@ Generate PDF data. This is provided as a function, but it has the
	side-effect of initializing the requested PDF set. A finalizer is not
	needed.

	The library uses double precision, so since the default precision may be
	extended or quadruple, we use auxiliary variables for type casting.
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: init => lhapdf_data_init
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_data_init &
	(data, model, pdg_in, prefix, file, member, photon_scheme, &
	hoppet_b_matching)
	class(lhapdf_data_t), intent(out) :: data
	class(model_data_t), intent(in), target :: model
	type(pdg_array_t), intent(in) :: pdg_in
	type(string_t), intent(in), optional :: prefix, file
	integer, intent(in), optional :: member
	integer, intent(in), optional :: photon_scheme
	logical, intent(in), optional :: hoppet_b_matching
	double precision :: xmin, xmax, q2min, q2max
	external :: InitPDFsetM, InitPDFM, numberPDFM
	external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM
	if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then
	call msg_fatal ("LHAPDF requested but library is not linked")
	return
	end if
	data%model => model
	- if (pdg_array_get_length (pdg_in) /= 1) &
	+ if (pdg_in%get_length () /= 1) &
	call msg_fatal ("PDF: incoming particle must be unique")
	- call data%flv_in%init (pdg_array_get (pdg_in, 1), model)
	- select case (pdg_array_get (pdg_in, 1))
	+ call data%flv_in%init (pdg_in%get (1), model)
	+ select case (pdg_in%get (1))
	case (PROTON)
	data%set = 1
	case (-PROTON)
	data%set = 1
	data%invert = .true.
	case (PIPLUS)
	data%set = 2
	case (-PIPLUS)
	data%set = 2
	data%invert = .true.
	case (PHOTON)
	data%set = 3
	data%photon = .true.
	if (present (photon_scheme)) data%photon_scheme = photon_scheme
	case default
	call msg_fatal (" LHAPDF: " &
	// "incoming particle must be (anti)proton, pion, or photon.")
	return
	end select
	if (present (prefix)) then
	data%prefix = prefix
	else
	data%prefix = ""
	end if
	if (present (file)) then
	data%file = file
	else
	data%file = ""
	end if
	if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching
	if (LHAPDF5_AVAILABLE) then
	call lhapdf_initialize (data%set, &
	data%prefix, data%file, data%member, &
	b_match = data%hoppet_b_matching)
	call GetXminM (data%set, data%member, xmin)
	call GetXmaxM (data%set, data%member, xmax)
	call GetQ2minM (data%set, data%member, q2min)
	call GetQ2maxM (data%set, data%member, q2max)
	data%xmin = xmin
	data%xmax = xmax
	data%qmin = sqrt (q2min)
	data%qmax = sqrt (q2max)
	data%has_photon = has_photon ()
	else if (LHAPDF6_AVAILABLE) then
	call lhapdf_initialize (data%set, &
	data%prefix, data%file, data%member, &
	data%pdf, data%hoppet_b_matching)
	data%xmin = data%pdf%getxmin ()
	data%xmax = data%pdf%getxmax ()
	data%qmin = sqrt(data%pdf%getq2min ())
	data%qmax = sqrt(data%pdf%getq2max ())
	data%has_photon = data%pdf%has_photon ()
	end if
	end subroutine lhapdf_data_init

	@ %def lhapdf_data_init
	@ Enable/disable partons explicitly. If a mask entry is true,
	applying the PDF will generate the corresponding flavor on output.
	<<LHAPDF: lhapdf data: TBP>>=
	procedure :: set_mask => lhapdf_data_set_mask
	<<LHAPDF: procedures>>=
	subroutine lhapdf_data_set_mask (data, mask)
	class(lhapdf_data_t), intent(inout) :: data
	logical, dimension(-6:6), intent(in) :: mask
	data%mask = mask
	end subroutine lhapdf_data_set_mask

	@ %def lhapdf_data_set_mask
	@ Return the public part of the data set.
	<<LHAPDF: public>>=
	public :: lhapdf_data_get_public_info
	<<LHAPDF: procedures>>=
	subroutine lhapdf_data_get_public_info &
	(data, lhapdf_dir, lhapdf_file, lhapdf_member)
	type(lhapdf_data_t), intent(in) :: data
	type(string_t), intent(out) :: lhapdf_dir, lhapdf_file
	integer, intent(out) :: lhapdf_member
	lhapdf_dir = data%prefix
	lhapdf_file = data%file
	lhapdf_member = data%member
	end subroutine lhapdf_data_get_public_info

	@ %def lhapdf_data_get_public_info
	@ Return the number of the member of the data set.
	<<LHAPDF: public>>=
	public :: lhapdf_data_get_set
	<<LHAPDF: procedures>>=
	function lhapdf_data_get_set(data) result(set)
	type(lhapdf_data_t), intent(in) :: data
	integer :: set
	set = data%set
	end function lhapdf_data_get_set

	@ %def lhapdf_data_get_set
	@ Output
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: write => lhapdf_data_write
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_data_write (data, unit, verbose)
	class(lhapdf_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	logical :: verb
	integer :: u
	if (present (verbose)) then
	verb = verbose
	else
	verb = .false.
	end if
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "LHAPDF data:"
	if (data%set /= 0) then
	write (u, "(3x,A)", advance="no") "flavor = "
	call data%flv_in%write (u); write (u, *)
	if (verb) then
	write (u, "(3x,A,A)") " prefix = ", char (data%prefix)
	else
	write (u, "(3x,A,A)") " prefix = ", &
	" <empty (non-verbose version)>"
	end if
	write (u, "(3x,A,A)") " file = ", char (data%file)
	write (u, "(3x,A,I3)") " member = ", data%member
	write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin
	write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax
	write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin
	write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax
	write (u, "(3x,A,L1)") " invert = ", data%invert
	if (data%photon) write (u, "(3x,A,I3)") &
	" IP2 (scheme) = ", data%photon_scheme
	write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
	" mask = ", &
	data%mask(-6:-1), "", data%mask(0), "", data%mask(1:6)
	write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon
	if (data%set == 1) write (u, "(3x,A,L1)") &
	" hoppet_b = ", data%hoppet_b_matching
	else
	write (u, "(3x,A)") "[undefined]"
	end if
	end subroutine lhapdf_data_write
	@ %def lhapdf_data_write
	@ The number of parameters is one. We do not generate transverse momentum.
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: get_n_par => lhapdf_data_get_n_par
	<<SF lhapdf: procedures>>=
	function lhapdf_data_get_n_par (data) result (n)
	class(lhapdf_data_t), intent(in) :: data
	integer :: n
	n = 1
	end function lhapdf_data_get_n_par

	@ %def lhapdf_data_get_n_par
	@ Return the outgoing particle PDG codes. This is based on the mask.
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: get_pdg_out => lhapdf_data_get_pdg_out
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_data_get_pdg_out (data, pdg_out)
	class(lhapdf_data_t), intent(in) :: data
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	integer :: n, np, i
	n = count (data%mask)
	np = 0; if (data%has_photon .and. data%mask_photon) np = 1
	allocate (pdg1 (n + np))
	pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
	if (np == 1) pdg1(n+np) = PHOTON
	pdg_out(1) = pdg1
	end subroutine lhapdf_data_get_pdg_out

	@ %def lhapdf_data_get_pdg_out
	@ Allocate the interaction record.
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_data_allocate_sf_int (data, sf_int)
	class(lhapdf_data_t), intent(in) :: data
	class(sf_int_t), intent(inout), allocatable :: sf_int
	allocate (lhapdf_t :: sf_int)
	end subroutine lhapdf_data_allocate_sf_int

	@ %def lhapdf_data_allocate_sf_int
	@ Return the numerical PDF set index.
	<<SF lhapdf: lhapdf data: TBP>>=
	procedure :: get_pdf_set => lhapdf_data_get_pdf_set
	<<SF lhapdf: procedures>>=
	elemental function lhapdf_data_get_pdf_set (data) result (pdf_set)
	class(lhapdf_data_t), intent(in) :: data
	integer :: pdf_set
	pdf_set = data%set
	end function lhapdf_data_get_pdf_set

	@ %def lhapdf_data_get_pdf_set
	@
	\subsection{The LHAPDF object}
	The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes
	the splitting of an (anti)proton into a parton and a beam remnant. We
	stay in the strict forward-splitting limit, but allow some invariant
	mass for the beam remnant such that the outgoing parton is exactly
	massless. For a real event, we would replace this by a parton
	cascade, where the outgoing partons have virtuality as dictated by
	parton-shower kinematics, and transverse momentum is generated.

	This is the LHAPDF object which holds input data together with the
	interaction. We also store the $x$ momentum fraction and the scale,
	since kinematics and function value are requested at different times.

	The PDF application is a $1\to 2$ splitting process, where the
	particles are ordered as (hadron, remnant, parton).

	Polarization is ignored completely. The beam particle is colorless,
	while partons and beam remnant carry color. The remnant gets a
	special flavor code.
	<<SF lhapdf: public>>=
	public :: lhapdf_t
	<<SF lhapdf: types>>=
	type, extends (sf_int_t) :: lhapdf_t
	type(lhapdf_data_t), pointer :: data => null ()
	real(default) :: x = 0
	real(default) :: q = 0
	real(default) :: s = 0
	contains
	<<SF lhapdf: lhapdf: TBP>>
	end type lhapdf_t

	@ %def lhapdf_t
	@ Type string: display the chosen PDF set.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: type_string => lhapdf_type_string
	<<SF lhapdf: procedures>>=
	function lhapdf_type_string (object) result (string)
	class(lhapdf_t), intent(in) :: object
	type(string_t) :: string
	if (associated (object%data)) then
	string = "LHAPDF: " // object%data%file
	else
	string = "LHAPDF: [undefined]"
	end if
	end function lhapdf_type_string

	@ %def lhapdf_type_string
	@ Output. Call the interaction routine after displaying the configuration.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: write => lhapdf_write
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_write (object, unit, testflag)
	class(lhapdf_t), intent(in) :: object
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: testflag
	integer :: u
	u = given_output_unit (unit)
	if (associated (object%data)) then
	call object%data%write (u)
	if (object%status >= SF_DONE_KINEMATICS) then
	write (u, "(1x,A)") "SF parameters:"
	write (u, "(3x,A," // FMT_17 // ")") "x =", object%x
	if (object%status >= SF_FAILED_EVALUATION) then
	write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q
	end if
	end if
	call object%base_write (u, testflag)
	else
	write (u, "(1x,A)") "LHAPDF data: [undefined]"
	end if
	end subroutine lhapdf_write

	@ %def lhapdf_write
	@ Initialize. We know that [[data]] will be of concrete type
	[[sf_lhapdf_data_t]], but we have to cast this explicitly.

	For this implementation, we set the incoming and outgoing masses equal
	to the physical particle mass, but keep the radiated mass zero.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: init => lhapdf_init
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_init (sf_int, data)
	class(lhapdf_t), intent(out) :: sf_int
	class(sf_data_t), intent(in), target :: data
	type(quantum_numbers_mask_t), dimension(3) :: mask
	type(flavor_t) :: flv, flv_remnant
	type(color_t) :: col0
	type(quantum_numbers_t), dimension(3) :: qn
	integer :: i
	select type (data)
	type is (lhapdf_data_t)
	mask = quantum_numbers_mask (.false., .false., .true.)
	call col0%init ()
	call sf_int%base_init (mask, [0._default], [0._default], [0._default])
	sf_int%data => data
	do i = -6, 6
	if (data%mask(i)) then
	call qn(1)%init (data%flv_in, col = col0)
	if (i == 0) then
	call flv%init (GLUON, data%model)
	call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
	else
	call flv%init (i, data%model)
	call flv_remnant%init &
	(sign (HADRON_REMNANT_TRIPLET, -i), data%model)
	end if
	call qn(2)%init ( &
	flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
	call qn(2)%tag_radiated ()
	call qn(3)%init ( &
	flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
	call sf_int%add_state (qn)
	end if
	end do
	if (data%has_photon .and. data%mask_photon) then
	call flv%init (PHOTON, data%model)
	call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
	call qn(2)%init (flv = flv_remnant, &
	col = color_from_flavor (flv_remnant, 1))
	call qn(2)%tag_radiated ()
	call qn(3)%init (flv = flv, &
	col = color_from_flavor (flv, 1, reverse=.true.))
	call sf_int%add_state (qn)
	end if
	call sf_int%freeze ()
	call sf_int%set_incoming ([1])
	call sf_int%set_radiated ([2])
	call sf_int%set_outgoing ([3])
	sf_int%status = SF_INITIAL
	end select
	end subroutine lhapdf_init

	@ %def lhapdf_init
	@
	\subsection{Structure function}
	We have to cast the LHAPDF arguments to/from double precision (possibly
	from/to extended/quadruple precision), if necessary.
	Some structure functions can yield negative results (sea quarks close
	to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values.
	Unlike total cross sections, PDFs do not have to be positive definite. For LO however,
	negative PDFs would cause negative event weights so we set these values to zero instead.
	<<SF lhapdf: lhapdf: TBP>>=
	procedure :: apply => lhapdf_apply
	<<SF lhapdf: procedures>>=
	subroutine lhapdf_apply (sf_int, scale, negative_sf, rescale, i_sub)
	class(lhapdf_t), intent(inout) :: sf_int
	real(default), intent(in) :: scale
	logical, intent(in), optional :: negative_sf
	class(sf_rescale_t), intent(in), optional :: rescale
	integer, intent(in), optional :: i_sub
	real(default) :: x, s
	double precision :: xx, qq, ss
	double precision, dimension(-6:6) :: ff
	double precision :: fphot
	complex(default), dimension(:), allocatable :: fc
	integer :: i, i_sub_opt, j_sub
	logical :: negative_sf_opt
	external :: evolvePDFM, evolvePDFpM
	i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
	negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
	associate (data => sf_int%data)
	sf_int%q = scale
	x = sf_int%x
	if (present (rescale)) call rescale%apply (x)
	s = sf_int%s
	xx = x
	if (debug2_active (D_BEAMS)) then
	call msg_debug2 (D_BEAMS, "lhapdf_apply")
	call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
	call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
	call msg_debug2 (D_BEAMS, "x: ", x)
	end if
	qq = min (data%qmax, scale)
	qq = max (data%qmin, qq)
	if (.not. data%photon) then
	if (data%invert) then
	if (data%has_photon) then
	if (LHAPDF5_AVAILABLE) then
	call evolvePDFphotonM &
	(data%set, xx, qq, ff(6:-6:-1), fphot)
	else if (LHAPDF6_AVAILABLE) then
	call data%pdf%evolve_pdfphotonm &
	(xx, qq, ff(6:-6:-1), fphot)
	end if
	else
	if (data%hoppet_b_matching) then
	call hoppet_eval (xx, qq, ff(6:-6:-1))
	else
	if (LHAPDF5_AVAILABLE) then
	call evolvePDFM (data%set, xx, qq, ff(6:-6:-1))
	else if (LHAPDF6_AVAILABLE) then
	call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1))
	end if
	end if
	end if
	else
	if (data%has_photon) then
	if (LHAPDF5_AVAILABLE) then
	call evolvePDFphotonM (data%set, xx, qq, ff, fphot)
	else if (LHAPDF6_AVAILABLE) then
	call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot)
	end if
	else
	if (data%hoppet_b_matching) then
	call hoppet_eval (xx, qq, ff)
	else
	if (LHAPDF5_AVAILABLE) then
	call evolvePDFM (data%set, xx, qq, ff)
	else if (LHAPDF6_AVAILABLE) then
	call data%pdf%evolve_pdfm (xx, qq, ff)
	end if
	end if
	end if
	end if
	else
	ss = s
	if (LHAPDF5_AVAILABLE) then
	call evolvePDFpM (data%set, xx, qq, &
	ss, data%photon_scheme, ff)
	else if (LHAPDF6_AVAILABLE) then
	call data%pdf%evolve_pdfpm (xx, qq, ss, &
	data%photon_scheme, ff)
	end if
	end if
	if (data%has_photon) then
	allocate (fc (count ([data%mask, data%mask_photon])))
	if (negative_sf_opt) then
	fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon])
	else
	fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default)
	end if
	else
	allocate (fc (count (data%mask)))
	if (negative_sf_opt) then
	fc = pack (ff / x, data%mask)
	else
	fc = max( pack (ff / x, data%mask), 0._default)
	end if
	end if
	end associate
	if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
	call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
	sf_int%status = SF_EVALUATED
	end subroutine lhapdf_apply

	@ %def apply_lhapdf
	@
	\subsection{Strong Coupling}
	Since the PDF codes provide a function for computing the running
	$\alpha_s$ value, we make this available as an implementation of the
	abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
	<<SF lhapdf: public>>=
	public :: alpha_qcd_lhapdf_t
	<<SF lhapdf: types>>=
	type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t
	type(string_t) :: pdfset_dir
	type(string_t) :: pdfset_file
	integer :: pdfset_member = -1
	type(lhapdf_pdf_t) :: pdf
	contains
	<<SF lhapdf: alpha qcd: TBP>>
	end type alpha_qcd_lhapdf_t

	@ %def alpha_qcd_lhapdf_t
	@ Output. As in earlier versions we leave the LHAPDF path out.
	<<SF lhapdf: alpha qcd: TBP>>=
	procedure :: write => alpha_qcd_lhapdf_write
	<<SF lhapdf: procedures>>=
	subroutine alpha_qcd_lhapdf_write (object, unit)
	class(alpha_qcd_lhapdf_t), intent(in) :: object
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit)
	write (u, "(3x,A)") "QCD parameters (lhapdf):"
	write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_file)
	write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member
	end subroutine alpha_qcd_lhapdf_write

	@ %def alpha_qcd_lhapdf_write
	@ Calculation: the numeric member ID selects the correct PDF set, which must
	be properly initialized.
	<<SF lhapdf: interfaces>>=
	interface
	double precision function alphasPDF (Q)
	double precision, intent(in) :: Q
	end function alphasPDF
	end interface

	@ %def alphasPDF
	@
	<<SF lhapdf: alpha qcd: TBP>>=
	procedure :: get => alpha_qcd_lhapdf_get
	<<SF lhapdf: procedures>>=
	function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha)
	class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
	real(default), intent(in) :: scale
	real(default) :: alpha
	if (LHAPDF5_AVAILABLE) then
	alpha = alphasPDF (dble (scale))
	else if (LHAPDF6_AVAILABLE) then
	alpha = alpha_qcd%pdf%alphas_pdf (dble (scale))
	end if
	end function alpha_qcd_lhapdf_get

	@ %def alpha_qcd_lhapdf_get
	@
	Initialization. We need to access the (quasi-global) initialization status.
	<<SF lhapdf: alpha qcd: TBP>>=
	procedure :: init => alpha_qcd_lhapdf_init
	<<SF lhapdf: procedures>>=
	subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path)
	class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd
	type(string_t), intent(inout) :: file
	integer, intent(inout) :: member
	type(string_t), intent(inout) :: path
	alpha_qcd%pdfset_file = file
	alpha_qcd%pdfset_member = member
	if (alpha_qcd%pdfset_member < 0) &
	call msg_fatal ("QCD parameter initialization: PDF set " &
	// char (file) // " is unknown")
	if (LHAPDF5_AVAILABLE) then
	call lhapdf_initialize (1, path, file, member)
	else if (LHAPDF6_AVAILABLE) then
	call lhapdf_initialize &
	(1, path, file, member, alpha_qcd%pdf)
	end if
	end subroutine alpha_qcd_lhapdf_init

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

	module sf_lhapdf_ut
	use unit_tests
	use system_dependencies, only: LHAPDF5_AVAILABLE
	use system_dependencies, only: LHAPDF6_AVAILABLE
	use sf_lhapdf_uti

	<<Standard module head>>

	<<SF lhapdf: public test>>

	contains

	<<SF lhapdf: test driver>>

	end module sf_lhapdf_ut
	@ %def sf_lhapdf_ut
	@
	<<[[sf_lhapdf_uti.f90]]>>=
	<<File header>>

	module sf_lhapdf_uti

	<<Use kinds>>
	<<Use strings>>
	use system_dependencies, only: LHAPDF5_AVAILABLE
	use system_dependencies, only: LHAPDF6_AVAILABLE
	use os_interface
	use physics_defs, only: PROTON
	use sm_qcd
	use lorentz
	use pdg_arrays
	use flavors
	use interactions, only: reset_interaction_counter
	use model_data
	use sf_base

	use sf_lhapdf

	<<Standard module head>>

	<<SF lhapdf: test declarations>>

	contains

	<<SF lhapdf: tests>>

	end module sf_lhapdf_uti
	@ %def sf_lhapdf_ut
	@ API: driver for the unit tests below.
	<<SF lhapdf: public test>>=
	public :: sf_lhapdf_test
	<<SF lhapdf: test driver>>=
	subroutine sf_lhapdf_test (u, results)
	integer, intent(in) :: u
	type(test_results_t), intent(inout) :: results
	<<SF lhapdf: execute tests>>
	end subroutine sf_lhapdf_test

	@ %def sf_lhapdf_test
	@
	\subsubsection{Test structure function data}
	Construct and display a test structure function data object.
	<<SF lhapdf: execute tests>>=
	if (LHAPDF5_AVAILABLE) then
	call test (sf_lhapdf_1, "sf_lhapdf5_1", &
	"structure function configuration", &
	u, results)
	else if (LHAPDF6_AVAILABLE) then
	call test (sf_lhapdf_1, "sf_lhapdf6_1", &
	"structure function configuration", &
	u, results)
	end if
	<<SF lhapdf: test declarations>>=
	public :: sf_lhapdf_1
	<<SF lhapdf: tests>>=
	subroutine sf_lhapdf_1 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(pdg_array_t) :: pdg_in
	type(pdg_array_t), dimension(1) :: pdg_out
	integer, dimension(:), allocatable :: pdg1
	class(sf_data_t), allocatable :: data

	write (u, "(A)") "* Test output: sf_lhapdf_1"
	write (u, "(A)") "* Purpose: initialize and display &
	&test structure function data"
	write (u, "(A)")

	write (u, "(A)") "* Create empty data object"
	write (u, "(A)")

	call model%init_sm_test ()
	pdg_in = PROTON

	allocate (lhapdf_data_t :: data)
	call data%write (u)

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

	select type (data)
	type is (lhapdf_data_t)
	call data%init (model, pdg_in)
	end select

	call data%write (u)

	write (u, "(A)")

	write (u, "(1x,A)") "Outgoing particle codes:"
	call data%get_pdg_out (pdg_out)
	pdg1 = pdg_out(1)
	write (u, "(2x,99(1x,I0))") pdg1

	call model%final ()

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

	end subroutine sf_lhapdf_1

	@ %def sf_lhapdf_1
	@
	\subsubsection{Test and probe structure function}
	Construct and display a structure function object based on the PDF builtin
	structure function.
	<<SF lhapdf: execute tests>>=
	if (LHAPDF5_AVAILABLE) then
	call test (sf_lhapdf_2, "sf_lhapdf5_2", &
	"structure function instance", &
	u, results)
	else if (LHAPDF6_AVAILABLE) then
	call test (sf_lhapdf_2, "sf_lhapdf6_2", &
	"structure function instance", &
	u, results)
	end if
	<<SF lhapdf: test declarations>>=
	public :: sf_lhapdf_2
	<<SF lhapdf: tests>>=
	subroutine sf_lhapdf_2 (u)
	integer, intent(in) :: u
	type(model_data_t), target :: model
	type(flavor_t) :: flv
	type(pdg_array_t) :: pdg_in
	class(sf_data_t), allocatable, target :: data
	class(sf_int_t), allocatable :: sf_int
	type(vector4_t) :: k
	type(vector4_t), dimension(2) :: q
	real(default) :: E
	real(default), dimension(:), allocatable :: r, rb, x, xb
	real(default) :: f

	write (u, "(A)") "* Test output: sf_lhapdf_2"
	write (u, "(A)") "* Purpose: initialize and fill &
	&test structure function object"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call model%init_sm_test ()
	call flv%init (PROTON, model)
	pdg_in = PROTON
	call lhapdf_global_reset ()

	call reset_interaction_counter ()

	allocate (lhapdf_data_t :: data)
	select type (data)
	type is (lhapdf_data_t)
	call data%init (model, pdg_in)
	end select

	write (u, "(A)") "* Initialize structure-function object"
	write (u, "(A)")

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Initialize incoming momentum with E=500"
	write (u, "(A)")
	E = 500
	k = vector4_moving (E, sqrt (E2 - flv%get_mass ()2), 3)
	call vector4_write (k, u)
	call sf_int%seed_kinematics ([k])

	write (u, "(A)")
	write (u, "(A)") "* Set kinematics for x=0.5"
	write (u, "(A)")

	allocate (r (data%get_n_par ()))
	allocate (rb(size (r)))
	allocate (x (size (r)))
	allocate (xb(size (r)))

	r = 0.5_default
	rb = 1 - r
	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%write (u)

	write (u, "(A)")
	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb
	write (u, "(A,9(1x,F10.7))") "f =", f

	write (u, "(A)")
	write (u, "(A)") "* Recover x from momenta"
	write (u, "(A)")

	q = sf_int%get_momenta (outgoing=.true.)
	call sf_int%final ()
	deallocate (sf_int)

	call data%allocate_sf_int (sf_int)
	call sf_int%init (data)
	call sf_int%set_beam_index ([1])

	call sf_int%seed_kinematics ([k])
	call sf_int%set_momenta (q, outgoing=.true.)
	call sf_int%recover_x (x, xb)

	write (u, "(A,9(1x,F10.7))") "x =", x
	write (u, "(A,9(1x,F10.7))") "xb=", xb

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for Q = 100 GeV"
	write (u, "(A)")

	call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
	call sf_int%apply (scale = 100._default)
	call sf_int%write (u, testflag = .true.)


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

	call sf_int%final ()
	call model%final ()

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

	end subroutine sf_lhapdf_2

	@ %def sf_lhapdf_2
	@
	\subsubsection{Strong Coupling}
	Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
	type.
	<<SF lhapdf: execute tests>>=
	if (LHAPDF5_AVAILABLE) then
	call test (sf_lhapdf_3, "sf_lhapdf5_3", &
	"running alpha_s", &
	u, results)
	else if (LHAPDF6_AVAILABLE) then
	call test (sf_lhapdf_3, "sf_lhapdf6_3", &
	"running alpha_s", &
	u, results)
	end if
	<<SF lhapdf: test declarations>>=
	public :: sf_lhapdf_3
	<<SF lhapdf: tests>>=
	subroutine sf_lhapdf_3 (u)
	integer, intent(in) :: u
	type(qcd_t) :: qcd
	type(string_t) :: name, path
	integer :: member

	write (u, "(A)") "* Test output: sf_lhapdf_3"
	write (u, "(A)") "* Purpose: initialize and evaluate alpha_s"
	write (u, "(A)")

	write (u, "(A)") "* Initialize configuration data"
	write (u, "(A)")

	call lhapdf_global_reset ()

	if (LHAPDF5_AVAILABLE) then
	name = "cteq6ll.LHpdf"
	member = 1
	path = ""
	else if (LHAPDF6_AVAILABLE) then
	name = "CT10"
	member = 1
	path = ""
	end if

	write (u, "(A)") "* Initialize qcd object"
	write (u, "(A)")

	allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
	select type (alpha => qcd%alpha)
	type is (alpha_qcd_lhapdf_t)
	call alpha%init (name, member, path)
	end select
	call qcd%write (u)

	write (u, "(A)")
	write (u, "(A)") "* Evaluate for Q = 100"
	write (u, "(A)")

	write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default)

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

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

	end subroutine sf_lhapdf_3

	@ %def sf_lhapdf_3
	@
	\section{Easy PDF Access}
	For the shower, subtraction and matching, it is very useful to have
	direct access to $f(x,Q)$ independently of the used library.
	<<[[pdf.f90]]>>=
	<<File header>>

	module pdf

	<<Use kinds with double>>
	use io_units
	use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE
	use diagnostics
	use beam_structures
	use lhapdf !NODEP!
	use pdf_builtin !NODEP!

	<<Standard module head>>

	<<PDF: public>>

	<<PDF: parameters>>

	<<PDF: types>>

	contains

	<<PDF: procedures>>

	end module pdf
	@ %def pdf
	We support the following implementations:
	<<PDF: parameters>>=
	integer, parameter, public :: STRF_NONE = 0
	integer, parameter, public :: STRF_LHAPDF6 = 1
	integer, parameter, public :: STRF_LHAPDF5 = 2
	integer, parameter, public :: STRF_PDF_BUILTIN = 3

	@ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN
	@ A container to bundle all necessary PDF data. Could be moved to a more
	central location.
	<<PDF: public>>=
	public :: pdf_data_t
	<<PDF: types>>=
	type :: pdf_data_t
	type(lhapdf_pdf_t) :: pdf
	real(default) :: xmin, xmax, qmin, qmax
	integer :: type = STRF_NONE
	integer :: set = 0
	contains
	<<PDF: pdf data: TBP>>
	end type pdf_data_t

	@ %def pdf_data
	@
	<<PDF: pdf data: TBP>>=
	procedure :: init => pdf_data_init
	<<PDF: procedures>>=
	subroutine pdf_data_init (pdf_data, pdf_data_in)
	class(pdf_data_t), intent(out) :: pdf_data
	type(pdf_data_t), target, intent(in) :: pdf_data_in
	pdf_data%xmin = pdf_data_in%xmin
	pdf_data%xmax = pdf_data_in%xmax
	pdf_data%qmin = pdf_data_in%qmin
	pdf_data%qmax = pdf_data_in%qmax
	pdf_data%set = pdf_data_in%set
	pdf_data%type = pdf_data_in%type
	if (pdf_data%type == STRF_LHAPDF6) then
	if (pdf_data_in%pdf%is_associated ()) then
	call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf)
	else
	call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!')
	end if
	end if
	end subroutine pdf_data_init

	@ %def pdf_data_init
	@
	<<PDF: pdf data: TBP>>=
	procedure :: write => pdf_data_write
	<<PDF: procedures>>=
	subroutine pdf_data_write (pdf_data, unit)
	class(pdf_data_t), intent(in) :: pdf_data
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(3x,A,I0)") "PDF set = ", pdf_data%set
	write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type
	end subroutine pdf_data_write

	@ %def pdf_data_write
	@
	<<PDF: pdf data: TBP>>=
	procedure :: setup => pdf_data_setup
	<<PDF: procedures>>=
	subroutine pdf_data_setup (pdf_data, caller, beam_structure, lhapdf_member, set)
	class(pdf_data_t), intent(inout) :: pdf_data
	character(len=*), intent(in) :: caller
	type(beam_structure_t), intent(in) :: beam_structure
	integer, intent(in) :: lhapdf_member, set
	real(default) :: xmin, xmax, q2min, q2max
	pdf_data%set = set
	if (beam_structure%contains ("lhapdf")) then
	if (LHAPDF6_AVAILABLE) then
	pdf_data%type = STRF_LHAPDF6
	else if (LHAPDF5_AVAILABLE) then
	pdf_data%type = STRF_LHAPDF5
	end if
	write (msg_buffer, "(A,I0)") caller &
	// ": interfacing LHAPDF set #", pdf_data%set
	call msg_message ()
	else if (beam_structure%contains ("pdf_builtin")) then
	pdf_data%type = STRF_PDF_BUILTIN
	write (msg_buffer, "(A,I0)") caller &
	// ": interfacing PDF builtin set #", pdf_data%set
	call msg_message ()
	end if
	select case (pdf_data%type)
	case (STRF_LHAPDF6)
	pdf_data%xmin = pdf_data%pdf%getxmin ()
	pdf_data%xmax = pdf_data%pdf%getxmax ()
	pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ())
	pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ())
	case (STRF_LHAPDF5)
	call GetXminM (1, lhapdf_member, xmin)
	call GetXmaxM (1, lhapdf_member, xmax)
	call GetQ2minM (1, lhapdf_member, q2min)
	call GetQ2maxM (1, lhapdf_member, q2max)
	pdf_data%xmin = xmin
	pdf_data%xmax = xmax
	pdf_data%qmin = sqrt(q2min)
	pdf_data%qmax = sqrt(q2max)
	end select
	end subroutine pdf_data_setup

	@ %def pdf_data_setup
	@ This could be overloaded with a version that only asks for a specific
	flavor as it is supported by LHAPDF6.
	<<PDF: pdf data: TBP>>=
	procedure :: evolve => pdf_data_evolve
	<<PDF: procedures>>=
	subroutine pdf_data_evolve (pdf_data, x, q_in, f)
	class(pdf_data_t), intent(inout) :: pdf_data
	real(double), intent(in) :: x, q_in
	real(double), dimension(-6:6), intent(out) :: f
	real(double) :: q
	select case (pdf_data%type)
	case (STRF_PDF_BUILTIN)
	call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f)
	case (STRF_LHAPDF6)
	q = min (pdf_data%qmax, q_in)
	q = max (pdf_data%qmin, q)
	call pdf_data%pdf%evolve_pdfm (x, q, f)
	case (STRF_LHAPDF5)
	q = min (pdf_data%qmax, q_in)
	q = max (pdf_data%qmin, q)
	call evolvePDFM (pdf_data%set, x, q, f)
	case default
	call msg_fatal ("PDF function: unknown PDF method.")
	end select
	end subroutine pdf_data_evolve
	@ %def pdf_data_evolve
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Dispatch}
	@
	<<[[dispatch_beams.f90]]>>=
	<<File header>>

	module dispatch_beams

	<<Use kinds>>
	<<Use strings>>
	use diagnostics
	use os_interface, only: os_data_t
	use variables, only: var_list_t
	use constants, only: PI, one
	use numeric_utils, only: vanishes
	use physics_defs, only: PHOTON
	use rng_base, only: rng_factory_t
	use pdg_arrays
	use model_data, only: model_data_t
	use dispatch_rng, only: dispatch_rng_factory
	use dispatch_rng, only: update_rng_seed_in_var_list
	use flavors, only: flavor_t
	use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t
	use sm_qcd, only: alpha_qcd_from_lambda_t
	use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t
	use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF

	use beam_structures
	use sf_base
	use sf_mappings
	use sf_isr
	use sf_epa
	use sf_ewa
	use sf_escan
	use sf_gaussian
	use sf_beam_events
	use sf_circe1
	use sf_circe2
	use sf_pdf_builtin
	use sf_lhapdf

	<<Standard module head>>

	<<Dispatch beams: public>>

	<<Dispatch beams: types>>

	<<Dispatch beams: variables>>

	contains

	<<Dispatch beams: procedures>>

	end module dispatch_beams
	@ %def dispatch_beams
	@ This data type is a container for transferring structure-function
	specific data from the [[dispatch_sf_data]] to the
	[[dispatch_sf_channels]] subroutine.
	<<Dispatch beams: public>>=
	public :: sf_prop_t
	<<Dispatch beams: types>>=
	type :: sf_prop_t
	real(default), dimension(2) :: isr_eps = 1
	end type sf_prop_t

	@ %def sf_prop_t
	@
	Allocate a structure-function configuration object according to the
	[[sf_method]] string.

	The [[sf_prop]] object can be used to transfer structure-function
	specific data up and to the [[dispatch_sf_channels]] subroutine below,
	so they can be used for particular mappings.

	The [[var_list_global]] object is used for the RNG generator seed.
	It is intent(inout) because the RNG generator seed
	may change during initialization.

	The [[pdg_in]] array is the array of incoming flavors, corresponding
	to the upstream structure function or the beam array. This will be
	checked for the structure function in question and replaced by the
	outgoing flavors. The [[pdg_prc]] array is the array of incoming
	flavors (beam index, component index) for the hard process.
	<<Dispatch beams: public>>=
	public :: dispatch_sf_data
	<<Dispatch beams: procedures>>=
	subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, &
	var_list, var_list_global, model, &
	os_data, sqrts, pdg_in, pdg_prc, polarized)
	class(sf_data_t), allocatable, intent(inout) :: data
	type(string_t), intent(in) :: sf_method
	integer, dimension(:), intent(in) :: i_beam
	type(pdg_array_t), dimension(:), intent(inout) :: pdg_in
	type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
	type(sf_prop_t), intent(inout) :: sf_prop
	type(var_list_t), intent(in) :: var_list
	type(var_list_t), intent(inout) :: var_list_global
	integer :: next_rng_seed
	class(model_data_t), target, intent(in) :: model
	type(os_data_t), intent(in) :: os_data
	real(default), intent(in) :: sqrts
	logical, intent(in) :: polarized
	type(pdg_array_t), dimension(:), allocatable :: pdg_out
	real(default) :: isr_alpha, isr_q_max, isr_mass
	integer :: isr_order
	logical :: isr_recoil, isr_keep_energy
	real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass
	logical :: epa_recoil, epa_keep_energy
	integer :: epa_int_mode
	type(string_t) :: epa_mode
	real(default) :: ewa_x_min, ewa_pt_max, ewa_mass
	logical :: ewa_recoil, ewa_keep_energy
	type(pdg_array_t), dimension(:), allocatable :: pdg_prc1
	integer :: ewa_id
	type(string_t) :: pdf_name
	type(string_t) :: lhapdf_dir, lhapdf_file
	type(string_t), dimension(13) :: lhapdf_photon_sets
	integer :: lhapdf_member, lhapdf_photon_scheme
	logical :: hoppet_b_matching
	class(rng_factory_t), allocatable :: rng_factory
	logical :: circe1_photon1, circe1_photon2, circe1_generate, &
	circe1_with_radiation
	real(default) :: circe1_sqrts, circe1_eps
	integer :: circe1_version, circe1_chattiness, &
	circe1_revision
	character(6) :: circe1_accelerator
	logical :: circe2_polarized
	type(string_t) :: circe2_design, circe2_file
	real(default), dimension(2) :: gaussian_spread
	logical :: beam_events_warn_eof
	type(string_t) :: beam_events_dir, beam_events_file
	logical :: escan_normalize
	integer :: i
	lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), &
	var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), &
	var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), &
	var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), &
	var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), &
	var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), &
	var_str ("SASG.LHgrid")]
	select case (char (sf_method))
	case ("pdf_builtin")
	allocate (pdf_builtin_data_t :: data)
	select type (data)
	type is (pdf_builtin_data_t)
	pdf_name = &
	var_list%get_sval (var_str ("$pdf_builtin_set"))
	hoppet_b_matching = &
	var_list%get_lval (var_str ("?hoppet_b_matching"))
	call data%init ( &
	model, pdg_in(i_beam(1)), &
	name = pdf_name, &
	path = os_data%pdf_builtin_datapath, &
	hoppet_b_matching = hoppet_b_matching)
	end select
	case ("pdf_builtin_photon")
	call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", &
	[var_str ("for the photon content inside a proton or neutron use"), &
	var_str ("the 'lhapdf_photon' structure function.")])
	case ("lhapdf")
	allocate (lhapdf_data_t :: data)
	- if (pdg_array_get (pdg_in(i_beam(1)), 1) == PHOTON) then
	+ if (pdg_in(i_beam(1))%get (1) == PHOTON) then
	call msg_fatal ("The 'lhapdf' structure is intended only for protons and", &
	[var_str ("pions, please use 'lhapdf_photon' for photon beams.")])
	end if
	lhapdf_dir = &
	var_list%get_sval (var_str ("$lhapdf_dir"))
	lhapdf_file = &
	var_list%get_sval (var_str ("$lhapdf_file"))
	lhapdf_member = &
	var_list%get_ival (var_str ("lhapdf_member"))
	lhapdf_photon_scheme = &
	var_list%get_ival (var_str ("lhapdf_photon_scheme"))
	hoppet_b_matching = &
	var_list%get_lval (var_str ("?hoppet_b_matching"))
	select type (data)
	type is (lhapdf_data_t)
	call data%init &
	(model, pdg_in(i_beam(1)), &
	lhapdf_dir, lhapdf_file, lhapdf_member, &
	lhapdf_photon_scheme, hoppet_b_matching)
	end select
	case ("lhapdf_photon")
	allocate (lhapdf_data_t :: data)
	- if (pdg_array_get_length (pdg_in(i_beam(1))) /= 1 .or. &
	- pdg_array_get (pdg_in(i_beam(1)), 1) /= PHOTON) then
	+ if (pdg_in(i_beam(1))%get_length () /= 1 .or. &
	+ pdg_in(i_beam(1))%get (1) /= PHOTON) then
	call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", &
	[var_str ("photon PDFs, i.e. for photons as beam particles")])
	end if
	lhapdf_dir = &
	var_list%get_sval (var_str ("$lhapdf_dir"))
	lhapdf_file = &
	var_list%get_sval (var_str ("$lhapdf_photon_file"))
	lhapdf_member = &
	var_list%get_ival (var_str ("lhapdf_member"))
	lhapdf_photon_scheme = &
	var_list%get_ival (var_str ("lhapdf_photon_scheme"))
	if (.not. any (lhapdf_photon_sets == lhapdf_file)) then
	call msg_fatal ("This PDF set is not supported or not " // &
	"intended for photon beams.")
	end if
	select type (data)
	type is (lhapdf_data_t)
	call data%init &
	(model, pdg_in(i_beam(1)), &
	lhapdf_dir, lhapdf_file, lhapdf_member, &
	lhapdf_photon_scheme)
	end select
	case ("isr")
	allocate (isr_data_t :: data)
	isr_alpha = &
	var_list%get_rval (var_str ("isr_alpha"))
	if (vanishes (isr_alpha)) then
	isr_alpha = (var_list%get_rval (var_str ("ee"))) &
	** 2 / (4 * PI)
	end if
	isr_q_max = &
	var_list%get_rval (var_str ("isr_q_max"))
	if (vanishes (isr_q_max)) then
	isr_q_max = sqrts
	end if
	isr_mass = var_list%get_rval (var_str ("isr_mass"))
	isr_order = var_list%get_ival (var_str ("isr_order"))
	isr_recoil = var_list%get_lval (var_str ("?isr_recoil"))
	isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy"))
	select type (data)
	type is (isr_data_t)
	call data%init &
	(model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, &
	isr_mass, isr_order, recoil = isr_recoil, keep_energy = &
	isr_keep_energy)
	call data%check ()
	sf_prop%isr_eps(i_beam(1)) = data%get_eps ()
	end select
	case ("epa")
	allocate (epa_data_t :: data)
	epa_mode = var_list%get_sval (var_str ("$epa_mode"))
	epa_int_mode = 0
	epa_alpha = var_list%get_rval (var_str ("epa_alpha"))
	if (vanishes (epa_alpha)) then
	epa_alpha = (var_list%get_rval (var_str ("ee"))) &
	** 2 / (4 * PI)
	end if
	epa_x_min = var_list%get_rval (var_str ("epa_x_min"))
	epa_q_min = var_list%get_rval (var_str ("epa_q_min"))
	epa_q_max = var_list%get_rval (var_str ("epa_q_max"))
	if (vanishes (epa_q_max)) then
	epa_q_max = sqrts
	end if
	select case (char (epa_mode))
	case ("default", "Budnev_617")
	epa_int_mode = 0
	case ("Budnev_616e")
	epa_int_mode = 1
	case ("log_power")
	epa_int_mode = 2
	epa_q_max = sqrts
	case ("log_simple")
	epa_int_mode = 3
	epa_q_max = sqrts
	case ("log")
	epa_int_mode = 4
	epa_q_max = sqrts
	case default
	call msg_fatal ("EPA: unsupported EPA mode; please choose " // &
	"'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // &
	"'log_simple', or 'log'")
	end select
	epa_mass = var_list%get_rval (var_str ("epa_mass"))
	epa_recoil = var_list%get_lval (var_str ("?epa_recoil"))
	epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy"))
	select type (data)
	type is (epa_data_t)
	call data%init &
	(model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, &
	epa_x_min, epa_q_min, epa_q_max, epa_mass, &
	recoil = epa_recoil, keep_energy = epa_keep_energy)
	call data%check ()
	end select
	case ("ewa")
	allocate (ewa_data_t :: data)
	allocate (pdg_prc1 (size (pdg_prc, 2)))
	pdg_prc1 = pdg_prc(i_beam(1),:)
	- if (any (pdg_array_get_length (pdg_prc1) /= 1) &
	+ if (any (pdg_prc1%get_length () /= 1) &
	.or. any (pdg_prc1 /= pdg_prc1(1))) then
	call msg_fatal &
	("EWA: process incoming particle (W/Z) must be unique")
	end if
	- ewa_id = abs (pdg_array_get (pdg_prc1(1), 1))
	+ ewa_id = abs (pdg_prc1(1)%get (1))
	ewa_x_min = var_list%get_rval (var_str ("ewa_x_min"))
	ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max"))
	if (vanishes (ewa_pt_max)) then
	ewa_pt_max = sqrts
	end if
	ewa_mass = var_list%get_rval (var_str ("ewa_mass"))
	ewa_recoil = var_list%get_lval (&
	var_str ("?ewa_recoil"))
	ewa_keep_energy = var_list%get_lval (&
	var_str ("?ewa_keep_energy"))
	select type (data)
	type is (ewa_data_t)
	call data%init &
	(model, pdg_in (i_beam(1)), ewa_x_min, &
	ewa_pt_max, sqrts, ewa_recoil, &
	ewa_keep_energy, ewa_mass)
	call data%set_id (ewa_id)
	call data%check ()
	end select
	case ("circe1")
	allocate (circe1_data_t :: data)
	select type (data)
	type is (circe1_data_t)
	circe1_photon1 = &
	var_list%get_lval (var_str ("?circe1_photon1"))
	circe1_photon2 = &
	var_list%get_lval (var_str ("?circe1_photon2"))
	circe1_sqrts = &
	var_list%get_rval (var_str ("circe1_sqrts"))
	circe1_eps = &
	var_list%get_rval (var_str ("circe1_eps"))
	if (circe1_sqrts <= 0) circe1_sqrts = sqrts
	circe1_generate = &
	var_list%get_lval (var_str ("?circe1_generate"))
	circe1_version = &
	var_list%get_ival (var_str ("circe1_ver"))
	circe1_revision = &
	var_list%get_ival (var_str ("circe1_rev"))
	circe1_accelerator = &
	char (var_list%get_sval (var_str ("$circe1_acc")))
	circe1_chattiness = &
	var_list%get_ival (var_str ("circe1_chat"))
	circe1_with_radiation = &
	var_list%get_lval (var_str ("?circe1_with_radiation"))
	call data%init (model, pdg_in, circe1_sqrts, circe1_eps, &
	[circe1_photon1, circe1_photon2], &
	circe1_version, circe1_revision, circe1_accelerator, &
	circe1_chattiness, circe1_with_radiation)
	if (circe1_generate) then
	call msg_message ("CIRCE1: activating generator mode")
	call dispatch_rng_factory &
	(rng_factory, var_list_global, next_rng_seed)
	call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
	call data%set_generator_mode (rng_factory)
	end if
	end select
	case ("circe2")
	allocate (circe2_data_t :: data)
	select type (data)
	type is (circe2_data_t)
	circe2_polarized = &
	var_list%get_lval (var_str ("?circe2_polarized"))
	circe2_file = &
	var_list%get_sval (var_str ("$circe2_file"))
	circe2_design = &
	var_list%get_sval (var_str ("$circe2_design"))
	call data%init (os_data, model, pdg_in, sqrts, &
	circe2_polarized, polarized, circe2_file, circe2_design)
	call msg_message ("CIRCE2: activating generator mode")
	call dispatch_rng_factory &
	(rng_factory, var_list_global, next_rng_seed)
	call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
	call data%set_generator_mode (rng_factory)
	end select
	case ("gaussian")
	allocate (gaussian_data_t :: data)
	select type (data)
	type is (gaussian_data_t)
	gaussian_spread = &
	[var_list%get_rval (var_str ("gaussian_spread1")), &
	var_list%get_rval (var_str ("gaussian_spread2"))]
	call dispatch_rng_factory &
	(rng_factory, var_list_global, next_rng_seed)
	call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
	call data%init (model, pdg_in, gaussian_spread, rng_factory)
	end select
	case ("beam_events")
	allocate (beam_events_data_t :: data)
	select type (data)
	type is (beam_events_data_t)
	beam_events_dir = os_data%whizard_beamsimpath
	beam_events_file = var_list%get_sval (&
	var_str ("$beam_events_file"))
	beam_events_warn_eof = var_list%get_lval (&
	var_str ("?beam_events_warn_eof"))
	call data%init (model, pdg_in, &
	beam_events_dir, beam_events_file, beam_events_warn_eof)
	end select
	case ("energy_scan")
	escan_normalize = &
	var_list%get_lval (var_str ("?energy_scan_normalize"))
	allocate (escan_data_t :: data)
	select type (data)
	type is (escan_data_t)
	if (escan_normalize) then
	call data%init (model, pdg_in)
	else
	call data%init (model, pdg_in, sqrts)
	end if
	end select
	case default
	if (associated (dispatch_sf_data_extra)) then
	call dispatch_sf_data_extra (data, sf_method, i_beam, &
	sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, &
	pdg_prc, polarized)
	end if
	if (.not. allocated (data)) then
	call msg_fatal ("Structure function '" &
	// char (sf_method) // "' not implemented")
	end if
	end select
	if (allocated (data)) then
	allocate (pdg_out (size (pdg_prc, 1)))
	call data%get_pdg_out (pdg_out)
	do i = 1, size (i_beam)
	pdg_in(i_beam(i)) = pdg_out(i)
	end do
	end if
	end subroutine dispatch_sf_data

	@ %def dispatch_sf_data
	@ This is a hook that allows us to inject further handlers for
	structure-function objects, in particular a test structure function.
	<<Dispatch beams: public>>=
	public :: dispatch_sf_data_extra
	<<Dispatch beams: variables>>=
	procedure (dispatch_sf_data), pointer :: &
	dispatch_sf_data_extra => null ()
	@ %def dispatch_sf_data_extra
	@ This is an auxiliary procedure, used by the beam-structure
	expansion: tell for a given structure function name, whether it
	corresponds to a pair spectrum ($n=2$), a single-particle structure
	function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can
	in principle also be a pair spectrum, it always has only one
	parameter.
	<<Dispatch beams: public>>=
	public :: strfun_mode
	<<Dispatch beams: procedures>>=
	function strfun_mode (name) result (n)
	type(string_t), intent(in) :: name
	integer :: n
	select case (char (name))
	case ("none")
	n = 0
	case ("sf_test_0", "sf_test_1")
	n = 1
	case ("pdf_builtin","pdf_builtin_photon", &
	"lhapdf","lhapdf_photon")
	n = 1
	case ("isr","epa","ewa")
	n = 1
	case ("circe1", "circe2")
	n = 2
	case ("gaussian")
	n = 2
	case ("beam_events")
	n = 2
	case ("energy_scan")
	n = 2
	case default
	n = -1
	call msg_bug ("Structure function '" // char (name) &
	// "' not supported yet")
	end select
	end function strfun_mode

	@ %def strfun_mode
	@ Dispatch a whole structure-function chain, given beam data and beam
	structure data.

	This could be done generically, but we should look at the specific
	combination of structure functions in order to select appropriate mappings.

	The [[beam_structure]] argument gets copied because
	we want to expand it to canonical form (one valid structure-function
	entry per record) before proceeding further.

	The [[pdg_prc]] argument is the array of incoming flavors. The first
	index is the beam index, the second one the process component index.
	Each element is itself a PDG array, notrivial if there is a flavor sum
	for the incoming state of this component.

	The dispatcher is divided in two parts. The first part configures the
	structure function data themselves. After this, we can configure the
	phase space for the elementary process.
	<<Dispatch beams: public>>=
	public :: dispatch_sf_config
	<<Dispatch beams: procedures>>=
	subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, &
	var_list, var_list_global, model, os_data, sqrts, pdg_prc)
	type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config
	type(sf_prop_t), intent(out) :: sf_prop
	type(beam_structure_t), intent(inout) :: beam_structure
	type(var_list_t), intent(in) :: var_list
	type(var_list_t), intent(inout) :: var_list_global
	class(model_data_t), target, intent(in) :: model
	type(os_data_t), intent(in) :: os_data
	real(default), intent(in) :: sqrts
	class(sf_data_t), allocatable :: sf_data
	type(beam_structure_t) :: beam_structure_tmp
	type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
	type(string_t), dimension(:), allocatable :: prt_in
	type(pdg_array_t), dimension(:), allocatable :: pdg_in
	type(flavor_t) :: flv_in
	integer :: n_beam, n_record, i
	beam_structure_tmp = beam_structure
	call beam_structure_tmp%expand (strfun_mode)
	n_record = beam_structure_tmp%get_n_record ()
	allocate (sf_config (n_record))
	n_beam = beam_structure_tmp%get_n_beam ()
	if (n_beam > 0) then
	allocate (prt_in (n_beam), pdg_in (n_beam))
	prt_in = beam_structure_tmp%get_prt ()
	do i = 1, n_beam
	call flv_in%init (prt_in(i), model)
	pdg_in(i) = flv_in%get_pdg ()
	end do
	else
	n_beam = size (pdg_prc, 1)
	allocate (pdg_in (n_beam))
	pdg_in = pdg_prc(:,1)
	end if
	do i = 1, n_record
	call dispatch_sf_data (sf_data, &
	beam_structure_tmp%get_name (i), &
	beam_structure_tmp%get_i_entry (i), &
	sf_prop, var_list, var_list_global, model, os_data, sqrts, &
	pdg_in, pdg_prc, &
	beam_structure_tmp%polarized ())
	call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data)
	deallocate (sf_data)
	end do
	end subroutine dispatch_sf_config

	@ %def dispatch_sf_config
	@
	\subsection{QCD and QED coupling}
	Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with
	a concrete implementation, depending on the variable settings in the
	[[global]] record.

	If a fixed $\alpha_s$ is requested, we do not allocate the
	[[qcd%alpha]] object. In this case, the matrix element code will just take
	the model parameter as-is, which implies fixed $\alpha_s$. If the
	object is allocated, the $\alpha_s$ value is computed and updated for
	each matrix-element call.

	Also fetch the [[alphas_nf]] variable from the list and store it in
	the QCD record. This is not used in the $\alpha_s$ calculation, but
	the QCD record thus becomes a messenger for this user parameter.
	<<Dispatch beams: public>>=
	public :: dispatch_qcd
	<<Dispatch beams: procedures>>=
	subroutine dispatch_qcd (qcd, var_list, os_data)
	type(qcd_t), intent(inout) :: qcd
	type(var_list_t), intent(in) :: var_list
	type(os_data_t), intent(in) :: os_data
	logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd
	real(default) :: mz, alpha_val, lambda
	integer :: nf, order, lhapdf_member
	type(string_t) :: pdfset, lhapdf_dir, lhapdf_file
	call unpack_variables ()
	if (allocated (qcd%alpha)) deallocate (qcd%alpha)
	if (from_lhapdf .and. from_pdf_builtin) then
	call msg_fatal (" Mixing alphas evolution", &
	[var_str (" from LHAPDF and builtin PDF is not permitted")])
	end if
	select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd]))
	case (0)
	if (fixed) then
	allocate (alpha_qcd_fixed_t :: qcd%alpha)
	else
	call msg_fatal ("QCD alpha: no calculation mode set")
	end if
	case (2:)
	call msg_fatal ("QCD alpha: calculation mode is ambiguous")
	case (1)
	if (fixed) then
	call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // &
	"running alphas")
	else if (from_mz) then
	allocate (alpha_qcd_from_scale_t :: qcd%alpha)
	else if (from_pdf_builtin) then
	allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
	else if (from_lhapdf) then
	allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
	else if (from_lambda_qcd) then
	allocate (alpha_qcd_from_lambda_t :: qcd%alpha)
	end if
	call msg_message ("QCD alpha: using a running strong coupling")
	end select
	call init_alpha ()
	qcd%n_f = var_list%get_ival (var_str ("alphas_nf"))
	contains
	<<Dispatch qcd: dispatch qcd: procedures>>
	end subroutine dispatch_qcd

	@ %def dispatch_qcd
	@
	<<Dispatch qcd: dispatch qcd: procedures>>=
	subroutine unpack_variables ()
	fixed = var_list%get_lval (var_str ("?alphas_is_fixed"))
	from_mz = var_list%get_lval (var_str ("?alphas_from_mz"))
	from_pdf_builtin = &
	var_list%get_lval (var_str ("?alphas_from_pdf_builtin"))
	from_lhapdf = &
	var_list%get_lval (var_str ("?alphas_from_lhapdf"))
	from_lambda_qcd = &
	var_list%get_lval (var_str ("?alphas_from_lambda_qcd"))
	pdfset = var_list%get_sval (var_str ("$pdf_builtin_set"))
	lambda = var_list%get_rval (var_str ("lambda_qcd"))
	nf = var_list%get_ival (var_str ("alphas_nf"))
	order = var_list%get_ival (var_str ("alphas_order"))
	lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir"))
	lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file"))
	lhapdf_member = var_list%get_ival (var_str ("lhapdf_member"))
	if (var_list%contains (var_str ("mZ"))) then
	mz = var_list%get_rval (var_str ("mZ"))
	else
	mz = MZ_REF
	end if
	if (var_list%contains (var_str ("alphas"))) then
	alpha_val = var_list%get_rval (var_str ("alphas"))
	else
	alpha_val = ALPHA_QCD_MZ_REF
	end if
	end subroutine unpack_variables

	@
	<<Dispatch qcd: dispatch qcd: procedures>>=
	subroutine init_alpha ()
	select type (alpha => qcd%alpha)
	type is (alpha_qcd_fixed_t)
	alpha%val = alpha_val
	type is (alpha_qcd_from_scale_t)
	alpha%mu_ref = mz
	alpha%ref = alpha_val
	alpha%order = order
	alpha%nf = nf
	type is (alpha_qcd_from_lambda_t)
	alpha%lambda = lambda
	alpha%order = order
	alpha%nf = nf
	type is (alpha_qcd_pdf_builtin_t)
	call alpha%init (pdfset, &
	os_data%pdf_builtin_datapath)
	type is (alpha_qcd_lhapdf_t)
	call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir)
	end select
	end subroutine init_alpha

	@
	@ Same for QED.
	<<Dispatch beams: public>>=
	public :: dispatch_qed
	<<Dispatch beams: procedures>>=
	subroutine dispatch_qed (qed, var_list)
	type(qed_t), intent(inout) :: qed
	type(var_list_t), intent(in) :: var_list
	logical :: fixed, from_me, analytic
	real(default) :: me, alpha_val
	integer :: nf, nlep, order
	call unpack_variables ()
	if (allocated (qed%alpha)) deallocate (qed%alpha)
	select case (count ([from_me]))
	case (0)
	if (fixed) then
	allocate (alpha_qed_fixed_t :: qed%alpha)
	else
	call msg_fatal ("QED alpha: no calculation mode set")
	end if
	case (2:)
	call msg_fatal ("QED alpha: calculation mode is ambiguous")
	case (1)
	if (fixed) then
	call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // &
	"running alpha")
	else if (from_me) then
	allocate (alpha_qed_from_scale_t :: qed%alpha)
	end if
	call msg_message ("QED alpha: using a running electromagnetic coupling")
	end select
	call init_alpha ()
	if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
	qed%n_f = var_list%get_ival (var_str ("alphas_nf"))
	else
	qed%n_f = var_list%get_ival (var_str ("alpha_nf"))
	end if
	qed%n_lep = var_list%get_ival (var_str ("alpha_nlep"))
	contains
	<<Dispatch qed: dispatch qed: procedures>>
	end subroutine dispatch_qed

	@ %def dispatch_qed
	@
	<<Dispatch qed: dispatch qed: procedures>>=
	subroutine unpack_variables ()
	fixed = var_list%get_lval (var_str ("?alpha_is_fixed"))
	from_me = var_list%get_lval (var_str ("?alpha_from_me"))
	if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
	nf = var_list%get_ival (var_str ("alphas_nf"))
	else
	nf = var_list%get_ival (var_str ("alpha_nf"))
	end if
	analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic"))
	nlep = var_list%get_ival (var_str ("alpha_nlep"))
	order = var_list%get_ival (var_str ("alpha_order"))
	if (var_list%contains (var_str ("me"))) then
	me = var_list%get_rval (var_str ("me"))
	else
	me = ME_REF
	end if
	if (var_list%contains (var_str ("alpha_em_i"))) then
	alpha_val = one / var_list%get_rval (var_str ("alpha_em_i"))
	else
	alpha_val = ALPHA_QED_ME_REF
	end if
	end subroutine unpack_variables

	@
	<<Dispatch qed: dispatch qed: procedures>>=
	subroutine init_alpha ()
	select type (alpha => qed%alpha)
	type is (alpha_qed_fixed_t)
	alpha%val = alpha_val
	type is (alpha_qed_from_scale_t)
	alpha%mu_ref = me
	alpha%ref = alpha_val
	alpha%order = order
	alpha%nf = nf
	alpha%nlep = nlep
	alpha%analytic = analytic
	end select
	end subroutine init_alpha

	@

File Metadata

Mime Type: application/octet-stream
Expires: Mon, Apr 29, 3:59 AM (1 d, 23 h)
Storage Engine: chunks
Storage Format: Chunks
Storage Handle: mMKbmV2edgQ9
Default Alt Text: (4 MB)

Offset	End	Complete
0	4194304	Yes
4194304	4439697	Yes

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions