whizard.attic.nw
No OneTemporary
Actions

Size

1 MB

Subscribers

None

whizard.attic.nw
View Options

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

	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% This file temporarily holds stuff that has been removed from
	% the main file whizard.nw, but may still be reused in part before
	% the obsolete parts are deleted.
	@
	\chapter{Particles and Event Formats}
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Event formats}
	This section provides the interface to event formats for user-defined
	processes, specifically the Les Houches Accord format and the HEPEVT format.

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

	module event_formats

	<<Use kinds>>
	use kinds, only: i32, i64 !NODEP!
	use constants, only: pb_per_fb !NODEP!
	<<Use file utils>>
	use lorentz !NODEP!
	use subevents
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use polarizations
	use stdhep_interface
	use diagnostics !NODEP!
	<<Use strings>>

	<<Standard module head>>

	<<Event formats: public>>

	<<Event formats: parameters>>

	<<Event formats: variables>>

	<<Event formats: common blocks>>

	<<Event formats: interfaces>>

	contains

	<<Event formats: procedures>>

	end module event_formats
	@ %def event_formats
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{HepMC events}
	This section provides the interface to the HepMC C++ library for handling
	Monte-Carlo events.

	Each C++ class of HepMC that we use is mirrored by a Fortran type,
	which contains as its only component the C pointer to the C++ object.

	Each C++ method of HepMC that we use has a C wrapper function. This
	function takes a pointer to the host object as its first argument.
	Further arguments are either C pointers, or in the case of simple
	types (integer, real), interoperable C/Fortran objects.

	The C wrapper functions have explicit interfaces in the Fortran
	module. They are called by Fortran wrapper procedures. These are
	treated as methods of the corresponding Fortran type.
	<<[[hepmc_interface.f90]]>>=
	<<File header>>

	module hepmc_interface

	use iso_c_binding !NODEP!
	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	use lorentz !NODEP!
	use models
	use flavors
	use colors
	use helicities
	use quantum_numbers
	use polarizations

	<<Standard module head>>

	<<HepMC interface: public>>

	<<HepMC interface: types>>

	<<HepMC interface: interfaces>>

	contains

	<<HepMC interface: procedures>>

	end module hepmc_interface
	@ %def hepmc_interface
	@
	\subsection{Interface check}
	This function can be called in order to verify that we are using the
	actual HepMC library, and not the dummy version.
	<<HepMC interface: interfaces>>=
	interface
	logical(c_bool) function hepmc_available () bind(C)
	import
	end function hepmc_available
	end interface
	<<HepMC interface: public>>=
	public :: hepmc_is_available
	<<HepMC interface: procedures>>=
	function hepmc_is_available () result (flag)
	logical :: flag
	flag = hepmc_available ()
	end function hepmc_is_available

	@ %def hepmc_is_available
	@
	\subsection{FourVector}
	The C version of four-vectors is often transferred by value, and the
	associated procedures are all inlined. The wrapper needs to transfer
	by reference, so we create FourVector objects on the heap which have
	to be deleted explicitly. The input is a [[vector4_t]] or
	[[vector3_t]] object from the [[lorentz]] module.
	<<HepMC interface: public>>=
	public :: hepmc_four_vector_t
	<<HepMC interface: types>>=
	type :: hepmc_four_vector_t
	private
	type(c_ptr) :: obj
	end type hepmc_four_vector_t

	@ %def hepmc_four_vector_t
	@ In the C constructor, the zero-component (fourth argument) is
	optional; if missing, it is set to zero. The Fortran version has
	initializer form and takes either a three-vector or a four-vector.
	A further version extracts the four-vector from a HepMC particle
	object.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_four_vector_xyz (x, y, z) bind(C)
	import
	real(c_double), value :: x, y, z
	end function new_four_vector_xyz
	end interface
	interface
	type(c_ptr) function new_four_vector_xyzt (x, y, z, t) bind(C)
	import
	real(c_double), value :: x, y, z, t
	end function new_four_vector_xyzt
	end interface
	@ %def new_four_vector_xyz new_four_vector_xyzt
	<<HepMC interface: public>>=
	public :: hepmc_four_vector_init
	<<HepMC interface: interfaces>>=
	interface hepmc_four_vector_init
	module procedure hepmc_four_vector_init_v4
	module procedure hepmc_four_vector_init_v3
	module procedure hepmc_four_vector_init_hepmc_prt
	end interface
	<<HepMC interface: procedures>>=
	subroutine hepmc_four_vector_init_v4 (pp, p)
	type(hepmc_four_vector_t), intent(out) :: pp
	type(vector4_t), intent(in) :: p
	real(default), dimension(0:3) :: pa
	pa = vector4_get_components (p)
	pp%obj = new_four_vector_xyzt &
	(real (pa(1), c_double), &
	real (pa(2), c_double), &
	real (pa(3), c_double), &
	real (pa(0), c_double))
	end subroutine hepmc_four_vector_init_v4

	subroutine hepmc_four_vector_init_v3 (pp, p)
	type(hepmc_four_vector_t), intent(out) :: pp
	type(vector3_t), intent(in) :: p
	real(default), dimension(3) :: pa
	pa = vector3_get_components (p)
	pp%obj = new_four_vector_xyz &
	(real (pa(1), c_double), &
	real (pa(2), c_double), &
	real (pa(3), c_double))
	end subroutine hepmc_four_vector_init_v3

	subroutine hepmc_four_vector_init_hepmc_prt (pp, prt)
	type(hepmc_four_vector_t), intent(out) :: pp
	type(hepmc_particle_t), intent(in) :: prt
	pp%obj = gen_particle_momentum (prt%obj)
	end subroutine hepmc_four_vector_init_hepmc_prt

	@ %def hepmc_four_vector_init
	@ Here, the destructor is explicitly needed.
	<<HepMC interface: interfaces>>=
	interface
	subroutine four_vector_delete (p_obj) bind(C)
	import
	type(c_ptr), value :: p_obj
	end subroutine four_vector_delete
	end interface
	@ %def four_vector_delete
	<<HepMC interface: public>>=
	public :: hepmc_four_vector_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_four_vector_final (p)
	type(hepmc_four_vector_t), intent(inout) :: p
	call four_vector_delete (p%obj)
	end subroutine hepmc_four_vector_final

	@ %def hepmc_four_vector_final
	@ Convert to a Lorentz vector.
	<<HepMC interface: interfaces>>=
	interface
	function four_vector_px (p_obj) result (px) bind(C)
	import
	real(c_double) :: px
	type(c_ptr), value :: p_obj
	end function four_vector_px
	end interface
	interface
	function four_vector_py (p_obj) result (py) bind(C)
	import
	real(c_double) :: py
	type(c_ptr), value :: p_obj
	end function four_vector_py
	end interface
	interface
	function four_vector_pz (p_obj) result (pz) bind(C)
	import
	real(c_double) :: pz
	type(c_ptr), value :: p_obj
	end function four_vector_pz
	end interface
	interface
	function four_vector_e (p_obj) result (e) bind(C)
	import
	real(c_double) :: e
	type(c_ptr), value :: p_obj
	end function four_vector_e
	end interface
	@ %def four_vector_px four_vector_py four_vector_pz four_vector_e
	<<HepMC interface: public>>=
	public :: hepmc_four_vector_to_vector4
	<<HepMC interface: procedures>>=
	subroutine hepmc_four_vector_to_vector4 (pp, p)
	type(hepmc_four_vector_t), intent(in) :: pp
	type(vector4_t), intent(out) :: p
	real(default) :: E
	real(default), dimension(3) :: p3
	E = four_vector_e (pp%obj)
	p3(1) = four_vector_px (pp%obj)
	p3(2) = four_vector_py (pp%obj)
	p3(3) = four_vector_pz (pp%obj)
	p = vector4_moving (E, vector3_moving (p3))
	end subroutine hepmc_four_vector_to_vector4

	@ %def hepmc_four_vector_to_vector4
	@
	\subsection{Polarization}
	Polarization objects are temporarily used for assigning particle
	polarization. We add a flag [[polarized]]. If this is false, the
	polarization is not set and should not be transferred to
	[[hepmc_particle]] objects.
	<<HepMC interface: public>>=
	public :: hepmc_polarization_t
	<<HepMC interface: types>>=
	type :: hepmc_polarization_t
	private
	logical :: polarized = .false.
	type(c_ptr) :: obj
	end type hepmc_polarization_t

	@ %def hepmc_polarization_t
	@ Constructor. The C wrapper takes polar and azimuthal angle as
	arguments. The Fortran version allows for either a complete
	polarization density matrix, or for a definite (diagonal) helicity.

	\emph{HepMC does not allow to specify the degree of polarization,
	therefore we have to map it to either 0 or 1. We choose 0 for
	polarization less than $0.5$ and 1 for polarization greater than
	$0.5$. Even this simplification works only for spin-1/2 and for
	massless particles; massive vector bosons cannot be treated this
	way. In particular, zero helicity is always translated as
	unpolarized.}
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_polarization (theta, phi) bind(C)
	import
	real(c_double), value :: theta, phi
	end function new_polarization
	end interface
	@ %def new_polarization
	<<HepMC interface: public>>=
	public :: hepmc_polarization_init
	<<HepMC interface: interfaces>>=
	interface hepmc_polarization_init
	module procedure hepmc_polarization_init_pol
	module procedure hepmc_polarization_init_hel
	end interface
	<<HepMC interface: procedures>>=
	subroutine hepmc_polarization_init_pol (hpol, pol)
	type(hepmc_polarization_t), intent(out) :: hpol
	type(polarization_t), intent(in) :: pol
	real(default) :: r, theta, phi
	if (polarization_is_polarized (pol)) then
	call polarization_to_angles (pol, r, theta, phi)
	if (r >= 0.5) then
	hpol%polarized = .true.
	hpol%obj = new_polarization &
	(real (theta, c_double), real (phi, c_double))
	end if
	end if
	end subroutine hepmc_polarization_init_pol

	subroutine hepmc_polarization_init_hel (hpol, hel)
	type(hepmc_polarization_t), intent(out) :: hpol
	type(helicity_t), intent(in) :: hel
	integer, dimension(2) :: h
	if (helicity_is_defined (hel)) then
	h = helicity_get (hel)
	select case (h(1))
	case (1:)
	hpol%polarized = .true.
	hpol%obj = new_polarization (0._c_double, 0._c_double)
	case (:-1)
	hpol%polarized = .true.
	hpol%obj = new_polarization (real (pi, c_double), 0._c_double)
	end select
	end if
	end subroutine hepmc_polarization_init_hel

	@ %def hepmc_polarization_init
	@ Destructor. The C object is deallocated only if the [[polarized]]
	flag is set.
	<<HepMC interface: interfaces>>=
	interface
	subroutine polarization_delete (pol_obj) bind(C)
	import
	type(c_ptr), value :: pol_obj
	end subroutine polarization_delete
	end interface
	@ %def polarization_delete
	<<HepMC interface: public>>=
	public :: hepmc_polarization_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_polarization_final (hpol)
	type(hepmc_polarization_t), intent(inout) :: hpol
	if (hpol%polarized) call polarization_delete (hpol%obj)
	end subroutine hepmc_polarization_final

	@ %def hepmc_polarization_final
	@ Recover polarization from HepMC polarization object (with the
	abovementioned deficiencies).
	<<HepMC interface: interfaces>>=
	interface
	function polarization_theta (pol_obj) result (theta) bind(C)
	import
	real(c_double) :: theta
	type(c_ptr), value :: pol_obj
	end function polarization_theta
	end interface
	interface
	function polarization_phi (pol_obj) result (phi) bind(C)
	import
	real(c_double) :: phi
	type(c_ptr), value :: pol_obj
	end function polarization_phi
	end interface
	@ %def polarization_theta polarization_phi
	<<HepMC interface: public>>=
	public :: hepmc_polarization_to_pol
	<<HepMC interface: procedures>>=
	subroutine hepmc_polarization_to_pol (hpol, flv, pol)
	type(hepmc_polarization_t), intent(in) :: hpol
	type(flavor_t), intent(in) :: flv
	type(polarization_t), intent(out) :: pol
	real(default) :: theta, phi
	theta = polarization_theta (hpol%obj)
	phi = polarization_phi (hpol%obj)
	call polarization_init_angles (pol, flv, 1._default, theta, phi)
	end subroutine hepmc_polarization_to_pol

	@ %def hepmc_polarization_to_pol
	@ Recover helicity. Here, $\phi$ is ignored and only the sign of
	$\cos\theta$ is relevant, mapped to positive/negative helicity.
	<<HepMC interface: public>>=
	public :: hepmc_polarization_to_hel
	<<HepMC interface: procedures>>=
	subroutine hepmc_polarization_to_hel (hpol, flv, hel)
	type(hepmc_polarization_t), intent(in) :: hpol
	type(flavor_t), intent(in) :: flv
	type(helicity_t), intent(out) :: hel
	real(default) :: theta
	integer :: hmax
	theta = polarization_theta (hpol%obj)
	hmax = flavor_get_spin_type (flv) / 2
	call helicity_init (hel, sign (hmax, nint (cos (theta))))
	end subroutine hepmc_polarization_to_hel

	@ %def hepmc_polarization_to_hel
	@
	\subsection{GenParticle}
	Particle objects have the obvious meaning.
	<<HepMC interface: public>>=
	public :: hepmc_particle_t
	<<HepMC interface: types>>=
	type :: hepmc_particle_t
	private
	type(c_ptr) :: obj
	end type hepmc_particle_t

	@ %def hepmc_particle_t
	@ Constructor. The C version takes a FourVector object, which in the
	Fortran wrapper is created on the fly from a [[vector4]] Lorentz
	vector.

	No destructor is needed as long as all particles are entered into
	vertex containers.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_gen_particle (prt_obj, pdg_id, status) bind(C)
	import
	type(c_ptr), value :: prt_obj
	integer(c_int), value :: pdg_id, status
	end function new_gen_particle
	end interface
	@ %def new_gen_particle
	<<HepMC interface: public>>=
	public :: hepmc_particle_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_particle_init (prt, p, pdg, status)
	type(hepmc_particle_t), intent(out) :: prt
	type(vector4_t), intent(in) :: p
	integer, intent(in) :: pdg, status
	type(hepmc_four_vector_t) :: pp
	call hepmc_four_vector_init (pp, p)
	prt%obj = new_gen_particle (pp%obj, int (pdg, c_int), int (status, c_int))
	call hepmc_four_vector_final (pp)
	end subroutine hepmc_particle_init

	@ %def hepmc_particle_init
	@ Set the particle color flow.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_particle_set_flow (prt_obj, code_index, code) bind(C)
	import
	type(c_ptr), value :: prt_obj
	integer(c_int), value :: code_index, code
	end subroutine gen_particle_set_flow
	end interface
	@ %def gen_particle_set_flow
	<<HepMC interface: public>>=
	public :: hepmc_particle_set_color
	<<HepMC interface: procedures>>=
	subroutine hepmc_particle_set_color (prt, col)
	type(hepmc_particle_t), intent(inout) :: prt
	type(color_t), intent(in) :: col
	integer(c_int) :: c
	c = color_get_col (col)
	if (c /= 0) call gen_particle_set_flow (prt%obj, 1_c_int, c)
	c = color_get_acl (col)
	if (c /= 0) call gen_particle_set_flow (prt%obj, 2_c_int, c)
	end subroutine hepmc_particle_set_color

	@ %def hepmc_particle_set_color
	@ Set the particle polarization. For the restrictions on particle
	polarization in HepMC, see above [[hepmc_polarization_init]].
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_particle_set_polarization (prt_obj, pol_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj, pol_obj
	end subroutine gen_particle_set_polarization
	end interface
	@ %def gen_particle_set_polarization
	<<HepMC interface: public>>=
	public :: hepmc_particle_set_polarization
	<<HepMC interface: interfaces>>=
	interface hepmc_particle_set_polarization
	module procedure hepmc_particle_set_polarization_pol
	module procedure hepmc_particle_set_polarization_hel
	end interface
	<<HepMC interface: procedures>>=
	subroutine hepmc_particle_set_polarization_pol (prt, pol)
	type(hepmc_particle_t), intent(inout) :: prt
	type(polarization_t), intent(in) :: pol
	type(hepmc_polarization_t) :: hpol
	call hepmc_polarization_init (hpol, pol)
	if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj)
	call hepmc_polarization_final (hpol)
	end subroutine hepmc_particle_set_polarization_pol

	subroutine hepmc_particle_set_polarization_hel (prt, hel)
	type(hepmc_particle_t), intent(inout) :: prt
	type(helicity_t), intent(in) :: hel
	type(hepmc_polarization_t) :: hpol
	call hepmc_polarization_init (hpol, hel)
	if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj)
	call hepmc_polarization_final (hpol)
	end subroutine hepmc_particle_set_polarization_hel

	@ %def hepmc_particle_set_polarization
	@ Return the HepMC barcode (unique integer ID) of the particle.
	<<HepMC interface: interfaces>>=
	interface
	function gen_particle_barcode (prt_obj) result (barcode) bind(C)
	import
	integer(c_int) :: barcode
	type(c_ptr), value :: prt_obj
	end function gen_particle_barcode
	end interface
	@ %def gen_particle_barcode
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_barcode
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_barcode (prt) result (barcode)
	integer :: barcode
	type(hepmc_particle_t), intent(in) :: prt
	barcode = gen_particle_barcode (prt%obj)
	end function hepmc_particle_get_barcode

	@ %def hepmc_particle_get_barcode
	@ Return the four-vector component of the particle object as a [[vector4_t]] Lorentz vector.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function gen_particle_momentum (prt_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj
	end function gen_particle_momentum
	end interface
	@ %def gen_particle_momentum
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_momentum
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_momentum (prt) result (p)
	type(vector4_t) :: p
	type(hepmc_particle_t), intent(in) :: prt
	type(hepmc_four_vector_t) :: pp
	call hepmc_four_vector_init (pp, prt)
	call hepmc_four_vector_to_vector4 (pp, p)
	call hepmc_four_vector_final (pp)
	end function hepmc_particle_get_momentum

	@ %def hepmc_particle_get_momentum
	@ Return the invariant mass squared of the particle object. HepMC
	stores the signed invariant mass (no squaring).
	<<HepMC interface: interfaces>>=
	interface
	function gen_particle_generated_mass (prt_obj) result (mass) bind(C)
	import
	real(c_double) :: mass
	type(c_ptr), value :: prt_obj
	end function gen_particle_generated_mass
	end interface
	@ %def gen_particle_generated_mass
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_mass_squared
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_mass_squared (prt) result (m2)
	real(default) :: m2
	type(hepmc_particle_t), intent(in) :: prt
	real(default) :: m
	m = gen_particle_generated_mass (prt%obj)
	m2 = sign (m**2, m)
	end function hepmc_particle_get_mass_squared

	@ %def hepmc_particle_get_mass_squared
	@ Return the PDG ID:
	<<HepMC interface: interfaces>>=
	interface
	function gen_particle_pdg_id (prt_obj) result (pdg_id) bind(C)
	import
	integer(c_int) :: pdg_id
	type(c_ptr), value :: prt_obj
	end function gen_particle_pdg_id
	end interface
	@ %def gen_particle_pdg_id
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_pdg
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_pdg (prt) result (pdg)
	integer :: pdg
	type(hepmc_particle_t), intent(in) :: prt
	pdg = gen_particle_pdg_id (prt%obj)
	end function hepmc_particle_get_pdg

	@ %def hepmc_particle_get_pdg
	@ Return the status code:
	<<HepMC interface: interfaces>>=
	interface
	function gen_particle_status (prt_obj) result (status) bind(C)
	import
	integer(c_int) :: status
	type(c_ptr), value :: prt_obj
	end function gen_particle_status
	end interface
	@ %def gen_particle_status
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_status
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_status (prt) result (status)
	integer :: status
	type(hepmc_particle_t), intent(in) :: prt
	status = gen_particle_status (prt%obj)
	end function hepmc_particle_get_status

	@ %def hepmc_particle_get_status
	@ Return the production/decay vertex (as a pointer, no finalization
	necessary).
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function gen_particle_production_vertex (prt_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj
	end function gen_particle_production_vertex
	end interface
	interface
	type(c_ptr) function gen_particle_end_vertex (prt_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj
	end function gen_particle_end_vertex
	end interface
	@ %def gen_particle_production_vertex gen_particle_end_vertex
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_production_vertex
	public :: hepmc_particle_get_decay_vertex
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_production_vertex (prt) result (v)
	type(hepmc_vertex_t) :: v
	type(hepmc_particle_t), intent(in) :: prt
	v%obj = gen_particle_production_vertex (prt%obj)
	end function hepmc_particle_get_production_vertex

	function hepmc_particle_get_decay_vertex (prt) result (v)
	type(hepmc_vertex_t) :: v
	type(hepmc_particle_t), intent(in) :: prt
	v%obj = gen_particle_end_vertex (prt%obj)
	end function hepmc_particle_get_decay_vertex

	@ %def hepmc_particle_get_production_vertex hepmc_particle_get_decay_vertex
	@ Return the number of parents/children.
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_n_parents
	public :: hepmc_particle_get_n_children
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_n_parents (prt) result (n_parents)
	integer :: n_parents
	type(hepmc_particle_t), intent(in) :: prt
	type(hepmc_vertex_t) :: v
	v = hepmc_particle_get_production_vertex (prt)
	if (hepmc_vertex_is_valid (v)) then
	n_parents = hepmc_vertex_get_n_in (v)
	else
	n_parents = 0
	end if
	end function hepmc_particle_get_n_parents

	function hepmc_particle_get_n_children (prt) result (n_children)
	integer :: n_children
	type(hepmc_particle_t), intent(in) :: prt
	type(hepmc_vertex_t) :: v
	v = hepmc_particle_get_decay_vertex (prt)
	if (hepmc_vertex_is_valid (v)) then
	n_children = hepmc_vertex_get_n_out (v)
	else
	n_children = 0
	end if
	end function hepmc_particle_get_n_children

	@ %def hepmc_particle_get_n_parents
	@ %def hepmc_particle_get_n_children
	@ Convenience function: Return the array of parent particles for a
	given HepMC particle. The contents are HepMC barcodes that still have
	to be mapped to the particle indices.
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_parent_barcodes
	public :: hepmc_particle_get_child_barcodes
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_parent_barcodes (prt) result (parent_barcode)
	type(hepmc_particle_t), intent(in) :: prt
	integer, dimension(:), allocatable :: parent_barcode
	type(hepmc_vertex_t) :: v
	type(hepmc_vertex_particle_in_iterator_t) :: it
	integer :: i
	v = hepmc_particle_get_production_vertex (prt)
	if (hepmc_vertex_is_valid (v)) then
	allocate (parent_barcode (hepmc_vertex_get_n_in (v)))
	if (size (parent_barcode) /= 0) then
	call hepmc_vertex_particle_in_iterator_init (it, v)
	do i = 1, size (parent_barcode)
	parent_barcode(i) = hepmc_particle_get_barcode &
	(hepmc_vertex_particle_in_iterator_get (it))
	call hepmc_vertex_particle_in_iterator_advance (it)
	end do
	call hepmc_vertex_particle_in_iterator_final (it)
	end if
	else
	allocate (parent_barcode (0))
	end if
	end function hepmc_particle_get_parent_barcodes

	function hepmc_particle_get_child_barcodes (prt) result (child_barcode)
	type(hepmc_particle_t), intent(in) :: prt
	integer, dimension(:), allocatable :: child_barcode
	type(hepmc_vertex_t) :: v
	type(hepmc_vertex_particle_out_iterator_t) :: it
	integer :: i
	v = hepmc_particle_get_decay_vertex (prt)
	if (hepmc_vertex_is_valid (v)) then
	allocate (child_barcode (hepmc_vertex_get_n_out (v)))
	call hepmc_vertex_particle_out_iterator_init (it, v)
	if (size (child_barcode) /= 0) then
	do i = 1, size (child_barcode)
	child_barcode(i) = hepmc_particle_get_barcode &
	(hepmc_vertex_particle_out_iterator_get (it))
	call hepmc_vertex_particle_out_iterator_advance (it)
	end do
	call hepmc_vertex_particle_out_iterator_final (it)
	end if
	else
	allocate (child_barcode (0))
	end if
	end function hepmc_particle_get_child_barcodes

	@ %def hepmc_particle_get_parent_barcodes hepmc_particle_get_child_barcodes
	@ Return the polarization (assuming that the particle is completely
	polarized). Note that the generated polarization object needs finalization.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function gen_particle_polarization (prt_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj
	end function gen_particle_polarization
	end interface
	@ %def gen_particle_polarization
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_polarization
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_polarization (prt) result (pol)
	type(hepmc_polarization_t) :: pol
	type(hepmc_particle_t), intent(in) :: prt
	pol%obj = gen_particle_polarization (prt%obj)
	end function hepmc_particle_get_polarization

	@ %def hepmc_particle_get_polarization
	@ Return the particle color as a two-dimensional array (color, anticolor).
	<<HepMC interface: interfaces>>=
	interface
	function gen_particle_flow (prt_obj, code_index) result (code) bind(C)
	import
	integer(c_int) :: code
	type(c_ptr), value :: prt_obj
	integer(c_int), value :: code_index
	end function gen_particle_flow
	end interface
	@ %def gen_particle_flow
	<<HepMC interface: public>>=
	public :: hepmc_particle_get_color
	<<HepMC interface: procedures>>=
	function hepmc_particle_get_color (prt) result (col)
	integer, dimension(2) :: col
	type(hepmc_particle_t), intent(in) :: prt
	col(1) = gen_particle_flow (prt%obj, 1)
	col(2) = - gen_particle_flow (prt%obj, 2)
	end function hepmc_particle_get_color

	@ %def hepmc_particle_get_color
	@
	\subsection{GenVertex}
	Vertices are made of particles (incoming and outgoing).
	<<HepMC interface: public>>=
	public :: hepmc_vertex_t
	<<HepMC interface: types>>=
	type :: hepmc_vertex_t
	private
	type(c_ptr) :: obj
	end type hepmc_vertex_t

	@ %def hepmc_vertex_t
	@ Constructor. Two versions, one plain, one with the position in
	space and time (measured in mm) as argument. The Fortran version has
	initializer form, and the vertex position is an optional argument.

	A destructor is unnecessary as long as all vertices are entered into
	an event container.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_gen_vertex () bind(C)
	import
	end function new_gen_vertex
	end interface
	interface
	type(c_ptr) function new_gen_vertex_pos (prt_obj) bind(C)
	import
	type(c_ptr), value :: prt_obj
	end function new_gen_vertex_pos
	end interface
	@ %def new_gen_vertex new_gen_vertex_pos
	<<HepMC interface: public>>=
	public :: hepmc_vertex_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_init (v, x)
	type(hepmc_vertex_t), intent(out) :: v
	type(vector4_t), intent(in), optional :: x
	type(hepmc_four_vector_t) :: pos
	if (present (x)) then
	call hepmc_four_vector_init (pos, x)
	v%obj = new_gen_vertex_pos (pos%obj)
	call hepmc_four_vector_final (pos)
	else
	v%obj = new_gen_vertex ()
	end if
	end subroutine hepmc_vertex_init

	@ %def hepmc_vertex_init
	@ Return true if the vertex pointer is non-null:
	<<HepMC interface: interfaces>>=
	interface
	function gen_vertex_is_valid (v_obj) result (flag) bind(C)
	import
	logical(c_bool) :: flag
	type(c_ptr), value :: v_obj
	end function gen_vertex_is_valid
	end interface
	@ %def gen_vertex_is_valid
	<<HepMC interface: public>>=
	public :: hepmc_vertex_is_valid
	<<HepMC interface: procedures>>=
	function hepmc_vertex_is_valid (v) result (flag)
	logical :: flag
	type(hepmc_vertex_t), intent(in) :: v
	flag = gen_vertex_is_valid (v%obj)
	end function hepmc_vertex_is_valid

	@ %def hepmc_vertex_is_valid
	@ Add a particle to a vertex, incoming or outgoing.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_vertex_add_particle_in (v_obj, prt_obj) bind(C)
	import
	type(c_ptr), value :: v_obj, prt_obj
	end subroutine gen_vertex_add_particle_in
	end interface
	interface
	subroutine gen_vertex_add_particle_out (v_obj, prt_obj) bind(C)
	import
	type(c_ptr), value :: v_obj, prt_obj
	end subroutine gen_vertex_add_particle_out
	end interface
	<<HepMC interface: public>>=
	public :: hepmc_vertex_add_particle_in
	public :: hepmc_vertex_add_particle_out
	@ %def gen_vertex_add_particle_in gen_vertex_add_particle_out
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_add_particle_in (v, prt)
	type(hepmc_vertex_t), intent(inout) :: v
	type(hepmc_particle_t), intent(in) :: prt
	call gen_vertex_add_particle_in (v%obj, prt%obj)
	end subroutine hepmc_vertex_add_particle_in

	subroutine hepmc_vertex_add_particle_out (v, prt)
	type(hepmc_vertex_t), intent(inout) :: v
	type(hepmc_particle_t), intent(in) :: prt
	call gen_vertex_add_particle_out (v%obj, prt%obj)
	end subroutine hepmc_vertex_add_particle_out

	@ %def hepmc_vertex_add_particle_in hepmc_vertex_add_particle_out
	@ Return the number of incoming/outgoing particles.
	<<HepMC interface: interfaces>>=
	interface
	function gen_vertex_particles_in_size (v_obj) result (size) bind(C)
	import
	integer(c_int) :: size
	type(c_ptr), value :: v_obj
	end function gen_vertex_particles_in_size
	end interface
	interface
	function gen_vertex_particles_out_size (v_obj) result (size) bind(C)
	import
	integer(c_int) :: size
	type(c_ptr), value :: v_obj
	end function gen_vertex_particles_out_size
	end interface
	@ %def gen_vertex_particles_in_size gen_vertex_particles_out_size
	<<HepMC interface: public>>=
	public :: hepmc_vertex_get_n_in
	public :: hepmc_vertex_get_n_out
	<<HepMC interface: procedures>>=
	function hepmc_vertex_get_n_in (v) result (n_in)
	integer :: n_in
	type(hepmc_vertex_t), intent(in) :: v
	n_in = gen_vertex_particles_in_size (v%obj)
	end function hepmc_vertex_get_n_in

	function hepmc_vertex_get_n_out (v) result (n_out)
	integer :: n_out
	type(hepmc_vertex_t), intent(in) :: v
	n_out = gen_vertex_particles_out_size (v%obj)
	end function hepmc_vertex_get_n_out

	@ %def hepmc_vertex_n_in hepmc_vertex_n_out
	@
	\subsection{Vertex-particle-in iterator}
	This iterator iterates over all incoming particles in an vertex. We store a
	pointer to the vertex in addition to the iterator. This allows for
	simple end checking.

	The iterator is actually a constant iterator; it can only read.
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_t
	<<HepMC interface: types>>=
	type :: hepmc_vertex_particle_in_iterator_t
	private
	type(c_ptr) :: obj
	type(c_ptr) :: v_obj
	end type hepmc_vertex_particle_in_iterator_t

	@ %def hepmc_vertex_particle_in_iterator_t
	@ Constructor. The iterator is initialized at the first particle in
	the vertex.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function &
	new_vertex_particles_in_const_iterator (v_obj) bind(C)
	import
	type(c_ptr), value :: v_obj
	end function new_vertex_particles_in_const_iterator
	end interface
	@ %def new_vertex_particles_in_const_iterator
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_in_iterator_init (it, v)
	type(hepmc_vertex_particle_in_iterator_t), intent(out) :: it
	type(hepmc_vertex_t), intent(in) :: v
	it%obj = new_vertex_particles_in_const_iterator (v%obj)
	it%v_obj = v%obj
	end subroutine hepmc_vertex_particle_in_iterator_init

	@ %def hepmc_vertex_particle_in_iterator_init
	@ Destructor. Necessary because the iterator is allocated on the
	heap.
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_in_const_iterator_delete (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine vertex_particles_in_const_iterator_delete
	end interface
	@ %def vertex_particles_in_const_iterator_delete
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_in_iterator_final (it)
	type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
	call vertex_particles_in_const_iterator_delete (it%obj)
	end subroutine hepmc_vertex_particle_in_iterator_final

	@ %def hepmc_vertex_particle_in_iterator_final
	@ Increment
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_in_const_iterator_advance (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine vertex_particles_in_const_iterator_advance
	end interface
	@ %def vertex_particles_in_const_iterator_advance
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_advance
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_in_iterator_advance (it)
	type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
	call vertex_particles_in_const_iterator_advance (it%obj)
	end subroutine hepmc_vertex_particle_in_iterator_advance

	@ %def hepmc_vertex_particle_in_iterator_advance
	@ Reset to the beginning
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_in_const_iterator_reset &
	(it_obj, v_obj) bind(C)
	import
	type(c_ptr), value :: it_obj, v_obj
	end subroutine vertex_particles_in_const_iterator_reset
	end interface
	@ %def vertex_particles_in_const_iterator_reset
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_reset
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_in_iterator_reset (it)
	type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
	call vertex_particles_in_const_iterator_reset (it%obj, it%v_obj)
	end subroutine hepmc_vertex_particle_in_iterator_reset

	@ %def hepmc_vertex_particle_in_iterator_reset
	@ Test: return true as long as we are not past the end.
	<<HepMC interface: interfaces>>=
	interface
	function vertex_particles_in_const_iterator_is_valid &
	(it_obj, v_obj) result (flag) bind(C)
	import
	logical(c_bool) :: flag
	type(c_ptr), value :: it_obj, v_obj
	end function vertex_particles_in_const_iterator_is_valid
	end interface
	@ %def vertex_particles_in_const_iterator_is_valid
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_is_valid
	<<HepMC interface: procedures>>=
	function hepmc_vertex_particle_in_iterator_is_valid (it) result (flag)
	logical :: flag
	type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it
	flag = vertex_particles_in_const_iterator_is_valid (it%obj, it%v_obj)
	end function hepmc_vertex_particle_in_iterator_is_valid

	@ %def hepmc_vertex_particle_in_iterator_is_valid
	@ Return the particle pointed to by the iterator. (The particle
	object should not be finalized, since it contains merely a pointer to
	the particle which is owned by the vertex.)
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function &
	vertex_particles_in_const_iterator_get (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end function vertex_particles_in_const_iterator_get
	end interface
	@ %def vertex_particles_in_const_iterator_get
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_in_iterator_get
	<<HepMC interface: procedures>>=
	function hepmc_vertex_particle_in_iterator_get (it) result (prt)
	type(hepmc_particle_t) :: prt
	type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it
	prt%obj = vertex_particles_in_const_iterator_get (it%obj)
	end function hepmc_vertex_particle_in_iterator_get

	@ %def hepmc_vertex_particle_in_iterator_get
	@
	\subsection{Vertex-particle-out iterator}
	This iterator iterates over all incoming particles in an vertex. We store a
	pointer to the vertex in addition to the iterator. This allows for
	simple end checking.

	The iterator is actually a constant iterator; it can only read.
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_t
	<<HepMC interface: types>>=
	type :: hepmc_vertex_particle_out_iterator_t
	private
	type(c_ptr) :: obj
	type(c_ptr) :: v_obj
	end type hepmc_vertex_particle_out_iterator_t

	@ %def hepmc_vertex_particle_out_iterator_t
	@ Constructor. The iterator is initialized at the first particle in
	the vertex.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function &
	new_vertex_particles_out_const_iterator (v_obj) bind(C)
	import
	type(c_ptr), value :: v_obj
	end function new_vertex_particles_out_const_iterator
	end interface
	@ %def new_vertex_particles_out_const_iterator
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_out_iterator_init (it, v)
	type(hepmc_vertex_particle_out_iterator_t), intent(out) :: it
	type(hepmc_vertex_t), intent(in) :: v
	it%obj = new_vertex_particles_out_const_iterator (v%obj)
	it%v_obj = v%obj
	end subroutine hepmc_vertex_particle_out_iterator_init

	@ %def hepmc_vertex_particle_out_iterator_init
	@ Destructor. Necessary because the iterator is allocated on the
	heap.
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_out_const_iterator_delete (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine vertex_particles_out_const_iterator_delete
	end interface
	@ %def vertex_particles_out_const_iterator_delete
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_out_iterator_final (it)
	type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
	call vertex_particles_out_const_iterator_delete (it%obj)
	end subroutine hepmc_vertex_particle_out_iterator_final

	@ %def hepmc_vertex_particle_out_iterator_final
	@ Increment
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_out_const_iterator_advance (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine vertex_particles_out_const_iterator_advance
	end interface
	@ %def vertex_particles_out_const_iterator_advance
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_advance
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_out_iterator_advance (it)
	type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
	call vertex_particles_out_const_iterator_advance (it%obj)
	end subroutine hepmc_vertex_particle_out_iterator_advance

	@ %def hepmc_vertex_particle_out_iterator_advance
	@ Reset to the beginning
	<<HepMC interface: interfaces>>=
	interface
	subroutine vertex_particles_out_const_iterator_reset &
	(it_obj, v_obj) bind(C)
	import
	type(c_ptr), value :: it_obj, v_obj
	end subroutine vertex_particles_out_const_iterator_reset
	end interface
	@ %def vertex_particles_out_const_iterator_reset
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_reset
	<<HepMC interface: procedures>>=
	subroutine hepmc_vertex_particle_out_iterator_reset (it)
	type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
	call vertex_particles_out_const_iterator_reset (it%obj, it%v_obj)
	end subroutine hepmc_vertex_particle_out_iterator_reset

	@ %def hepmc_vertex_particle_out_iterator_reset
	@ Test: return true as long as we are not past the end.
	<<HepMC interface: interfaces>>=
	interface
	function vertex_particles_out_const_iterator_is_valid &
	(it_obj, v_obj) result (flag) bind(C)
	import
	logical(c_bool) :: flag
	type(c_ptr), value :: it_obj, v_obj
	end function vertex_particles_out_const_iterator_is_valid
	end interface
	@ %def vertex_particles_out_const_iterator_is_valid
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_is_valid
	<<HepMC interface: procedures>>=
	function hepmc_vertex_particle_out_iterator_is_valid (it) result (flag)
	logical :: flag
	type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it
	flag = vertex_particles_out_const_iterator_is_valid (it%obj, it%v_obj)
	end function hepmc_vertex_particle_out_iterator_is_valid

	@ %def hepmc_vertex_particle_out_iterator_is_valid
	@ Return the particle pointed to by the iterator. (The particle
	object should not be finalized, since it contains merely a pointer to
	the particle which is owned by the vertex.)
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function &
	vertex_particles_out_const_iterator_get (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end function vertex_particles_out_const_iterator_get
	end interface
	@ %def vertex_particles_out_const_iterator_get
	<<HepMC interface: public>>=
	public :: hepmc_vertex_particle_out_iterator_get
	<<HepMC interface: procedures>>=
	function hepmc_vertex_particle_out_iterator_get (it) result (prt)
	type(hepmc_particle_t) :: prt
	type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it
	prt%obj = vertex_particles_out_const_iterator_get (it%obj)
	end function hepmc_vertex_particle_out_iterator_get

	@ %def hepmc_vertex_particle_out_iterator_get
	@
	\subsection{GenEvent}
	The main object of HepMC is a GenEvent. The object is filled by
	GenVertex objects, which in turn contain GenParticle objects.
	<<HepMC interface: public>>=
	public :: hepmc_event_t
	<<HepMC interface: types>>=
	type :: hepmc_event_t
	private
	type(c_ptr) :: obj
	end type hepmc_event_t

	@ %def hepmc_event_t
	@ Constructor. Arguments are process ID (integer) and event ID
	(integer).

	The Fortran version has initializer form.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_gen_event (proc_id, event_id) bind(C)
	import
	integer(c_int), value :: proc_id, event_id
	end function new_gen_event
	end interface
	@ %def new_gen_event
	<<HepMC interface: public>>=
	public :: hepmc_event_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_init (evt, proc_id, event_id)
	type(hepmc_event_t), intent(out) :: evt
	integer, intent(in), optional :: proc_id, event_id
	integer(c_int) :: pid, eid
	pid = 0; if (present (proc_id)) pid = proc_id
	eid = 0; if (present (event_id)) eid = event_id
	evt%obj = new_gen_event (pid, eid)
	end subroutine hepmc_event_init

	@ %def hepmc_event_init
	@ Destructor.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_delete (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end subroutine gen_event_delete
	end interface
	@ %def gen_event_delete
	<<HepMC interface: public>>=
	public :: hepmc_event_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_final (evt)
	type(hepmc_event_t), intent(inout) :: evt
	call gen_event_delete (evt%obj)
	end subroutine hepmc_event_final

	@ %def hepmc_event_final
	@ Screen output. Printing to file is possible in principle (using a
	C++ output channel), by allowing an argument. Printing to an open
	Fortran unit is obviously not possible.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_print (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end subroutine gen_event_print
	end interface
	@ %def gen_event_print
	<<HepMC interface: public>>=
	public :: hepmc_event_print
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_print (evt)
	type(hepmc_event_t), intent(in) :: evt
	call gen_event_print (evt%obj)
	end subroutine hepmc_event_print

	@ %def hepmc_event_print
	@ Get the event number.
	<<HepMC interface: interfaces>>=
	interface
	integer(c_int) function gen_event_event_number (evt_obj) bind(C)
	use iso_c_binding !NODEP!
	type(c_ptr), value :: evt_obj
	end function gen_event_event_number
	end interface
	@ %def gen_event_event_number
	<<HepMC interface: public>>=
	public :: hepmc_event_get_event_index
	<<HepMC interface: procedures>>=
	function hepmc_event_get_event_index (evt) result (i_proc)
	integer :: i_proc
	type(hepmc_event_t), intent(in) :: evt
	i_proc = gen_event_event_number (evt%obj)
	end function hepmc_event_get_event_index

	@ %def hepmc_event_get_event_index
	@ Set the numeric signal process ID
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_signal_process_id (evt_obj, proc_id) bind(C)
	import
	type(c_ptr), value :: evt_obj
	integer(c_int), value :: proc_id
	end subroutine gen_event_set_signal_process_id
	end interface
	@ %def gen_event_set_signal_process_id
	<<HepMC interface: public>>=
	public :: hepmc_event_set_process_id
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_process_id (evt, proc)
	type(hepmc_event_t), intent(in) :: evt
	integer, intent(in) :: proc
	integer(c_int) :: i_proc
	i_proc = proc
	call gen_event_set_signal_process_id (evt%obj, i_proc)
	end subroutine hepmc_event_set_process_id

	@ %def hepmc_event_set_process_id
	@ Get the numeric signal process ID
	<<HepMC interface: interfaces>>=
	interface
	integer(c_int) function gen_event_signal_process_id (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end function gen_event_signal_process_id
	end interface
	@ %def gen_event_signal_process_id
	<<HepMC interface: public>>=
	public :: hepmc_event_get_process_id
	<<HepMC interface: procedures>>=
	function hepmc_event_get_process_id (evt) result (i_proc)
	integer :: i_proc
	type(hepmc_event_t), intent(in) :: evt
	i_proc = gen_event_signal_process_id (evt%obj)
	end function hepmc_event_get_process_id

	@ %def hepmc_event_get_process_id
	@ Set the event energy scale
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_event_scale (evt_obj, scale) bind(C)
	import
	type(c_ptr), value :: evt_obj
	real(c_double), value :: scale
	end subroutine gen_event_set_event_scale
	end interface
	@ %def gen_event_set_event_scale
	<<HepMC interface: public>>=
	public :: hepmc_event_set_scale
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_scale (evt, scale)
	type(hepmc_event_t), intent(in) :: evt
	real(default), intent(in) :: scale
	real(c_double) :: cscale
	cscale = scale
	call gen_event_set_event_scale (evt%obj, cscale)
	end subroutine hepmc_event_set_scale

	@ %def hepmc_event_set_scale
	@ Get the event energy scale
	<<HepMC interface: interfaces>>=
	interface
	real(c_double) function gen_event_event_scale (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end function gen_event_event_scale
	end interface
	@ %def gen_event_event_scale
	<<HepMC interface: public>>=
	public :: hepmc_event_get_scale
	<<HepMC interface: procedures>>=
	function hepmc_event_get_scale (evt) result (scale)
	real(default) :: scale
	type(hepmc_event_t), intent(in) :: evt
	scale = gen_event_event_scale (evt%obj)
	end function hepmc_event_get_scale

	@ %def hepmc_event_set_scale
	@ Set the value of $\alpha_{\rm QCD}$.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_alpha_qcd (evt_obj, a) bind(C)
	import
	type(c_ptr), value :: evt_obj
	real(c_double), value :: a
	end subroutine gen_event_set_alpha_qcd
	end interface
	@ %def gen_event_set_alpha_qcd
	<<HepMC interface: public>>=
	public :: hepmc_event_set_alpha_qcd
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_alpha_qcd (evt, alpha)
	type(hepmc_event_t), intent(in) :: evt
	real(default), intent(in) :: alpha
	real(c_double) :: a
	a = alpha
	call gen_event_set_alpha_qcd (evt%obj, a)
	end subroutine hepmc_event_set_alpha_qcd

	@ %def hepmc_event_set_alpha_qcd
	@ Get the value of $\alpha_{\rm QCD}$.
	<<HepMC interface: interfaces>>=
	interface
	real(c_double) function gen_event_alpha_qcd (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end function gen_event_alpha_qcd
	end interface
	@ %def gen_event_get_alpha_qcd
	<<HepMC interface: public>>=
	public :: hepmc_event_get_alpha_qcd
	<<HepMC interface: procedures>>=
	function hepmc_event_get_alpha_qcd (evt) result (alpha)
	real(default) :: alpha
	type(hepmc_event_t), intent(in) :: evt
	alpha = gen_event_alpha_qcd (evt%obj)
	end function hepmc_event_get_alpha_qcd

	@ %def hepmc_event_get_alpha_qcd
	@ Set the value of $\alpha_{\rm QED}$.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_alpha_qed (evt_obj, a) bind(C)
	import
	type(c_ptr), value :: evt_obj
	real(c_double), value :: a
	end subroutine gen_event_set_alpha_qed
	end interface
	@ %def gen_event_set_alpha_qed
	<<HepMC interface: public>>=
	public :: hepmc_event_set_alpha_qed
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_alpha_qed (evt, alpha)
	type(hepmc_event_t), intent(in) :: evt
	real(default), intent(in) :: alpha
	real(c_double) :: a
	a = alpha
	call gen_event_set_alpha_qed (evt%obj, a)
	end subroutine hepmc_event_set_alpha_qed

	@ %def hepmc_event_set_alpha_qed
	@ Get the value of $\alpha_{\rm QED}$.
	<<HepMC interface: interfaces>>=
	interface
	real(c_double) function gen_event_alpha_qed (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end function gen_event_alpha_qed
	end interface
	@ %def gen_event_get_alpha_qed
	<<HepMC interface: public>>=
	public :: hepmc_event_get_alpha_qed
	<<HepMC interface: procedures>>=
	function hepmc_event_get_alpha_qed (evt) result (alpha)
	real(default) :: alpha
	type(hepmc_event_t), intent(in) :: evt
	alpha = gen_event_alpha_qed (evt%obj)
	end function hepmc_event_get_alpha_qed

	@ %def hepmc_event_get_alpha_qed
	@ Clear a weight value to the end of the weight container.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_clear_weights (evt_obj) bind(C)
	use iso_c_binding !NODEP!
	type(c_ptr), value :: evt_obj
	end subroutine gen_event_clear_weights
	end interface
	@ %def gen_event_set_alpha_qed
	<<HepMC interface: public>>=
	public :: hepmc_event_clear_weights
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_clear_weights (evt)
	type(hepmc_event_t), intent(in) :: evt
	call gen_event_clear_weights (evt%obj)
	end subroutine hepmc_event_clear_weights

	@ %def hepmc_event_clear_weights
	@ Add a weight value to the end of the weight container.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_add_weight (evt_obj, w) bind(C)
	use iso_c_binding !NODEP!
	type(c_ptr), value :: evt_obj
	real(c_double), value :: w
	end subroutine gen_event_add_weight
	end interface
	@ %def gen_event_set_alpha_qed
	<<HepMC interface: public>>=
	public :: hepmc_event_add_weight
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_add_weight (evt, weight)
	type(hepmc_event_t), intent(in) :: evt
	real(default), intent(in) :: weight
	real(c_double) :: w
	w = weight
	call gen_event_add_weight (evt%obj, w)
	end subroutine hepmc_event_add_weight

	@ %def hepmc_event_add_weight
	@ Get the size of the weight container (the number of valid elements).
	<<HepMC interface: interfaces>>=
	interface
	integer(c_int) function gen_event_weights_size (evt_obj) bind(C)
	use iso_c_binding !NODEP!
	type(c_ptr), value :: evt_obj
	end function gen_event_weights_size
	end interface
	@ %def gen_event_get_weight
	<<HepMC interface: public>>=
	public :: hepmc_event_get_weights_size
	<<HepMC interface: procedures>>=
	function hepmc_event_get_weights_size (evt) result (n)
	integer :: n
	type(hepmc_event_t), intent(in) :: evt
	n = gen_event_weights_size (evt%obj)
	end function hepmc_event_get_weights_size

	@ %def hepmc_event_get_weights_size
	@ Get the value of the weight with index [[i]]. (Count from 1, while C counts
	from zero.)
	<<HepMC interface: interfaces>>=
	interface
	real(c_double) function gen_event_weight (evt_obj, i) bind(C)
	use iso_c_binding !NODEP!
	type(c_ptr), value :: evt_obj
	integer(c_int), value :: i
	end function gen_event_weight
	end interface
	@ %def gen_event_get_weight
	<<HepMC interface: public>>=
	public :: hepmc_event_get_weight
	<<HepMC interface: procedures>>=
	function hepmc_event_get_weight (evt, index) result (weight)
	real(default) :: weight
	type(hepmc_event_t), intent(in) :: evt
	integer, intent(in) :: index
	integer(c_int) :: i
	i = index - 1
	weight = gen_event_weight (evt%obj, i)
	end function hepmc_event_get_weight

	@ %def hepmc_event_get_weight
	@ Add a vertex to the event container.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_add_vertex (evt_obj, v_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	type(c_ptr), value :: v_obj
	end subroutine gen_event_add_vertex
	end interface
	@ %def gen_event_add_vertex
	<<HepMC interface: public>>=
	public :: hepmc_event_add_vertex
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_add_vertex (evt, v)
	type(hepmc_event_t), intent(inout) :: evt
	type(hepmc_vertex_t), intent(in) :: v
	call gen_event_add_vertex (evt%obj, v%obj)
	end subroutine hepmc_event_add_vertex

	@ %def hepmc_event_add_vertex
	@ Mark a particular vertex as the signal process (hard interaction).
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_signal_process_vertex (evt_obj, v_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	type(c_ptr), value :: v_obj
	end subroutine gen_event_set_signal_process_vertex
	end interface
	@ %def gen_event_set_signal_process_vertex
	<<HepMC interface: public>>=
	public :: hepmc_event_set_signal_process_vertex
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_signal_process_vertex (evt, v)
	type(hepmc_event_t), intent(inout) :: evt
	type(hepmc_vertex_t), intent(in) :: v
	call gen_event_set_signal_process_vertex (evt%obj, v%obj)
	end subroutine hepmc_event_set_signal_process_vertex

	@ %def hepmc_event_set_signal_process_vertex
	@ Set the beam particles explicitly.
	<<HepMC interface: public>>=
	public :: hepmc_event_set_beam_particles
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_beam_particles (evt, prt1, prt2)
	type(hepmc_event_t), intent(inout) :: evt
	type(hepmc_particle_t), intent(in) :: prt1, prt2
	logical(c_bool) :: flag
	flag = gen_event_set_beam_particles (evt%obj, prt1%obj, prt2%obj)
	end subroutine hepmc_event_set_beam_particles

	@ %def hepmc_event_set_beam_particles
	@ The C function returns a boolean which we do not use.
	<<HepMC interface: interfaces>>=
	interface
	logical(c_bool) function gen_event_set_beam_particles &
	(evt_obj, prt1_obj, prt2_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj, prt1_obj, prt2_obj
	end function gen_event_set_beam_particles
	end interface

	@ %def gen_event_set_beam_particles
	@ Set the cross section and error explicitly. Note that HepMC uses
	pb, while WHIZARD uses fb.
	<<HepMC interface: public>>=
	public :: hepmc_event_set_cross_section
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_set_cross_section (evt, xsec, xsec_err)
	type(hepmc_event_t), intent(inout) :: evt
	real(default), intent(in) :: xsec, xsec_err
	call gen_event_set_cross_section &
	(evt%obj, &
	real (xsec * 1e-3_default, c_double), &
	real (xsec_err * 1e-3_default, c_double))
	end subroutine hepmc_event_set_cross_section

	@ %def hepmc_event_set_cross_section
	@ The C function returns a boolean which we do not use.
	<<HepMC interface: interfaces>>=
	interface
	subroutine gen_event_set_cross_section (evt_obj, xs, xs_err) bind(C)
	import
	type(c_ptr), value :: evt_obj
	real(c_double), value :: xs, xs_err
	end subroutine gen_event_set_cross_section
	end interface

	@ %def gen_event_set_cross_section
	@
	\subsection{Event-particle iterator}
	This iterator iterates over all particles in an event. We store a
	pointer to the event in addition to the iterator. This allows for
	simple end checking.

	The iterator is actually a constant iterator; it can only read.
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_t
	<<HepMC interface: types>>=
	type :: hepmc_event_particle_iterator_t
	private
	type(c_ptr) :: obj
	type(c_ptr) :: evt_obj
	end type hepmc_event_particle_iterator_t

	@ %def hepmc_event_particle_iterator_t
	@ Constructor. The iterator is initialized at the first particle in
	the event.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_event_particle_const_iterator (evt_obj) bind(C)
	import
	type(c_ptr), value :: evt_obj
	end function new_event_particle_const_iterator
	end interface
	@ %def new_event_particle_const_iterator
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_init
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_particle_iterator_init (it, evt)
	type(hepmc_event_particle_iterator_t), intent(out) :: it
	type(hepmc_event_t), intent(in) :: evt
	it%obj = new_event_particle_const_iterator (evt%obj)
	it%evt_obj = evt%obj
	end subroutine hepmc_event_particle_iterator_init

	@ %def hepmc_event_particle_iterator_init
	@ Destructor. Necessary because the iterator is allocated on the
	heap.
	<<HepMC interface: interfaces>>=
	interface
	subroutine event_particle_const_iterator_delete (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine event_particle_const_iterator_delete
	end interface
	@ %def event_particle_const_iterator_delete
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_final
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_particle_iterator_final (it)
	type(hepmc_event_particle_iterator_t), intent(inout) :: it
	call event_particle_const_iterator_delete (it%obj)
	end subroutine hepmc_event_particle_iterator_final

	@ %def hepmc_event_particle_iterator_final
	@ Increment
	<<HepMC interface: interfaces>>=
	interface
	subroutine event_particle_const_iterator_advance (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end subroutine event_particle_const_iterator_advance
	end interface
	@ %def event_particle_const_iterator_advance
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_advance
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_particle_iterator_advance (it)
	type(hepmc_event_particle_iterator_t), intent(inout) :: it
	call event_particle_const_iterator_advance (it%obj)
	end subroutine hepmc_event_particle_iterator_advance

	@ %def hepmc_event_particle_iterator_advance
	@ Reset to the beginning
	<<HepMC interface: interfaces>>=
	interface
	subroutine event_particle_const_iterator_reset (it_obj, evt_obj) bind(C)
	import
	type(c_ptr), value :: it_obj, evt_obj
	end subroutine event_particle_const_iterator_reset
	end interface
	@ %def event_particle_const_iterator_reset
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_reset
	<<HepMC interface: procedures>>=
	subroutine hepmc_event_particle_iterator_reset (it)
	type(hepmc_event_particle_iterator_t), intent(inout) :: it
	call event_particle_const_iterator_reset (it%obj, it%evt_obj)
	end subroutine hepmc_event_particle_iterator_reset

	@ %def hepmc_event_particle_iterator_reset
	@ Test: return true as long as we are not past the end.
	<<HepMC interface: interfaces>>=
	interface
	function event_particle_const_iterator_is_valid &
	(it_obj, evt_obj) result (flag) bind(C)
	import
	logical(c_bool) :: flag
	type(c_ptr), value :: it_obj, evt_obj
	end function event_particle_const_iterator_is_valid
	end interface
	@ %def event_particle_const_iterator_is_valid
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_is_valid
	<<HepMC interface: procedures>>=
	function hepmc_event_particle_iterator_is_valid (it) result (flag)
	logical :: flag
	type(hepmc_event_particle_iterator_t), intent(in) :: it
	flag = event_particle_const_iterator_is_valid (it%obj, it%evt_obj)
	end function hepmc_event_particle_iterator_is_valid

	@ %def hepmc_event_particle_iterator_is_valid
	@ Return the particle pointed to by the iterator. (The particle
	object should not be finalized, since it contains merely a pointer to
	the particle which is owned by the vertex.)
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function event_particle_const_iterator_get (it_obj) bind(C)
	import
	type(c_ptr), value :: it_obj
	end function event_particle_const_iterator_get
	end interface
	@ %def event_particle_const_iterator_get
	<<HepMC interface: public>>=
	public :: hepmc_event_particle_iterator_get
	<<HepMC interface: procedures>>=
	function hepmc_event_particle_iterator_get (it) result (prt)
	type(hepmc_particle_t) :: prt
	type(hepmc_event_particle_iterator_t), intent(in) :: it
	prt%obj = event_particle_const_iterator_get (it%obj)
	end function hepmc_event_particle_iterator_get

	@ %def hepmc_event_particle_iterator_get
	@
	\subsection{I/O streams}
	There is a specific I/O stream type for handling the output of
	GenEvent objects (i.e., Monte Carlo event samples) to file. Opening
	the file is done by the constructor, closing by the destructor.
	<<HepMC interface: public>>=
	public :: hepmc_iostream_t
	<<HepMC interface: types>>=
	type :: hepmc_iostream_t
	private
	type(c_ptr) :: obj
	end type hepmc_iostream_t

	@ %def hepmc_iostream_t
	@ Constructor for an output stream associated to a file.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_io_gen_event_out (filename) bind(C)
	import
	character(c_char), dimension(*), intent(in) :: filename
	end function new_io_gen_event_out
	end interface
	@ %def new_io_gen_event
	<<HepMC interface: public>>=
	public :: hepmc_iostream_open_out
	<<HepMC interface: procedures>>=
	subroutine hepmc_iostream_open_out (iostream, filename)
	type(hepmc_iostream_t), intent(out) :: iostream
	type(string_t), intent(in) :: filename
	iostream%obj = new_io_gen_event_out (char (filename) // c_null_char)
	end subroutine hepmc_iostream_open_out

	@ %def hepmc_iostream_open_out
	@ Constructor for an input stream associated to a file.
	<<HepMC interface: interfaces>>=
	interface
	type(c_ptr) function new_io_gen_event_in (filename) bind(C)
	import
	character(c_char), dimension(*), intent(in) :: filename
	end function new_io_gen_event_in
	end interface
	@ %def new_io_gen_event
	<<HepMC interface: public>>=
	public :: hepmc_iostream_open_in
	<<HepMC interface: procedures>>=
	subroutine hepmc_iostream_open_in (iostream, filename)
	type(hepmc_iostream_t), intent(out) :: iostream
	type(string_t), intent(in) :: filename
	iostream%obj = new_io_gen_event_in (char (filename) // c_null_char)
	end subroutine hepmc_iostream_open_in

	@ %def hepmc_iostream_open_in
	@ Destructor:
	<<HepMC interface: interfaces>>=
	interface
	subroutine io_gen_event_delete (io_obj) bind(C)
	import
	type(c_ptr), value :: io_obj
	end subroutine io_gen_event_delete
	end interface
	@ %def io_gen_event_delete
	<<HepMC interface: public>>=
	public :: hepmc_iostream_close
	<<HepMC interface: procedures>>=
	subroutine hepmc_iostream_close (iostream)
	type(hepmc_iostream_t), intent(inout) :: iostream
	call io_gen_event_delete (iostream%obj)
	end subroutine hepmc_iostream_close

	@ %def hepmc_iostream_close
	@ Write a single event to the I/O stream.
	<<HepMC interface: interfaces>>=
	interface
	subroutine io_gen_event_write_event (io_obj, evt_obj) bind(C)
	import
	type(c_ptr), value :: io_obj, evt_obj
	end subroutine io_gen_event_write_event
	end interface
	@ %def io_gen_event_write_event
	<<HepMC interface: public>>=
	public :: hepmc_iostream_write_event
	<<HepMC interface: procedures>>=
	subroutine hepmc_iostream_write_event (iostream, evt)
	type(hepmc_iostream_t), intent(inout) :: iostream
	type(hepmc_event_t), intent(in) :: evt
	call io_gen_event_write_event (iostream%obj, evt%obj)
	end subroutine hepmc_iostream_write_event

	@ %def hepmc_iostream_write_event
	@ Read a single event from the I/O stream. Return true if successful.
	<<HepMC interface: interfaces>>=
	interface
	logical(c_bool) function io_gen_event_read_event (io_obj, evt_obj) bind(C)
	import
	type(c_ptr), value :: io_obj, evt_obj
	end function io_gen_event_read_event
	end interface
	@ %def io_gen_event_read_event
	<<HepMC interface: public>>=
	public :: hepmc_iostream_read_event
	<<HepMC interface: procedures>>=
	subroutine hepmc_iostream_read_event (iostream, evt, ok)
	type(hepmc_iostream_t), intent(inout) :: iostream
	type(hepmc_event_t), intent(in) :: evt
	logical, intent(out) :: ok
	ok = io_gen_event_read_event (iostream%obj, evt%obj)
	end subroutine hepmc_iostream_read_event

	@ %def hepmc_iostream_read_event
	@
	\subsection{Test}
	This test example is an abridged version from the build-from-scratch
	example in the HepMC distribution. We create two vertices for $p\to
	q$ PDF splitting, then a vertex for a $qq\to W^-g$ hard-interaction
	process, and finally a vertex for $W^-\to qq$ decay. The setup is for
	LHC kinematics.

	Extending the original example, we set color flow for the incoming
	quarks and polarization for the outgoing photon. For the latter, we
	have to define a particle-data object for the photon, so a flavor
	object can be correctly initialized.
	<<HepMC interface: public>>=
	public :: hepmc_test
	<<HepMC interface: procedures>>=
	subroutine hepmc_test
	type(hepmc_event_t) :: evt
	type(hepmc_vertex_t) :: v1, v2, v3, v4
	type(hepmc_particle_t) :: prt1, prt2, prt3, prt4, prt5, prt6, prt7, prt8
	type(hepmc_iostream_t) :: iostream
	type(flavor_t) :: flv
	type(color_t) :: col
	type(polarization_t) :: pol
	type(particle_data_t), target :: photon_data

	! Initialize a photon flavor object and some polarization
	call particle_data_init (photon_data, var_str ("PHOTON"), 22)
	call particle_data_set (photon_data, spin_type=VECTOR)
	call particle_data_freeze (photon_data)
	call flavor_init (flv, photon_data)
	call polarization_init_angles &
	(pol, flv, 0.6_default, 1._default, 0.5_default)

	! Event initialization
	call hepmc_event_init (evt, 20, 1)

	! $p\to q$ splittings
	call hepmc_vertex_init (v1)
	call hepmc_event_add_vertex (evt, v1)
	call hepmc_vertex_init (v2)
	call hepmc_event_add_vertex (evt, v2)
	call particle_init (prt1, &
	0._default, 0._default, 7000._default, 7000._default, &
	2212, 3)
	call hepmc_vertex_add_particle_in (v1, prt1)
	call particle_init (prt2, &
	0._default, 0._default,-7000._default, 7000._default, &
	2212, 3)
	call hepmc_vertex_add_particle_in (v2, prt2)
	call particle_init (prt3, &
	.750_default, -1.569_default, 32.191_default, 32.238_default, &
	1, 3)
	call color_init_from_array (col, (/501/))
	call hepmc_particle_set_color (prt3, col)
	call hepmc_vertex_add_particle_out (v1, prt3)
	call particle_init (prt4, &
	-3.047_default, -19._default, -54.629_default, 57.920_default, &
	-2, 3)
	call color_init_from_array (col, (/-501/))
	call hepmc_particle_set_color (prt4, col)
	call hepmc_vertex_add_particle_out (v2, prt4)

	! Hard interaction
	call hepmc_vertex_init (v3)
	call hepmc_event_add_vertex (evt, v3)
	call hepmc_vertex_add_particle_in (v3, prt3)
	call hepmc_vertex_add_particle_in (v3, prt4)
	call particle_init (prt6, &
	-3.813_default, 0.113_default, -1.833_default, 4.233_default, &
	22, 1)
	call hepmc_particle_set_polarization (prt6, pol)
	call hepmc_vertex_add_particle_out (v3, prt6)
	call particle_init (prt5, &
	1.517_default, -20.68_default, -20.605_default, 85.925_default, &
	-24, 3)
	call hepmc_vertex_add_particle_out (v3, prt5)
	call hepmc_event_set_signal_process_vertex (evt, v3)

	! $W^-$ decay
	call vertex_init_pos (v4, &
	0.12_default, -0.3_default, 0.05_default, 0.004_default)
	call hepmc_event_add_vertex (evt, v4)
	call hepmc_vertex_add_particle_in (v4, prt5)
	call particle_init (prt7, &
	-2.445_default, 28.816_default, 6.082_default, 29.552_default, &
	1, 1)
	call hepmc_vertex_add_particle_out (v4, prt7)
	call particle_init (prt8, &
	3.962_default, -49.498_default, -26.687_default, 56.373_default, &
	-2, 1)
	call hepmc_vertex_add_particle_out (v4, prt8)

	! Event output
	call hepmc_event_print (evt)
	print *, "Writing to file 'hepmc_test.hepmc.dat'"
	call hepmc_iostream_open_out (iostream , var_str ("hepmc_test.hepmc.dat"))
	call hepmc_iostream_write_event (iostream, evt)
	call hepmc_iostream_close (iostream)
	print *, "Write completed"

	! Wrapup
	call polarization_final (pol)
	call hepmc_event_final (evt)

	contains

	subroutine vertex_init_pos (v, x, y, z, t)
	type(hepmc_vertex_t), intent(out) :: v
	real(default), intent(in) :: x, y, z, t
	type(vector4_t) :: xx
	xx = vector4_moving (t, vector3_moving ((/x, y, z/)))
	call hepmc_vertex_init (v, xx)
	end subroutine vertex_init_pos

	subroutine particle_init (prt, px, py, pz, E, pdg, status)
	type(hepmc_particle_t), intent(out) :: prt
	real(default), intent(in) :: px, py, pz, E
	integer, intent(in) :: pdg, status
	type(vector4_t) :: p
	p = vector4_moving (E, vector3_moving ((/px, py, pz/)))
	call hepmc_particle_init (prt, p, pdg, status)
	end subroutine particle_init

	end subroutine hepmc_test

	@ %def hepmc_test
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{External modules}
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{STDHEP interface}
	Interface to the \texttt{STDHEP} library for portable
	I/O of binary event data. The dummy module is needed if the STDHEP
	library cannot be linked, in order to provide dummy routines. The
	second module contains calls to the actual stdhep routines.
	The number of expected events is not really important. It is a
	32-bit number, so if the actual number gets larger, insert the maximal
	possible 32-bit number.

	When writing events, the flag [[ilbl]] determines the common block to
	write: 1 for HEPEVT, 11 for HEPEUP, 12 for HEPRUP
	<<[[stdhep_interface.f90]]>>=
	<<File header>>

	module stdhep_interface

	use kinds, only: i32, i64 !NODEP!

	<<Standard module head>>

	public :: stdhep_init, stdhep_write, stdhep_end

	integer, parameter, public :: &
	STDHEP_HEPEVT = 1, STDHEP_HEPEUP = 11, STDHEP_HEPRUP = 12

	integer, save :: istr, lok

	contains

	subroutine stdhep_init (file, title, nevt)
	character(len=*), intent(in) :: file, title
	integer(i64), intent(in) :: nevt
	integer(i32) :: nevt32
	external stdxwinit, stdxwrt
	nevt32 = min (nevt, int (huge (1_i32), i64))
	call stdxwinit (file, title, nevt32, istr, lok)
	call stdxwrt (100, istr, lok)
	end subroutine stdhep_init

	subroutine stdhep_write (ilbl)
	integer, intent(in) :: ilbl
	external stdxwrt
	call stdxwrt (ilbl, istr, lok)
	end subroutine stdhep_write

	subroutine stdhep_end
	external stdxend
	call stdxend (istr)
	end subroutine stdhep_end

	end module stdhep_interface
	@ %def stdhep_interface
	@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	@
	\chapter{Process Libraries}
	Initialize a process configuration. The configuration is
	[[intent(inout)]] such that any [[next]] pointer is kept if an
	existing configuration is overwritten. Otherwise,
	all contents are reset.
	<<XXX Process libraries: procedures>>=
	subroutine process_configuration_init &
	(prc_conf, ci_type, prc_id, model, prt_in, prt_out, method, status, &
	restrictions, omega_flags, known_md5sum, omega_openmp, &
	nlo_setup)
	type(process_configuration_t), intent(inout) :: prc_conf
	integer, intent(in) :: ci_type
	type(string_t), intent(in) :: prc_id
	type(model_t), intent(in), target :: model
	type(string_t), dimension(:), intent(in) :: prt_in, prt_out
	integer, intent(in), optional :: status
	integer, intent(in), optional :: method
	type(string_t), intent(in), optional :: restrictions, omega_flags
	character(32), intent(in), optional :: known_md5sum
	logical, intent(in), optional :: omega_openmp
	type(nlo_setup_t), intent(in), optional :: &
	nlo_setup
	prc_conf%ci_type = ci_type
	prc_conf%id = prc_id
	prc_conf%model => model
	prc_conf%n_in = size (prt_in)
	prc_conf%n_out = size (prt_out)
	prc_conf%n_tot = prc_conf%n_in + prc_conf%n_out
	if (allocated (prc_conf%prt_in)) deallocate (prc_conf%prt_in)
	allocate (prc_conf%prt_in (prc_conf%n_in))
	if (allocated (prc_conf%prt_out)) deallocate (prc_conf%prt_out)
	allocate (prc_conf%prt_out (prc_conf%n_out))
	prc_conf%prt_in = prt_in
	prc_conf%prt_out = prt_out
	if (present (status)) then
	prc_conf%status = status
	else
	prc_conf%status = STAT_CONFIGURED
	end if
	if (present (method)) then
	if (method == PRC_SUM) call msg_bug ("process_configuration_init " // &
	"called for PRC_SUM")
	prc_conf%method = method
	else
	prc_conf%method = PRC_OMEGA
	end if
	if (present (restrictions)) then
	prc_conf%restrictions = canonicalize_restrictions (restrictions, model)
	else
	prc_conf%restrictions = ""
	end if
	if (present (omega_flags)) then
	prc_conf%omega_flags = omega_flags
	else
	prc_conf%omega_flags = ""
	end if
	if (present (omega_openmp)) then
	select case (prc_conf%method)
	case (PRC_OMEGA)
	prc_conf%omega_openmp = omega_openmp
	case default
	prc_conf%omega_openmp = .false.
	end select
	else
	prc_conf%omega_openmp = .false.
	end if
	if (present (known_md5sum)) then
	prc_conf%md5sum = known_md5sum
	else
	call process_configuration_compute_md5sum (prc_conf)
	end if
	if (present (nlo_setup)) then
	prc_conf%nlo_setup = nlo_setup
	end if
	end subroutine process_configuration_init

	@ %def process_configuration_init
	@ Init a sum process. This is really just a stub as such a process only
	encapsulates the names of its child processes.
	<<XXX Process libraries: procedures>>=
	subroutine process_configuration_init_sum ( &
	prc_conf, proc_id, child1, child2, nlo_setup)
	type(process_configuration_t), intent(inout) :: prc_conf
	type(string_t), intent(in) :: proc_id
	type(string_t), intent(in), optional :: child1, child2
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	if (prc_conf%method == PRC_UNDEFINED) then
	prc_conf%child1 = var_str ("")
	prc_conf%child2 = var_str ("")
	end if
	prc_conf%id = proc_id
	prc_conf%method = PRC_SUM
	prc_conf%ci_type = CI_SUM
	if (present (child1)) prc_conf%child1 = child1
	if (present (child2)) prc_conf%child2 = child2
	if (present (nlo_setup)) prc_conf%nlo_setup = nlo_setup
	end subroutine process_configuration_init_sum

	@ %def process_configuration_init_sum
	@ Compute the MD5 sum. Write all relevant information to a string.
	<<XXX Process libraries: procedures>>=
	subroutine process_configuration_compute_md5sum (prc_conf)
	type(process_configuration_t), intent(inout) :: prc_conf
	integer :: u, i
	u = free_unit ()
	open (unit=u, status="scratch")
	if (prc_conf%method == PRC_SUM) then
	prc_conf%md5sum = ""
	else
	write (u, "(A)") char (model_get_name (prc_conf%model))
	write (u, "(I0)") prc_conf%n_in
	write (u, "(I0)") prc_conf%n_out
	write (u, "(I0)") prc_conf%n_tot
	do i = 1, size (prc_conf%prt_in)
	write (u, "(A)") char (prc_conf%prt_in(i))
	end do
	do i = 1, size (prc_conf%prt_out)
	write (u, "(A)") char (prc_conf%prt_out(i))
	end do
	if (prc_conf%restrictions /= "") then
	write (u, "(A)") char (prc_conf%restrictions)
	end if
	if (prc_conf%method /= PRC_OMEGA) then
	write (u, "(I0)") prc_conf%method
	end if
	if (prc_conf%omega_flags /= "") then
	write (u, "(A)") char (prc_conf%omega_flags)
	end if
	end if
	rewind (u)
	prc_conf%md5sum = md5sum (u)
	close (u)
	end subroutine process_configuration_compute_md5sum

	@ %def process_configuration_compute_md5sum
	@ [[PRC_SUM]] type processes are checksummed on the fly.
	<<XXX Process libraries: procedures>>=
	function process_configuration_prc_sum_md5sum (prc_conf, prc_lib) result (md5)
	type(process_configuration_t), intent(in) :: prc_conf
	type(process_library_t), intent(in), optional :: prc_lib
	type(string_t) :: md5
	integer :: u, pid1, pid2
	u = free_unit ()
	open (unit=u, status="scratch")
	write (u, '(A)') char (prc_conf%child1)
	write (u, '(A)') char (prc_conf%child2)
	if (present (prc_lib)) then
	pid1 = process_library_get_process_pid (prc_lib, prc_conf%child1)
	pid2 = process_library_get_process_pid (prc_lib, prc_conf%child2)
	if (pid1 > 0) write (u, '(A)') &
	char (process_library_get_process_md5sum (prc_lib, pid1))
	if (pid2 > 0) write (u, '(A)') &
	char (process_library_get_process_md5sum (prc_lib, pid2))
	end if
	rewind (u)
	md5 = md5sum (u)
	close (u)
	end function process_configuration_prc_sum_md5sum

	@ %def process_configuration_prc_sum_md5sum
	@ Output (used by the 'list' command):
	<<XXX Process libraries: procedures>>=
	subroutine process_configuration_write (prc_conf, unit)
	type(process_configuration_t), intent(in) :: prc_conf
	integer, intent(in), optional :: unit
	character :: status
	type(string_t) :: in_state, out_state
	type(string_t) :: restrictions_str, omega_flags_str
	integer :: i, u
	u = output_unit (unit)
	if (prc_conf%method == PRC_SUM) then
	call msg_message (" [ ] " // char (prc_conf%id) // " = " // &
	char (prc_conf%child1) // " + " // char(prc_conf%child2))
	return
	end if
	select case (prc_conf%status)
	case (STAT_UNKNOWN); status = "?"
	case (STAT_CONFIGURED); status = "O"
	case (STAT_CODE_GENERATED); status = "G"
	case (STAT_COMPILED); status = "C"
	case (STAT_LOADED); status = "L"
	end select
	in_state = prc_conf%prt_in(1)
	do i = 2, size (prc_conf%prt_in)
	in_state = in_state // ", " // prc_conf%prt_in(i)
	end do
	out_state = prc_conf%prt_out(1)
	do i = 2, size (prc_conf%prt_out)
	out_state = out_state // ", " // prc_conf%prt_out(i)
	end do
	if (prc_conf%restrictions == "" .and. prc_conf%omega_flags == "") then
	call msg_message (" [" // status // "] " // char (prc_conf%id) // " = " &
	// char (in_state) // " => " // char (out_state), unit)
	else
	if (prc_conf%restrictions /= "") then
	restrictions_str = "$restrictions = """ & ! $
	// prc_conf%restrictions // """"
	else
	restrictions_str = ""
	end if
	if (prc_conf%omega_flags /= "") then
	omega_flags_str = "$omega_flags = """ & ! $
	// prc_conf%omega_flags // """"
	else
	omega_flags_str = ""
	end if
	call msg_message (" [" // status // "] " // char (prc_conf%id) // " = " &
	// char (in_state) // " => " // char (out_state) &
	// " { " // char (restrictions_str) // " " &
	// char (omega_flags_str) // " }", unit)
	end if
	call nlo_setup_write (prc_conf%nlo_setup, u)
	end subroutine process_configuration_write

	@ %def process_configuration_write
	@
	\subsection{Canonicalize particle names}
	The [[restrictions]] string can contain particle names, but if it is passed
	verbatim to the matrix element generator, only those particles that the latter
	knows will be understood. Therefore, we tokenize the string, translate the
	particle names, and return the string with translations.
	<<XXX Process libraries: procedures>>=
	function canonicalize_restrictions (string, model) result (newstring)
	type(string_t) :: newstring
	type(string_t), intent(in) :: string
	type(model_t), intent(in), target :: model
	type(stream_t), target :: stream
	type(lexer_t) :: lexer
	type(lexeme_t) :: lexeme
	type(string_t) :: token
	if (string == "") return
	if (extract (string, 1, 1) == "!") return
	newstring = "!"
	call lexer_init (lexer, &
	comment_chars = "", &
	quote_chars = "'", &
	quote_match = "'", &
	single_chars = "+~:", &
	special_class = (/ "&" /), &
	keyword_list = null ())
	call stream_init (stream, string)
	call lexer_assign_stream (lexer, stream)
	TRANSFORM_TOKENS: do
	call lex (lexeme, lexer)
	if (lexeme_is_eof (lexeme)) exit TRANSFORM_TOKENS
	if (lexeme_is_break (lexeme)) then
	call msg_message ("Restriction string = " &
	// '"' // char (string) // '"')
	call msg_fatal ("Syntax error in restrictions specification")
	exit TRANSFORM_TOKENS
	end if
	token = lexeme_get_contents (lexeme)
	select case (lexeme_get_type (lexeme))
	case (T_NUMERIC)
	newstring = newstring // token
	case (T_IDENTIFIER)
	select case (char (extract (token, 1, 1)))
	case ("+", "~", "&", ":")
	newstring = newstring // token
	case default
	newstring = newstring // canonicalize_prt (token, model)
	end select
	case (T_QUOTED)
	newstring = newstring // canonicalize_prt (token, model)
	case default
	call msg_bug ("Token type error in restrictions specification")
	end select
	end do TRANSFORM_TOKENS
	call stream_final (stream)
	end function canonicalize_restrictions

	@ %def canonicalize_restrictions
	@ Transform a particle string into its flavor code and back; this yields the
	canonical name.
	<<XXX Process libraries: procedures>>=
	function canonicalize_prt (string, model) result (newstring)
	type(string_t) :: newstring
	type(string_t), intent(in) :: string
	type(model_t), intent(in), target :: model
	type(flavor_t) :: flv
	integer :: pdg
	pdg = model_get_particle_pdg (model, string)
	if (pdg == 0) then
	call msg_fatal ("Undefined particle in restrictions specification")
	end if
	call flavor_init (flv, pdg, model)
	newstring = flavor_get_name (flv)
	end function canonicalize_prt

	@ %def canonicalize_prt
	@
	\subsection{Process library data}
	This object contains filenames, the complete set of process
	configuration data, the C filehandle interface for the shared library,
	and procedure pointers for the library functions.

	The contents of this type are public because we do not want to have
	another wrapper around the procedure pointer components.

	Note: The procedure pointer [[prc_get_id]] triggers a bug in
	nagfor5.2(649) [incorrect C generated], apparently related to the
	string argument of this procedure. Fortunately, we can live without
	it.
	<<XXX Process libraries: public>>=
	public :: process_library_t
	<<XXX Process libraries: types>>=
	type :: process_library_t
	! private
	logical :: static = .false.
	integer :: status = STAT_UNKNOWN
	type(string_t) :: basename
	type(string_t) :: srcname
	type(string_t) :: libname
	integer :: n_prc = 0
	type(process_configuration_t), pointer :: prc_first => null ()
	type(process_configuration_t), pointer :: prc_last => null ()
	type(dlaccess_t) :: dlaccess
	procedure(prc_get_n_processes), nopass, pointer :: &
	get_n_processes => null ()
	procedure(prc_get_stringptr), nopass, pointer :: &
	get_process_id_ptr => null ()
	procedure(prc_get_stringptr), nopass, pointer :: &
	get_model_name_ptr => null ()
	procedure(prc_get_stringptr), nopass, pointer :: &
	get_md5sum_ptr => null ()
	procedure(prc_get_log), nopass, pointer :: &
	get_openmp_status => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_in => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_out => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_flv => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_hel => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_col => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_cin => null ()
	procedure(prc_get_int), nopass, pointer :: get_n_cf => null ()
	procedure(prc_set_int_tab1), nopass, pointer :: set_flv_state => null ()
	procedure(prc_set_int_tab1), nopass, pointer :: set_hel_state => null ()
	procedure(prc_set_int_tab2), nopass, pointer :: set_col_state => null ()
	procedure(prc_set_cf_tab), nopass, pointer :: set_color_factors => null ()
	procedure(prc_get_fptr), nopass, pointer :: &
	get_fptr => null()
	! procedure(prc_get_int), nopass, pointer :: get_ci_type => null ()
	! procedure(prclib_unload_hook), nopass, pointer :: unload_hook => null ()
	! procedure(prclib_reload_hook), nopass, pointer :: reload_hook => null ()
	end type process_library_t

	@ %def process_library_t
	@ Just allocate the configuration array and set filenames, the rest
	comes later. Note that because libtool may be used, the actual
	[[libname]] can be determined only after the library has been created.
	<<XXX Process libraries: public>>=
	public :: process_library_init
	<<XXX Process libraries: procedures>>=
	subroutine process_library_init (prc_lib, name, os_data)
	type(process_library_t), intent(out) :: prc_lib
	type(string_t), intent(in) :: name
	type(os_data_t), intent(in) :: os_data
	prc_lib%basename = name
	prc_lib%srcname = name // os_data%fc_src_ext
	prc_lib%status = STAT_CONFIGURED
	end subroutine process_library_init

	@ %def process_library_init
	@ Delete the process configuration list, if any.
	<<XXX Process libraries: procedures>>=
	subroutine process_library_clear_configuration (prc_lib)
	type(process_library_t), intent(inout) :: prc_lib
	type(process_configuration_t), pointer :: current
	do while (associated (prc_lib%prc_first))
	current => prc_lib%prc_first
	prc_lib%prc_first => current%next
	deallocate (current)
	end do
	prc_lib%prc_last => null ()
	prc_lib%n_prc = 0
	end subroutine process_library_clear_configuration

	@ %def process_library_clear_configuration
	@ Close the library access if it is open. Delete the
	process-configuration list.
	<<XXX Process libraries: public>>=
	public :: process_library_final
	<<XXX Process libraries: procedures>>=
	subroutine process_library_final (prc_lib)
	type(process_library_t), intent(inout) :: prc_lib
	if (.not. prc_lib%static) call dlaccess_final (prc_lib%dlaccess)
	call process_library_clear_configuration (prc_lib)
	end subroutine process_library_final

	@ %def process_library_final
	@ Given a pointer to a library, return the next pointer.
	<<XXX Process libraries: public>>=
	public :: process_library_advance
	<<XXX Process libraries: procedures>>=
	subroutine process_library_advance (prc_lib)
	type(process_library_t), pointer :: prc_lib
	prc_lib => prc_lib%next
	end subroutine process_library_advance

	@ %def process_library_advance
	@ Output (called by the 'show' command):
	<<XXX Process libraries: public>>=
	public :: process_library_write
	<<XXX Process libraries: procedures>>=
	subroutine process_library_write (prc_lib, unit)
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in), optional :: unit
	type(string_t) :: status
	type(process_configuration_t), pointer :: current
	select case (prc_lib%status)
	case (STAT_UNKNOWN)
	status = "[unknown]"
	case (STAT_CONFIGURED)
	status = "[open]"
	case (STAT_CODE_GENERATED)
	status = "[generated code]"
	case (STAT_COMPILED)
	status = "[compiled]"
	case (STAT_LOADED)
	if (prc_lib%static) then
	status = "[static]"
	else
	status = "[loaded]"
	end if
	end select
	call msg_message ("Process library: " // char (prc_lib%basename) &
	// " " // char (status), unit)
	current => prc_lib%prc_first
	do while (associated (current))
	call process_configuration_write (current, unit)
	current => current%next
	end do
	end subroutine process_library_write

	@ %def process_library_write
	@
	\subsection{Accessing contents}
	Tell/set if the library is static or dynamic
	<<XXX Process libraries: public>>=
	public :: process_library_set_static
	public :: process_library_is_static
	<<XXX Process libraries: procedures>>=
	subroutine process_library_set_static (prc_lib, flag)
	type(process_library_t), intent(inout) :: prc_lib
	logical, intent(in) :: flag
	prc_lib%static = flag
	end subroutine process_library_set_static

	function process_library_is_static (prc_lib) result (flag)
	logical :: flag
	type(process_library_t), intent(in) :: prc_lib
	flag = prc_lib%static
	end function process_library_is_static

	@ %def process_library_set_static
	@ %def process_library_is_static
	@ Return the nominal compilation status of a library.
	<<XXX Process libraries: public>>=
	public :: process_library_is_compiled
	public :: process_library_is_loaded
	<<XXX Process libraries: procedures>>=
	function process_library_is_compiled (prc_lib) result (flag)
	logical :: flag
	type(process_library_t), intent(in) :: prc_lib
	flag = prc_lib%status >= STAT_COMPILED
	end function process_library_is_compiled

	function process_library_is_loaded (prc_lib) result (flag)
	logical :: flag
	type(process_library_t), intent(in) :: prc_lib
	flag = prc_lib%status >= STAT_LOADED
	end function process_library_is_loaded

	@ %def process_library_is_compiled
	@ %def process_library_is_loaded
	@ Return the name of a library (the basename).
	<<XXX Process libraries: public>>=
	public :: process_library_get_name
	<<XXX Process libraries: procedures>>=
	function process_library_get_name (prc_lib) result (name)
	type(string_t) :: name
	type(process_library_t), intent(in) :: prc_lib
	name = prc_lib%basename
	end function process_library_get_name

	@ %def process_library_get_name
	@ Return the number of processes defined so far.
	<<XXX Process libraries: public>>=
	public :: process_library_get_n_processes
	<<XXX Process libraries: procedures>>=
	function process_library_get_n_processes (prc_lib) result (n)
	integer :: n
	type(process_library_t), intent(in) :: prc_lib
	n = prc_lib%n_prc
	end function process_library_get_n_processes

	@ %def process_library_get_n_processes
	@ Return the pointer to a process with specified tag.
	<<XXX Process libraries: procedures>>=
	function process_library_get_process_ptr (prc_lib, prc_id) result (current)
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	type(process_configuration_t), pointer :: current
	current => prc_lib%prc_first
	do while (associated (current))
	if (current%id == prc_id) return
	current => current%next
	end do
	end function process_library_get_process_ptr

	@ %def process_library_get_process_ptr
	@ Return the pointer to a process with specified tag.
	<<XXX Process libraries: public>>=
	public :: process_library_check_name_consistency
	<<XXX Process libraries: procedures>>=
	subroutine process_library_check_name_consistency (prc_id, prc_lib)
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	if (char (prc_id) == 'prc') &
	call msg_fatal ("The name 'prc' cannot " // &
	"be chosen as a valid process name.")
	if (prc_id == prc_lib%basename) &
	call msg_fatal ("Process and library names must not be identical ('" &
	// char (prc_id) // "').")
	end subroutine process_library_check_name_consistency

	@ %def process_library_check_name_consistency
	@ Return the index of a process with specified tag. If the process is
	not found, return zero.
	<<XXX Process libraries: public>>=
	public :: process_library_get_process_index
	<<XXX Process libraries: procedures>>=
	function process_library_get_process_index (prc_lib, prc_id) result (index)
	integer :: index
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	type(process_configuration_t), pointer :: current
	index = 0
	current => prc_lib%prc_first
	do while (associated (current))
	index = index + 1
	if (current%id == prc_id) return
	current => current%next
	end do
	index = 0
	end function process_library_get_process_index

	@ %def process_library_get_process_index
	@
	Query the core interaction type of a process.
	<<XXX Process libraries: public>>=
	public :: process_library_get_ci_type
	<<XXX Process libraries: procedures>>=
	function process_library_get_ci_type (prc_lib, prc_id) result (id)
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	integer :: id
	type(process_configuration_t), pointer :: current
	current => prc_lib%prc_first
	do while (associated (current))
	if (current%id == prc_id) then
	id = current%ci_type
	return
	end if
	current => current%next
	end do
	id = -1
	end function process_library_get_ci_type

	@ %def process_library_get_ci_type
	@
	Get the children of a process sum.
	<<XXX Process libraries: public>>=
	public :: process_library_get_sum_child
	<<XXX Process libraries: procedures>>=
	function process_library_get_sum_child (prc_lib, id, i) result (child)
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: id
	integer, intent(in) :: i
	type(string_t) :: child
	type(process_configuration_t), pointer :: current
	child = ""
	current => prc_lib%prc_first
	do while (associated (current))
	if (current%id == id) then
	if (current%method == PRC_SUM) then
	select case (i)
	case (1); child = current%child1
	case (2); child = current%child2
	end select
	end if
	return
	end if
	current => current%next
	end do
	end function process_library_get_sum_child
	@ %def process_library_get_sum_child
	@
	Apply a nlo setup list.
	<<XXX Process libraries: public>>=
	public :: process_library_apply_nlo_setup
	<<XXX Process libraries: procedures>>=
	subroutine process_library_apply_nlo_setup (prc_lib, prc_id, setup)
	type(process_library_t), intent(inout), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	type(nlo_setup_list_t), intent(in) :: setup
	type(process_configuration_t), pointer :: process
	process => prc_lib%prc_first
	do while (associated (process))
	if (process%id == prc_id) exit
	process => process%next
	end do
	if (.not. associated (process)) then
	call msg_bug ("process_library_apply_nlo_setup called on " &
	// "nonexisting process. This is a BUG.")
	end if
	call nlo_setup_apply_list (process%nlo_setup, setup)
	end subroutine process_library_apply_nlo_setup

	@ %def process_library_apply_nlo_setup.
	@

	Retrieve the dipole config.
	<<XXX Process libraries: public>>=
	public :: process_library_get_nlo_setup
	<<XXX Process libraries: procedures>>=
	function process_library_get_nlo_setup (prc_lib, prc_id) result (config)
	type(process_library_t), intent(in), target :: prc_lib
	type(string_t), intent(in) :: prc_id
	type(nlo_setup_t) :: config
	type(process_configuration_t), pointer :: process
	process => prc_lib%prc_first
	do while (associated (process))
	if (process%id == prc_id) exit
	process => process%next
	end do
	if (.not. associated (process)) call msg_bug ( &
	"process_library_get_nlo_setup called on nonexisting process. " &
	// "This is a BUG.")
	config = process%nlo_setup
	end function process_library_get_nlo_setup
	@ %def process_library_get_nlo_setup
	@

	\subsection{Creating a process library}
	Configure a specific process in the list. First check if the process
	exists, then either edit the existing process configuration or initiate
	a new one. If a status is given, mark the process configuration
	accordingly. Overwrite any existing configuration for the given
	process ID. If the [[rebuild_library]] flag is set, do this silently and
	reset the status. If it is absent or unset, we want to keep the old
	configuration as far as possible. If the checksum has changed issue a
	warning that the configuration was overwritten. If the old status was
	higher, keep it.
	<<XXX Process libraries: public>>=
	public :: process_library_append
	<<XXX Process libraries: procedures>>=
	subroutine process_library_append &
	(prc_lib, ci_type, prc_id, model, prt_in, prt_out, method, &
	status, restrictions, omega_flags, &
	rebuild_library, message, known_md5sum, &
	omega_openmp, nlo_setup)
	type(process_library_t), intent(inout), target :: prc_lib
	integer, intent(in) :: ci_type
	type(string_t), intent(in) :: prc_id
	type(model_t), intent(in), target :: model
	type(string_t), dimension(:), intent(in) :: prt_in, prt_out
	integer, intent(in), optional :: status, method
	type(string_t), intent(in), optional :: restrictions, omega_flags
	logical, intent(in), optional :: rebuild_library, message, omega_openmp
	character(32), intent(in), optional :: known_md5sum
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	type(process_configuration_t), pointer :: current
	character(32) :: old_md5sum
	integer :: old_status, old_ci_type
	logical :: keep_status
	logical :: msg
	logical :: old_omega_openmp, new_omega_openmp
	keep_status = .true.
	if (present (rebuild_library)) keep_status = .not. rebuild_library
	msg = .false.; if (present (message)) msg = message
	if (.not. present (method)) then
	new_omega_openmp = omega_openmp
	else
	select case (method)
	case (PRC_OMEGA)
	new_omega_openmp = omega_openmp
	case default
	new_omega_openmp = .false.
	end select
	end if
	current => process_library_get_process_ptr (prc_lib, prc_id)
	if (associated (current)) then
	old_md5sum = current%md5sum
	old_status = current%status
	old_omega_openmp = current%omega_openmp
	old_ci_type = current%ci_type
	if (present (nlo_setup)) then
	call process_configuration_init &
	(current, ci_type, prc_id, model, prt_in, prt_out, method, status, &
	restrictions, omega_flags, known_md5sum, new_omega_openmp, &
	nlo_setup)
	else
	call process_configuration_init &
	(current, ci_type, prc_id, model, prt_in, prt_out, method, status, &
	restrictions, omega_flags, known_md5sum, new_omega_openmp, &
	current%nlo_setup)
	end if
	if (size (prt_in) == 0) then
	call msg_warning ("Process '" // char (prc_id) &
	// "': matrix element vanishes in selected model '" &
	// char (model_get_name (model)) // "'")
	else if (keep_status) then
	if ((current%md5sum == old_md5sum) .and. &
	(old_omega_openmp .eqv. new_omega_openmp) .and. &
	(old_ci_type == ci_type)) then
	if (current%status <= old_status) then
	call msg_message ("Process '" // char (prc_id) &
	// "': keeping configuration")
	current%status = old_status
	else
	call msg_message ("Process '" // char (prc_id) &
	// "': updating configuration")
	end if
	else
	call msg_warning ("Process '" // char (prc_id) &
	// "': configuration changed, overwriting.")
	end if
	else
	if ((current%md5sum /= old_md5sum) .or. &
	(current%omega_openmp .neqv. old_omega_openmp)) then
	call msg_message ("Process '" // char (prc_id) &
	// "': ignoring previous configuration")
	end if
	end if
	else
	allocate (current)
	if (associated (prc_lib%prc_last)) then
	prc_lib%prc_last%next => current
	else
	prc_lib%prc_first => current
	end if
	prc_lib%prc_last => current
	prc_lib%n_prc = prc_lib%n_prc + 1
	call process_library_check_name_consistency (prc_id, prc_lib)
	call process_configuration_init &
	(current, ci_type, prc_id, model, prt_in, prt_out, method, status, &
	restrictions, omega_flags, known_md5sum, new_omega_openmp, &
	nlo_setup)
	call process_update_code_status (current, keep_status)
	if (msg) call msg_message &
	("Added process to library '" // char (prc_lib%basename) // "':")
	end if
	if (msg) call process_configuration_write (current)
	end subroutine process_library_append

	@ %def process_library_append
	The same, but for a [[PRC_SUM]] type stub proces.
	<<XXX Process libraries: public>>=
	public :: process_library_append_prc_sum
	<<XXX Process libraries: procedures>>=
	subroutine process_library_append_prc_sum &
	(prc_lib, proc_id, child1, child2, nlo_setup, message)
	type(process_library_t), intent(inout), target :: prc_lib
	type(string_t), intent(in) :: proc_id
	type(string_t), intent(in), optional :: child1, child2
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	logical, intent(in), optional :: message
	logical :: msg
	type(process_configuration_t), pointer :: current
	msg = .false.; if (present (message)) msg = message
	current => process_library_get_process_ptr (prc_lib, proc_id)
	if (associated (current)) then
	call process_configuration_init_sum (current, proc_id, child1, child2, &
	nlo_setup)
	else
	allocate (current)
	if (associated (prc_lib%prc_last)) then
	prc_lib%prc_last%next => current
	else
	prc_lib%prc_first => current
	end if
	prc_lib%prc_last => current
	prc_lib%n_prc = prc_lib%n_prc + 1
	call process_library_check_name_consistency (proc_id, prc_lib)
	call process_configuration_init_sum &
	(current, proc_id, child1, child2, nlo_setup)
	if (msg) call msg_message &
	("Added process to library '" // char (prc_lib%basename) // "':")
	end if
	if (msg) call process_configuration_write (current)
	end subroutine process_library_append_prc_sum

	@ %def process_library_append_prc_sum

	@ Look for an existing file for the current process and its MD5
	signature. If successful and a rebuild flag is set, reset the status
	to [[STAT_CODE_GENERATED]]. Otherwise, just issue appropriate
	diagnostic messages.
	<<XXX Process libraries: procedures>>=
	subroutine process_update_code_status (prc_conf, keep_status)
	type(process_configuration_t), intent(inout) :: prc_conf
	logical, intent(in) :: keep_status
	type(string_t) :: filename
	logical :: exist, found
	integer :: u, iostat
	character(80) :: buffer
	character(32) :: md5sum
	logical :: omega_openmp
	if (prc_conf%method == PRC_SUM) return
	filename = prc_conf%id // ".f90"
	inquire (file=char(filename), exist=exist)
	if (exist) then
	found = .false.
	u = free_unit ()
	omega_openmp = .false.
	open (u, file=char(filename), action="read")
	SCAN_FILE: do
	read (u, "(A)", iostat=iostat) buffer
	select case (iostat)
	case (0)
	if (buffer(1:12) == " md5sum =") then
	md5sum = buffer(15:47)
	found = .true.
	end if
	if (buffer(1:5) == "!$OMP") omega_openmp = .true. ! $
	case default
	exit SCAN_FILE
	end select
	end do SCAN_FILE
	close (u)
	if (found) then
	if (keep_status) then
	if (prc_conf%status < STAT_CODE_GENERATED) then
	if ((md5sum == prc_conf%md5sum) .and. &
	(omega_openmp .eqv. prc_conf%omega_openmp)) then
	call msg_message ("Process '" // char (prc_conf%id) &
	// "': using existing source code")
	prc_conf%status = STAT_CODE_GENERATED
	else
	call msg_warning ("Process '" // char (prc_conf%id) &
	// "': will overwrite existing source code")
	end if
	else if ((md5sum /= prc_conf%md5sum) .or. &
	(omega_openmp .neqv. prc_conf%omega_openmp)) then
	call msg_warning ("Process '" // char (prc_conf%id) &
	// "': source code and loaded checksums differ")
	end if
	else if (prc_conf%status < STAT_CODE_GENERATED) then
	call msg_message ("Process '" // char (prc_conf%id) &
	// "': ignoring existing source code")
	end if
	else
	call msg_warning ("Process '" // char (prc_conf%id) &
	// "': No MD5 sum found in source code")
	end if
	end if
	end subroutine process_update_code_status

	@ %def source_code_exists
	@ Check whether all processes in the current library are configured,
	compiled and loaded, and update the library status accordingly.

	If the library needs recompilation, unload it now if necessary.
	<<XXX Process libraries: public>>=
	public :: process_library_update_status
	<<XXX Process libraries: procedures>>=
	subroutine process_library_update_status (prc_lib)
	type(process_library_t), intent(inout), target :: prc_lib
	type(process_configuration_t), pointer :: prc_conf
	integer :: initial_status
	initial_status = prc_lib%status
	prc_conf => prc_lib%prc_first
	do while (associated (prc_conf))
	if (prc_conf%method /= PRC_SUM) &
	prc_lib%status = min (prc_lib%status, prc_conf%status)
	prc_conf => prc_conf%next
	end do
	if (initial_status == STAT_LOADED .and. prc_lib%status < STAT_LOADED) &
	call process_library_unload (prc_lib)
	end subroutine process_library_update_status

	@ %def process_library_update_status
	@ Recover process configuration from a loaded library. Existing
	configurations for processes present in the loaded library will be
	overwritten. If the process is a process sum, we add it to the process library
	without specifying the child processes; the process definitions in SINDARIN will
	later add those with the proper values. Return the pointer to the model
	appropriate for the loaded library.
	<<XXX Process libraries: procedures>>=
	subroutine process_library_load_configuration &
	(prc_lib, os_data, model)
	type(process_library_t), intent(inout), target :: prc_lib
	type(os_data_t), intent(in) :: os_data
	type(model_t), pointer :: model
	integer :: n_prc, p, n_flv, n_in, n_out, n_tot, i
	integer(c_int) :: pid
	integer, dimension(:,:), allocatable :: flv_state
	integer(c_int), dimension(:,:), allocatable, target :: flv_state_tmp
	type(string_t) :: prc_id, model_name, filename, restrictions, omega_flags
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	logical :: omega_openmp
	character(32) :: md5sum
	integer :: ci_type
	n_prc = prc_lib% get_n_prc ()
	SCAN_PROCESSES: do p = 1, n_prc
	pid = p
	ci_type = prc_lib%get_ci_type (pid)
	prc_id = process_library_get_process_id (prc_lib, pid)
	if (ci_type == CI_SUM) then
	call process_library_append_prc_sum (prc_lib, prc_id)
	cycle
	end if
	md5sum = process_library_get_process_md5sum (prc_lib, pid)
	model_name = process_library_get_process_model_name (prc_lib, pid)
	restrictions = process_library_get_process_restrictions (prc_lib, pid)
	omega_flags = process_library_get_process_omega_flags (prc_lib, pid)
	omega_openmp = process_library_get_openmp_status (prc_lib, pid)
	filename = model_name // ".mdl"
	model => null ()
	call model_list_read_model (model_name, filename, os_data, model)
	if (.not. associated (model)) then
	call msg_error ("Process library '" // char (prc_lib%basename) &
	// "', process '" // char (prc_id) // "': " &
	// "model unavailable, process skipped")
	cycle SCAN_PROCESSES
	end if
	n_in = prc_lib% get_n_in (pid)
	n_out = prc_lib% get_n_out (pid)
	n_tot = n_in + n_out
	n_flv = prc_lib% get_n_flv (pid)
	allocate (flv_state (n_tot, n_flv))
	allocate (flv_state_tmp (n_tot, n_flv))
	allocate (prt_in (n_in ))
	allocate (prt_out (n_out))
	call prc_lib% set_flv_state (pid, &
	c_loc (flv_state_tmp), &
	int((/n_tot, n_flv/), kind=c_int))
	flv_state = flv_state_tmp
	do i = 1, n_in
	prt_in(i) = particle_name_string (flv_state (i, :), model)
	end do
	do i = 1, n_out
	prt_out(i) = particle_name_string (flv_state (n_in+i, :), model)
	end do
	call process_library_append &
	(prc_lib, ci_type, prc_id, model, prt_in, prt_out, &
	status=STAT_LOADED, &
	restrictions=restrictions, omega_flags=omega_flags, &
	known_md5sum=md5sum, omega_openmp=omega_openmp)
	deallocate (prt_in, prt_out, flv_state, flv_state_tmp)
	end do SCAN_PROCESSES
	contains
	function particle_name_string (ff, model) result (prt)
	type(string_t) :: prt
	integer, dimension(:), intent(in) :: ff
	type(model_t), intent(in), target :: model
	type(flavor_t) :: flv
	integer :: i
	prt = ""
	do i = 1, size (ff)
	if (all (ff(i) /= ff(:i-1))) then
	call flavor_init (flv, ff(i), model)
	if (prt /= "") prt = prt // ":"
	prt = prt // flavor_get_name (flv)
	end if
	end do
	end function particle_name_string
	end subroutine process_library_load_configuration

	@ %def process_library_load_configuration
	<<XXX Process libraries: public>>=
	public :: process_library_get_process_id
	public :: process_library_get_process_pid
	public :: process_library_get_process_md5sum
	public :: process_library_get_process_model_name
	public :: process_library_get_openmp_status
	<<XXX Process libraries: procedures>>=
	function process_library_get_process_id (prc_lib, pid) result (process_id)
	type(string_t) :: process_id
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	type(c_ptr) :: cptr
	integer(c_int) :: len
	character(kind=c_char), dimension(:), pointer :: char_array
	integer, dimension(1) :: shape
	call prc_lib% get_process_id (pid, cptr, len)
	if (c_associated (cptr)) then
	shape(1) = len
	call c_f_pointer (cptr, char_array, shape)
	process_id = char_from_array (char_array)
	call prc_lib% get_process_id (0_c_int, cptr, len)
	else
	process_id = ""
	end if
	end function process_library_get_process_id

	function process_library_get_process_pid (prc_lib, id) result (process_pid)
	type(process_library_t), intent(in) :: prc_lib
	type(string_t), intent(in) :: id
	integer :: process_pid, pid, n_proc
	process_pid = -1
	n_proc = process_library_get_n_processes (prc_lib)
	if (n_proc <= 0) return
	do pid = 1, n_proc
	if (process_library_get_process_id (prc_lib, pid) == id) then
	process_pid = pid
	return
	end if
	end do
	end function process_library_get_process_pid

	function process_library_get_process_model_name &
	(prc_lib, pid) result (model_name)
	type(string_t) :: model_name
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	type(c_ptr) :: cptr
	integer(c_int) :: len
	character(kind=c_char), dimension(:), pointer :: char_array
	integer, dimension(1) :: shape
	call prc_lib% get_model_name (pid, cptr, len)
	if (c_associated (cptr)) then
	shape(1) = len
	call c_f_pointer (cptr, char_array, shape)
	model_name = char_from_array (char_array)
	call prc_lib% get_model_name (0_c_int, cptr, len)
	else
	model_name = ""
	end if
	end function process_library_get_process_model_name

	function process_library_get_process_restrictions &
	(prc_lib, pid) result (restrictions)
	type(string_t) :: restrictions
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	type(c_ptr) :: cptr
	integer(c_int) :: len
	character(kind=c_char), dimension(:), pointer :: char_array
	integer, dimension(1) :: shape
	call prc_lib% get_restrictions (pid, cptr, len)
	if (c_associated (cptr)) then
	shape(1) = len
	call c_f_pointer (cptr, char_array, shape)
	restrictions = char_from_array (char_array)
	call prc_lib% get_restrictions (0_c_int, cptr, len)
	else
	restrictions = ""
	end if
	end function process_library_get_process_restrictions

	function process_library_get_process_omega_flags &
	(prc_lib, pid) result (omega_flags)
	type(string_t) :: omega_flags
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	type(c_ptr) :: cptr
	integer(c_int) :: len
	character(kind=c_char), dimension(:), pointer :: char_array
	integer, dimension(1) :: shape
	call prc_lib% get_omega_flags (pid, cptr, len)
	if (c_associated (cptr)) then
	shape(1) = len
	call c_f_pointer (cptr, char_array, shape)
	omega_flags = char_from_array (char_array)
	call prc_lib% get_omega_flags (0_c_int, cptr, len)
	else
	omega_flags = ""
	end if
	end function process_library_get_process_omega_flags

	function process_library_get_openmp_status &
	(prc_lib, pid) result (openmp_status)
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	logical :: openmp_status
	type(c_ptr) :: cptr
	openmp_status = prc_lib%get_openmp_status (pid)
	end function process_library_get_openmp_status

	recursive function process_library_get_process_md5sum &
	(prc_lib, pid) result (md5sum)
	type(string_t) :: md5sum
	type(process_library_t), intent(in), target :: prc_lib
	integer(c_int), intent(in) :: pid
	type(c_ptr) :: cptr
	integer(c_int) :: len
	character(kind=c_char), dimension(:), pointer :: char_array
	integer, dimension(1) :: shape
	type(process_configuration_t), pointer :: current
	integer :: i
	md5sum = ""
	if (prc_lib%get_ci_type (pid) == CI_SUM) then
	current => prc_lib%prc_first
	do i = 1, pid - 1
	if (associated (current)) current => current%next
	end do
	if (associated (current)) md5sum = &
	process_configuration_prc_sum_md5sum (current, prc_lib)
	return
	end if
	call prc_lib% get_md5sum (pid, cptr, len)
	if (c_associated (cptr)) then
	shape(1) = len
	call c_f_pointer (cptr, char_array, shape)
	md5sum = char_from_array (char_array)
	call prc_lib% get_md5sum (0_c_int, cptr, len)
	end if
	end function process_library_get_process_md5sum
	@ %def process_library_get_process_id
	@ %def process_library_get_process_model_name
	@ %def process_library_get_process_restrictions
	@ %def process_library_get_process_omega_flags
	@ %def process_library_get_process_md5sum
	@ %def process_library_get_process_pid
	@ %def process_library_get_openmp_status
	@ Auxiliary: Transform a character array into a character string.
	<<XXX Process libraries: procedures>>=
	function char_from_array (a) result (char)
	character(kind=c_char), dimension(:), intent(in) :: a
	character(len=size(a)) :: char
	integer :: i
	do i = 1, len (char)
	char(i:i) = a(i)
	end do
	end function char_from_array

	@ %def char_from_array
	@ Generate process source code. Do this for all processes which have
	just been configured, unless there is a source-code file with
	identical MD5sum.
	<<XXX Process libraries: public>>=
	public :: process_library_generate_code
	<<XXX Process libraries: procedures>>=
	subroutine process_library_generate_code (prc_lib, os_data, simulate)
	type(process_library_t), intent(in) :: prc_lib
	type(os_data_t), intent(in) :: os_data
	logical, intent(in), optional :: simulate
	type(process_configuration_t), pointer :: current
	integer :: status
	call msg_message ("Generating code for process library '" &
	// char (process_library_get_name (prc_lib)) // "'")
	current => prc_lib%prc_first
	SCAN_PROCESSES: do while (associated (current))
	select case (current%status)
	case (STAT_CONFIGURED)
	select case (current%method)
	case (PRC_OMEGA)
	call call_omega (current, os_data, status, simulate)
	if (status == 0) then
	current%status = STAT_CODE_GENERATED
	else
	call msg_error ("Process '" // char (current%id) &
	// "': code generation failed")
	end if
	case (PRC_TEST)
	call write_unit_matrix_element (current, os_data, status, unit=.false.)
	if (status == 0) then
	current%status = STAT_CODE_GENERATED
	else
	call msg_error ("Process '" // char (current%id) &
	// "': code generation failed")
	end if
	case (PRC_UNIT)
	call write_unit_matrix_element (current, os_data, status, unit=.true.)
	if (status == 0) then
	current%status = STAT_CODE_GENERATED
	else
	call msg_error ("Process '" // char (current%id) &
	// "': code generation failed")
	end if
	case default
	call msg_fatal ("These methods are not yet implemented.")
	end select
	case (STAT_CODE_GENERATED:)
	call msg_message ("Skipping process '" // char (current%id) &
	// "' (source code exists)")
	case default
	call msg_message ("Skipping process '" // char (current%id) &
	// "' (undefined configuration)")
	end select
	current => current%next
	end do SCAN_PROCESSES
	end subroutine process_library_generate_code

	@ %def process_library_generate_code
	@ Call \oMega\ for process-code generation.
	<<XXX Process libraries: procedures>>=
	subroutine call_omega (prc_conf, os_data, status, simulate)
	type(process_configuration_t), intent(in) :: prc_conf
	type(os_data_t), intent(in) :: os_data
	integer, intent(out) :: status
	logical, intent(in), optional :: simulate
	type(string_t) :: command_string, binary_name
	type(string_t) :: model_id, omega_mode, omega_cascade, omega_kmatrix, &
	omega_openmp
	integer :: j
	logical :: sim, binary_found
	sim = .false.; if (present (simulate)) sim = simulate
	call msg_message ("Calling O'Mega for process '" &
	// char (prc_conf%id) // "'")
	model_id = model_get_name (prc_conf%model)
	binary_name = "omega_" // model_id // ".opt"
	binary_found = .false.
	select case (char (model_id))
	case ("SM_km")
	omega_kmatrix = " -target:kmatrix_write"
	case default
	omega_kmatrix = ""
	end select
	if (prc_conf%omega_openmp) then
	omega_openmp = " -target:openmp "
	call msg_message ("Enabling OpenMP support in O'Mega")
	! call msg_message ("WARNING: enabling OpenMP support in O'Mega --- " &
	! // "make sure that _both_ ")
	! call msg_message (" WHIZARD _and_ the matrix element are compiled with " &
	! // "the proper OpenMP compiler flags.")
	! call msg_message (" Be prepared for broken results if you compile only " &
	! // " the matrix element with OpenMP flags.")
	else
	omega_openmp = ""
	end if
	if (.not. os_data%use_testfiles) then
	command_string = os_data%whizard_omega_binpath_local &
	// "/" // binary_name
	inquire (file=char (command_string), exist=binary_found)
	end if
	if (.not. binary_found) then
	command_string = os_data%whizard_omega_binpath // "/" // binary_name
	inquire (file=char (command_string), exist=binary_found)
	end if
	if (.not. binary_found) &
	call msg_fatal ("O'Mega binary """ // char (binary_name) // """ not found")
	select case (prc_conf%n_in)
	case (1); omega_mode = "-decay"
	case (2); omega_mode = "-scatter"
	end select
	if (prc_conf%restrictions == "") then
	omega_cascade = ""
	else if (extract (prc_conf%restrictions, 1, 1) == "!") then
	omega_cascade = " -cascade '" &
	// extract (prc_conf%restrictions, 2) // "'"
	else
	omega_cascade = " -cascade '" // prc_conf%restrictions // "'"
	end if
	command_string = command_string &
	// " -o " // prc_conf%id // ".f90" &
	// " -target:whizard" &
	// " -target:parameter_module parameters_" // model_id &
	// " -target:module opr_" // prc_conf%id &
	// omega_kmatrix // omega_openmp &
	// " -target:md5sum " // prc_conf%md5sum &
	// omega_cascade &
	// " -fusion:progress" &
	// " " // prc_conf%omega_flags &
	// " " // omega_mode
	command_string = command_string // " "
	do j = 1, prc_conf%n_in
	if (j == 1) then
	command_string = command_string // "'"
	else
	command_string = command_string // " "
	end if
	command_string = command_string // prc_conf%prt_in(j)
	end do
	command_string = command_string // " ->"
	do j = 1, prc_conf%n_out
	command_string = command_string &
	// " " // prc_conf%prt_out(j)
	end do
	command_string = command_string // "'"
	if (sim) then
	command_string = "cp " // os_data%whizard_testdatapath // "/" &
	// prc_conf%id // ".f90 ."
	call msg_message ("[call not executed, instead: copy file from " &
	// char (os_data%whizard_testdatapath) // "]")
	end if
	call os_system_call (command_string, status, verbose=.true.)
	end subroutine call_omega

	@ %def call_omega
	@
	@ Intrinsic \whizard\ call for unit matrix elements generation. Note
	that color flows, spins and flavors are taken as trivial, i.e. there
	is one (trivial) color flow, one spin combination for all
	particles, and tensor products for flavors are ignored.
	<<XXX Process libraries: procedures>>=
	subroutine write_unit_matrix_element (prc_conf, os_data, status, unit)
	type(process_configuration_t), intent(in) :: prc_conf
	type(os_data_t), intent(in) :: os_data
	integer, intent(out) :: status
	logical, intent(in) :: unit
	integer, dimension(prc_conf%n_in) :: prt_in, mult_in, col_in
	type(flavor_t), dimension(1:prc_conf%n_in) :: flv_in
	integer, dimension(prc_conf%n_out) :: prt_out, mult_out
	integer, dimension(prc_conf%n_tot) :: prt, mult
	integer, dimension(:,:), allocatable :: sxxx
	integer :: dummy
	type(flavor_t), dimension(1:prc_conf%n_out) :: flv_out
	type(string_t) :: proc_str, comment_str
	integer :: u, i, j, count
	integer :: hel, hel_in, hel_out, fac, factor, col_fac
	type(string_t) :: filename
	comment_str = ""
	do i = 1, prc_conf%n_in
	comment_str = comment_str // prc_conf%prt_in(i) // " "
	end do
	do j = 1, prc_conf%n_out
	comment_str = comment_str // prc_conf%prt_out(j) // " "
	end do
	do i = 1, prc_conf%n_in
	prt_in(i) = model_get_particle_pdg (prc_conf%model, prc_conf%prt_in(i))
	call flavor_init (flv_in(i), prt_in(i), prc_conf%model)
	mult_in(i) = flavor_get_multiplicity (flv_in(i))
	col_in(i) = abs(flavor_get_color_type (flv_in(i)))
	mult(i) = mult_in(i)
	end do
	do j = 1, prc_conf%n_out
	prt_out(j) = model_get_particle_pdg (prc_conf%model, prc_conf%prt_out(j))
	call flavor_init (flv_out(j), prt_out(j), prc_conf%model)
	mult_out(j) = flavor_get_multiplicity (flv_out(j))
	mult(prc_conf%n_in + j) = mult_out(j)
	end do
	prt(1:prc_conf%n_in) = prt_in(1:prc_conf%n_in)
	prt(prc_conf%n_in+1:prc_conf%n_tot) = prt_out(1:prc_conf%n_out)
	proc_str = converter (prt)
	hel_in = product (mult_in)
	hel_out = product (mult_out)
	col_fac = product (col_in)
	hel = hel_in * hel_out
	fac = hel
	dummy = 1
	factor = 1
	if (prc_conf%n_out >= 3) then
	do i = 3, prc_conf%n_out
	factor = factor * (i - 2) * (i - 1)
	end do
	end if
	factor = factor * col_fac
	allocate (sxxx(1:hel,1:prc_conf%n_tot))
	call create_spin_table (dummy,hel,fac,mult,sxxx)
	call msg_message ("Writing test matrix element for process '" &
	// char (prc_conf%id) // "'")
	filename = prc_conf%id // ".f90"
	u = free_unit ()
	open (unit=u, file=char(filename), action="write")
	write (u, "(A)") "! File generated automatically by WHIZARD"
	write (u, "(A)") "! "
	write (u, "(A)") "! Note that irresp. of what you demanded WHIZARD"
	write (u, "(A)") "! treats this as colorless process "
	write (u, "(A)") "! "
	write (u, "(A)") "module tpr_" // char(prc_conf%id)
	write (u, "(A)") " "
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use omega_color, OCF => omega_color_factor"
	write (u, "(A)") " "
	write (u, "(A)") " implicit none"
	write (u, "(A)") " private"
	write (u, "(A)") " "
	write (u, "(A)") " public :: md5sum"
	write (u, "(A)") " public :: number_particles_in, number_particles_out"
	write (u, "(A)") " public :: number_spin_states, spin_states"
	write (u, "(A)") " public :: number_flavor_states, flavor_states"
	write (u, "(A)") " public :: number_color_flows, color_flows"
	write (u, "(A)") " public :: number_color_indices, number_color_factors, &"
	write (u, "(A)") " color_factors, color_sum, openmp_supported"
	write (u, "(A)") " public :: init, final, update_alpha_s"
	write (u, "(A)") " public :: reset_helicity_selection"
	write (u, "(A)") " "
	write (u, "(A)") " public :: new_event, is_allowed, get_amplitude"
	write (u, "(A)") " "
	write (u, "(A)") " real(default), parameter :: &"
	write (u, "(A)") " & conv = 0.38937966e12_default"
	write (u, "(A)") " "
	write (u, "(A)") " real(default), parameter :: &"
	write (u, "(A)") " & pi = 3.1415926535897932384626433832795028841972_default"
	write (u, "(A)") " "
	write (u, "(A)") " real(default), parameter :: &"
	if (unit) then
	write (u, "(A)") " & const = 1"
	else
	write (u, "(A,1x,I0,A)") " & const = (16 * pi / conv) * " &
	// "(16 * pi2)(", prc_conf%n_out, "-2) "
	end if
	write (u, "(A)") " "
	write (u, "(A,1x,I0)") " integer, parameter, private :: n_prt = ", &
	prc_conf%n_tot
	write (u, "(A,1x,I0)") " integer, parameter, private :: n_in = ", &
	prc_conf%n_in
	write (u, "(A,1x,I0)") " integer, parameter, private :: n_out = ", &
	prc_conf%n_out
	write (u, "(A)") " integer, parameter, private :: n_cflow = 1"
	write (u, "(A)") " integer, parameter, private :: n_cindex = 2"
	write (u, "(A)") " !!! We ignore tensor products and take only one flavor state."
	write (u, "(A)") " integer, parameter, private :: n_flv = 1"
	write (u, "(A,1x,I0)") " integer, parameter, private :: n_hel = ", hel
	write (u, "(A)") " "
	write (u, "(A)") " logical, parameter, private :: T = .true."
	write (u, "(A)") " logical, parameter, private :: F = .false."
	write (u, "(A)") " "
	do i = 1, hel
	write (u, "(A)") " integer, dimension(n_prt), parameter, private :: &"
	write (u, "(A)") " " // s_conv(i) // " = (/ " // char(converter(sxxx(i,1:prc_conf%n_tot))) // " /)"
	end do
	write (u, "(A)") " integer, dimension(n_prt,n_hel), parameter, private :: table_spin_states = &"
	write (u, "(A)") " reshape ( (/ & "
	do i = 1, hel-1
	write (u, "(A)") " " // s_conv(i) // ", & "
	end do
	write (u, "(A)") " " // s_conv(hel) // " & "
	write (u, "(A)") " /), (/ n_prt, n_hel /) )"
	write (u, "(A)") " "
	write (u, "(A)") " integer, dimension(n_prt), parameter, private :: &"
	write (u, "(A)") " f0001 = (/ " // char(proc_str) // " /) ! " // char(comment_str)
	write (u, "(A)") " integer, dimension(n_prt,n_flv), parameter, private :: table_flavor_states = &"
	write (u, "(A)") " reshape ( (/ f0001 /), (/ n_prt, n_flv /) )"
	write (u, "(A)") " "
	write (u, "(A)") " integer, dimension(n_cindex, n_prt), parameter, private :: &"
	write (u, "(A)") " c0001 = reshape ( (/ " // char (dummy_colorizer (flv_in)) // " " // &
	(repeat ("0,0, ", prc_conf%n_out-1)) // "0,0 /), " // " (/ n_cindex, n_prt /) )"
	write (u, "(A)") " integer, dimension(n_cindex, n_prt, n_cflow), parameter, private :: &"
	write (u, "(A)") " table_color_flows = reshape ( (/ c0001 /), (/ n_cindex, n_prt, n_cflow /) )"
	write (u, "(A)") " "
	write (u, "(A)") " logical, dimension(n_prt), parameter, private :: & "
	write (u, "(A)") " g0001 = (/ " // (repeat ("F, ", prc_conf%n_tot-1)) // "F /) "
	write (u, "(A)") " logical, dimension(n_prt, n_cflow), parameter, private :: table_ghost_flags = &"
	write (u, "(A)") " reshape ( (/ g0001 /), (/ n_prt, n_cflow /) )"
	write (u, "(A)") " "
	write (u, "(A)") " integer, parameter, private :: n_cfactors = 1"
	write (u, "(A)") " type(OCF), dimension(n_cfactors), parameter, private :: &"
	write (u, "(A)") " table_color_factors = (/ OCF(1,1,+1._default) /)"
	write (u, "(A)") " "
	write (u, "(A)") " logical, dimension(n_flv), parameter, private :: a0001 = (/ T /)"
	write (u, "(A)") " logical, dimension(n_flv, n_cflow), parameter, private :: &"
	write (u, "(A)") " flv_col_is_allowed = reshape ( (/ a0001 /), (/ n_flv, n_cflow /) )"
	write (u, "(A)") " "
	write (u, "(A)") " complex(default), dimension (n_flv, n_hel, n_cflow), private, save :: amp"
	write (u, "(A)") " "
	write (u, "(A)") " logical, dimension(n_hel), private, save :: hel_is_allowed = T"
	write (u, "(A)") " "
	write (u, "(A)") "contains"
	write (u, "(A)") " "
	write (u, "(A)") " pure function md5sum ()"
	write (u, "(A)") " character(len=32) :: md5sum"
	write (u, "(A)") " ! DON'T EVEN THINK of modifying the following line!"
	write (u, "(A)") " md5sum = """ // prc_conf%md5sum // """"
	write (u, "(A)") " end function md5sum"
	write (u, "(A)") " "
	write (u, "(A)") " subroutine init (par)"
	write (u, "(A)") " real(default), dimension(*), intent(in) :: par"
	write (u, "(A)") " end subroutine init"
	write (u, "(A)") " "
	write (u, "(A)") " subroutine final ()"
	write (u, "(A)") " end subroutine final"
	write (u, "(A)") " "
	write (u, "(A)") " subroutine update_alpha_s (alpha_s)"
	write (u, "(A)") " real(default), intent(in) :: alpha_s"
	write (u, "(A)") " end subroutine update_alpha_s"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_particles_in () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = n_in"
	write (u, "(A)") " end function number_particles_in"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_particles_out () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = n_out"
	write (u, "(A)") " end function number_particles_out"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_spin_states () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = size (table_spin_states, dim=2)"
	write (u, "(A)") " end function number_spin_states"
	write (u, "(A)") " "
	write (u, "(A)") " pure subroutine spin_states (a)"
	write (u, "(A)") " integer, dimension(:,:), intent(out) :: a"
	write (u, "(A)") " a = table_spin_states"
	write (u, "(A)") " end subroutine spin_states"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_flavor_states () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = 1"
	write (u, "(A)") " end function number_flavor_states"
	write (u, "(A)") " "
	write (u, "(A)") " pure subroutine flavor_states (a)"
	write (u, "(A)") " integer, dimension(:,:), intent(out) :: a"
	write (u, "(A)") " a = table_flavor_states"
	write (u, "(A)") " end subroutine flavor_states"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_color_indices () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = size(table_color_flows, dim=1)"
	write (u, "(A)") " end function number_color_indices"
	write (u, "(A)") " "
	write (u, "(A)") " pure subroutine color_factors (cf)"
	write (u, "(A)") " type(OCF), dimension(:), intent(out) :: cf"
	write (u, "(A)") " cf = table_color_factors"
	write (u, "(A)") " end subroutine color_factors"
	write (u, "(A)") " "
	write (u, "(A)") " pure function color_sum (flv, hel) result (amp2)"
	write (u, "(A)") " integer, intent(in) :: flv, hel"
	write (u, "(A)") " real(kind=default) :: amp2"
	write (u, "(A)") " amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"
	write (u, "(A)") " end function color_sum"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_color_flows () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = size (table_color_flows, dim=3)"
	write (u, "(A)") " end function number_color_flows"
	write (u, "(A)") " "
	write (u, "(A)") " pure subroutine color_flows (a, g)"
	write (u, "(A)") " integer, dimension(:,:,:), intent(out) :: a"
	write (u, "(A)") " logical, dimension(:,:), intent(out) :: g"
	write (u, "(A)") " a = table_color_flows"
	write (u, "(A)") " g = table_ghost_flags"
	write (u, "(A)") " end subroutine color_flows"
	write (u, "(A)") " "
	write (u, "(A)") " pure function number_color_factors () result (n)"
	write (u, "(A)") " integer :: n"
	write (u, "(A)") " n = size (table_color_factors)"
	write (u, "(A)") " end function number_color_factors"
	write (u, "(A)") " "
	write (u, "(A)") " pure function openmp_supported () result (status)"
	write (u, "(A)") " logical :: status"
	write (u, "(A)") " status = .false."
	write (u, "(A)") " end function openmp_supported"
	write (u, "(A)") " "
	write (u, "(A)") " subroutine new_event (p)"
	write (u, "(A)") " real(default), dimension(0:3,*), intent(in) :: p"
	write (u, "(A)") " call calculate_amplitudes (amp, p)"
	write (u, "(A)") " end subroutine new_event"
	write (u, "(A)") " "
	write (u, "(A)") " subroutine reset_helicity_selection (threshold, cutoff)"
	write (u, "(A)") " real(default), intent(in) :: threshold"
	write (u, "(A)") " integer, intent(in) :: cutoff"
	write (u, "(A)") " end subroutine reset_helicity_selection"
	write (u, "(A)") " "
	write (u, "(A)") " pure function is_allowed (flv, hel, col) result (yorn)"
	write (u, "(A)") " logical :: yorn"
	write (u, "(A)") " integer, intent(in) :: flv, hel, col"
	write (u, "(A)") " yorn = hel_is_allowed(hel) .and. flv_col_is_allowed(flv,col)"
	write (u, "(A)") " end function is_allowed"
	write (u, "(A)") " "
	write (u, "(A)") " pure function get_amplitude (flv, hel, col) result (amp_result)"
	write (u, "(A)") " complex(default) :: amp_result"
	write (u, "(A)") " integer, intent(in) :: flv, hel, col"
	write (u, "(A)") " amp_result = amp (flv, hel, col)"
	write (u, "(A)") " end function get_amplitude"
	write (u, "(A)") " "
	write (u, "(A)") " pure subroutine calculate_amplitudes (amp, k)"
	write (u, "(A)") " complex(default), dimension(:,:,:), intent(out) :: amp"
	write (u, "(A)") " real(default), dimension(0:3,*), intent(in) :: k"
	write (u, "(A)") " real(default) :: fac"
	write (u, "(A)") " integer :: i"
	write (u, "(A)") " ! We give all helicities the same weight!"
	if (unit) then
	write (u, "(A,1x,I0,1x,A)") " fac = ", col_fac
	write (u, "(A)") " amp = const * sqrt(fac)"
	else
	write (u, "(A,1x,I0,1x,A)") " fac = ", factor
	write (u, "(A)") " amp = sqrt((2 * (k(0,1)*k(0,2) &"
	write (u, "(A,1x,I0,A)") " - dot_product (k(1:,1), k(1:,2)))) ** (3-", &
	prc_conf%n_out, ")) * sqrt(const * fac)"
	end if
	write (u, "(A,1x,I0,A)") " amp = amp / sqrt(", hel_out, "._default)"
	write (u, "(A)") " end subroutine calculate_amplitudes"
	write (u, "(A)") " "
	write (u, "(A)") "end module tpr_" // char(prc_conf%id)
	close (u, iostat=status)
	deallocate (sxxx)
	contains
	function s_conv (num) result (chrt)
	integer, intent(in) :: num
	character(len=10) :: chrt
	write (chrt, "(I10)") num
	chrt = trim(adjustl(chrt))
	if (num < 10) then
	chrt = "s000" // chrt
	else if (num < 100) then
	chrt = "s00" // chrt
	else if (num < 1000) then
	chrt = "s0" // chrt
	else
	chrt = "s" // chrt
	end if
	end function s_conv
	function converter (flv) result (str)
	integer, dimension(:), intent(in) :: flv
	type(string_t) :: str
	character(len=150), dimension(size(flv)) :: chrt
	integer :: i
	str = ""
	do i = 1, size(flv) - 1
	write (chrt(i), "(I10)") flv(i)
	str = str // var_str(trim(adjustl(chrt(i)))) // ", "
	end do
	write (chrt(size(flv)), "(I10)") flv(size(flv))
	str = str // trim(adjustl(chrt(size(flv))))
	end function converter
	integer function sj (j,m)
	integer, intent(in) :: j, m
	if (((j == 1) .and. (m == 1)) .or. &
	((j == 2) .and. (m == 2)) .or. &
	((j == 3) .and. (m == 3)) .or. &
	((j == 4) .and. (m == 3)) .or. &
	((j == 5) .and. (m == 4))) then
	sj = 1
	else if (((j == 2) .and. (m == 1)) .or. &
	((j == 3) .and. (m == 1)) .or. &
	((j == 4) .and. (m == 2)) .or. &
	((j == 5) .and. (m == 2))) then
	sj = -1
	else if (((j == 3) .and. (m == 2)) .or. &
	((j == 5) .and. (m == 3))) then
	sj = 0
	else if (((j == 4) .and. (m == 1)) .or. &
	((j == 5) .and. (m == 1))) then
	sj = -2
	else if (((j == 4) .and. (m == 4)) .or. &
	((j == 5) .and. (m == 5))) then
	sj = 2
	else
	call msg_fatal ("Write_unit_matrix_element: Wrong spin type")
	end if
	end function sj
	recursive subroutine create_spin_table (index, nhel, fac, mult, inta)
	integer, intent(inout) :: index, fac
	integer, intent(in) :: nhel
	integer, dimension(:), intent(in) :: mult
	integer, dimension(nhel,size(mult)), intent(out) :: inta
	integer :: i, j
	if (index > size(mult)) return
	fac = fac / mult(index)
	do j = 1, nhel
	inta(j,index) = sj (mult(index),mod(((j-1)/fac),mult(index))+1)
	end do
	index = index + 1
	call create_spin_table (index, nhel, fac, mult, inta)
	end subroutine create_spin_table
	function dummy_colorizer (flv) result (str)
	type(flavor_t), dimension(:), intent(in) :: flv
	type(string_t) :: str
	integer :: i, k
	str = ""
	k = 0
	do i = 1, size(flv)
	k = k + 1
	select case (flavor_get_color_type (flv(i)))
	case (1,-1)
	str = str // "0,0, "
	case (3)
	str = str // int2string(k) // ",0, "
	case (-3)
	str = str // "0," // int2string(-k) // ", "
	case (8)
	str = str // int2string(k) // "," // int2string(-k-1) // ", "
	k = k + 1
	case default
	call msg_error ("Color type not supported.")
	end select
	end do
	str = adjustl(trim(str))
	end function dummy_colorizer
	end subroutine write_unit_matrix_element

	@ %def write_unit_matrix_element
	@
	\subsection{Interface file for the generated modules}
	<<XXX Process libraries: public>>=
	public :: process_library_write_driver
	<<XXX Process libraries: procedures>>=
	subroutine process_library_write_driver (prc_lib)

	type(process_library_t), intent(inout) :: prc_lib
	type(string_t) :: filename, prefix
	type(string_t), dimension(:), allocatable :: prc_id, mod_prc_id, model
	type(string_t), dimension(:), allocatable :: restrictions, omega_flags
	integer, dimension(:), allocatable :: n_par, ci_type
	logical, dimension(:), allocatable :: virtual
	character(32), dimension(:), allocatable :: md5sum
	type(process_configuration_t), pointer :: current
	integer :: u, i, n_prc

	call msg_message ("Writing interface code for process library '" // &
	char (process_library_get_name (prc_lib)) // "'")
	prefix = prc_lib%basename // "_"

	n_prc = prc_lib%n_prc
	allocate (prc_id (n_prc), mod_prc_id (n_prc), model (n_prc))
	allocate (restrictions (n_prc), omega_flags (n_prc))
	allocate (n_par (n_prc), md5sum (n_prc), ci_type (n_prc))
	allocate (virtual(n_prc))
	current => prc_lib%prc_first
	do i = 1, n_prc
	ci_type(i) = current%ci_type
	prc_id(i) = current%id
	if (current%method == PRC_SUM) then
	virtual(i) = .true.
	current => current%next
	cycle
	end if
	virtual(i) = .false.
	mod_prc_id(i) = &
	process_library_get_module_name (current%id,current%method)
	model(i) = model_get_name (current%model)
	restrictions(i) = current%restrictions
	omega_flags(i) = current%omega_flags
	n_par(i) = model_get_n_parameters (current%model)
	md5sum(i) = current%md5sum
	current => current%next
	end do
	filename = prc_lib%basename // "_interface.f90"
	u = free_unit ()
	open (unit=u, file=char(prc_lib%basename // ".f90"), action="write")
	write (u, "(A)") "! WHIZARD process interface"
	write (u, "(A)") "!"
	write (u, "(A)") "! Automatically generated file, do not edit"
	call write_get_n_processes_fun ()
	call write_get_process_id_fun ()
	call write_get_model_name_fun ()
	call write_get_restrictions_fun ()
	call write_get_omega_flags_fun ()
	call write_get_openmp_status_fun ()
	call write_get_md5sum_fun ()
	call write_string_to_array_fun ()
	call write_get_int_fun ("n_in", "number_particles_in")
	call write_get_int_fun ("n_out", "number_particles_out")
	call write_get_int_fun ("n_flv", "number_flavor_states")
	call write_get_int_fun ("n_hel", "number_spin_states")
	call write_get_int_fun ("n_col", "number_color_flows")
	call write_get_int_fun ("n_cin", "number_color_indices")
	call write_get_int_fun ("n_cf", "number_color_factors")
	call write_set_int_sub1 ("flv_state", "flavor_states")
	call write_set_int_sub1 ("hel_state", "spin_states")
	call write_set_int_sub2 ("col_state", "color_flows", "ghost_flag")
	call write_set_cf_tab_sub ()
	call write_init_get_fptr ()
	call write_final_get_fptr ()
	call write_update_alpha_s_get_fptr ()
	call write_reset_helicity_selection_get_fptr ()
	call write_new_event_get_fptr ()
	call write_is_allowed_get_fptr ()
	call write_get_amplitude_get_fptr ()
	call write_get_ci_type
	close (u)

	prc_lib%status = max (prc_lib%status, STAT_CODE_GENERATED)

	contains

	function logical_to_string (flag) result (str)
	logical, intent(in) :: flag
	type(string_t) :: str
	if (flag) then
	str = ".true."
	else
	str = ".false."
	end if
	end function logical_to_string

	subroutine write_get_n_processes_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the number of processes in this library"
	write (u, "(A)") "function " // char (prefix) &
	// "get_n_processes () result (n) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int) :: n"
	write (u, "(A,I0)") " n = ", n_prc
	write (u, "(A)") "end function " // char (prefix) &
	// "get_n_processes"
	end subroutine write_get_n_processes_fun

	subroutine write_get_process_id_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the process ID of process #i (as a C pointer to a character array)"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_process_id (i, cptr, len) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " type(c_ptr), intent(inout) :: cptr"
	write (u, "(A)") " integer(c_int), intent(out) :: len"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a"
	call write_string_to_array_interface ()
	write (u, "(A)") " select case (i)"
	write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)"
	do i = 1, n_prc
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "call " // char (prefix) &
	// "string_to_array ('" // char (prc_id(i)) // "', a)"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") " if (allocated (a)) then"
	write (u, "(A)") " cptr = c_loc (a)"
	write (u, "(A)") " len = size (a)"
	write (u, "(A)") " else"
	write (u, "(A)") " cptr = c_null_ptr"
	write (u, "(A)") " len = 0"
	write (u, "(A)") " end if"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_process_id"
	end subroutine write_get_process_id_fun

	subroutine write_get_model_name_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the model name for process #i (as a C pointer to a character array)"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_model_name (i, cptr, len) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " type(c_ptr), intent(inout) :: cptr"
	write (u, "(A)") " integer(c_int), intent(out) :: len"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a"
	call write_string_to_array_interface ()
	write (u, "(A)") " select case (i)"
	write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "call " // char (prefix) &
	// "string_to_array ('" // char (model(i)) // "', a)"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") " if (allocated (a)) then"
	write (u, "(A)") " cptr = c_loc (a)"
	write (u, "(A)") " len = size (a)"
	write (u, "(A)") " else"
	write (u, "(A)") " cptr = c_null_ptr"
	write (u, "(A)") " len = 0"
	write (u, "(A)") " end if"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_model_name"
	end subroutine write_get_model_name_fun

	subroutine write_get_restrictions_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the restriction string process #i (as a C pointer to a character array)"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_restrictions (i, cptr, len) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " type(c_ptr), intent(inout) :: cptr"
	write (u, "(A)") " integer(c_int), intent(out) :: len"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a"
	call write_string_to_array_interface ()
	write (u, "(A)") " select case (i)"
	write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "call " // char (prefix) &
	// "string_to_array ('" // char (restrictions(i)) // "', a)"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") " if (allocated (a)) then"
	write (u, "(A)") " cptr = c_loc (a)"
	write (u, "(A)") " len = size (a)"
	write (u, "(A)") " else"
	write (u, "(A)") " cptr = c_null_ptr"
	write (u, "(A)") " len = 0"
	write (u, "(A)") " end if"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_restrictions"
	end subroutine write_get_restrictions_fun

	subroutine write_get_omega_flags_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the omega flags for process #i (as a C pointer to a character array)"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_omega_flags (i, cptr, len) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " type(c_ptr), intent(inout) :: cptr"
	write (u, "(A)") " integer(c_int), intent(out) :: len"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a"
	call write_string_to_array_interface ()
	write (u, "(A)") " select case (i)"
	write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "call " // char (prefix) &
	// "string_to_array ('" // char (omega_flags(i)) // "', a)"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") " if (allocated (a)) then"
	write (u, "(A)") " cptr = c_loc (a)"
	write (u, "(A)") " len = size (a)"
	write (u, "(A)") " else"
	write (u, "(A)") " cptr = c_null_ptr"
	write (u, "(A)") " len = 0"
	write (u, "(A)") " end if"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_omega_flags"
	end subroutine write_get_omega_flags_fun

	subroutine write_get_openmp_status_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return the OpenMP support status"
	write (u, "(A)") "function " // char (prefix) &
	// "get_openmp_status (i) result (openmp_status) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	call write_use_lines ("openmp_supported", "openmp_supported")
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " logical(c_bool) :: openmp_status"
	write (u, "(A)") " select case (i)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "openmp_status = " // char (prc_id(i)) // "_openmp_supported ()"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") "end function " // char (prefix) &
	// "get_openmp_status"
	end subroutine write_get_openmp_status_fun

	subroutine write_get_md5sum_fun ()
	integer :: i
	write (u, "(A)") ""
	write (u, "(A)") "! Return the MD5 sum for the process configuration (as a C pointer to a character array)"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_md5sum (i, cptr, len) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	call write_use_lines ("md5sum", "md5sum")
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " type(c_ptr), intent(inout) :: cptr"
	write (u, "(A)") " integer(c_int), intent(out) :: len"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a"
	call write_string_to_array_interface ()
	write (u, "(A)") " select case (i)"
	write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(A,I0,A)") " case (", i, "); " &
	// "call " // char (prefix) &
	// "string_to_array (" // char (prc_id(i)) &
	// "_md5sum (), a)"
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") " if (allocated (a)) then"
	write (u, "(A)") " cptr = c_loc (a)"
	write (u, "(A)") " len = size (a)"
	write (u, "(A)") " else"
	write (u, "(A)") " cptr = c_null_ptr"
	write (u, "(A)") " len = 0"
	write (u, "(A)") " end if"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_md5sum"
	end subroutine write_get_md5sum_fun

	subroutine write_string_to_array_interface ()
	write (u, "(2x,A)") "interface"
	write (u, "(5x,A)") "subroutine " // char (prefix) &
	// "string_to_array (string, a)"
	write (u, "(5x,A)") " use iso_c_binding"
	write (u, "(5x,A)") " character(*), intent(in) :: string"
	write (u, "(5x,A)") " character(kind=c_char), dimension(:), allocatable, intent(out) :: a"
	write (u, "(5x,A)") "end subroutine " // char (prefix) &
	// "string_to_array"
	write (u, "(2x,A)") "end interface"
	end subroutine write_string_to_array_interface

	subroutine write_string_to_array_fun ()
	write (u, "(A)") ""
	write (u, "(A)") "! Auxiliary: convert character string to array pointer"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "string_to_array (string, a)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " character(*), intent(in) :: string"
	write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, intent(out) :: a"
	write (u, "(A)") " integer :: i"
	write (u, "(A)") " allocate (a (len (string)))"
	write (u, "(A)") " do i = 1, size (a)"
	write (u, "(A)") " a(i) = string(i:i)"
	write (u, "(A)") " end do"
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "string_to_array"
	end subroutine write_string_to_array_fun

	subroutine write_get_int_fun (vname, fname)
	character(*), intent(in) :: vname, fname
	write (u, "(A)") ""
	write (u, "(A)") "! Return the value of " // vname
	write (u, "(A)") "function " // char (prefix) &
	// "get_" // vname // " (pid)" &
	// " result (" // vname // ") bind(C)"
	write (u, "(A)") " use iso_c_binding"
	call write_use_lines (vname, fname)
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " integer(c_int) :: " // vname
	call write_case_lines (vname // " = ", "_" // vname // " ()")
	write (u, "(A)") "end function " // char (prefix) &
	// "get_" // vname
	end subroutine write_get_int_fun

	subroutine write_set_int_sub1 (vname, fname)
	character(*), intent(in) :: vname, fname
	write (u, "(A)") ""
	write (u, "(A)") "! Set table: " // vname
	write (u, "(A)") "subroutine " // char (prefix) &
	// "set_" // vname &
	// " (pid, cptr, shape) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	call write_use_lines (vname, fname)
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_ptr), intent(in) :: cptr"
	write (u, "(A)") " integer(c_int), dimension(2), intent(in) :: shape"
	write (u, "(A)") " integer(c_int), dimension(:,:), pointer :: " // vname
	if (kind(1) /= c_int) then
	write (u, "(A)") " integer, dimension(:,:), allocatable :: " &
	// vname // "_tmp"
	end if
	write (u, "(A)") " call c_f_pointer (cptr, " // vname // ", shape)"
	if (kind(1) == c_int) then
	call write_case_lines ("call ", "_" // vname // " (" // vname // ")")
	else
	write (u, "(A)") " allocate (" &
	// vname // "_tmp (shape(1), shape(2)))"
	call write_case_lines ("call ", &
	"_" // vname // " (" // vname // "_tmp)")
	write (u, "(A)") " " // vname // " = " // vname // "_tmp"
	end if
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "set_" // vname
	end subroutine write_set_int_sub1

	subroutine write_set_int_sub2 (vname, fname, lname)
	character(*), intent(in) :: vname, fname, lname
	write (u, "(A)") ""
	write (u, "(A)") "! Set tables: " // vname // ", " // lname
	write (u, "(A)") "subroutine " // char (prefix) &
	// "set_" // vname &
	// " (pid, cptr, shape, lcptr, lshape) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	call write_use_lines (vname, fname)
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_ptr), intent(in) :: cptr"
	write (u, "(A)") " integer(c_int), dimension(3), intent(in) :: shape"
	write (u, "(A)") " type(c_ptr), intent(in) :: lcptr"
	write (u, "(A)") " integer(c_int), dimension(2), intent(in) :: lshape"
	write (u, "(A)") " integer(c_int), dimension(:,:,:), pointer :: " &
	// vname
	write (u, "(A)") " logical(c_bool), dimension(:,:), pointer :: " &
	// lname
	if (kind(1) /= c_int) then
	write (u, "(A)") " integer, dimension(:,:), allocatable :: " &
	// vname // "_tmp"
	end if
	if (kind(.true.) /= c_bool) then
	write (u, "(A)") " logical, dimension(:,:), allocatable :: " &
	// lname // "_tmp"
	end if
	write (u, "(A)") " call c_f_pointer (cptr, " // vname // ", shape)"
	write (u, "(A)") " call c_f_pointer (lcptr, " // lname // ", lshape)"
	if (kind(1) /= c_int) then
	write (u, "(A)") " allocate (" &
	// vname // "_tmp (shape(1), shape(2), shape(3)))"
	end if
	if (kind(.true.) /= c_bool) then
	write (u, "(A)") " allocate (" &
	// lname // "_tmp (lshape(1), lshape(2)))"
	end if
	if (kind(1) == c_int) then
	if (kind(.true.) == c_bool) then
	call write_case_lines ("call ", &
	"_" // vname // " (" // vname // ", " // lname // ")")
	else
	call write_case_lines ("call ", &
	"_" // vname // " (" // vname // ", " // lname // "_tmp)")
	write (u, "(A)") " " // lname // " = " // lname // "_tmp"
	end if
	else
	if (kind(.true.) == c_bool) then
	call write_case_lines ("call ", &
	"_" // vname // " (" // vname // "_tmp, " // lname // ")")
	else
	call write_case_lines ("call ", &
	"_" // vname // " (" // vname // "_tmp, " // lname // "_tmp)")
	write (u, "(A)") " " // lname // " = " // lname // "_tmp"
	end if
	write (u, "(A)") " " // vname // " = " // vname // "_tmp"
	end if
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "set_" // vname
	end subroutine write_set_int_sub2

	subroutine write_set_cf_tab_sub ()
	write (u, "(A)") ""
	write (u, "(A)") "subroutine " // char (prefix) &
	// "set_cf_table (pid, iptr1, iptr2, cptr, shape) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use omega_color"
	call write_use_lines ("color_factors", "color_factors")
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_ptr), intent(in) :: iptr1, iptr2, cptr"
	write (u, "(A)") " integer(c_int), dimension(1), intent(in) :: shape"
	write (u, "(A)") " integer(c_int), dimension(:), pointer :: " &
	// "cf_index1, cf_index2"
	write (u, "(A)") " complex(c_default_complex), dimension(:), " &
	// "pointer :: col_factor"
	write (u, "(A)") " type(omega_color_factor), dimension(:), " &
	// "allocatable :: cf"
	write (u, "(A)") " call c_f_pointer (iptr1, cf_index1, shape)"
	write (u, "(A)") " call c_f_pointer (iptr2, cf_index2, shape)"
	write (u, "(A)") " call c_f_pointer (cptr, col_factor, shape)"
	write (u, "(A)") " allocate (cf (shape(1)))"
	call write_case_lines ("call ", "_color_factors (cf)")
	write (u, "(A)") " cf_index1 = cf%i1"
	write (u, "(A)") " cf_index2 = cf%i2"
	write (u, "(A)") " col_factor = cf%factor"
	write (u, "(A)") "end subroutine " // char (prefix) // "set_cf_table"
	end subroutine write_set_cf_tab_sub

	subroutine write_init_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'init'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "init_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " subroutine prc_init (par) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " real(c_default_float), dimension(*), " &
	// "intent(in) :: par"
	write (u, "(A)") " end subroutine prc_init"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_init), bind(C) :: " &
	// char (prc_id(i)) // "_init"
	end do
	call write_case_lines ("fptr = c_funloc (", "_init)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "init_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "subroutine " // char (prc_id(i)) &
	// "_init (par) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " real(c_default_float), dimension(*), " &
	// "intent(in) :: par"
	if (c_default_float == default) then
	write (u, "(A)") " call init (par)"
	else
	write (u, "(A, I0)") " integer, parameter :: n_par = ", n_par(i)
	write (u, "(A)") " real(default), dimension(n_par) :: fpar"
	write (u, "(A)") " fpar = par"
	write (u, "(A)") " call init (fpar)"
	end if
	write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_init"
	end do
	end subroutine write_init_get_fptr

	subroutine write_final_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'final'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "final_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " subroutine prc_final () bind(C)"
	write (u, "(A)") " end subroutine prc_final"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_final), bind(C) :: " &
	// char (prc_id(i)) // "_final"
	end do
	call write_case_lines ("fptr = c_funloc (", "_final)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "final_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "subroutine " // char (prc_id(i)) &
	// "_final () bind(C)"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " call final ()"
	write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_final"
	end do
	end subroutine write_final_get_fptr

	subroutine write_update_alpha_s_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'update_alpha_s'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "update_alpha_s_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " subroutine prc_update_alpha_s (alpha_s) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " real(c_default_float), " &
	// "intent(in) :: alpha_s"
	write (u, "(A)") " end subroutine prc_update_alpha_s"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_update_alpha_s), bind(C) :: " &
	// char (prc_id(i)) // "_update_alpha_s"
	end do
	call write_case_lines ("fptr = c_funloc (", "_update_alpha_s)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "update_alpha_s_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "subroutine " // char (prc_id(i)) &
	// "_update_alpha_s (alpha_s) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " real(c_default_float), " &
	// "intent(in) :: alpha_s"
	if (c_default_float == default) then
	write (u, "(A)") " call update_alpha_s (alpha_s)"
	else
	write (u, "(A)") " call update_alpha_s " &
	// "(real (alpha_s, c_default_float))"
	end if
	write (u, "(A)") "end subroutine " // char (prc_id(i)) &
	// "_update_alpha_s"
	end do
	end subroutine write_update_alpha_s_get_fptr

	subroutine write_reset_helicity_selection_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: " &
	// "'reset_helicity_selection'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "reset_helicity_selection_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " subroutine " &
	// "prc_reset_helicity_selection (threshold, cutoff) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " real(c_default_float), " &
	// "intent(in) :: threshold"
	write (u, "(A)") " integer(c_int), " &
	// "intent(in) :: cutoff"
	write (u, "(A)") " end subroutine prc_reset_helicity_selection"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_reset_helicity_selection), " &
	// "bind(C) :: " &
	// char (prc_id(i)) // "_reset_helicity_selection"
	end do
	call write_case_lines ("fptr = c_funloc (", "_reset_helicity_selection)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "reset_helicity_selection_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "subroutine " // char (prc_id(i)) &
	// "_reset_helicity_selection (threshold, cutoff) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " real(c_default_float), " &
	// "intent(in) :: threshold"
	write (u, "(A)") " integer(c_int), " &
	// "intent(in) :: cutoff"
	write (u, "(A)") " real(default) :: rthreshold"
	write (u, "(A)") " integer :: icutoff"
	write (u, "(A)") " rthreshold = threshold"
	write (u, "(A)") " icutoff = cutoff"
	write (u, "(A)") " call reset_helicity_selection " &
	// "(rthreshold, icutoff)"
	write (u, "(A)") "end subroutine " // char (prc_id(i)) &
	// "_reset_helicity_selection"
	end do
	end subroutine write_reset_helicity_selection_get_fptr

	subroutine write_new_event_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'new_event'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "new_event_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " subroutine prc_new_event (p) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " real(c_default_float), dimension(0:3,*), " &
	// "intent(in) :: p"
	write (u, "(A)") " end subroutine prc_new_event"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_new_event), bind(C) :: " &
	// char (prc_id(i)) // "_new_event"
	end do
	call write_case_lines ("fptr = c_funloc (", "_new_event)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "new_event_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "subroutine " // char (prc_id(i)) &
	// "_new_event (p) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " real(c_default_float), dimension(0:3,*), " &
	// "intent(in) :: p"
	if (c_default_float == default) then
	write (u, "(A)") " call new_event (p)"
	else
	write (u, "(A)") " integer :: n_tot"
	write (u, "(A)") " real(default), dimension(:,:), " &
	// "allocatable :: k"
	write (u, "(A)") " n_tot = " &
	// "number_particles_in () + number_particles_out ()"
	write (u, "(A)") " allocate (k (0:3,n_tot))"
	write (u, "(A)") " k = p"
	write (u, "(A)") " call new_event (k)"
	end if
	write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_new_event"
	end do
	end subroutine write_new_event_get_fptr

	subroutine write_is_allowed_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'is_allowed'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "is_allowed_get_fptr (pid, fptr) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " function " &
	// "prc_is_allowed (flv, hel, col) result (flag) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " logical(c_bool) :: flag"
	write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col"
	write (u, "(A)") " end function prc_is_allowed"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_is_allowed), bind(C) :: " &
	// char (prc_id(i)) // "_is_allowed"
	end do
	call write_case_lines ("fptr = c_funloc (", "_is_allowed)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "is_allowed_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "function " // char (prc_id(i)) &
	// "_is_allowed (flv, hel, col) result (flag) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " logical(c_bool) :: flag"
	write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col"
	if (c_int == kind(1)) then
	write (u, "(A)") " flag = is_allowed (flv, hel, col)"
	else
	write (u, "(A)") " integer :: iflv, ihel, icol"
	write (u, "(A)") " iflv = flv; ihel = hel; icol = col"
	write (u, "(A)") " flag = is_allowed (iflv, ihel, icol)"
	end if
	write (u, "(A)") "end function " // char (prc_id(i)) &
	// "_is_allowed"
	end do
	end subroutine write_is_allowed_get_fptr

	subroutine write_get_amplitude_get_fptr ()
	write (u, "(A)") ""
	write (u, "(A)") "! Return pointer to function: 'get_amplitude'"
	write (u, "(A)") "subroutine " // char (prefix) &
	// "get_amplitude_get_fptr (pid, fptr) " &
	// "bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: pid"
	write (u, "(A)") " type(c_funptr), intent(out) :: fptr"
	write (u, "(A)") " abstract interface"
	write (u, "(A)") " function " &
	// "prc_get_amplitude (flv, hel, col) result (amp) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " complex(c_default_complex) :: amp"
	write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col"
	write (u, "(A)") " end function prc_get_amplitude"
	write (u, "(A)") " end interface"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "procedure(prc_get_amplitude), bind(C) :: " &
	// char (prc_id(i)) // "_get_amplitude"
	end do
	call write_case_lines ("fptr = c_funloc (", "_get_amplitude)")
	write (u, "(A)") "end subroutine " // char (prefix) &
	// "get_amplitude_get_fptr"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, *)
	write (u, "(A)") "function " // char (prc_id(i)) &
	// "_get_amplitude (flv, hel, col) result (amp) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use kinds"
	write (u, "(A)") " use " // char (mod_prc_id(i))
	write (u, "(A)") " complex(c_default_complex) :: amp"
	write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col"
	if (c_int == kind(1)) then
	write (u, "(A)") " amp = get_amplitude (flv, hel, col)"
	else
	write (u, "(A)") " integer :: iflv, ihel, icol"
	write (u, "(A)") " iflv = flv; ihel = hel; icol = col"
	write (u, "(A)") " amp = get_amplitude (iflv, ihel, icol)"
	end if
	write (u, "(A)") "end function " // char (prc_id(i)) &
	// "_get_amplitude"
	end do
	end subroutine write_get_amplitude_get_fptr

	subroutine write_get_ci_type
	write (u, "(A)") ""
	write (u, "(A)") "! Return the core interaction type of process #i"
	write (u, "(A)") "function " // char (prefix) // &
	"get_ci_type (i) result (ci_type) bind(C)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " integer(c_int), intent(in) :: i"
	write (u, "(A)") " integer(c_int) :: ci_type"
	write (u, "(A)") " select case (i)"
	do i = 1, n_prc
	write (u, "(A,I0,A,I0)") " case (", i, "); ci_type = ", ci_type(i)
	end do
	write (u, "(A)") " end select"
	write (u, "(A)") "end function " // char (prefix) // "get_ci_type"
	end subroutine write_get_ci_type

	subroutine write_use_lines (vname, fname)
	character(*), intent(in) :: vname, fname
	integer :: i
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A)") "use " // char (mod_prc_id(i)) // ", only: " &
	// char (prc_id(i)) // "_" // vname // " => " // fname
	end do
	end subroutine write_use_lines

	subroutine write_case_lines (cmd1, cmd2)
	character(*), intent(in) :: cmd1, cmd2
	integer :: i
	write (u, "(A)") " select case (pid)"
	do i = 1, n_prc
	if (virtual(i)) cycle
	write (u, "(2x,A,I0,A)") "case(", i, "); " &
	// cmd1 // char (prc_id(i)) // cmd2
	end do
	write (u, "(A)") " end select"
	end subroutine write_case_lines

	end subroutine process_library_write_driver

	@ %def process_library_write_driver
	@
	\subsection{User code library access}
	The static executable must incorporate user-defined code for various
	tasks. In ordinary execution, this is linked dynamically in the same
	way as the process code. Therefore, we include it here.
	<<XXX Process libraries: public>>=
	public :: user_procs_t
	<<XXX Process libraries: types>>=
	type :: user_procs_t
	type(string_t), dimension(:), allocatable :: cut
	type(string_t), dimension(:), allocatable :: event_shape
	type(string_t), dimension(:), allocatable :: obs_real_unary
	type(string_t), dimension(:), allocatable :: obs_real_binary
	type(string_t), dimension(:), allocatable :: sf
	end type user_procs_t

	@ %def user_procs_t
	@ Declare the procedures with appropriate interfaces
	<<XXX Process libraries: procedures>>=
	subroutine write_user_code_declarations (u, user_procs)
	integer, intent(in) :: u
	type(user_procs_t), intent(in) :: user_procs
	integer :: i
	do i = 1, size (user_procs%cut)
	write (u, "(A)") " procedure(user_cut_fun), bind(C) :: " &
	// char (user_procs%cut(i))
	end do
	do i = 1, size (user_procs%event_shape)
	write (u, "(A)") " procedure(user_event_shape_fun), bind(C) :: " &
	// char (user_procs%event_shape(i))
	end do
	do i = 1, size (user_procs%obs_real_unary)
	write (u, "(A)") " procedure(user_obs_real_unary), bind(C) :: " &
	// char (user_procs%obs_real_unary(i))
	end do
	do i = 1, size (user_procs%obs_real_binary)
	write (u, "(A)") " procedure(user_obs_real_binary), bind(C) :: " &
	// char (user_procs%obs_real_binary(i))
	end do
	end subroutine write_user_code_declarations

	@ %def write_user_code_declarations
	@ Write access code for the procedures
	<<XXX Process libraries: procedures>>=
	subroutine write_user_code_access (u, user_procs)
	integer, intent(in) :: u
	type(user_procs_t), intent(in) :: user_procs
	write (u, "(5x,A)") "select case (fname)"
	call write_access (user_procs%cut)
	call write_access (user_procs%event_shape)
	call write_access (user_procs%obs_real_unary)
	call write_access (user_procs%obs_real_binary)
	call write_sf_access (user_procs%sf)
	write (u, "(5x,A)") "case default"
	write (u, "(5x,A)") " c_fptr = c_null_funptr"
	write (u, "(5x,A)") "end select"
	contains
	subroutine write_access (procname)
	type(string_t), dimension(:), intent(in) :: procname
	integer :: i
	do i = 1, size (procname)
	call write_access_line (procname(i))
	end do
	end subroutine write_access
	subroutine write_sf_access (procname)
	type(string_t), dimension(:), intent(in) :: procname
	integer :: i
	do i = 1, size (procname)
	call write_access_line (procname(i) // "_info")
	call write_access_line (procname(i) // "_mask")
	call write_access_line (procname(i) // "_state")
	call write_access_line (procname(i) // "_kinematics")
	call write_access_line (procname(i) // "_evaluate")
	end do
	end subroutine write_sf_access
	subroutine write_access_line (procname)
	type(string_t), intent(in) :: procname
	write (u, "(5x,A)") "case ('" // char (procname) // "')"
	write (u, "(8x,A)") "c_fptr = c_funloc (" // char (procname) // ")"
	end subroutine write_access_line
	end subroutine write_user_code_access

	@ %def write_user_code_access
	@
	\subsection{Library manager}
	When static libraries are compiled, procedure pointer are not assigned
	by a dlopen mechanism, but must be done at program startup. Mainly
	for this task we write a library manager which links to the static
	libraries as they are defined by the user.

	For each library, it has to assign all possible interface function to
	a C function pointer, which then is dereferenced in the same way as it
	is done for dlopened libraries.
	<<XXX Process libraries: public>>=
	public :: write_library_manager
	<<XXX Process libraries: procedures>>=
	subroutine write_library_manager (libname, user_procs)

	type(string_t), dimension(:), intent(in) :: libname
	type(user_procs_t), intent(in) :: user_procs
	integer :: u, i

	call msg_message ("Writing library manager code")
	u = free_unit ()
	open (unit=u, file="libmanager.f90", action="write", status="replace")
	write (u, "(A)") "! WHIZARD library manager"
	write (u, "(A)") "!"
	write (u, "(A)") "! Automatically generated file, do not edit"
	write (u, "(A)") ""
	write (u, "(A)") "function libmanager_get_n_libs () result (n)"
	write (u, "(A)") " implicit none"
	write (u, "(A)") " integer :: n"
	write (u, "(A,1x,I0)") " n =", size (libname)
	write (u, "(A)") "end function libmanager_get_n_libs"
	write (u, "(A)") ""
	write (u, "(A)") "function libmanager_get_libname (i) result (name)"
	write (u, "(A)") " use iso_varying_string, string_t => varying_string"
	write (u, "(A)") " implicit none"
	write (u, "(A)") " type(string_t) :: name"
	write (u, "(A)") " integer, intent(in) :: i"
	write (u, "(A)") " select case (i)"
	do i = 1, size (libname)
	call write_lib_name (i, libname(i))
	end do
	write (u, "(A)") " case default; name = ''"
	write (u, "(A)") " end select"
	write (u, "(A)") "end function libmanager_get_libname"
	write (u, "(A)") ""
	write (u, "(A)") "function libmanager_get_c_funptr (libname, fname) " &
	// "result (c_fptr)"
	write (u, "(A)") " use iso_c_binding"
	write (u, "(A)") " use prclib_interfaces"
	write (u, "(A)") " use user_code_interface"
	write (u, "(A)") " implicit none"
	write (u, "(A)") " type(c_funptr) :: c_fptr"
	write (u, "(A)") " character(*), intent(in) :: libname, fname"
	do i = 1, size (libname)
	call write_lib_declarations (libname(i))
	end do
	if (has_user_lib) call write_user_code_declarations (u, user_procs)
	write (u, "(A)") " select case (libname)"
	do i = 1, size (libname)
	call write_lib_code (libname(i))
	end do
	if (has_user_lib) then
	write (u, "(A)") " case ('user')"
	call write_user_code_access (u, user_procs)
	end if
	write (u, "(A)") " case default"
	write (u, "(A)") " c_fptr = c_null_funptr"
	write (u, "(A)") " end select"
	write (u, "(A)") "end function libmanager_get_c_funptr"
	close (u)

	contains

	subroutine write_lib_name (i, libname)
	integer, intent(in) :: i
	type(string_t), intent(in) :: libname
	write (u, "(A,I0,A)") " case (", i, "); name = '" // char (libname) &
	// "'"
	end subroutine write_lib_name

	subroutine write_lib_declarations (libname)
	type(string_t), intent(in) :: libname
	write (u, "(A)") " procedure(prc_get_n_processes), bind(C) :: " &
	// char (libname)// "_" // "get_n_processes"
	write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " &
	// char (libname)// "_" // "get_process_id"
	write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " &
	// char (libname)// "_" // "get_model_name"
	write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " &
	// char (libname)// "_" // "get_restrictions"
	write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " &
	// char (libname)// "_" // "get_omega_flags"
	write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " &
	// char (libname)// "_" // "get_md5sum"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_in"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_out"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_flv"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_hel"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_col"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_cin"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_n_cf"
	write (u, "(A)") " procedure(prc_get_log), bind(C) :: " &
	// char (libname)// "_" // "get_openmp_status"
	write (u, "(A)") " procedure(prc_set_int_tab1), bind(C) :: " &
	// char (libname)// "_" // "set_flv_state"
	write (u, "(A)") " procedure(prc_set_int_tab1), bind(C) :: " &
	// char (libname)// "_" // "set_hel_state"
	write (u, "(A)") " procedure(prc_set_int_tab2), bind(C) :: " &
	// char (libname)// "_" // "set_col_state"
	write (u, "(A)") " procedure(prc_set_cf_tab), bind(C) :: " &
	// char (libname)// "_" // "set_cf_table"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "init_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "final_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "update_alpha_s_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "new_event_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "reset_helicity_selection_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "is_allowed_get_fptr"
	write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " &
	// char (libname)// "_" // "get_amplitude_get_fptr"
	write (u, "(A)") " procedure(prc_get_int), bind(C) :: " &
	// char (libname)// "_" // "get_ci_type"
	end subroutine write_lib_declarations

	subroutine write_lib_code (libname)
	type(string_t), intent(in) :: libname
	write (u, "(2x,A)") "case ('" // char (libname) // "')"
	write (u, "(2x,A)") " select case (fname)"
	call write_fun_code (char (libname), "get_n_processes")
	call write_fun_code (char (libname), "get_process_id")
	call write_fun_code (char (libname), "get_model_name")
	call write_fun_code (char (libname), "get_restrictions")
	call write_fun_code (char (libname), "get_omega_flags")
	call write_fun_code (char (libname), "get_md5sum")
	call write_fun_code (char (libname), "get_n_in")
	call write_fun_code (char (libname), "get_n_out")
	call write_fun_code (char (libname), "get_n_flv")
	call write_fun_code (char (libname), "get_n_hel")
	call write_fun_code (char (libname), "get_n_col")
	call write_fun_code (char (libname), "get_n_cin")
	call write_fun_code (char (libname), "get_n_cf")
	call write_fun_code (char (libname), "get_openmp_status")
	call write_fun_code (char (libname), "set_flv_state")
	call write_fun_code (char (libname), "set_hel_state")
	call write_fun_code (char (libname), "set_col_state")
	call write_fun_code (char (libname), "set_cf_table")
	call write_fun_code (char (libname), "init_get_fptr")
	call write_fun_code (char (libname), "final_get_fptr")
	call write_fun_code (char (libname), "update_alpha_s_get_fptr")
	call write_fun_code (char (libname), "reset_helicity_selection_get_fptr")
	call write_fun_code (char (libname), "new_event_get_fptr")
	call write_fun_code (char (libname), "is_allowed_get_fptr")
	call write_fun_code (char (libname), "get_amplitude_get_fptr")
	call write_fun_code (char (libname), "get_ci_type")
	write (u, "(2x,A)") " case default"
	write (u, "(2x,A)") " print *, fname"
	write (u, "(2x,A)") " stop 'WHIZARD bug: " &
	// "libmanager cannot handle this function'"
	write (u, "(2x,A)") " end select"
	end subroutine write_lib_code

	subroutine write_fun_code (prefix, fname)
	character(*), intent(in) :: prefix, fname
	write (u, "(5x,A)") "case ('" // fname // "')"
	write (u, "(5x,A)") " c_fptr = c_funloc (" // prefix &
	// "_" // fname // ")"
	end subroutine write_fun_code

	end subroutine write_library_manager

	@ %def write_library_manager
	@ These are the interfaces of the functions provided by the library
	manager.
	<<XXX Process libraries: interfaces>>=
	<<Libmanager: interfaces>>
	<<Libmanager: interfaces>>=
	interface
	function libmanager_get_n_libs () result (n)
	integer :: n
	end function libmanager_get_n_libs
	end interface

	@ %def libmanager_get_n_libs
	<<Libmanager: interfaces>>=
	interface
	function libmanager_get_libname (i) result (name)
	use iso_varying_string, string_t => varying_string !NODEP!
	type(string_t) :: name
	integer, intent(in) :: i
	end function libmanager_get_libname
	end interface

	@ %def libmanager_get_libname
	<<Libmanager: interfaces>>=
	interface
	function libmanager_get_c_funptr (libname, fname) result (c_fptr)
	use iso_c_binding !NODEP!
	type(c_funptr) :: c_fptr
	character(*), intent(in) :: libname, fname
	end function libmanager_get_c_funptr
	end interface

	@ %def libmanager_get_c_funptr
	@
	\subsection{Collect model-specific libraries}
	This returns appropriate linker flags for the model parameter libraries that
	are used by the generated matrix element. At the end, the main libwhizard is
	appended (again), because functions from that may be reqired.

	Extra models in the local user space need to be treated individually.
	<<XXX Process libraries: public>>=
	public :: get_modellibs_flags
	<<XXX Process libraries: procedures>>=
	function get_modellibs_flags (prc_lib, os_data) result (flags)
	type(process_library_t), intent(in) :: prc_lib
	type(os_data_t), intent(in) :: os_data
	type(string_t) :: flags
	type(string_t), dimension(:), allocatable :: models
	type(string_t) :: modelname, modellib, modellib_full
	logical :: exist
	type(process_configuration_t), pointer :: current
	integer :: i, j, mi
	flags = " -lomega"
	if ((.not. os_data%use_testfiles) .and. &
	os_dir_exist (os_data%whizard_models_libpath_local)) &
	flags = flags // " -L" // os_data%whizard_models_libpath_local
	flags = flags // " -L" // os_data%whizard_models_libpath
	allocate (models(prc_lib%n_prc + 1))
	models = ""
	mi = 1
	current => prc_lib%prc_first
	SCAN: do i = 1, prc_lib%n_prc
	if (current%method == PRC_SUM) then
	current => current%next
	cycle
	end if
	modelname = model_get_name (current%model)
	do j = 1, mi
	if (models(mi) == modelname) cycle SCAN
	end do
	models(mi) = modelname
	mi = mi + 1
	if (os_data%use_libtool) then
	modellib = "libparameters_" // modelname // ".la"
	else
	modellib = "libparameters_" // modelname // ".a"
	end if
	exist = .false.
	if (.not. os_data%use_testfiles) then
	modellib_full = os_data%whizard_models_libpath_local &
	// "/" // modellib
	inquire (file=char (modellib_full), exist=exist)
	end if
	if (.not. exist) then
	modellib_full = os_data%whizard_models_libpath &
	// "/" // modellib
	inquire (file=char (modellib_full), exist=exist)
	end if
	if (exist) flags = flags // " -lparameters_" // modelname
	current => current%next
	end do SCAN
	deallocate (models)
	flags = flags // " -lwhizard"
	end function get_modellibs_flags

	@ %def get_modellibs_flags
	@
	\subsection{Compile and link a library}
	The process library proper consists of the process-specific Fortran
	source files and the driver (interface)
	<<XXX Process libraries: public>>=
	public :: process_library_compile
	<<XXX Process libraries: procedures>>=
	subroutine process_library_compile &
	(prc_lib, os_data, recompile_library, objlist_link)
	type(process_library_t), intent(inout) :: prc_lib
	type(os_data_t), intent(in) :: os_data
	logical, intent(in) :: recompile_library
	type(string_t), intent(out) :: objlist_link
	type(string_t) :: objlist_comp
	type(process_configuration_t), pointer :: current
	type(string_t) :: ext
	integer :: i
	if (prc_lib%status == STAT_LOADED) call process_library_unload (prc_lib)
	call msg_message ("Compiling process library '" // &
	char (process_library_get_name (prc_lib)) // "'")
	objlist_comp = ""
	objlist_link = ""
	if (os_data%use_libtool) then
	ext = ".lo"
	else
	ext = os_data%obj_ext
	end if
	current => prc_lib%prc_first
	SCAN_PROCESSES: do i = 1, prc_lib%n_prc
	if (current%method == PRC_SUM) then
	current => current%next
	cycle
	end if
	objlist_link = objlist_link // " " // current%id // ext
	if (recompile_library) &
	current%status = min (STAT_CODE_GENERATED, current%status)
	if (current%status == STAT_CODE_GENERATED) then
	objlist_comp = objlist_comp // " " // current%id // ext
	call os_compile_shared (current%id, os_data)
	current%status = STAT_COMPILED
	else
	call msg_message ("Skipping process '" // char (current%id) &
	// "' (object code exists)")
	end if
	current => current%next
	end do SCAN_PROCESSES
	if (objlist_comp /= "") then
	call os_compile_shared (prc_lib%basename, os_data)
	objlist_link = objlist_link // " " // prc_lib%basename // ext
	else
	call msg_message ("Skipping library '" &
	// char (prc_lib%basename) &
	// "' (no processes have been recompiled)")
	objlist_link = ""
	end if
	prc_lib%status = STAT_COMPILED
	end subroutine process_library_compile

	@ %def process_library_compile
	<<XXX Process libraries: public>>=
	public :: process_library_link
	<<XXX Process libraries: procedures>>=
	subroutine process_library_link (prc_lib, os_data, objlist)
	type(process_library_t), intent(in) :: prc_lib
	type(os_data_t), intent(in) :: os_data
	type(string_t), intent(in) :: objlist
	type(os_data_t) :: local_os_data
	local_os_data = os_data
	local_os_data%ldflags = os_data%ldflags &
	// " " // get_modellibs_flags (prc_lib, os_data)
	if (objlist /= "") then
	call os_link_shared (objlist, prc_lib%basename, local_os_data)
	end if
	end subroutine process_library_link

	@ %def process_library_link
	@
	\subsection{Standalone executable}
	Compile the library bundle and link with the libraries as a standalone
	executable
	<<XXX Process libraries: public>>=
	public :: compile_library_manager
	<<XXX Process libraries: procedures>>=
	subroutine compile_library_manager (os_data)
	type(os_data_t), intent(in) :: os_data
	call msg_message ("Compiling library manager")
	call os_compile_shared (var_str ("libmanager"), os_data)
	end subroutine compile_library_manager

	@ %def compile_library_manager
	<<XXX Process libraries: public>>=
	public :: link_executable
	<<XXX Process libraries: procedures>>=
	subroutine link_executable (libname, exec_name, flags, os_data)
	type(string_t), dimension(:), intent(in) :: libname
	type(string_t), intent(in) :: exec_name, flags
	type(os_data_t), intent(in) :: os_data
	type(string_t) :: objlist, ext_o, ext_a
	integer :: i
	if (os_data%use_libtool) then
	ext_o = ".lo"
	ext_a = ".la"
	else
	ext_o = ".o"
	ext_a = ".a"
	end if
	objlist = "libmanager" // ext_o
	do i = 1, size (libname)
	objlist = objlist // " " // libname(i) // ext_a
	end do
	if (has_user_lib) then
	objlist = objlist // " user" // ext_a
	end if
	call os_link_static (objlist // flags, exec_name, os_data)
	end subroutine link_executable

	@ %def link_executable
	@
	\subsection{Loading a library}
	This loads a process library. We assume that it resides in the
	current directory.

	Loading the library assigns all procedure pointers to procedures
	within the library.

	Unloading is done by the finalizer.
	<<XXX Process libraries: public>>=
	public :: process_library_load
	<<XXX Process libraries: procedures>>=
	subroutine process_library_load (prc_lib, os_data, model, var_list, ignore)
	type(process_library_t), intent(inout), target :: prc_lib
	type(os_data_t), intent(in) :: os_data
	type(model_t), pointer, optional :: model
	type(var_list_t), intent(inout) :: var_list
	logical, intent(in), optional :: ignore
	type(c_funptr) :: c_fptr
	type(model_t), pointer :: mdl
	type(string_t) :: prefix
	logical :: ignore_error
	ignore_error = .false.; if (present (ignore)) ignore_error = ignore
	if (prc_lib%status == STAT_LOADED) then
	if (.not. ignore_error) then
	call msg_message ("Process library '" // char (prc_lib%basename) &
	// "' is already loaded")
	end if
	return
	end if
	if (prc_lib%static) then
	call msg_message ("Loading static process library '" &
	// char (prc_lib%basename) // "'")
	else
	call msg_message ("Loading process library '" &
	// char (prc_lib%basename) // "'")
	prc_lib%libname = os_get_dlname (prc_lib%basename, os_data, ignore)
	if (prc_lib%libname == "") return
	call dlaccess_init (prc_lib%dlaccess, var_str ("."), &
	prc_lib%libname, os_data)
	call process_library_check_dlerror (prc_lib)
	end if
	prefix = prc_lib%basename
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_processes"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_prc)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_process_id"))
	call c_f_procpointer (c_fptr, prc_lib%get_process_id)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_model_name"))
	call c_f_procpointer (c_fptr, prc_lib%get_model_name)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_restrictions"))
	call c_f_procpointer (c_fptr, prc_lib%get_restrictions)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_omega_flags"))
	call c_f_procpointer (c_fptr, prc_lib%get_omega_flags)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_openmp_status"))
	call c_f_procpointer (c_fptr, prc_lib%get_openmp_status)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_md5sum"))
	call c_f_procpointer (c_fptr, prc_lib%get_md5sum)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_in"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_in)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_out"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_out)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_flv"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_flv)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_hel"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_hel)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_col"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_col)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_cin"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_cin)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_n_cf"))
	call c_f_procpointer (c_fptr, prc_lib%get_n_cf)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("set_flv_state"))
	call c_f_procpointer (c_fptr, prc_lib%set_flv_state)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("set_hel_state"))
	call c_f_procpointer (c_fptr, prc_lib%set_hel_state)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("set_col_state"))
	call c_f_procpointer (c_fptr, prc_lib%set_col_state)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("set_cf_table"))
	call c_f_procpointer (c_fptr, prc_lib%set_cf_table)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("init_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%init_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("final_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%final_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("update_alpha_s_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%update_alpha_s_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("new_event_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%new_event_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("reset_helicity_selection_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%reset_helicity_selection_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("is_allowed_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%is_allowed_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_amplitude_get_fptr"))
	call c_f_procpointer (c_fptr, prc_lib%get_amplitude_get_fptr)
	c_fptr = process_library_get_c_funptr &
	(prc_lib, prefix, var_str ("get_ci_type"))
	call c_f_procpointer (c_fptr, prc_lib%get_ci_type)
	call process_library_load_configuration (prc_lib, os_data, mdl)
	prc_lib%status = STAT_LOADED
	if (associated (prc_lib%reload_hook)) &
	call prc_lib%reload_hook (process_library_get_name (prc_lib))
	call var_list_set_string (var_list, var_str ("$library_name"), &
	process_library_get_name (prc_lib), is_known=.true.) ! $
	if (present (model)) model => mdl
	end subroutine process_library_load

	@ %def process_library_load
	@ Unload a process library. Necessary before recompiling and
	reloading.
	<<XXX Process libraries: public>>=
	public :: process_library_unload
	<<XXX Process libraries: procedures>>=
	subroutine process_library_unload (prc_lib)
	type(process_library_t), intent(inout) :: prc_lib
	call msg_message ("Unloading process library '" // &
	char (process_library_get_name (prc_lib)) // "'")
	if (associated (prc_lib%unload_hook)) &
	call prc_lib%unload_hook (process_library_get_name(prc_lib))
	call dlaccess_final (prc_lib%dlaccess)
	prc_lib%status = STAT_CODE_GENERATED
	end subroutine process_library_unload

	@ %def process_library_unload
	@ Register hooks for un- / reloading the process library.
	<<XXX Process libraries: public>>=
	public :: process_library_set_unload_hook
	public :: process_library_set_reload_hook
	<<XXX Process libraries: procedures>>=
	subroutine process_library_set_unload_hook (prc_lib, hook)
	type(process_library_t), intent(inout), target :: prc_lib
	procedure(prclib_unload_hook), pointer, intent(in) :: hook
	prc_lib%unload_hook => hook
	end subroutine process_library_set_unload_hook

	subroutine process_library_set_reload_hook (prc_lib, hook)
	type(process_library_t), intent(inout), target :: prc_lib
	procedure(prclib_reload_hook), pointer, intent(in) :: hook
	prc_lib%reload_hook => hook
	end subroutine process_library_set_reload_hook

	@ %def process_library_set_unload_hook
	@ %def process_library_set_reload_hook
	@ Get a C function pointer to a procedure belonging to the process
	library interface and check for an error condition.
	<<XXX Process libraries: procedures>>=
	function process_library_get_c_funptr &
	(prc_lib, prefix, fname) result (c_fptr)
	type(c_funptr) :: c_fptr
	type(process_library_t), intent(inout) :: prc_lib
	type(string_t), intent(in) :: prefix, fname
	type(string_t) :: full_name
	full_name = prefix // "_" // fname
	if (prc_lib%static) then
	c_fptr = libmanager_get_c_funptr (char (prefix), char (fname))
	else
	c_fptr = dlaccess_get_c_funptr (prc_lib%dlaccess, full_name)
	call process_library_check_dlerror (prc_lib)
	end if
	end function process_library_get_c_funptr

	@ %def process_library_get_c_funptr
	@ Check for an error condition and signal it.
	<<XXX Process libraries: procedures>>=
	subroutine process_library_check_dlerror (prc_lib)
	type(process_library_t), intent(in) :: prc_lib
	if (dlaccess_has_error (prc_lib%dlaccess)) then
	call msg_fatal (char (dlaccess_get_error (prc_lib%dlaccess)))
	end if
	end subroutine process_library_check_dlerror

	@ %def process_library_check_dlerror
	@
	\subsection{The library store}
	We want to handle several libraries in parallel, therefore we
	introduce a global library store, similar to the model and process
	lists. The store is a module variable.
	<<XXX Process libraries: types>>=
	type :: process_library_store_t
	private
	type(process_library_t), pointer :: first => null ()
	type(process_library_t), pointer :: last => null ()
	end type process_library_store_t

	@ %def process_library_store_t
	<<XXX Process libraries: variables>>=
	type(process_library_store_t), save :: process_library_store
	@ %def process_library_store
	@ Append a new library, if it does not yet exist, and return a pointer
	to it.
	<<XXX Process libraries: public>>=
	public :: process_library_store_append
	<<XXX Process libraries: procedures>>=
	subroutine process_library_store_append (name, os_data, prc_lib)
	type(string_t), intent(in) :: name
	type(os_data_t), intent(in) :: os_data
	type(process_library_t), pointer :: prc_lib
	prc_lib => process_library_store_get_ptr (name)
	if (.not. associated (prc_lib)) then
	call msg_message &
	("Initializing process library '" // char (name) // "'")
	allocate (prc_lib)
	call process_library_init (prc_lib, name, os_data)
	if (associated (process_library_store%last)) then
	process_library_store%last%next => prc_lib
	else
	process_library_store%first => prc_lib
	end if
	process_library_store%last => prc_lib
	end if
	end subroutine process_library_store_append

	@ %def process_library_store_append
	@ Finalizer. This closes all open libraries.
	<<XXX Process libraries: public>>=
	public :: process_library_store_final
	<<XXX Process libraries: procedures>>=
	subroutine process_library_store_final ()
	type(process_library_t), pointer :: current
	do while (associated (process_library_store%first))
	current => process_library_store%first
	process_library_store%first => current%next
	call process_library_final (current)
	deallocate (current)
	end do
	process_library_store%last => null ()
	end subroutine process_library_store_final

	@ %def process_library_store_final
	@ Load all libraries
	<<XXX Process libraries: public>>=
	public :: process_library_store_load
	<<XXX Process libraries: procedures>>=
	subroutine process_library_store_load (os_data, var_list)
	type(os_data_t), intent(in) :: os_data
	type(var_list_t), intent(inout), optional :: var_list
	type(process_library_t), pointer :: current
	current => process_library_store%first
	do while (associated (current))
	call process_library_load (current, os_data, var_list=var_list)
	current => current%next
	end do
	end subroutine process_library_store_load

	@ %def process_library_store_load
	@ Get a pointer to an existing (named) library
	<<XXX Process libraries: public>>=
	public :: process_library_store_get_ptr
	<<XXX Process libraries: procedures>>=
	function process_library_store_get_ptr (name) result (prc_lib)
	type(process_library_t), pointer :: prc_lib
	type(string_t), intent(in) :: name
	prc_lib => process_library_store%first
	do while (associated (prc_lib))
	if (prc_lib%basename == name) exit
	prc_lib => prc_lib%next
	end do
	end function process_library_store_get_ptr

	@ %def process_library_store_get_ptr
	@ Get a pointer to the first/next library
	<<XXX Process libraries: public>>=
	public :: process_library_store_get_first
	<<XXX Process libraries: procedures>>=
	function process_library_store_get_first () result (prc_lib)
	type(process_library_t), pointer :: prc_lib
	prc_lib => process_library_store%first
	end function process_library_store_get_first

	@ %def process_library_store_get_first
	@
	\subsection{Preloading static libraries}
	Static libraries are static, so it is sensible to load them all at
	startup. (By default, they are linked, but not loaded in the sense
	that a [[process_library]] object exists for them.) This can be done
	using this routine.
	<<XXX Process libraries: public>>=
	public :: process_library_store_load_static
	<<XXX Process libraries: procedures>>=
	subroutine process_library_store_load_static &
	(os_data, prc_lib, model, var_list)
	type(os_data_t), intent(in) :: os_data
	type(process_library_t), pointer :: prc_lib
	type(model_t), pointer :: model
	type(var_list_t), intent(inout) :: var_list
	integer :: n, i
	type(string_t), dimension(:), allocatable :: libname
	n = libmanager_get_n_libs ()
	allocate (libname (n))
	do i = 1, n
	libname(i) = libmanager_get_libname (i)
	end do
	do i = 1, n
	call process_library_store_append (libname(i), os_data, prc_lib)
	call process_library_set_static (prc_lib, .true.)
	call process_library_load (prc_lib, os_data, model, var_list)
	end do
	end subroutine process_library_store_load_static

	@ %def process_library_store_load_static
	@
	Distinguish the module name, depending on the method of the process.
	<<XXX Process libraries: procedures>>=
	function process_library_get_module_name (id, method) result (mod_id)
	type(string_t), intent(in) :: id
	integer, intent(in) :: method
	type(string_t) :: mod_id
	select case (method)
	case (PRC_OMEGA)
	mod_id = "opr_" // id
	case (PRC_TEST, PRC_UNIT)
	mod_id = "tpr_" // id
	case default
	mod_id = id
	end select
	end function process_library_get_module_name
	@ %def process_library_get_module_name
	@
	\subsection{Test}
	<<XXX Process libraries: public>>=
	public :: process_libraries_test
	<<XXX Process libraries: procedures>>=
	subroutine process_libraries_test ()
	type(model_t), pointer :: model
	type(process_library_t), pointer :: prc_lib => null ()
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	type(os_data_t) :: os_data
	type(string_t) :: objlist
	type(var_list_t), pointer :: var_list => null ()
	integer :: n_prc
	allocate (var_list)
	allocate (prc_lib)
	call process_library_store_final
	call os_data_init (os_data)
	print , "** Read model file"
	call syntax_model_file_init ()
	call model_list_read_model &
	(var_str("SM"), var_str("SM.mdl"), os_data, model)
	call syntax_model_file_final ()
	print , "** Create library 'proc' with two processes"
	print , " Setup process configuration"
	call var_list_append_string (var_list, name = "$library_name", sval = "proc") ! $
	call process_library_store_append (var_str ("proc"), os_data, prc_lib)
	allocate (prt_in (1), prt_out (2))
	prt_in(1) = "Z"
	prt_out(1) = "e1"
	prt_out(2) = "E1"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("zee"), model, prt_in, prt_out, &
	method = PRC_TEST)
	deallocate (prt_in, prt_out)
	allocate (prt_in (2), prt_out (2))
	prt_in(1) = "g"
	prt_in(2) = "g"
	prt_out(1) = "u"
	prt_out(2) = "U"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("uu"), model, prt_in, prt_out, &
	method = PRC_TEST)
	print *
	print , " Generate code"
	call process_library_generate_code (prc_lib, os_data)
	print *
	print , " Write driver file 'proc_interface.f90'"
	call process_library_write_driver (prc_lib)
	print *
	print , " Compile and link as 'libproc.so'"
	call process_library_compile (prc_lib, os_data, .false., objlist)
	call process_library_link (prc_lib, os_data, objlist)
	print *
	print , " Load shared libraries"
	call process_library_load (prc_lib, os_data, var_list = var_list)
	print *
	print , " Execute 'get_n_processes' from the shared library named 'proc'"
	print *
	prc_lib => process_library_store_get_ptr (var_str ("proc"))
	n_prc = prc_lib% get_n_prc ()
	print *, "n_prc = ", n_prc
	if (n_prc .ne. 2) then
	call msg_fatal (" Process library test failed.")
	else
	call msg_message ("Successful.")
	end if
	print *
	print , " Cleanup"
	call process_library_store_final
	call var_list_final (var_list)
	deallocate (var_list)
	end subroutine process_libraries_test

	@ %def process_libraries_test
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Integration and Event Generation}
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Hard interactions}
	This module is concerned with the matrix element of an elementary
	interaction (typically, a hard scattering or heavy-particle decay).
	The module does not hold phase space information.
	<<[[hard_interactions.f90]]>>=
	<<File header>>

	module hard_interactions

	use iso_c_binding !NODEP!
	use kinds !NODEP!
	<<Use strings>>
	<<Use file utils>>
	use diagnostics !NODEP!
	use lorentz !NODEP!
	use os_interface
	use variables
	use models
	use flavors
	use helicities
	use colors
	use quantum_numbers
	use state_matrices
	use interactions
	use evaluators
	use particles
	use prclib_interfaces
	use process_libraries

	<<Standard module head>>

	<<Hard interactions: public>>

	<<Hard interactions: types>>

	<<Hard interactions: interfaces>>

	contains

	<<Hard interactions: procedures>>

	end module hard_interactions
	@ %def hard_interactions
	@
	\subsection{The hard-interaction data type}
	We define a special data type that accesses the process library.
	While constant data are stored as data, the process-specific functions
	for initialization, calculation and finalization are stored as
	procedure pointers.
	<<Hard interactions: types>>=
	type :: hard_interaction_data_t
	type(string_t) :: id
	type(model_t), pointer :: model => null ()
	integer :: n_tot = 0
	integer :: n_in = 0
	integer :: n_out = 0
	integer :: n_flv = 0
	integer :: n_hel = 0
	integer :: n_col = 0
	integer :: n_cin = 0
	integer :: n_cf = 0
	real(default), dimension(:), allocatable :: par
	integer, dimension(:,:), allocatable :: flv_state, hel_state
	integer, dimension(:,:,:), allocatable :: col_state
	logical, dimension(:,:), allocatable :: ghost_flag
	integer, dimension(:,:), allocatable :: col_flow_index
	complex(default), dimension(:), allocatable :: col_factor
	procedure(prc_init), nopass, pointer :: init => null ()
	procedure(prc_final), nopass, pointer :: final => null ()
	procedure(prc_update_alpha_s), nopass, pointer :: update_alpha_s => null ()
	procedure(prc_reset_helicity_selection), nopass, pointer :: &
	reset_helicity_selection => null ()
	procedure(prc_new_event), nopass, pointer :: new_event => null ()
	procedure(prc_is_allowed), nopass, pointer :: is_allowed => null ()
	procedure(prc_get_amplitude), nopass, pointer :: get_amplitude => null ()
	end type hard_interaction_data_t

	@ %def hard_interaction_data_t
	@ Initialize the hard process, using the process ID and the model
	parameters.

	Assigning flavor/helicity/color tables: we need an intermediate
	allocatable array to serve as a C pointer target; the C pointer is
	passed to the process library where it is dereferenced and the array
	is filled. In principle, this copying step is necessary only if the
	Fortran and C types differ (which happens for the logical type).
	However, since this is not critical, we do it anyway.

	For incoming particles, the particle color is inverted. This is
	useful for squaring the color flow, but has to be undone before
	convoluting with structure functions.

	We define additional functions for finalizing and resetting the pointers into
	the process library when the library is reloaded.
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_data_unload (data)
	type(hard_interaction_data_t), intent(inout) :: data
	call data%final
	nullify (data%init)
	nullify (data%final)
	nullify (data%update_alpha_s)
	nullify (data%reset_helicity_selection)
	nullify (data%new_event)
	nullify (data%is_allowed)
	nullify (data%get_amplitude)
	end subroutine hard_interaction_data_unload

	subroutine hard_interaction_data_reload (data, prc_lib, pid)
	type(hard_interaction_data_t), intent(inout) :: data
	type(process_library_t), intent(in) :: prc_lib
	integer, optional :: pid
	integer :: the_pid
	type(c_funptr) :: fptr
	if (present (pid)) then
	the_pid = pid
	else
	the_pid = process_library_get_process_pid (prc_lib, data%id)
	if (the_pid <= 0) call msg_bug &
	("Invalid process ID '" // char (data%id) // "'")
	end if
	call prc_lib% init_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% init)
	call prc_lib% final_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% final)
	call prc_lib% update_alpha_s_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% update_alpha_s)
	call prc_lib% reset_helicity_selection_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% reset_helicity_selection)
	call prc_lib% new_event_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% new_event)
	call prc_lib% is_allowed_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% is_allowed)
	call prc_lib% get_amplitude_get_fptr (the_pid, fptr)
	call c_f_procpointer (fptr, data% get_amplitude)
	end subroutine hard_interaction_data_reload

	<<Hard interactions: procedures>>=
	subroutine hard_interaction_data_init &
	(data, prc_lib, process_index, process_id, model)
	type(hard_interaction_data_t), intent(out) :: data
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	integer(c_int) :: pid
	type(string_t) :: model_name
	integer(c_int), dimension(:,:), allocatable, target :: flv_state, hel_state
	integer(c_int), dimension(:,:,:), allocatable, target :: col_state
	logical(c_bool), dimension(:,:), allocatable, target :: ghost_flag
	integer(c_int), dimension(:), allocatable, target :: cf_index1, cf_index2
	complex(c_default_complex), dimension(:), allocatable, target :: col_factor
	integer :: c, i
	if (.not. associated (prc_lib% get_process_id)) then
	call msg_fatal ("Process library '" // char (prc_lib%basename) // "':" &
	// " procedures unavailable (missing compile command?)")
	data%id = ""
	return
	end if
	pid = process_index
	data%id = process_library_get_process_id (prc_lib, pid)
	if (data%id /= process_id) then
	call msg_bug ("Process ID mismatch: requested '" &
	// char (process_id) // "' but found '" // char (data%id) // "'")
	end if
	data%model => model
	model_name = process_library_get_process_model_name (prc_lib, pid)
	if (model_get_name (data%model) /= model_name) then
	call msg_warning ("Process '" // char (process_id) // "': " &
	// "temporarily resetting model from '" &
	// char (model_get_name (data%model)) // "' to '" &
	// char (model_name) // "'")
	data%model => model_list_get_model_ptr (model_name)
	if (.not. associated (data%model)) then
	call msg_fatal ("Model '" // char (model_name) &
	// "' is not initialized")
	end if
	end if
	data%n_in = prc_lib% get_n_in (pid)
	data%n_out = prc_lib% get_n_out (pid)
	data%n_tot = data%n_in + data%n_out
	data%n_flv = prc_lib% get_n_flv (pid)
	data%n_hel = prc_lib% get_n_hel (pid)
	data%n_col = prc_lib% get_n_col (pid)
	data%n_cin = prc_lib% get_n_cin (pid)
	data%n_cf = prc_lib% get_n_cf (pid)
	if (data%n_flv == 0) then
	call msg_warning ("Process '" // char (process_id) // "': " &
	// "matrix element vanishes.")
	end if
	call model_parameters_to_array (data%model, data%par)
	allocate (data%flv_state (data%n_tot, data%n_flv))
	allocate (data%hel_state (data%n_tot, data%n_hel))
	allocate (data%col_state (data%n_cin, data%n_tot, data%n_col))
	allocate (data%ghost_flag (data%n_tot, data%n_col))
	allocate (data%col_flow_index (2, data%n_cf))
	allocate (data%col_factor (data%n_cf))
	allocate (flv_state (data%n_tot, data%n_flv))
	allocate (hel_state (data%n_tot, data%n_hel))
	allocate (col_state (data%n_cin, data%n_tot, data%n_col))
	allocate (ghost_flag (data%n_tot, data%n_col))
	allocate (cf_index1 (data%n_cf))
	allocate (cf_index2 (data%n_cf))
	allocate (col_factor (data%n_cf))
	call prc_lib% set_flv_state (pid, &
	c_loc (flv_state), &
	int((/data%n_tot, data%n_flv/), kind=c_int))
	data%flv_state = flv_state
	call prc_lib% set_hel_state (pid, &
	c_loc (hel_state), &
	int((/data%n_tot, data%n_hel/), kind=c_int))
	data%hel_state = hel_state
	call prc_lib% set_col_state (pid, &
	c_loc (col_state), &
	int((/data%n_cin, data%n_tot, data%n_col/), kind=c_int), &
	c_loc (ghost_flag), &
	int((/data%n_tot, data%n_col/), kind=c_int))
	if (data%n_cin /= 2) &
	call msg_bug ("Process library '" // char (prc_lib%basename) // "':" &
	// " number of color indices must be two")
	forall (c = 1:2, i = 1:data%n_in)
	data%col_state(c,i,:) = - col_state(3-c,i,:)
	end forall
	forall (i = data%n_in+1:data%n_tot)
	data%col_state(:,i,:) = col_state(:,i,:)
	end forall
	data%ghost_flag = ghost_flag
	call prc_lib% set_cf_table (pid, &
	c_loc (cf_index1), c_loc (cf_index2), c_loc (col_factor), &
	int ((/data%n_cf/), kind=c_int))
	data%col_flow_index(1,:) = cf_index1
	data%col_flow_index(2,:) = cf_index2
	data%col_factor = col_factor
	call hard_interaction_data_reload (data, prc_lib, pid=pid)
	call hard_interaction_data_check_masses (data)
	end subroutine hard_interaction_data_init

	@ %def hard_interaction_data_init
	@ %def hard_interaction_data_unload
	@ %def hard_interaction_data_reload
	@ We have to make sure that the masses of the various flavors
	in a given position in the particle string coincide.
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_data_check_masses (data)
	type(hard_interaction_data_t), intent(in) :: data
	type(flavor_t), dimension(:), allocatable :: flv
	real(default), dimension(:), allocatable :: mass
	integer :: i, j
	allocate (flv (data%n_flv), mass (data%n_flv))
	do i = 1, data%n_tot
	call flavor_init (flv, data%flv_state(i,:), data%model)
	mass = flavor_get_mass (flv)
	if (any (mass /= mass(1))) then
	call msg_fatal ("Process '" // char (data%id) // "': " &
	// "mass values in flavor combination do not coincide.")
	end if
	end do
	end subroutine hard_interaction_data_check_masses

	@ %def hard_interaction_data_check_masses
	@ I/O:
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_data_write (data, unit)
	type(hard_interaction_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	integer :: f, h, c, n, i
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, *) "Process '", char (trim (data%id)), "'"
	write (u, *) "n_tot = ", data%n_tot
	write (u, *) "n_in = ", data%n_in
	write (u, *) "n_out = ", data%n_out
	write (u, *) "n_flv = ", data%n_flv
	write (u, *) "n_hel = ", data%n_hel
	write (u, *) "n_col = ", data%n_col
	write (u, *) "n_cin = ", data%n_cin
	write (u, *) "n_cf = ", data%n_cf
	write (u, *) "Model parameters:"
	do i = 1, size (data%par)
	write (u, *) i, data%par(i)
	end do
	write (u, *) "Flavor states:"
	do f = 1, data%n_flv
	write (u, *) f, ":", data%flv_state (:,f)
	end do
	write (u, *) "Helicity states:"
	do h = 1, data%n_hel
	write (u, *) h, ":", data%hel_state (:,h)
	end do
	write (u, *) "Color states:"
	do c = 1, data%n_col
	write (u, "(I5,A)", advance="no") c, ":"
	do n = 1, data%n_tot
	write (u, "('/')", advance="no")
	if (data%ghost_flag (n, c)) write (u, "('*')", advance="no")
	do i = 1, data%n_cin
	if (data%col_state(i,n,c) == 0) cycle
	write (u, "(I3)", advance="no") data%col_state(i,n,c)
	end do
	end do
	write (u, "('/')")
	end do
	write (u, *) "Color factors:"
	do c = 1, data%n_cf
	write (u, "(I5,A,2(I4,1x))", advance="no") c, ":", &
	data%col_flow_index(:,c)
	write (u, *) data%col_factor(c)
	end do
	end subroutine hard_interaction_data_write

	@ %def hard_interaction_data_write
	@
	\subsection{The hard-interaction type}
	The type contains an interaction that is used to store the bare matrix
	element values. The flavor/helicity/color arrays are used to identify
	each matrix element for the amplitude function. Furthermore, there
	are three evaluators for the trace (the squared matrix element
	proper), the squared matrix element with color factors, possibly
	exclusive in some quantum numbers, and the squared matrix element
	broken down by color flows. The latter two are needed only for the
	simulation of complete events, not for integration.

	For the integrated dipoles we need copies of the hard interaction which share
	everything apart from the kinematics and the actual values of the matrix
	elements. Copies are marked with the [[is_copy]] flag, and
	[[hard_interaction_data_t]] points to the original data.
	<<Hard interactions: public>>=
	public :: hard_interaction_t
	<<Hard interactions: types>>=
	type :: hard_interaction_t
	private
	logical :: initialized = .false.
	logical :: is_copy = .false.
	type(hard_interaction_data_t), pointer :: data => null ()
	integer :: n_values = 0
	integer, dimension(:), allocatable :: flv, hel, col
	type(interaction_t) :: int
	type(evaluator_t) :: eval_trace
	type(evaluator_t) :: eval_sqme
	type(evaluator_t) :: eval_flows
	end type hard_interaction_t

	@ %def hard_interaction
	@ Initializer. Set up the hard-process data and build the
	corresponding interaction structure. In parallel, assign the allowed
	flavor/helicity/color indices to the corresponding index arrays. For
	each valid combination, a matrix element pointer is prepared which is
	inserted as a new leaf in the interaction quantum-number tree.

	In addition to initialization, we also provide subroutines for partial
	finalization and re-initialization if the process library is reloaded, or the
	parameters are changed.
	<<Hard interactions: public>>=
	public :: hard_interaction_init
	public :: hard_interaction_unload
	public :: hard_interaction_reload
	public :: hard_interaction_update_parameters
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_init &
	(hi, prc_lib, process_index, process_id, model)
	type(hard_interaction_t), intent(out), target :: hi
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	type(flavor_t), dimension(:), allocatable :: flv
	type(color_t), dimension(:), allocatable :: col
	type(helicity_t), dimension(:), allocatable :: hel
	type(quantum_numbers_t), dimension(:), allocatable :: qn
	integer :: f, h, c, i, n
	hi%is_copy = .false.
	allocate (hi%data)
	call hard_interaction_data_init &
	(hi%data, prc_lib, process_index, process_id, model)
	if (hi%data%id == "") return
	call hi%data% init (real (hi%data%par, c_default_float))
	call interaction_init &
	(hi%int, hi%data%n_in, 0, hi%data%n_out, set_relations=.true.)
	call hard_interaction_reset_helicity_selection (hi, 0._default, 0)
	n = 0
	do f = 1, hi%data%n_flv
	do h = 1, hi%data%n_hel
	do c = 1, hi%data%n_col
	if (hi%data%is_allowed (f, h, c)) n = n + 1
	end do
	end do
	end do
	hi%n_values = n
	allocate (hi%flv (n), hi%hel (n), hi%col (n))
	allocate (flv (hi%data%n_tot), col (hi%data%n_tot), hel (hi%data%n_tot))
	allocate (qn (hi%data%n_tot))
	i = 0
	do f = 1, hi%data%n_flv
	do h = 1, hi%data%n_hel
	do c = 1, hi%data%n_col
	if (hi%data%is_allowed (f, h, c)) then
	i = i + 1
	hi%flv(i) = f
	hi%hel(i) = h
	hi%col(i) = c
	call flavor_init (flv, hi%data%flv_state(:,f), hi%data%model)
	call color_init_from_array (col, hi%data%col_state(:,:,c), &
	hi%data%ghost_flag(:,c))
	call helicity_init (hel, hi%data%hel_state(:,h))
	call quantum_numbers_init (qn, flv, col, hel)
	call interaction_add_state (hi%int, qn)
	end if
	end do
	end do
	end do
	call interaction_freeze (hi%int)
	hi%initialized = .true.
	end subroutine hard_interaction_init

	subroutine hard_interaction_unload (hi)
	type(hard_interaction_t), intent(inout), target :: hi
	if (hi%is_copy .or. .not. associated (hi%data%final)) return
	call hard_interaction_data_unload (hi%data)
	end subroutine hard_interaction_unload

	subroutine hard_interaction_reload (hi, prc_lib)
	type(hard_interaction_t), intent(inout), target :: hi
	type(process_library_t), intent(in) :: prc_lib
	if (hi%is_copy .or. associated (hi%data%init)) return
	call hard_interaction_data_reload (hi%data, prc_lib)
	call hi%data% init (real (hi%data%par, c_default_float))
	end subroutine hard_interaction_reload

	subroutine hard_interaction_update_parameters (hi)
	type(hard_interaction_t), intent(inout), target :: hi
	if (hi%is_copy) return
	call model_parameters_to_array (hi%data%model, hi%data%par)
	call hi%data% init (real (hi%data%par, c_default_float))
	end subroutine hard_interaction_update_parameters

	@ %def hard_interaction_init
	@ %def hard_interaction_unload
	@ %def hard_interaction_reload
	@ %def hard_interaction_update_parameters
	@ Finalizer:
	<<Hard interactions: public>>=
	public :: hard_interaction_final
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_final (hi)
	type(hard_interaction_t), intent(inout) :: hi
	hi%initialized = .false.
	if (.not. hi%is_copy .and. associated (hi%data)) then
	if (associated (hi%data% final)) call hi%data% final ()
	deallocate (hi%data)
	nullify (hi%data)
	end if
	call interaction_final (hi%int)
	call evaluator_final (hi%eval_trace)
	call evaluator_final (hi%eval_flows)
	call evaluator_final (hi%eval_sqme)
	hi%n_values = 0
	if (allocated (hi%flv)) deallocate (hi%flv)
	if (allocated (hi%hel)) deallocate (hi%hel)
	if (allocated (hi%col)) deallocate (hi%col)
	end subroutine hard_interaction_final

	@ %def hard_interaction_final
	@ I/O:
	<<Hard interactions: public>>=
	public :: hard_interaction_write
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_write &
	(hi, unit, verbose, show_momentum_sum, show_mass, write_comb)
	type(hard_interaction_t), intent(in) :: hi
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: write_comb
	integer :: u, i
	u = output_unit (unit); if (u < 0) return
	if (hi%is_copy) then
	write (u, "(1x,A)") "Hard interaction (copy):"
	else
	write (u, "(1x,A)") "Hard interaction:"
	call hard_interaction_data_write (hi%data, u)
	end if
	if (present (write_comb)) then
	if (write_comb .and. hi%n_values /= 0) then
	write (u, "(1x,A)") "Allowed f/h/c index combinations:"
	do i = 1, hi%n_values
	write (u, *) i, ":", hi%flv(i), hi%hel(i), hi%col(i)
	end do
	end if
	end if
	write (u, *)
	call interaction_write &
	(hi%int, unit, verbose, show_momentum_sum, show_mass)
	write (u, *) repeat ("- ", 36)
	write (u, "(A)") "Trace including color factors (hard interaction)"
	call evaluator_write &
	(hi%eval_trace, unit, verbose, show_momentum_sum, show_mass)
	write (u, *) repeat ("- ", 36)
	write (u, "(A)") "Exclusive sqme including color factors (hard interaction)"
	call evaluator_write &
	(hi%eval_sqme, unit, verbose, show_momentum_sum, show_mass)
	write (u, *) repeat ("- ", 36)
	write (u, "(A)") "Color flow coefficients (hard interaction)"
	call evaluator_write &
	(hi%eval_flows, unit, verbose, show_momentum_sum, show_mass)
	end subroutine hard_interaction_write

	@ %def hard_interaction_write
	@ Defined assignment. Deep copy (except for procedure pointers, of
	course).
	<<Hard interactions: public>>=
	public :: assignment(=)
	<<Hard interactions: interfaces>>=
	interface assignment(=)
	module procedure hard_interaction_assign
	end interface

	<<Hard interactions: procedures>>=
	subroutine hard_interaction_assign (hi_out, hi_in)
	type(hard_interaction_t), intent(out) :: hi_out
	type(hard_interaction_t), intent(in) :: hi_in
	hi_out%initialized = hi_in%initialized
	hi_out%is_copy = hi_in%is_copy
	if (hi_out%is_copy) then
	hi_out%data => hi_in%data
	else
	allocate (hi_out%data)
	hi_out%data = hi_in%data
	end if
	hi_out%n_values = hi_in%n_values
	if (allocated (hi_in%flv)) then
	allocate (hi_out%flv (size (hi_in%flv)))
	hi_out%flv = hi_in%flv
	end if
	if (allocated (hi_in%hel)) then
	allocate (hi_out%hel (size (hi_in%hel)))
	hi_out%hel = hi_in%hel
	end if
	if (allocated (hi_in%col)) then
	allocate (hi_out%col (size (hi_in%col)))
	hi_out%col = hi_in%col
	end if
	hi_out%int = hi_in%int
	hi_out%eval_trace = hi_in%eval_trace
	call evaluator_replace_interaction (hi_out%eval_trace, hi_out%int)
	hi_out%eval_sqme = hi_in%eval_sqme
	call evaluator_replace_interaction (hi_out%eval_sqme, hi_out%int)
	hi_out%eval_flows = hi_in%eval_flows
	call evaluator_replace_interaction (hi_out%eval_flows, hi_out%int)
	end subroutine hard_interaction_assign

	@ %def hard_interaction_assign
	@ Create a copy. Evaluators are not copied but must be recreated manually.
	<<Hard interactions: public>>=
	public :: hard_interaction_make_copy
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_make_copy (hi_out, hi_in)
	type(hard_interaction_t), intent(in) :: hi_in
	type(hard_interaction_t), intent(out) :: hi_out
	hi_out%initialized = hi_in%initialized
	hi_out%is_copy = .true.
	hi_out%data => hi_in%data
	hi_out%n_values = hi_in%n_values
	if (allocated (hi_in%flv)) then
	allocate (hi_out%flv (size (hi_in%flv)))
	hi_out%flv = hi_in%flv
	end if
	if (allocated (hi_in%hel)) then
	allocate (hi_out%hel (size (hi_in%hel)))
	hi_out%hel = hi_in%hel
	end if
	if (allocated (hi_in%col)) then
	allocate (hi_out%col (size (hi_in%col)))
	hi_out%col = hi_in%col
	end if
	hi_out%int = hi_in%int
	end subroutine hard_interaction_make_copy

	@ %def hard_interaction_make_copy

	\subsection{Access contents}
	Whether we have a valid data set:
	<<Hard interactions: public>>=
	public :: hard_interaction_is_valid
	<<Hard interactions: procedures>>=
	function hard_interaction_is_valid (hi) result (flag)
	logical :: flag
	type(hard_interaction_t), intent(in) :: hi
	flag = hi%initialized
	end function hard_interaction_is_valid

	@ %def hard_interaction_is_valid
	@ The alphanumeric ID.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_id
	<<Hard interactions: procedures>>=
	function hard_interaction_get_id (hi) result (id)
	type(string_t) :: id
	type(hard_interaction_t), intent(in) :: hi
	id = hi%data%id
	end function hard_interaction_get_id

	@ %def hard_interaction_get_id
	@ The model as used for the hard interaction.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_model_ptr
	<<Hard interactions: procedures>>=
	function hard_interaction_get_model_ptr (hi) result (model)
	type(model_t), pointer :: model
	type(hard_interaction_t), intent(in) :: hi
	model => hi%data%model
	end function hard_interaction_get_model_ptr

	@ %def hard_interaction_get_model_ptr
	@ Particle counts.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_n_in
	public :: hard_interaction_get_n_out
	public :: hard_interaction_get_n_tot
	<<Hard interactions: procedures>>=
	pure function hard_interaction_get_n_in (hi) result (n_in)
	integer :: n_in
	type(hard_interaction_t), intent(in) :: hi
	n_in = hi%data%n_in
	end function hard_interaction_get_n_in

	pure function hard_interaction_get_n_out (hi) result (n_out)
	integer :: n_out
	type(hard_interaction_t), intent(in) :: hi
	n_out = hi%data%n_out
	end function hard_interaction_get_n_out

	pure function hard_interaction_get_n_tot (hi) result (n_tot)
	integer :: n_tot
	type(hard_interaction_t), intent(in) :: hi
	n_tot = hi%data%n_tot
	end function hard_interaction_get_n_tot

	@ %def hard_interaction_get_n_in
	@ %def hard_interaction_get_n_out
	@ %def hard_interaction_get_n_tot
	@ Quantum number counts.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_n_flv
	public :: hard_interaction_get_n_col
	public :: hard_interaction_get_n_hel
	<<Hard interactions: procedures>>=
	pure function hard_interaction_get_n_flv (hi) result (n_flv)
	integer :: n_flv
	type(hard_interaction_t), intent(in) :: hi
	n_flv = hi%data%n_flv
	end function hard_interaction_get_n_flv

	pure function hard_interaction_get_n_col (hi) result (n_col)
	integer :: n_col
	type(hard_interaction_t), intent(in) :: hi
	n_col = hi%data%n_col
	end function hard_interaction_get_n_col

	pure function hard_interaction_get_n_hel (hi) result (n_hel)
	integer :: n_hel
	type(hard_interaction_t), intent(in) :: hi
	n_hel = hi%data%n_hel
	end function hard_interaction_get_n_hel

	@ %def hard_interaction_get_n_flv
	@ %def hard_interaction_get_n_col
	@ %def hard_interaction_get_n_hel
	@ Particle tables.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_flv_states
	<<Hard interactions: procedures>>=
	function hard_interaction_get_flv_states (hi) result (flv_state)
	integer, dimension(:,:), allocatable :: flv_state
	type(hard_interaction_t), intent(in) :: hi
	allocate (flv_state (size (hi%data%flv_state, 1), &
	size (hi%data%flv_state, 2)))
	flv_state = hi%data%flv_state
	end function hard_interaction_get_flv_states

	@ %def hard_interaction_get_flv_states
	@ Color factor tables.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_n_cf
	<<Hard interactions: procedures>>=
	pure function hard_interaction_get_n_cf (hi) result (n_cf)
	integer :: n_cf
	type(hard_interaction_t), intent(in) :: hi
	n_cf = hi%data%n_cf
	end function hard_interaction_get_n_cf

	@ %def hard_interaction_get_n_cf
	@ Incoming particles. Consider only the first entry in
	the array of flavor combinations.

	If the process is forbidden and no flavor states are present, create
	at least an initial state with undefined particles.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_first_pdg_in
	<<Hard interactions: procedures>>=
	function hard_interaction_get_first_pdg_in (hi) result (pdg)
	integer, dimension(:), allocatable :: pdg
	type(hard_interaction_t), intent(in) :: hi
	allocate (pdg (hi%data%n_in))
	if (hi%data%n_flv > 0) then
	pdg = hi%data%flv_state (:hi%data%n_in, 1)
	else
	pdg = 0
	end if
	end function hard_interaction_get_first_pdg_in

	@ %def hard_interaction_get_first_pdg_in
	@ The analogous function for outgoing particles. Again, only the
	first entry in the array of flavor combinations.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_first_pdg_out
	<<Hard interactions: procedures>>=
	function hard_interaction_get_first_pdg_out (hi) result (pdg)
	integer, dimension(:), allocatable :: pdg
	type(hard_interaction_t), intent(in) :: hi
	allocate (pdg (hi%data%n_out))
	if (hi%data%n_flv > 0) then
	pdg = hi%data%flv_state (hi%data%n_in+1:hi%data%n_tot, 1)
	else
	pdg = 0
	end if
	end function hard_interaction_get_first_pdg_out

	@ %def hard_interaction_get_first_pdg_out
	@ This procedure is used for checking whether some of the final-state
	particles can initiate decay cascades. We check only the first row in the
	flavor array, since unstable particles are massive and should not be subject
	to flavor summation. Thus they must be common to all rows.
	<<Hard interactions: public>>=
	public :: hard_interaction_get_unstable_products
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_get_unstable_products (hi, flv_unstable)
	type(hard_interaction_t), intent(in) :: hi
	type(flavor_t), dimension(:), intent(out), allocatable :: flv_unstable
	type(model_t), pointer :: model
	integer, dimension(hi%data%n_out) :: pdg_out
	type(flavor_t) :: flv
	integer :: i
	model => hi%data%model
	if (associated (model) .and. size (hi%data%flv_state, 2) /= 0) then
	pdg_out = hi%data%flv_state(hi%data%n_in+1:,1)
	do i = 1, size (pdg_out)
	if (pdg_out(i) /= 0) then
	call flavor_init (flv, pdg_out(i), model)
	if (flavor_is_stable (flv)) then
	where (pdg_out(i:) == pdg_out(i)) pdg_out(i:) = 0
	else
	where (pdg_out(i+1:) == pdg_out(i)) pdg_out(i+1:) = 0
	end if
	end if
	end do
	allocate (flv_unstable (count (pdg_out /= 0)))
	call flavor_init &
	(flv_unstable, pack (pdg_out, pdg_out /= 0), model)
	else
	allocate (flv_unstable (0))
	end if
	end subroutine hard_interaction_get_unstable_products

	@ %def hard_interaction_get_unstable_products
	@
	\subsection{Evaluators}
	This procedure initializes the evaluator that computes the matrix
	element squared, traced over all outgoing quantum numbers. Whether
	the trace over incoming quantum numbers is done, depends on the
	specified mask -- except for color which is always summed.
	<<Hard interactions: public>>=
	public :: hard_interaction_init_trace
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_init_trace &
	(hi, qn_mask_in, use_hi_color_factors, nc)
	type(hard_interaction_t), intent(inout), target :: hi
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	logical, intent(in), optional :: use_hi_color_factors
	integer, intent(in), optional :: nc
	logical :: use_hi_cf
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	if (present (use_hi_color_factors)) then
	use_hi_cf = use_hi_color_factors
	else
	use_hi_cf = .false.
	end if
	allocate (qn_mask (hi%data%n_tot))
	qn_mask(:hi%data%n_in) = &
	new_quantum_numbers_mask (.false., .true., .false.) &
	.or. qn_mask_in
	qn_mask(hi%data%n_in+1:) = &
	new_quantum_numbers_mask (.true., .true., .true.)
	if (use_hi_cf) then
	call evaluator_init_square (hi%eval_trace, hi%int, qn_mask, &
	hi%data%col_flow_index, hi%data%col_factor, hi%col, nc=nc)
	else
	call evaluator_init_square (hi%eval_trace, hi%int, qn_mask, nc=nc)
	end if
	end subroutine hard_interaction_init_trace

	@ %def hard_interaction_init_trace
	@ This procedure initializes the evaluator that computes the matrix
	element square separated in parts (e.g., polarization components).
	Polarization is kept in the initial state (if allowed by
	[[qn_mask_in]]) and for those final-state
	particles which are marked as unstable. The incoming-particle mask
	can also be used to sum over incoming flavor.
	<<Hard interactions: public>>=
	public :: hard_interaction_init_sqme
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_init_sqme &
	(hi, qn_mask_in, use_hi_color_factors, nc)
	type(hard_interaction_t), intent(inout), target :: hi
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	logical, intent(in), optional :: use_hi_color_factors
	integer, intent(in), optional :: nc
	logical :: use_hi_cf
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(flavor_t), dimension(:), allocatable :: flv
	integer :: i
	logical :: helmask, helmask_hd
	if (present (use_hi_color_factors)) then
	use_hi_cf = use_hi_color_factors
	else
	use_hi_cf = .false.
	end if
	allocate (qn_mask (hi%data%n_tot), flv (hi%data%n_flv))
	qn_mask(:hi%data%n_in) = &
	new_quantum_numbers_mask (.false., .true., .false.) &
	.or. qn_mask_in
	do i = hi%data%n_in + 1, hi%data%n_tot
	call flavor_init (flv, hi%data%flv_state(i,:), hi%data%model)
	if (.not. all (flavor_is_stable (flv))) then
	helmask = all (flavor_decays_isotropically (flv))
	helmask_hd = all (flavor_decays_diagonal (flv))
	else
	helmask = all (.not. flavor_is_polarized (flv))
	helmask_hd = .true.
	end if
	qn_mask(i) = new_quantum_numbers_mask (.false., .true., &
	helmask, mask_hd = helmask_hd)
	end do
	if (use_hi_cf) then
	call evaluator_init_square (hi%eval_sqme, hi%int, qn_mask, &
	hi%data%col_flow_index, hi%data%col_factor, hi%col, nc=nc)
	else
	call evaluator_init_square (hi%eval_sqme, hi%int, qn_mask, nc=nc)
	end if
	end subroutine hard_interaction_init_sqme

	@ %def hard_interaction_init_sqme
	@ 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.
	<<Hard interactions: public>>=
	public :: hard_interaction_init_flows
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_init_flows (hi, qn_mask_in)
	type(hard_interaction_t), intent(inout), target :: hi
	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
	allocate (qn_mask (hi%data%n_tot), flv (hi%data%n_flv))
	qn_mask(:hi%data%n_in) = &
	new_quantum_numbers_mask (.false., .false., .false.) &
	.or. qn_mask_in
	do i = hi%data%n_in + 1, hi%data%n_tot
	call flavor_init (flv, hi%data%flv_state(i,:), hi%data%model)
	if (.not. all (flavor_is_stable (flv))) then
	helmask = all (flavor_decays_isotropically (flv))
	helmask_hd = all (flavor_decays_diagonal (flv))
	else
	helmask = all (.not. flavor_is_polarized (flv))
	helmask_hd = .true.
	end if
	qn_mask(i) = new_quantum_numbers_mask (.false., .false., &
	helmask, mask_hd = helmask_hd)
	end do
	call evaluator_init_square (hi%eval_flows, hi%int, qn_mask, &
	expand_color_flows = .true.)
	end subroutine hard_interaction_init_flows

	@ %def hard_interaction_init_flows
	@ Finalize the previous evaluators.
	<<Hard interactions: public>>=
	public :: hard_interaction_final_sqme
	public :: hard_interaction_final_flows
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_final_sqme (hi)
	type(hard_interaction_t), intent(inout) :: hi
	call evaluator_final (hi%eval_sqme)
	end subroutine hard_interaction_final_sqme

	subroutine hard_interaction_final_flows (hi)
	type(hard_interaction_t), intent(inout) :: hi
	call evaluator_final (hi%eval_flows)
	end subroutine hard_interaction_final_flows

	@ %def hard_interaction_final_sqme hard_interaction_final_flows
	@
	\subsection{Matrix-element evaluation}
	Update the $\alpha_s$ value used by the matrix element (if any).
	<<Hard interactions: public>>=
	public :: hard_interaction_update_alpha_s
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_update_alpha_s (hi, alpha_s)
	type(hard_interaction_t), intent(inout) :: hi
	real(default), intent(in) :: alpha_s
	real(c_default_float) :: c_alpha_s
	c_alpha_s = alpha_s
	call hi%data% update_alpha_s (c_alpha_s)
	end subroutine hard_interaction_update_alpha_s

	@ %def hard_interaction_update_alpha_s
	@ Reset the helicity selection counters that are used to speed up
	things by dropping zero helicity channels after [[cutoff]] tries.
	<<Hard interactions: public>>=
	public :: hard_interaction_reset_helicity_selection
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_reset_helicity_selection (hi, threshold, cutoff)
	type(hard_interaction_t), intent(inout) :: hi
	real(default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	real(c_default_float) :: c_threshold
	integer(c_int) :: c_cutoff
	c_threshold = threshold
	c_cutoff = cutoff
	call hi%data% reset_helicity_selection (c_threshold, c_cutoff)
	end subroutine hard_interaction_reset_helicity_selection

	@ %def hard_interaction_reset_helicity_selection
	@
	This interfaces the matrix element proper. First, we request a new
	matrix element value to be computed from the given momenta. Then, we
	extract all values that are known to be allowed and assign them to the
	matrix element array. This array consists of pointers to the
	interaction values, so in fact the latter are calculated.

	Although it may be irrelevant, this is an obvious place for parallel
	execution, so write a forall assignment. Making the assignment
	elemental is not possible because [[get_amplitude]] is a procedure
	pointer. [This is deactivated; to be checked again.]

	After the matrix element data are read, we evaluate the squared matrix
	element ([[eval_trace]]).
	square and the
	color-flow coefficients.
	<<Hard interactions: public>>=
	public :: hard_interaction_evaluate
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_evaluate (hi)
	type(hard_interaction_t), intent(inout), target :: hi
	integer :: i
	complex(default) :: val
	call hi%data% new_event &
	(array_from_vector4 (interaction_get_momenta (hi%int)))
	! forall (i = 1:hi%n_values)
	! hi%me(i) = hi%data% get_amplitude (hi%flv(i), hi%hel(i), hi%col(i))
	! end forall
	do i = 1, hi%n_values
	val = hi%data% get_amplitude (hi%flv(i), hi%hel(i), hi%col(i))
	call interaction_set_matrix_element (hi%int, i, val)
	end do
	call evaluator_evaluate (hi%eval_trace)
	end subroutine hard_interaction_evaluate

	@ %def hard_interaction_evaluate
	@ The extra evaluators (squared matrix element without trace, color
	flows) need only be evaluated for simulation events that pass the
	unweighting step. This follows the previous routine.
	<<Hard interactions: public>>=
	public :: hard_interaction_evaluate_sqme
	public :: hard_interaction_evaluate_flows
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_evaluate_sqme (hi)
	type(hard_interaction_t), intent(inout), target :: hi
	call evaluator_receive_momenta (hi%eval_sqme)
	call evaluator_evaluate (hi%eval_sqme)
	end subroutine hard_interaction_evaluate_sqme

	subroutine hard_interaction_evaluate_flows (hi)
	type(hard_interaction_t), intent(inout), target :: hi
	call evaluator_receive_momenta (hi%eval_flows)
	call evaluator_evaluate (hi%eval_flows)
	end subroutine hard_interaction_evaluate_flows

	@ %def hard_interaction_evaluate_sqme hard_interaction_evaluate_flows
	@ This provides direct access to the matrix element, squared and
	traced over all quantum numbers. It is not used for ordinary evaluation.
	<<Hard interactions: public>>=
	public :: hard_interaction_compute_sqme_sum
	<<Hard interactions: procedures>>=
	function hard_interaction_compute_sqme_sum (hi, p) result (sqme)
	real(default) :: sqme
	type(hard_interaction_t), intent(inout), target :: hi
	type(vector4_t), dimension(:), intent(in) :: p
	call interaction_set_momenta (hi%int, p)
	call hard_interaction_evaluate (hi)
	sqme = evaluator_sum (hi%eval_trace)
	end function hard_interaction_compute_sqme_sum

	@ %def hard_interaction_compute_sqme_sum
	@
	\subsection{Access results}
	<<Hard interactions: public>>=
	public :: hard_interaction_get_int_ptr
	<<Hard interactions: procedures>>=
	function hard_interaction_get_int_ptr (hi) result (int)
	type(interaction_t), pointer :: int
	type(hard_interaction_t), intent(in), target :: hi
	int => hi%int
	end function hard_interaction_get_int_ptr

	@ %def hard_interaction_get_int_ptr
	<<Hard interactions: public>>=
	public :: hard_interaction_get_eval_trace_ptr
	public :: hard_interaction_get_eval_sqme_ptr
	public :: hard_interaction_get_eval_flows_ptr
	<<Hard interactions: procedures>>=
	function hard_interaction_get_eval_trace_ptr (hi) result (eval)
	type(evaluator_t), pointer :: eval
	type(hard_interaction_t), intent(in), target :: hi
	eval => hi%eval_trace
	end function hard_interaction_get_eval_trace_ptr

	function hard_interaction_get_eval_sqme_ptr (hi) result (eval)
	type(evaluator_t), pointer :: eval
	type(hard_interaction_t), intent(in), target :: hi
	eval => hi%eval_sqme
	end function hard_interaction_get_eval_sqme_ptr

	function hard_interaction_get_eval_flows_ptr (hi) result (eval)
	type(evaluator_t), pointer :: eval
	type(hard_interaction_t), intent(in), target :: hi
	eval => hi%eval_flows
	end function hard_interaction_get_eval_flows_ptr

	@ %def hard_interaction_get_eval_trace_ptr
	@ %def hard_interaction_get_eval_sqme_ptr
	@ %def hard_interaction_get_eval_flows_ptr
	@
	\subsection{Reconstruction}
	Reconstruct the kinematics of the hard interaction from a given particle set.
	The particle set may have been decayed, and the particle order is not
	necessarily correct.
	<<Hard interactions: public>>=
	public :: hard_interaction_recover_kinematics
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_recover_kinematics (hi, pset)
	type(hard_interaction_t), intent(inout) :: hi
	type(particle_set_t), intent(in) :: pset
	call particle_set_extract_interaction (pset, hi%int, hi%data%flv_state)
	end subroutine hard_interaction_recover_kinematics

	@ %def hard_interaction_recover_kinematics
	@
	\subsection{Process summary}
	Write an account of the allowed quantum numbers.
	<<Hard interactions: public>>=
	public :: hard_interaction_write_state_summary
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_write_state_summary (hi, unit)
	type(hard_interaction_t), intent(in), target :: hi
	integer, intent(in), optional :: unit
	type(state_iterator_t) :: it
	integer :: u, i, f, h, c
	character(1) :: sgn
	u = output_unit (unit)
	call state_iterator_init (it, interaction_get_state_matrix_ptr (hi%int))
	do while (state_iterator_is_valid (it))
	i = state_iterator_get_me_index (it)
	f = hi%flv(i)
	h = hi%hel(i)
	c = hi%col(i)
	if (hi%data% is_allowed (f, h, c)) then
	sgn = "+"
	else
	sgn = " "
	end if
	write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i
	call quantum_numbers_write (state_iterator_get_quantum_numbers (it), u)
	write (u, *)
	call state_iterator_advance (it)
	end do
	end subroutine hard_interaction_write_state_summary

	@ %def hard_interaction_write_state_summary
	@
	\subsection{Test}
	<<Hard interactions: public>>=
	public :: hard_interaction_test
	<<Hard interactions: procedures>>=
	subroutine hard_interaction_test (model)
	type(model_t), target :: model
	type(process_library_t), pointer :: prc_lib => null ()
	type(os_data_t), pointer :: os_data => null ()
	type(hard_interaction_t), pointer :: hi => null ()
	type(var_list_t), pointer :: var_list => null ()
	type(vector4_t), dimension(4) :: p
	type(quantum_numbers_mask_t), dimension(2) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(4) :: qn_mask
	real(default) :: sqme, mh
	allocate (hi)
	allocate (prc_lib)
	allocate (os_data)
	allocate (var_list)
	call os_data_init (os_data)
	call msg_message ("*** Load library 'test_me'")
	call msg_message &
	(" [must exist and contain process 'test_me_eemm' (test_me.sin)]")
	call var_list_append_string &
	(var_list, name = "$library_name", sval = "test_me") ! $
	call process_library_init (prc_lib, var_str("test_me"), os_data)
	call process_library_load (prc_lib, os_data, var_list = var_list)
	call msg_message ()
	call msg_message ("*** Create hard interaction")
	call hard_interaction_init (hi, prc_lib, 1, var_str ("test_me_eemm"), model)
	qn_mask_in = new_quantum_numbers_mask (.true., .true., .true.)
	call hard_interaction_init_trace (hi, qn_mask_in)
	print *, "Interaction: n_values = ", &
	interaction_get_n_matrix_elements (hi%int)
	qn_mask_in = new_quantum_numbers_mask (.false., .false., .false., .true.)
	call hard_interaction_init_sqme (hi, qn_mask_in)
	call hard_interaction_init_flows (hi, qn_mask_in)
	p(1) = vector4_moving (250._default, 250._default, 3)
	p(2) = vector4_moving (250._default,-250._default, 3)
	p(3) = rotation (1._default, 1) * p(1)
	p(4) = p(1) + p(2) - p(3)
	call msg_message ()
	call msg_message ("*** Evaluate new event")
	sqme = hard_interaction_compute_sqme_sum (hi, p)
	call hard_interaction_evaluate_sqme (hi)
	call hard_interaction_evaluate_flows (hi)
	call hard_interaction_write (hi)
	print *
	print *, "sqme sum =", sqme
	print *
	print , "** Cleanup"
	call hard_interaction_final (hi)
	call process_library_final (prc_lib)
	end subroutine hard_interaction_test

	@ %def hard_interaction_test
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Core interactions}

	This is in abstraction above the hard core interaction which can be either a
	%
	\begin{itemize}
	\item \oMega\ tree level matrix element ($\rightarrow$ [[hard_interaction_t]])
	%
	\item NLO matrix element via BLHA
	%
	\item Dipole
	%
	\item Subtractor combining dipole and matrix element
	%
	\end{itemize}

	Evaluating a dipole or a recombined matrix element requires a much more involved
	kinematical setup than the straightforward evaluation of a simple matrix
	element:
	%
	\begin{itemize}
	\item In order for real dipole subtraction terms to be analytically integrable,
	the additional emission must always be recombined with the emitter. For the same
	reason, the cuts and the renormalization / factorization scales must depend only
	on those recombined momenta. Thus, a $n+1$ particle subtraction term built from
	$m$ individual dipoles can lead to as much as $m$ different $n$ particle phase
	space points which have to be considered separately. As filling a histogram bin
	is equivalent to integrating the recombined momenta over a restricted subset of
	phase space, these $m$ points have to be treated as separate events in the event
	generation. In the following, these points will be referred to as ``out''
	points.
	%
	\item Integrating dipole components involving an initial particle as either
	emitter or spectator leads to a convolution integral of the form
	%
	\[
	\mathcal{D} =
	\int_0^1 dx\; \left(\int d\phi A(x) - \int d\phi(x) B(x)\right) +
	\int d\phi\;C
	\]
	%
	where the second integral is over the phase space associated with the the
	initial state kinematics \emph{after} the additional emission.
	Both the phasespace integrals over $A$ and $B$ are singular for $x\rightarrow 1$
	and only the difference is finite. This cancellation can be implemented by
	calculating $\phi(1)$ and $\phi(x)$ from the same set of random variables $\xi$
	in the phase space sampling. In the limit $x\rightarrow 1$, the those points
	will coincide, and the cancellation between the two terms will render the sum
	finite. Thus, the phasespace ``forks'' into two different configurations which I
	will refer to as ``in''points. As a typical subtraction terms will involve
	emissions from both inital state partons, there will usually be three different
	``in'' points which also lead to three different ``out'' points.

	In the language using plus distribution, this approach corresponds to directly
	evaluating the prescription for the plus distribution in the integration over
	the MC hypercube.
	%
	\item Recombining the real subtraction term with the real emission matrix
	element requires a collinear / IR safe recombination of the additional emission
	with the emitter. Together with the first bullet, this suggests treating both
	the dipole and the matrix element as $n+1$ particle processes only for the
	purpose of phase space generation and effectively as $n$ particle processes
	everywhere else.
	\end{itemize}
	%

	The workflow for evaluating the core interaction at a phase space point should
	look like the following:
	%
	\begin{enumerate}
	\item Draw random variables $\xi$.
	\item Determine parton level kinematics from structure function chain and
	communicate them to the core interaction.
	\item Query the boosts defining any additional ``in'' points from the core
	interactions.
	\item Generate all ``in'' points and hand them over to the core interaction.
	\item Get the ``out'' kinematics from the core interaction which should proceed
	via associated [[interaction_t]] objects.
	\item Evaluate cuts and scales, communicate the result to the core interaction.
	\item Evaluate core interaction. This will fill in the matrix elements in the
	[[interaction_t]] objects and evaluators associated with the ``out'' points.
	\item Evaluate the structure function chain for the different ``out'' points.
	\item Calculate the jacobians, communicate them together with phase space volume
	etc. to the core interaction as ``weight''.
	\item The final value of the sample function can now be retrieved from
	evaluators multiplying the desity matrices associated with the structure
	function chain and the core interaction after summing this product over the
	``out'' points with the proper (jacobian) weights.
	\end{enumerate}
	%
	Subsequent event generation should be straightforward, with the ``out''
	configurations being treated as separate weighted events. The weights may be
	negative and can get large, but for a collinear / IR safe observe, they will add
	to a finite value in each histogram bin. The [[core_interaction_t]] interface
	should facilitate this chain.

	NOTES:
	\begin{itemize}
	\item I still am not clear how a good way of stating the recombination criteriom
	should look like. The ideal solution should give the flexibility to cover most
	physically interesting cases. However, I think it is safe to defer this as the
	necessary functionality is mostly encapsulated in [[core_interaction_t]].
	%
	\item Unpolarized dipoles should suffice for a start. After the setup detailed
	above has been implemented, the extension to polarized dipoles (massive dipoles,
	cut dipoles, whatever) will be straightforward and localized \emph{only} to the
	core interaction and dipole modules.
	%
	\item The simple approach to calculating the dipoles currently implemented
	applies only to photon / gluon radiation. Photon / gluon splitting in the
	initial / final states is more involved and requires a sum over emitter,
	spectator and emitted parton. To this end, a much more involved mapping between
	the Born flavor states and the dipole flavor states is required.
	\end{itemize}

	In order to avoid cyclic dependencies, this module is split into
	[[core_interactions_config]] (which holds all declarations which are necessary
	to describe the configuration of the core interaction) and
	[[core_interactions]] (the actual implementation.

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

	module core_interactions_config

	use kinds !NODEP!
	<<Use strings>>
	use diagnostics !NODEP!

	<<Standard module head>>

	<<Core interactions config: public>>

	<<Core interactions config: parameters>>

	contains

	<<Core interactions config: procedures>>

	end module core_interactions_config
	@ %def core_interactions_config
	@
	<<[[core_interactions.f90]]>>=
	<<File header>>

	module core_interactions

	use kinds !NODEP!
	<<Use strings>>
	<<Use file utils>>
	use diagnostics !NODEP!
	use lorentz !NODEP!
	use models
	use flavors
	use helicities
	use colors
	use quantum_numbers
	use state_matrices
	use interactions
	use evaluators
	use particles
	use prclib_interfaces
	use process_libraries
	use hard_interactions
	use core_interactions_config
	use dipoles_integrated_qed
	use dipoles_real_qed
	use photon_recombination
	use nlo_setup

	<<Standard module head>>

	<<Core interactions: public>>

	<<Core interactions: parameters>>

	<<Core interactions: types>>

	<<Core interactions: interfaces>>

	contains

	<<Core interactions: procedures>>

	end module core_interactions
	@ %def core_interactions
	@

	\subsection{Configuration}

	A tag discriminates between the different underlying matrix element types
	<<Core interactions config: parameters>>=
	integer, parameter, public :: &
	CI_OMEGA=1, CI_BLHA=2, CI_DIPOLE_INTEGRATED_QED=3, &
	CI_DIPOLE_REAL_QED=4, CI_DIPOLE_INTEGRATED_QCD=5, CI_DIPOLE_REAL_QCD=6, &
	CI_SUM = 11, CI_PHOTON_RECOMBINATION = 12, CI_UNDEFINED = -1

	@ %def CI_OMEGA CI_BLHA CI_DIPOLE_INTEGRATED_QED CI_DIPOLE_REAL_QED
	@ %def CI_DIPOLE_INTEGRATED_QCD CI_DIPOLE_REAL_QCD
	@ %def CI_SUBTRACTED_VIRT_QED CI_SUBTRACTED_REAL_QED
	@ %def CI_SUBTRACTED_REAL_QCD CI_SUBTRACTED_VIRT_QCD
	@ %def CI_UNDEFINED CI_SUM CI_PHOTON_RECOMBINATION
	@
	Return a textual description of the core interaction type. We will need it
	often, so we define a function.
	<<Core interactions config: public>>=
	public :: core_interaction_type_description
	<<Core interactions config: procedures>>=
	function core_interaction_type_description (id) result (desc)
	integer, intent(in) :: id
	type(string_t) :: desc
	select case (id)
	case (CI_OMEGA)
	desc = "O'Mega matrix element"
	case (CI_BLHA)
	desc = "BLHA matrix element"
	case (CI_DIPOLE_INTEGRATED_QED)
	desc = "Integrated QED dipole"
	case (CI_DIPOLE_REAL_QED)
	desc = "Unintegrated QED dipole"
	case (CI_DIPOLE_INTEGRATED_QCD)
	desc = "Integrated QCD dipole"
	case (CI_DIPOLE_REAL_QCD)
	desc = "Unintegrated QCD dipole"
	case (CI_SUM)
	desc = "Sum of two interactions"
	case (CI_PHOTON_RECOMBINATION)
	desc = "Tree level with photon emission recombined"
	case default
	desc = "[undefined]"
	end select
	end function core_interaction_type_description

	@ %def core_interaction_type_description
	@

	\subsection{Implementation}

	As the program proceeds along the evaluation chain, the state of the core
	interaction objects is advanced using tags:
	%
	\begin{enumerate}
	\item [[CI_STATE_CLEAR]] A new evaluation cycle begins.
	%
	\item [[CI_STATE_SEED_MOMENTA_SET]] The ingoing seed momenta have been
	communicated to the interaction objects and any additional convolution parameters
	have been set via [[core_interaction_set_x]]. Triggers the evaluation of the
	auxiliary kinematics.
	%
	\item [[CI_STATE_MOMENTA_SET]] All ingoing momenta have been set. This triggers
	the evaluation of the ``out'' kinematics.
	%
	\item [[CI_STATE_EVALUATE]] Cuts (and scales) have been set up. After
	this point, [[core_interaction_evaluate]] may be called.
	%
	\item [[CI_STATE_WEIGHTS_SET]] All phasespace weights (jacobians times volume
	factors) have been set via [[core_interaction_set_weight]]. Triggers the
	computation of the ``out'' weights.
	\end{enumerate}
	%
	To advance the state, [[core_interaction_set_state]] is called.
	<<Core interactions: parameters>>=
	integer, public, parameter :: CI_STATE_CLEAR=1, &
	CI_STATE_SEED_MOMENTA_SET=2, CI_STATE_MOMENTA_SET=3, CI_STATE_EVALUATE=4, &
	CI_STATE_WEIGHTS_SET=5

	@ %def CI_STATE_CLEAR CI_STATE_SEED_MOMENTA_SET CI_STATE_EVALUATE
	@ %def CI_STATE_WEIGHTS_SET CI_STATE_MOMENTA_SET
	@
	The [[core_interaction_t]] type wraps around the different ``subclasses''.
	<<Core interactions: public>>=
	public :: core_interaction_t
	<<Core interactions: types>>=
	type core_interaction_t
	private
	integer :: type = CI_UNDEFINED
	integer :: state = CI_STATE_CLEAR
	type(hard_interaction_t) :: hard_interaction
	logical :: me_passed_cut
	real(kind=default) :: me_weight
	integer :: me_n_in, me_n_out, me_n_tot
	type(dipole_integrated_qed_t) :: dipole_integrated_qed
	type(dipole_real_qed_t) :: dipole_real_qed
	type(core_interaction_sum_t), pointer :: core_interaction_sum
	type(photon_recombination_t) :: photon_recombination
	end type core_interaction_t

	@ %def core_interaction_t
	@
	Initialization.
	<<Core interactions: public>>=
	public :: core_interaction_init
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_init (ci, prc_lib, process_index, &
	process_id, model, nlo_setup)
	type(core_interaction_t), intent(out), target :: ci
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	ci%type = process_library_get_ci_type (prc_lib, process_id)
	if (ci%type < 0) call msg_bug ("core_interaction_init: undefined type")
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_init (ci%hard_interaction, &
	prc_lib, process_index, process_id, model)
	ci%me_n_in = hard_interaction_get_n_in (ci%hard_interaction)
	ci%me_n_out = hard_interaction_get_n_out (ci%hard_interaction)
	ci%me_n_tot = hard_interaction_get_n_tot (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_init (ci%dipole_integrated_qed, &
	prc_lib, process_index, process_id, model, nlo_setup = nlo_setup)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_init (ci%dipole_real_qed, &
	prc_lib, process_index, process_id, model, nlo_setup = nlo_setup)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_init (ci%photon_recombination, &
	prc_lib, process_index, process_id, model, nlo_setup = nlo_setup)
	case (CI_SUM)
	call core_interaction_init_sum (ci, prc_lib, process_id, &
	process_index, model, nlo_setup = nlo_setup)
	case default
	call msg_bug ("core_interaction_init: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_init

	@ %def core_interaction_init
	@
	Init a [[CI_SUM]] type core interaction.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_init_sum &
	(ci, prc_lib, process_id, pid, model, nlo_setup)
	type(core_interaction_t), intent(out), target :: ci
	type(process_library_t), intent(in) :: prc_lib
	type(string_t), intent(in) :: process_id
	integer, intent(in) :: pid
	type(model_t), target, intent(in) :: model
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	type(nlo_setup_t) :: setup
	type(core_interaction_sum_t) :: cis
	type(core_interaction_t) :: ci1, ci2
	type(string_t) :: id1, id2
	integer :: pid1, pid2
	if (present (nlo_setup)) then
	setup = nlo_setup
	else
	setup = process_library_get_nlo_setup (prc_lib, process_id)
	end if
	id1 = process_library_get_sum_child (prc_lib, process_id, 1)
	id2 = process_library_get_sum_child (prc_lib, process_id, 2)
	pid1 = process_library_get_process_pid (prc_lib, id1)
	pid2 = process_library_get_process_pid (prc_lib, id2)
	if (pid1 < 0) then
	call not_found (id1)
	return
	end if
	if (pid2 < 0) then
	call not_found (id2)
	return
	end if
	call core_interaction_init (ci1, prc_lib, pid1, id1, model, nlo_setup = setup)
	call core_interaction_init (ci2, prc_lib, pid2, id2, model, nlo_setup = setup)
	allocate (ci%core_interaction_sum)
	call core_interaction_sum_init (ci%core_interaction_sum, ci1, ci2, &
	process_id)
	ci%type = CI_SUM
	call core_interaction_final (ci1)
	call core_interaction_final (ci2)

	contains

	subroutine not_found (id)
	type(string_t), intent(in) :: id
	call msg_error ("process " // char (id) // " does not exist" // &
	" in process library " // char (process_library_get_name (prc_lib)))
	end subroutine not_found

	end subroutine core_interaction_init_sum

	@ %def core_interaction_init_sum
	@
	Finalization.
	<<Core interactions: public>>=
	public :: core_interaction_final
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_final (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_UNDEFINED)
	case (CI_OMEGA)
	call hard_interaction_final (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_final (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_final (ci%dipole_real_qed)
	case (CI_SUM)
	call core_interaction_sum_final (ci%core_interaction_sum)
	deallocate (ci%core_interaction_sum)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_final (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_final: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	ci%type = CI_UNDEFINED
	end subroutine core_interaction_final

	@ %def core_interaction_final
	@
	Return the core interaction type.
	<<Core interactions: public>>=
	public :: core_interaction_get_type
	<<Core interactions: procedures>>=
	function core_interaction_get_type (ci) result (t)
	type(core_interaction_t), intent(in) :: ci
	integer ::t
	t = ci%type
	end function core_interaction_get_type

	@ %def core_interaction_get_type
	@
	Process library unload and reload hooks.
	<<Core interactions: public>>=
	public :: core_interaction_unload
	public :: core_interaction_reload
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_unload (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_unload (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_unload (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_unload (ci%dipole_real_qed)
	case (CI_SUM)
	call core_interaction_unload (ci%core_interaction_sum%ci1)
	call core_interaction_unload (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_unload (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_unload: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_unload

	recursive subroutine core_interaction_reload (ci, prc_lib)
	type(core_interaction_t), intent(inout) :: ci
	type(process_library_t), intent(in) :: prc_lib
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_reload (ci%hard_interaction, prc_lib)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_reload (ci%dipole_integrated_qed, &
	prc_lib)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_reload (ci%dipole_real_qed, prc_lib)
	case (CI_SUM)
	call core_interaction_reload (ci%core_interaction_sum%ci1, prc_lib)
	call core_interaction_reload (ci%core_interaction_sum%ci2, prc_lib)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_reload (ci%photon_recombination, prc_lib)
	case default
	call msg_bug ("core_interaction_reload: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_reload

	@ %def core_interaction_unload core_interaction_reload
	Update the model parameters
	<<Core interactions: public>>=
	public :: core_interaction_update_parameters
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_update_parameters (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_update_parameters (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_update_parameters (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_update_parameters (ci%dipole_real_qed)
	case (CI_SUM)
	call core_interaction_update_parameters (ci%core_interaction_sum%ci1)
	call core_interaction_update_parameters (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_update_parameters (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_update_parameters: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_update_parameters

	@ %def core_interaction_update_parameters
	@
	Write contents.
	<<Core interactions: public>>=
	public :: core_interaction_write
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_write &
	(ci, unit, verbose, show_momentum_sum, show_mass, write_comb)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: write_comb
	integer :: u
	u = output_unit (unit)
	write (u, "(1X,A)") "Core interaction type: " // &
	char (core_interaction_type_description (ci%type))
	select case (ci%type)
	case (CI_OMEGA)
	write (u, "(1X,A)") "Hard interaction:"
	call hard_interaction_write (ci%hard_interaction, &
	unit, verbose, show_momentum_sum, show_mass, write_comb)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_write (ci%dipole_integrated_qed, unit)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_write (ci%dipole_real_qed, unit)
	case (CI_SUM)
	call core_interaction_sum_write (ci%core_interaction_sum, &
	unit, verbose, show_momentum_sum, show_mass, write_comb)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_write (ci%photon_recombination, &
	unit, verbose, show_momentum_sum, show_mass, write_comb)
	case default
	call msg_bug ("core_interaction_write: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_write

	@ %def core_interaction_write
	@
	Assignment operator.
	<<Core interactions: public>>=
	public :: assignment(=)
	<<Core interactions: interfaces>>=
	interface assignment(=)
	module procedure core_interaction_assign
	end interface
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_assign (ci_out, ci_in)
	type(core_interaction_t), intent(in) :: ci_in
	type(core_interaction_t), intent(inout) :: ci_out
	call core_interaction_final (ci_out)
	ci_out%type = ci_in%type
	select case (ci_in%type)
	case (CI_OMEGA)
	ci_out%hard_interaction = ci_in%hard_interaction
	ci_out%me_passed_cut = ci_in%me_passed_cut
	ci_out%me_weight = ci_in%me_weight
	ci_out%me_n_in = ci_in%me_n_in
	ci_out%me_n_out = ci_in%me_n_out
	ci_out%me_n_tot = ci_in%me_n_tot
	case (CI_DIPOLE_INTEGRATED_QED)
	ci_out%dipole_integrated_qed = ci_in%dipole_integrated_qed
	case (CI_DIPOLE_REAL_QED)
	ci_out%dipole_real_qed = ci_in%dipole_real_qed
	case (CI_SUM)
	allocate (ci_out%core_interaction_sum)
	ci_out%core_interaction_sum = ci_in%core_interaction_sum
	case (CI_PHOTON_RECOMBINATION)
	ci_out%photon_recombination = ci_in%photon_recombination
	case default
	call msg_bug ("core_interaction_assign: not implemented: " &
	// char (core_interaction_type_description (ci_in%type)))
	end select
	end subroutine core_interaction_assign

	@ %def core_interaction_assign
	@
	Sanity check.
	<<Core interactions: public>>=
	public :: core_interaction_is_valid
	<<Core interactions: procedures>>=
	recursive function core_interaction_is_valid (ci) result (stat)
	type(core_interaction_t), intent(in) :: ci
	logical :: stat
	if (ci%type < 0) then
	stat = .false.
	return
	end if
	select case (ci%type)
	case (CI_OMEGA)
	stat = hard_interaction_is_valid (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	stat = dipole_integrated_qed_is_valid (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	stat = dipole_real_qed_is_valid (ci%dipole_real_qed)
	case (CI_SUM)
	stat = core_interaction_sum_is_valid (ci%core_interaction_sum)
	case (CI_PHOTON_RECOMBINATION)
	stat = photon_recombination_is_valid (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_is_valid: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_is_valid

	@ %def core_interaction_is_valid
	@
	Process ID.
	<<Core interactions: public>>=
	public :: core_interaction_get_id
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_id (ci) result (id)
	type(core_interaction_t), intent(in) :: ci
	type(string_t) :: id
	select case (ci%type)
	case (CI_OMEGA)
	id = hard_interaction_get_id (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	id = dipole_integrated_qed_get_id (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	id = dipole_real_qed_get_id (ci%dipole_real_qed)
	case (CI_SUM)
	id = ci%core_interaction_sum%id
	case (CI_PHOTON_RECOMBINATION)
	id = photon_recombination_get_id (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_id: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_id

	@ %def core_interaction_get_id
	@
	Model pointer.
	<<Core interactions: public>>=
	public :: core_interaction_get_model_ptr
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_model_ptr (ci) result (model)
	type(core_interaction_t), intent(in) :: ci
	type(model_t), pointer :: model
	select case (ci%type)
	case (CI_OMEGA)
	model => hard_interaction_get_model_ptr (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	model => dipole_integrated_qed_get_model_ptr ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	model => dipole_real_qed_get_model_ptr (ci%dipole_real_qed)
	case (CI_SUM)
	model => core_interaction_get_model_ptr (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	model => photon_recombination_get_model_ptr (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_model_ptr: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_model_ptr

	@ %def core_interaction_get_model_ptr
	@
	Particle counts. Two variants exist, one for obtaining the effective particle
	count after recombination ([[_eff]]), and one for the actual particle count in
	the integration ([[_real]]).
	<<Core interactions: public>>=
	public :: core_interaction_get_n_in
	public :: core_interaction_get_n_out_eff
	public :: core_interaction_get_n_tot_eff
	public :: core_interaction_get_n_out_real
	public :: core_interaction_get_n_tot_real
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_n_in (ci) result (n_in)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_in
	select case (ci%type)
	case (CI_OMEGA)
	n_in = ci%me_n_in
	case (CI_DIPOLE_INTEGRATED_QED)
	n_in = dipole_integrated_qed_get_n_in (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_in = dipole_real_qed_get_n_in (ci%dipole_real_qed)
	case (CI_SUM)
	n_in = core_interaction_get_n_in (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_in = 2
	case default
	call msg_bug ("core_interaction_get_n_in: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_in

	recursive function core_interaction_get_n_out_eff (ci) result (n_out)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_out
	select case (ci%type)
	case (CI_OMEGA)
	n_out = ci%me_n_out
	case (CI_DIPOLE_INTEGRATED_QED)
	n_out = dipole_integrated_qed_get_n_out (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_out = dipole_real_qed_get_n_out_eff (ci%dipole_real_qed)
	case (CI_SUM)
	n_out = core_interaction_get_n_out_eff (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_out = photon_recombination_get_n_out_eff (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_out_eff: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_out_eff

	recursive function core_interaction_get_n_tot_eff (ci) result (n_tot)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_tot
	select case (ci%type)
	case (CI_OMEGA)
	n_tot = ci%me_n_tot
	case (CI_DIPOLE_INTEGRATED_QED)
	n_tot = dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_tot = dipole_real_qed_get_n_tot_eff (ci%dipole_real_qed)
	case (CI_SUM)
	n_tot = core_interaction_get_n_tot_eff (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_tot = photon_recombination_get_n_tot_eff (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_tot: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_tot_eff

	recursive function core_interaction_get_n_out_real (ci) result (n_out)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_out
	select case (ci%type)
	case (CI_OMEGA)
	n_out = ci%me_n_out
	case (CI_DIPOLE_INTEGRATED_QED)
	n_out = dipole_integrated_qed_get_n_out (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_out = dipole_real_qed_get_n_out_real (ci%dipole_real_qed)
	case (CI_SUM)
	n_out = core_interaction_get_n_out_real (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_out = photon_recombination_get_n_out_real (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_out_real: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_out_real

	recursive function core_interaction_get_n_tot_real (ci) result (n_tot)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_tot
	select case (ci%type)
	case (CI_OMEGA)
	n_tot = ci%me_n_tot
	case (CI_DIPOLE_INTEGRATED_QED)
	n_tot = dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_tot = dipole_real_qed_get_n_tot_real (ci%dipole_real_qed)
	case (CI_SUM)
	n_tot = core_interaction_get_n_tot_real (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_tot = photon_recombination_get_n_tot_real (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_tot: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_tot_real

	@ %def core_interaction_get_n_in core_interaction_get_n_out_eff
	@ %def core_interaction_get_n_tot_eff
	@ %def core_interaction_get_n_out_real
	@ %def core_interaction_get_n_tot_real
	@
	Quantum number counts. For [[core_interaction_n_flv]], there are again two
	[[_eff]] and [[_real]] versions. As the other two methods are currently unused,
	they are hidden for the moment
	<<Core interactions: public>>=
	public :: core_interaction_get_n_flv_eff
	public :: core_interaction_get_n_flv_real
	!public :: core_interaction_get_n_col
	!public :: core_interaction_get_n_hel
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_n_flv_eff (ci) result (n_flv)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_flv
	select case (ci%type)
	case (CI_OMEGA)
	n_flv = hard_interaction_get_n_flv (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	n_flv = dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_flv = dipole_real_qed_get_n_flv (ci%dipole_real_qed)
	case (CI_SUM)
	n_flv = core_interaction_get_n_flv_eff (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_flv = photon_recombination_get_n_flv (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_flv_eff: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_flv_eff

	recursive function core_interaction_get_n_flv_real (ci) result (n_flv)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_flv
	select case (ci%type)
	case (CI_OMEGA)
	n_flv = hard_interaction_get_n_flv (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	n_flv = dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n_flv = dipole_real_qed_get_n_flv (ci%dipole_real_qed)
	case (CI_SUM)
	n_flv = core_interaction_get_n_flv_real (ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	n_flv = photon_recombination_get_n_flv (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_n_flv_real: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_flv_real

	! Currently unused
	recursive function core_interaction_get_n_col (ci) result (n_col)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_col
	select case (ci%type)
	case (CI_OMEGA)
	n_col = hard_interaction_get_n_col (ci%hard_interaction)
	case default
	call msg_bug ("core_interaction_get_n_col: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_col

	! Currently unused
	recursive function core_interaction_get_n_hel (ci) result (n_hel)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_hel
	select case (ci%type)
	case (CI_OMEGA)
	n_hel = hard_interaction_get_n_hel (ci%hard_interaction)
	case default
	call msg_bug ("core_interaction_get_n_hel: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_hel

	@ %def core_interaction_get_n_flv_eff core_interaction_get_n_col
	@ %def core_interaction_get_n_hel core_interaction_get_n_flv_real
	@
	Particle tables. Again, we have [[_eff]] and [[_real]].
	<<Core interactions: public>>=
	public :: core_interaction_get_flv_states_eff
	public :: core_interaction_get_flv_states_real
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_flv_states_eff (ci) result (flv_state)
	type(core_interaction_t), intent(in) :: ci
	integer, dimension(:, :), allocatable :: flv_state
	select case (ci%type)
	case (CI_OMEGA)
	allocate (flv_state (&
	size (hard_interaction_get_flv_states (ci%hard_interaction), dim=1), &
	size (hard_interaction_get_flv_states (ci%hard_interaction), dim=2) &
	))
	flv_state = hard_interaction_get_flv_states (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	allocate (flv_state ( &
	dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed), &
	dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed)))
	flv_state = dipole_integrated_qed_get_flv_states ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	allocate (flv_state ( &
	dipole_real_qed_get_n_tot_eff (ci%dipole_real_qed), &
	dipole_real_qed_get_n_flv (ci%dipole_real_qed)))
	flv_state = dipole_real_qed_get_flv_states_eff (ci%dipole_real_qed)
	case (CI_SUM)
	allocate (flv_state ( &
	core_interaction_get_n_tot_eff (ci%core_interaction_sum%ci1), &
	core_interaction_get_n_flv_eff (ci%core_interaction_sum%ci1)))
	flv_state = core_interaction_get_flv_states_eff ( &
	ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	allocate (flv_state( &
	photon_recombination_get_n_tot_eff (ci%photon_recombination), &
	photon_recombination_get_n_flv (ci%photon_recombination)))
	flv_state = photon_recombination_get_flv_states_eff &
	(ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_flv_state_eff: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_flv_states_eff

	recursive function core_interaction_get_flv_states_real (ci) result (flv_state)
	type(core_interaction_t), intent(in) :: ci
	integer, dimension(:, :), allocatable :: flv_state
	select case (ci%type)
	case (CI_OMEGA)
	allocate (flv_state (&
	size (hard_interaction_get_flv_states (ci%hard_interaction), dim=1), &
	size (hard_interaction_get_flv_states (ci%hard_interaction), dim=2) &
	))
	flv_state = hard_interaction_get_flv_states (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	allocate (flv_state ( &
	dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed), &
	dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed)))
	flv_state = dipole_integrated_qed_get_flv_states ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	allocate (flv_state ( &
	dipole_real_qed_get_n_tot_real (ci%dipole_real_qed), &
	dipole_real_qed_get_n_flv (ci%dipole_real_qed)))
	flv_state = dipole_real_qed_get_flv_states_real (ci%dipole_real_qed)
	case (CI_SUM)
	allocate (flv_state ( &
	core_interaction_get_n_tot_real (ci%core_interaction_sum%ci1), &
	core_interaction_get_n_flv_real (ci%core_interaction_sum%ci1)))
	flv_state = core_interaction_get_flv_states_real ( &
	ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	allocate (flv_state( &
	photon_recombination_get_n_tot_real (ci%photon_recombination), &
	photon_recombination_get_n_flv (ci%photon_recombination)))
	flv_state = photon_recombination_get_flv_states_real &
	(ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_flv_state_real: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_flv_states_real

	@ %def core_interaction_get_flv_states_eff
	@ %def core_interaction_get_flv_states_real
	@
	Color flow count. Again, I am not yet sure how to map this to dipoles \& friends
	but, luckily, it isn't used anywhere right now, so I'll hide it for the moment.
	<<Core interactions: public>>=
	!public :: core_interaction_get_n_cf
	<<Core interactions: procedures>>=
	! Currently unused
	recursive function core_interaction_get_n_cf (ci) result (n_cf)
	type(core_interaction_t), intent(in) :: ci
	integer :: n_cf
	select case (ci%type)
	case (CI_OMEGA)
	n_cf = hard_interaction_get_n_cf (ci%hard_interaction)
	case (CI_SUM)
	n_cf = core_interaction_get_n_cf (ci%core_interaction_sum%ci1)
	case default
	call msg_bug ("core_interaction_get_n_cf: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_cf

	@ %def core_interactions_get_n_cf
	@
	Incoming and outgoing particles. Only the first particle in a flavor product is
	considered. Again, we have [[_eff]] and [[_real]]
	<<Core interactions: public>>=
	public :: core_interaction_get_first_pdg_in
	public :: core_interaction_get_first_pdg_out_eff
	public :: core_interaction_get_first_pdg_out_real
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_first_pdg_in (ci) result (pdg_in)
	type(core_interaction_t), intent(in) :: ci
	integer, dimension(:), allocatable :: pdg_in
	select case (ci%type)
	case (CI_OMEGA)
	allocate (pdg_in (size (hard_interaction_get_first_pdg_in ( &
	ci%hard_interaction))))
	pdg_in = hard_interaction_get_first_pdg_in (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	allocate (pdg_in (dipole_integrated_qed_get_n_in ( &
	ci%dipole_integrated_qed)))
	pdg_in = dipole_integrated_qed_get_first_pdg_in ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	allocate (pdg_in (dipole_real_qed_get_n_in (ci%dipole_real_qed)))
	pdg_in = dipole_real_qed_get_first_pdg_in (ci%dipole_real_qed)
	case (CI_SUM)
	allocate (pdg_in (core_interaction_get_n_in &
	(ci%core_interaction_sum%ci1)))
	pdg_in = core_interaction_get_first_pdg_in &
	(ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	allocate (pdg_in(2))
	pdg_in = photon_recombination_get_first_pdg_in &
	(ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_first_pdg_in: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_first_pdg_in

	recursive function core_interaction_get_first_pdg_out_eff (ci) result (pdg_out)
	type(core_interaction_t), intent(in) :: ci
	integer, dimension(:), allocatable :: pdg_out
	select case (ci%type)
	case (CI_OMEGA)
	allocate (pdg_out (size (hard_interaction_get_first_pdg_out ( &
	ci%hard_interaction))))
	pdg_out = hard_interaction_get_first_pdg_out (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	allocate (pdg_out (dipole_integrated_qed_get_n_out ( &
	ci%dipole_integrated_qed)))
	pdg_out = dipole_integrated_qed_get_first_pdg_out ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	allocate (pdg_out (dipole_real_qed_get_n_out_eff (ci%dipole_real_qed)))
	pdg_out = dipole_real_qed_get_first_pdg_out_eff (ci%dipole_real_qed)
	case (CI_SUM)
	allocate (pdg_out (core_interaction_get_n_out_eff ( &
	ci%core_interaction_sum%ci1)))
	pdg_out = core_interaction_get_first_pdg_out_eff ( &
	ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	allocate (pdg_out(photon_recombination_get_n_out_eff ( &
	ci%photon_recombination)))
	pdg_out = photon_recombination_get_first_pdg_out_eff ( &
	ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_first_pdg_out_eff: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_first_pdg_out_eff

	recursive function core_interaction_get_first_pdg_out_real (ci) result (pdg_out)
	type(core_interaction_t), intent(in) :: ci
	integer, dimension(:), allocatable :: pdg_out
	select case (ci%type)
	case (CI_OMEGA)
	allocate (pdg_out (size (hard_interaction_get_first_pdg_out ( &
	ci%hard_interaction))))
	pdg_out = hard_interaction_get_first_pdg_out (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	allocate (pdg_out (dipole_integrated_qed_get_n_out ( &
	ci%dipole_integrated_qed)))
	pdg_out = dipole_integrated_qed_get_first_pdg_out ( &
	ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	allocate (pdg_out (dipole_real_qed_get_n_out_real ( &
	ci%dipole_real_qed)))
	pdg_out = dipole_real_qed_get_first_pdg_out_real ( &
	ci%dipole_real_qed)
	case (CI_SUM)
	allocate (pdg_out (core_interaction_get_n_out_real ( &
	ci%core_interaction_sum%ci1)))
	pdg_out = core_interaction_get_first_pdg_out_real ( &
	ci%core_interaction_sum%ci1)
	case (CI_PHOTON_RECOMBINATION)
	allocate (pdg_out(photon_recombination_get_n_out_real ( &
	ci%photon_recombination)))
	pdg_out = photon_recombination_get_first_pdg_out_real ( &
	ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_first_pdg_out_real: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_first_pdg_out_real
	@ %def core_interaction_get_first_pdg_in
	@ %core_interaction_get_first_pdg_out_eff
	@ %core_interaction_get_first_pdg_out_real
	@
	Check for decaying final state products. Only the first entry of each flavor
	product is considered. The method operates on the effective final state.
	<<Core interactions: public>>=
	public :: core_interaction_get_unstable_products
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_get_unstable_products (ci, flavors)
	type(core_interaction_t), intent(in) :: ci
	type(flavor_t), dimension(:), allocatable, intent(out) :: flavors
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_get_unstable_products (ci%hard_interaction, &
	flavors)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_get_unstable_products ( &
	ci%dipole_integrated_qed, flavors)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_get_unstable_products (ci%dipole_real_qed, flavors)
	case (CI_SUM)
	call core_interaction_get_unstable_products ( &
	ci%core_interaction_sum%ci1, flavors)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_get_unstable_products ( &
	ci%photon_recombination, flavors)
	case default
	call msg_bug ("core_interaction_get_unstable_products: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_get_unstable_products

	@ %def core_interaction_get_unstable_products
	@
	Evaluator init. All evaluators refer to the effective state.
	<<Core interactions: public>>=
	public :: core_interaction_init_trace
	public :: core_interaction_init_sqme
	public :: core_interaction_init_flows
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_init_trace &
	(ci, qn_mask_in, use_hi_color_factors, nc)
	type(core_interaction_t), intent(inout), target :: ci
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	logical, intent(in), optional :: use_hi_color_factors
	integer, intent(in), optional :: nc
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_init_trace (ci%hard_interaction, &
	qn_mask_in, use_hi_color_factors, nc)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_init_trace (ci%dipole_integrated_qed, &
	qn_mask_in)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_init_trace (ci%dipole_real_qed, qn_mask_in)
	case (CI_SUM)
	call core_interaction_init_trace (ci%core_interaction_sum%ci1, &
	qn_mask_in, use_hi_color_factors, nc)
	call core_interaction_init_trace (ci%core_interaction_sum%ci2, &
	qn_mask_in, use_hi_color_factors, nc)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_init_trace (ci%photon_recombination, &
	qn_mask_in)
	case default
	call msg_bug ("core_interaction_init_trace: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_init_trace

	recursive subroutine core_interaction_init_sqme &
	(ci, qn_mask_in, use_hi_color_factors, nc)
	type(core_interaction_t), intent(inout), target :: ci
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	logical, intent(in), optional :: use_hi_color_factors
	integer, intent(in), optional :: nc
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_init_sqme (ci%hard_interaction, &
	qn_mask_in, use_hi_color_factors, nc)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_init_sqme ( &
	ci%dipole_integrated_qed, qn_mask_in)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_init_sqme (ci%dipole_real_qed, qn_mask_in)
	case (CI_SUM)
	call core_interaction_init_sqme (ci%core_interaction_sum%ci1, &
	qn_mask_in, use_hi_color_factors, nc)
	call core_interaction_init_sqme (ci%core_interaction_sum%ci2, &
	qn_mask_in, use_hi_color_factors, nc)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_init_sqme (ci%photon_recombination, &
	qn_mask_in)
	case default
	call msg_bug ("core_interaction_init_sqme: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_init_sqme

	recursive subroutine core_interaction_init_flows (ci, qn_mask_in)
	type(core_interaction_t), intent(inout), target :: ci
	type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_init_flows (ci%hard_interaction, qn_mask_in)
	case (CI_SUM)
	call core_interaction_init_flows (ci%core_interaction_sum%ci1, &
	qn_mask_in)
	call core_interaction_init_flows (ci%core_interaction_sum%ci2, &
	qn_mask_in)
	case default
	call msg_bug ("core_interaction_init_flows: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_init_flows

	@ %def core_interaction_init_sqme core_interaction_init_sqme
	@ %def core_interaction_init_flows
	@
	Evaluator final.
	<<Core interactions: public>>=
	public :: core_interaction_final_sqme
	public :: core_interaction_final_flows
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_final_sqme (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_final_sqme (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_final_sqme (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_final_sqme (ci%dipole_real_qed)
	case (CI_SUM)
	call core_interaction_final_sqme (ci%core_interaction_sum%ci1)
	call core_interaction_final_sqme (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_final_sqme (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_final_sqme: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_final_sqme

	recursive subroutine core_interaction_final_flows (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_final_flows (ci%hard_interaction)
	case (CI_SUM)
	call core_interaction_final_flows (ci%core_interaction_sum%ci1)
	call core_interaction_final_flows (ci%core_interaction_sum%ci2)
	case default
	call msg_bug ("core_interaction_final_flows: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_final_flows

	@ %def core_interaction_final_sqme core_interaction_final_flows
	@
	Update $\alpha_s$.
	<<Core interactions: public>>=
	public :: core_interaction_update_alpha_s
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_update_alpha_s (ci, as, index)
	type(core_interaction_t), intent(inout) :: ci
	real(kind=default), intent(in) :: as
	integer, optional, intent(in) :: index
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_update_alpha_s (ci%hard_interaction, as)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_update_alpha_s ( &
	ci%dipole_integrated_qed, as, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_update_alpha_s ( &
	ci%dipole_real_qed, as, index)
	case (CI_SUM)
	call core_interaction_update_alpha_s ( &
	ci%core_interaction_sum%ci1, as, index)
	call core_interaction_update_alpha_s ( &
	ci%core_interaction_sum%ci2, as, index)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_update_alpha_s (ci%photon_recombination, as)
	case default
	call msg_bug ("core_interaction_update_alpha_s: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_update_alpha_s

	@ %def core_interaction_update_alpha_s
	@
	Reset the helicity selection (\oMega).
	<<Core interactions: public>>=
	public :: core_interaction_reset_helicity_selection
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_reset_helicity_selection (ci, threshold, cutoff)
	type(core_interaction_t), intent(inout) :: ci
	real(default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_reset_helicity_selection (ci%hard_interaction, &
	threshold, cutoff)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_reset_helicity_selection ( &
	ci%dipole_integrated_qed, threshold, cutoff)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_reset_helicity_selection (ci%dipole_real_qed, &
	threshold, cutoff)
	case (CI_SUM)
	call core_interaction_reset_helicity_selection ( &
	ci%core_interaction_sum%ci1, threshold, cutoff)
	call core_interaction_reset_helicity_selection ( &
	ci%core_interaction_sum%ci2, threshold, cutoff)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_reset_helicity_selection ( &
	ci%photon_recombination, threshold, cutoff)
	case default
	call msg_bug ("core_interaction_reset_helicity_selection: not " &
	// "implemeneted: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_reset_helicity_selection

	@ %def core_interaction_reset_helicity_selection
	@
	Evaluation.
	<<Core interactions: public>>=
	public :: core_interaction_evaluate
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_evaluate (ci)
	type(core_interaction_t), intent(inout) :: ci
	if (ci%state < CI_STATE_EVALUATE) call msg_bug ( &
	"core interaction: premature evaluation")
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_evaluate (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_evaluate (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_evaluate (ci%dipole_real_qed)
	case (CI_SUM)
	call core_interaction_evaluate (ci%core_interaction_sum%ci1)
	call core_interaction_evaluate (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_evaluate (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_evaluate: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_evaluate

	@ %def core_interaction_evaluate
	@
	Extra evaluators.
	<<Core interactions: public>>=
	public :: core_interaction_evaluate_sqme
	public :: core_interaction_evaluate_flows
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_evaluate_sqme (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_evaluate_sqme (ci%hard_interaction)
	case (CI_SUM)
	call core_interaction_evaluate_sqme (ci%core_interaction_sum%ci1)
	call core_interaction_evaluate_sqme (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_evaluate_sqme (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_evaluate_sqme: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_evaluate_sqme

	recursive subroutine core_interaction_evaluate_flows (ci)
	type(core_interaction_t), intent(inout) :: ci
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_evaluate_flows (ci%hard_interaction)
	case (CI_SUM)
	call core_interaction_evaluate_flows (ci%core_interaction_sum%ci1)
	call core_interaction_evaluate_flows (ci%core_interaction_sum%ci2)
	case default
	call msg_bug ("core_interaction_evaluate_flows: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_evaluate_flows

	@ %def core_interaction_evaluate_sqme core_interaction_evaluate_flows
	@
	Direct acces to the squared matrix element traced over all quantum numbers.
	<<Core interactions: public>>=
	public :: core_interaction_compute_sqme_sum
	<<Core interactions: procedures>>=
	recursive function core_interaction_compute_sqme_sum (ci, p, index) result (sqme)
	type(core_interaction_t), intent(inout) :: ci
	type(vector4_t), intent(in), dimension(:) :: p
	integer, intent(in), optional :: index
	real(kind=default) :: sqme
	logical :: weights
	select case (ci%type)
	case (CI_OMEGA)
	sqme = hard_interaction_compute_sqme_sum (ci%hard_interaction, p)
	case (CI_SUM)
	sqme = core_interaction_compute_sqme_sum (ci%core_interaction_sum%ci1, &
	p, index) + &
	core_interaction_compute_sqme_sum (ci%core_interaction_sum%ci2, &
	p, index)
	case (CI_PHOTON_RECOMBINATION)
	sqme = photon_recombination_compute_sqme_sum ( &
	ci%photon_recombination, p)
	case default
	call msg_bug ("core_interaction_compute_sqme_sum: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_compute_sqme_sum

	@ %def core_interaction_compute_sqme_sum
	@
	Pointers to the interaction and to the evaluators.
	<<Core interactions: public>>=
	public :: core_interaction_get_int_ptr
	public :: core_interaction_get_eval_trace_ptr
	public :: core_interaction_get_eval_sqme_ptr
	public :: core_interaction_get_eval_flows_ptr
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_int_ptr (ci, index) result (int)
	type(core_interaction_t), intent(in), target :: ci
	integer, intent(in) :: index
	type(interaction_t), pointer :: int
	select case (ci%type)
	case (CI_OMEGA)
	int => hard_interaction_get_int_ptr (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	int => dipole_integrated_qed_get_int_ptr ( &
	ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	int => dipole_real_qed_get_int_ptr (ci%dipole_real_qed, index)
	case (CI_SUM)
	int => core_interaction_get_int_ptr (&
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	int => photon_recombination_get_int_ptr (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_int_ptr: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_int_ptr

	recursive function core_interaction_get_eval_trace_ptr (ci, index) result (eval_trace)
	type(core_interaction_t), intent(in), target :: ci
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval_trace
	select case (ci%type)
	case (CI_OMEGA)
	eval_trace => hard_interaction_get_eval_trace_ptr (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	eval_trace => dipole_integrated_qed_get_eval_trace_ptr ( &
	ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	eval_trace => dipole_real_qed_get_eval_trace_ptr ( &
	ci%dipole_real_qed, index)
	case (CI_SUM)
	eval_trace => core_interaction_get_eval_trace_ptr ( &
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	eval_trace => photon_recombination_get_eval_trace_ptr ( &
	ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_eval_trace_ptr: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_eval_trace_ptr

	recursive function core_interaction_get_eval_sqme_ptr (ci, index) result (eval_sqme)
	type(core_interaction_t), intent(in), target :: ci
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval_sqme
	select case (ci%type)
	case (CI_OMEGA)
	eval_sqme => hard_interaction_get_eval_sqme_ptr (ci%hard_interaction)
	case (CI_DIPOLE_INTEGRATED_QED)
	eval_sqme => dipole_integrated_qed_get_eval_sqme_ptr ( &
	ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	eval_sqme => dipole_real_qed_get_eval_sqme_ptr ( &
	ci%dipole_real_qed, index)
	case (CI_SUM)
	eval_sqme => core_interaction_get_eval_sqme_ptr ( &
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	eval_sqme => photon_recombination_get_eval_sqme_ptr ( &
	ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_eval_sqme_ptr: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_eval_sqme_ptr

	recursive function core_interaction_get_eval_flows_ptr (ci, index) result (eval_flows)
	type(core_interaction_t), intent(in), target :: ci
	integer, intent(in) :: index
	type(evaluator_t), pointer :: eval_flows
	select case (ci%type)
	case (CI_OMEGA)
	eval_flows => hard_interaction_get_eval_flows_ptr (ci%hard_interaction)
	case (CI_SUM)
	eval_flows => core_interaction_get_eval_flows_ptr ( &
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case default
	call msg_bug ("core_interaction_get_eval_flows_ptr: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_eval_flows_ptr

	@ %def core_interaction_get_int_ptr core_interaction_get_eval_sqme_ptr
	@ %def core_interaction_get_eval_trace_ptr core_interaction_get_eval_flows_ptr
	Recover the kinematics.
	<<Core interactions: public>>=
	public :: core_interaction_recover_kinematics
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_recover_kinematics (ci, pset, index)
	type(core_interaction_t), intent(inout) :: ci
	integer, intent(in), optional :: index
	type(particle_set_t), intent(in) :: pset
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_recover_kinematics (ci%hard_interaction, &
	pset)
	case default
	call msg_bug ("core_interaction_recover_kinematics: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_recover_kinematics

	@ %def core_interaction_recover_kinematics
	@
	List allowed quantum numbers.
	<<Core interactions: public>>=
	public :: core_interaction_write_state_summary
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_write_state_summary (ci, unit)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: unit
	select case (ci%type)
	case (CI_OMEGA)
	call hard_interaction_write_state_summary (ci%hard_interaction, unit)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_write_state_summary ( &
	ci%dipole_integrated_qed, unit)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_write_state_summary (ci%dipole_real_qed, unit)
	case (CI_SUM)
	call core_interaction_sum_write_state_summary ( &
	ci%core_interaction_sum, unit)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_write_state_summary ( &
	ci%photon_recombination, unit)
	case default
	call msg_bug ("core_interaction_write_state_summary: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_write_state_summary

	@ %def core_interaction_write_state_summary
	@
	Get the number of random variables required for evaluation.
	<<Core interactions: public>>=
	public :: core_interaction_get_n_x
	<<Core interactions: procedures>>=
	function core_interaction_get_n_x (ci) result (n)
	type(core_interaction_t), intent(in) :: ci
	integer :: n
	select case (ci%type)
	case (CI_OMEGA)
	n = 0
	case (CI_DIPOLE_INTEGRATED_QED)
	n = 1
	case (CI_DIPOLE_REAL_QED)
	n = 0
	case (CI_SUM)
	n = ci%core_interaction_sum%nx1 + ci%core_interaction_sum%nx2
	case (CI_PHOTON_RECOMBINATION)
	n = 0
	case default
	call msg_bug ("core_interaction_get_n_x: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_x

	@ %def core_interaction_get_n_x
	@
	Set any required random variables
	<<Core interactions: public>>=
	public :: core_interaction_set_x
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_x (ci, x)
	type(core_interaction_t), intent(inout) :: ci
	real(kind=default), intent(in), dimension(:) :: x
	select case (ci%type)
	case (CI_OMEGA)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_x (ci%dipole_integrated_qed, x(1))
	case (CI_DIPOLE_REAL_QED)
	case (CI_SUM)
	call core_interaction_sum_set_x (ci%core_interaction_sum, x)
	case (CI_PHOTON_RECOMBINATION)
	case default
	call msg_bug ("core_interaction_set_x: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_set_x

	@ %def core_interaction_set_x
	@
	Get the number of ``in'' type configurations.
	<<Core interactions: public>>=
	public :: core_interaction_get_n_kinematics_in
	<<Core interactions: procedures>>=
	function core_interaction_get_n_kinematics_in (ci) result (n)
	type(core_interaction_t), intent(in) :: ci
	integer :: n
	select case (ci%type)
	case (CI_OMEGA)
	n = 1
	case (CI_DIPOLE_INTEGRATED_QED)
	n = dipole_integrated_qed_get_n_kinematics (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n = 1
	case (CI_SUM)
	n = ci%core_interaction_sum%nin1 + ci%core_interaction_sum%nin2 - 1
	case (CI_PHOTON_RECOMBINATION)
	n = 1
	case default
	call msg_bug ("core_interaction_get_n_kinematics_n: " &
	// "not implemented: " // char ( &
	core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_kinematics_in

	@ %def core_interaction_get_n_kinematics_in
	@
	Get the number of ``out'' type configurations.
	<<Core interactions: public>>=
	public :: core_interaction_get_n_kinematics_out
	<<Core interactions: procedures>>=
	function core_interaction_get_n_kinematics_out (ci) result (n)
	type(core_interaction_t), intent(in) :: ci
	integer :: n
	select case (ci%type)
	case (CI_OMEGA)
	n = 1
	case (CI_DIPOLE_INTEGRATED_QED)
	n = dipole_integrated_qed_get_n_kinematics (ci%dipole_integrated_qed)
	case (CI_DIPOLE_REAL_QED)
	n = dipole_real_qed_get_n_kinematics_out (ci%dipole_real_qed)
	case (CI_SUM)
	n = ci%core_interaction_sum%nout1 + ci%core_interaction_sum%nout2
	case (CI_PHOTON_RECOMBINATION)
	n = 1
	case default
	call msg_bug ("core_interaction_get_n_kinematics_n: " &
	// "not implemented: " // char ( &
	core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_n_kinematics_out

	@ %def core_interaction_get_n_kinematics_out
	@
	Query whether the kinematic setup required for evaluation is trivial --- only
	one ``in'' configuration with an identical ``out'' configuration.
	<<Core interactions: public>>=
	public :: core_interaction_trivial_kinematics
	<<Core interactions: procedures>>=
	function core_interaction_trivial_kinematics (ci) result (flag)
	type(core_interaction_t), intent(in) :: ci
	logical :: flag
	select case (ci%type)
	case (CI_OMEGA)
	flag = .true.
	case (CI_DIPOLE_INTEGRATED_QED)
	flag = .false.
	case (CI_DIPOLE_REAL_QED)
	flag = .false.
	case (CI_SUM)
	flag = .false.
	case (CI_PHOTON_RECOMBINATION)
	flag = .false.
	case default
	call msg_bug ("core_interaction_trivial_kinematics: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_trivial_kinematics

	@ %def core_interaction_trivial_kinematics
	@
	Query whether a matrix element is physical, i.e. positive.
	<<Core interactions: public>>=
	public :: core_interaction_is_physical
	<<Core interactions: procedures>>=
	recursive function core_interaction_is_physical (ci) result (physical)
	type(core_interaction_t), intent(in) :: ci
	logical :: physical
	select case (ci%type)
	case (CI_OMEGA)
	physical = .true.
	case (CI_DIPOLE_INTEGRATED_QED)
	physical = .false.
	case (CI_DIPOLE_REAL_QED)
	physical = .false.
	case (CI_SUM)
	physical = &
	core_interaction_is_physical (ci%core_interaction_sum%ci1) .and. &
	core_interaction_is_physical (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	physical = .true.
	case default
	call msg_bug ("core_interaction_is_physical: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_is_physical

	@ %def core_interaction_is_physical
	@ %
	Set the outgoing momentum information for an ``in'' point. The default [[index]]
	is 1. Note that there is no similar function for setting the incoming momenta.
	For the seed point, they are supposed to be transmitted to the ``out'' interactions
	and evaluators, for the others, they are determined by the core interaction itself.
	<<Core interactions: public>>=
	public :: core_interaction_set_momenta_out
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_momenta_out (ci, momenta, index)
	type(core_interaction_t), intent(inout), target :: ci
	type(vector4_t), intent(in), dimension(:) :: momenta
	integer, optional, intent(in) :: index
	type(interaction_t), pointer :: int
	integer :: i
	select case (ci%type)
	case (CI_OMEGA)
	int => hard_interaction_get_int_ptr (ci%hard_interaction)
	call interaction_set_momenta (int, momenta, outgoing = .true.)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_momenta_out ( &
	ci%dipole_integrated_qed, momenta, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_set_momenta_out (ci%dipole_real_qed, momenta)
	case (CI_SUM)
	call core_interaction_sum_set_momenta_out (ci%core_interaction_sum, &
	momenta, index)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_set_momenta (ci%photon_recombination, &
	momenta)
	case default
	call msg_bug ("core_interaction_set_momenta_out: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_set_momenta_out

	@ %def core_interaction_set_momenta_out
	@
	Query whether the core interaction supports extended evaluators.
	<<Core interactions: public>>=
	public :: core_interaction_has_eval_sqme
	public :: core_interaction_has_eval_flows
	<<Core interactions: procedures>>=
	recursive function core_interaction_has_eval_sqme (ci) result (flag)
	type(core_interaction_t), intent(in) :: ci
	logical :: flag
	select case (ci%type)
	case (CI_OMEGA)
	flag = .true.
	case (CI_DIPOLE_INTEGRATED_QED)
	flag = .true.
	case (CI_DIPOLE_REAL_QED)
	flag = .true.
	case (CI_SUM)
	flag = &
	core_interaction_has_eval_sqme (ci%core_interaction_sum%ci1) .and. &
	core_interaction_has_eval_sqme (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	flag = .true.
	case default
	call msg_bug ("core_interaction_has_eval_sqme: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_has_eval_sqme

	recursive function core_interaction_has_eval_flows (ci) result (flag)
	type(core_interaction_t), intent(in) :: ci
	logical :: flag
	select case (ci%type)
	case (CI_OMEGA)
	flag = .true.
	case (CI_DIPOLE_INTEGRATED_QED)
	flag = .false.
	case (CI_DIPOLE_REAL_QED)
	flag = .false.
	case (CI_SUM)
	flag = &
	core_interaction_has_eval_flows (ci%core_interaction_sum%ci1) .and. &
	core_interaction_has_eval_flows (ci%core_interaction_sum%ci2)
	case (CI_PHOTON_RECOMBINATION)
	flag = .false.
	case default
	call msg_bug ("core_interaction_has_eval_flows: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_has_eval_flows

	@ %def core_interaction_has_eval_flows core_interaction_has_eval_sqme
	@
	Get the incoming momenta for a specific ``in'' configuration. The default index
	is $1$. As allocation-on-assignment is not available yet, we implement this as a
	subroutine.
	<<Core interactions: public>>=
	public :: core_interaction_get_momenta_in
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_get_momenta_in (ci, momenta, index)
	type(core_interaction_t), intent(in) :: ci
	type(vector4_t), intent(out), dimension(:) :: momenta
	integer, intent(in), optional :: index
	select case (ci%type)
	case (CI_OMEGA)
	momenta = interaction_get_momenta (hard_interaction_get_int_ptr ( &
	ci%hard_interaction), outgoing=.false.)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_get_momenta_in (ci%dipole_integrated_qed, &
	momenta, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_get_momenta_in (ci%dipole_real_qed, momenta)
	case (CI_SUM)
	call core_interaction_get_momenta_in ( &
	ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), &
	momenta, &
	ci_sum_multiplex_in (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	momenta = photon_recombination_get_momenta_in ( &
	ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_momenta_in: not implemented: " &
	// char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_get_momenta_in

	@ %def core_interaction_get_momenta_in
	@
	Set / get the cut status for an ``out'' configuration. Just after transitioning
	to [[CI_STATE_MOMENTA_SET]], (before the actual phase space cut has been applied),
	[[core_interaction_get_cut_status]] reflects whether the configuration has been
	populated (which may not be the case if the phasespace generator fails to generate
	valid configs for all ``in'' points).
	<<Core interactions: public>>=
	public :: core_interaction_set_cut_status
	public :: core_interaction_get_cut_status
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_cut_status (ci, stat, index)
	type(core_interaction_t), intent(inout) :: ci
	logical, intent(in) :: stat
	integer, intent(in), optional :: index
	type(core_interaction_t), pointer :: cp
	select case (ci%type)
	case (CI_OMEGA)
	ci%me_passed_cut = stat
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_cut_status (ci%dipole_integrated_qed, &
	stat, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_set_cut_status (ci%dipole_real_qed, stat, index)
	case (CI_SUM)
	cp => ci_sum_multiplex_ci_out (ci%core_interaction_sum, index)
	call core_interaction_set_cut_status (cp, stat, &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_set_cut_status (ci%photon_recombination, &
	stat)
	case default
	call msg_bug ("core_interaction_set_cut_status: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_set_cut_status

	recursive function core_interaction_get_cut_status (ci, index) result (stat)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: index
	logical :: stat
	select case (ci%type)
	case (CI_OMEGA)
	stat = ci%me_passed_cut
	case (CI_DIPOLE_INTEGRATED_QED)
	stat = dipole_integrated_qed_get_cut_status ( &
	ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	stat = dipole_real_qed_get_cut_status (ci%dipole_real_qed, index)
	case (CI_SUM)
	stat = core_interaction_get_cut_status ( &
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	stat = photon_recombination_get_cut_status (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_cut_status: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_cut_status

	@ %def core_interaction_set_cut_status
	@ %def core_interaction_get_cut_status
	Check whether an ``in'' configuration needs a weight.
	<<Core interactions: public>>=
	public :: core_interaction_needs_weight
	<<Core interactions: procedures>>=
	recursive function core_interaction_needs_weight (ci, index) result (stat)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: index
	logical :: stat
	select case (ci%type)
	case (CI_OMEGA)
	stat = ci%me_passed_cut
	case (CI_DIPOLE_INTEGRATED_QED)
	stat = dipole_integrated_qed_get_cut_status ( &
	ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	stat = dipole_real_qed_any_passed (ci%dipole_real_qed)
	case (CI_SUM)
	stat = core_interaction_needs_weight ( &
	ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), &
	ci_sum_multiplex_in (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	stat = photon_recombination_get_cut_status (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_needs_weight: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_needs_weight

	@ %def core_interaction_needs_weight
	@
	Set the weight associated with an ``in'' configuration
	<<Core interactions: public>>=
	public :: core_interaction_set_weight
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_weight (ci, j, index)
	type(core_interaction_t), intent(inout) :: ci
	real(kind=default), intent(in) :: j
	integer, intent(in), optional :: index
	select case (ci%type)
	case (CI_OMEGA)
	ci%me_weight = j
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_weight (ci%dipole_integrated_qed, &
	j, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_set_weight (ci%dipole_real_qed, j)
	case (CI_SUM)
	call core_interaction_sum_set_weight ( &
	ci%core_interaction_sum, j, index)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_set_weight (ci%photon_recombination, &
	j)
	case default
	call msg_bug ("core_interaction_set_weight: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_set_weight

	@ %def core_interaction_set_weight
	@
	Get the weight associated to an ``out'' configuration.
	<<Core interactions: public>>=
	public :: core_interaction_get_weight
	<<Core interactions: procedures>>=
	recursive function core_interaction_get_weight (ci, index) result (j)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: index
	real(kind=default) :: j
	select case (ci%type)
	case (CI_OMEGA)
	j = ci%me_weight
	case (CI_DIPOLE_INTEGRATED_QED)
	j = dipole_integrated_qed_get_weight (ci%dipole_integrated_qed, index)
	case (CI_DIPOLE_REAL_QED)
	j = dipole_real_qed_get_weight (ci%dipole_real_qed)
	case (CI_SUM)
	j = core_interaction_get_weight ( &
	ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), &
	ci_sum_multiplex_out (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	j = photon_recombination_get_weight (ci%photon_recombination)
	case default
	call msg_bug ("core_interaction_get_weight: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_get_weight

	@ %def core_interaction_get_weight
	@
	Set the value of the electroweak $\alpha$.
	<<Core interactions: public>>=
	public :: core_interaction_set_alpha_qed
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_alpha_qed (ci, alpha)
	type(core_interaction_t), intent(inout) :: ci
	real(kind=default), intent(in) :: alpha
	select case (ci%type)
	case (CI_OMEGA)
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_alpha_qed (ci%dipole_integrated_qed, &
	alpha)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_set_alpha (ci%dipole_real_qed, alpha)
	case (CI_SUM)
	call core_interaction_set_alpha_qed ( &
	ci%core_interaction_sum%ci1, alpha)
	call core_interaction_set_alpha_qed ( &
	ci%core_interaction_sum%ci2, alpha)
	case (CI_PHOTON_RECOMBINATION)
	case default
	call msg_bug ("core_interaction_set_alpha_qed: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_set_alpha_qed

	@ %def core_interaction_set_alpha_qed
	@
	Advance the state of the core interaction object.
	<<Core interactions: public>>=
	public :: core_interaction_set_state
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_set_state (ci, state)
	type(core_interaction_t), intent(inout) :: ci
	integer, intent(in) :: state
	type(interaction_t), pointer :: int
	select case (state)
	case (CI_STATE_CLEAR)
	case (CI_STATE_SEED_MOMENTA_SET)
	if (ci%state /= CI_STATE_CLEAR) call msg_bug ( &
	"core interaction: invalid state transition")
	case (CI_STATE_MOMENTA_SET)
	if (ci%state /= CI_STATE_SEED_MOMENTA_SET) call msg_bug ( &
	"core interaction: invalid state transition")
	case (CI_STATE_EVALUATE)
	if (ci%state < CI_STATE_MOMENTA_SET) call msg_bug ( &
	"core interaction: invalid state transition")
	case (CI_STATE_WEIGHTS_SET)
	if (ci%state < CI_STATE_MOMENTA_SET) call msg_bug ( &
	"core interaction: invalid state transition")
	case default
	call msg_bug ("core interactions: transition to unknown state")
	end select
	select case (ci%type)
	case (CI_OMEGA)
	case (CI_DIPOLE_INTEGRATED_QED)
	select case (state)
	case (CI_STATE_CLEAR)
	call dipole_integrated_qed_reset (ci%dipole_integrated_qed)
	case (CI_STATE_SEED_MOMENTA_SET)
	call dipole_integrated_qed_process_momenta_in ( &
	ci%dipole_integrated_qed)
	end select
	case (CI_DIPOLE_REAL_QED)
	select case (state)
	case (CI_STATE_CLEAR)
	call dipole_real_qed_reset (ci%dipole_real_qed)
	case (CI_STATE_SEED_MOMENTA_SET)
	call dipole_real_qed_digest_kinematics_in (ci%dipole_real_qed)
	case (CI_STATE_MOMENTA_SET)
	call dipole_real_qed_digest_kinematics_out (ci%dipole_real_qed)
	end select
	case (CI_SUM)
	call core_interaction_set_state (ci%core_interaction_sum%ci1, state)
	call core_interaction_set_state (ci%core_interaction_sum%ci2, state)
	case (CI_PHOTON_RECOMBINATION)
	case default
	call msg_bug ("core_interaction_set_state: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	ci%state = state
	end subroutine core_interaction_set_state

	@ %def core_interaction_set_state
	@
	Tell us whether the phase space generated generated a valid configuration for
	an ``in'' point.
	<<Core interactions: public>>=
	public :: core_interaction_kinematics_passed
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_kinematics_passed (ci, passed, index)
	type(core_interaction_t), intent(inout) :: ci
	logical, intent(in) :: passed
	integer, intent(in), optional :: index
	select case (ci%type)
	case (CI_OMEGA)
	ci%me_passed_cut = passed
	case (CI_DIPOLE_INTEGRATED_QED)
	call dipole_integrated_qed_set_cut_status (ci%dipole_integrated_qed, &
	passed, index)
	case (CI_DIPOLE_REAL_QED)
	call dipole_real_qed_kinematics_passed (ci%dipole_real_qed, passed)
	case (CI_SUM)
	call core_interaction_sum_kinematics_passed ( &
	ci%core_interaction_sum, passed, index)
	case (CI_PHOTON_RECOMBINATION)
	call photon_recombination_kinematics_passed (ci%photon_recombination, &
	passed)
	case default
	call msg_bug ("core_interaction_kinematics_passed: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end subroutine core_interaction_kinematics_passed

	@ %def core_interaction_kinematics_passed
	@
	Query whether if $\sqrt{s}$ depends on $x$ for an ``in'' channel
	<<Core interactions: public>>=
	public :: core_interaction_varying_sqrts
	<<Core interactions: procedures>>=
	recursive function core_interaction_varying_sqrts (ci, index) result (flag)
	type(core_interaction_t), intent(in) :: ci
	integer, intent(in), optional :: index
	logical :: flag
	select case (ci%type)
	case (CI_OMEGA)
	flag = .false.
	case (CI_DIPOLE_INTEGRATED_QED)
	if (present (index)) then
	flag = index > 1
	else
	flag = .false.
	end if
	case (CI_DIPOLE_REAL_QED)
	flag = .false.
	case (CI_SUM)
	flag = &
	core_interaction_varying_sqrts ( &
	ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), &
	ci_sum_multiplex_in (ci%core_interaction_sum, index))
	case (CI_PHOTON_RECOMBINATION)
	flag = .false.
	case default
	call msg_bug ("core_interaction_varying_sqrts: not implemented: " // &
	char (core_interaction_type_description (ci%type)))
	end select
	end function core_interaction_varying_sqrts

	@ %def core_interaction_varying_sqrts
	@
	\subsection{The [[core_interaction_sum_t]] type}

	This type takes two [[core_interaction_t]] objects and combines them into a
	single [[core_interaction_t]]. This can only work if flavor and helicity states
	match. The type should go into its own module, but for this either inheritance
	and polymorphism or submodules would be required, so we put it here for the time
	being. For the same reason, the trivial parts of the logic are directly
	implemented in the corresponding [[core_interaction_t]] methods.

	The type definition:
	<<Core interactions: types>>=
	type :: core_interaction_sum_t
	private
	type(core_interaction_t), pointer :: ci1 => null (), ci2 => null ()
	type(string_t) :: id
	logical :: valid = .false.
	integer, dimension(:), allocatable :: flavor_map
	integer :: nx1, nx2
	integer :: nin1, nin2, nout1, nout2
	end type core_interaction_sum_t

	@ %def core_interaction_sum_t
	@
	Initialization.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_init (ci, ci1, ci2, id)
	type(core_interaction_sum_t), intent(out) :: ci
	type(core_interaction_t), intent(in) :: ci1, ci2
	type(string_t), intent(in) :: id
	ci%valid = core_interaction_sum_sane (ci, ci1, ci2)
	if (.not. ci%valid) then
	call msg_fatal ("core interaction sum " // char (id) // " is invalid: " &
	// char (core_interaction_get_id (ci1)) // " and " // &
	char (core_interaction_get_id (ci2)) // " are incompatible")
	return
	end if
	allocate (ci%ci1, ci%ci2)
	ci%ci1 = ci1
	ci%ci2 = ci2
	ci%nin1 = core_interaction_get_n_kinematics_in (ci%ci1)
	ci%nin2 = core_interaction_get_n_kinematics_in (ci%ci2)
	ci%nout1 = core_interaction_get_n_kinematics_out (ci%ci1)
	ci%nout2 = core_interaction_get_n_kinematics_out (ci%ci2)
	ci%nx1 = core_interaction_get_n_x (ci%ci1)
	ci%nx2 = core_interaction_get_n_x (ci%ci2)
	ci%id = id
	end subroutine core_interaction_sum_init

	@ %def core_interaction_sum_init
	@
	Sanity checks.
	<<Core interactions: procedures>>=
	recursive function core_interaction_sum_sane (ci, ci1, ci2) result (sane)
	type(core_interaction_sum_t), intent(inout) :: ci
	type(core_interaction_t), intent(in) :: ci1, ci2
	logical :: sane
	integer, allocatable, dimension(:,:) :: flv1, flv2
	integer :: n, n_flv
	integer, allocatable, dimension(:) :: flavor_map
	! Validity
	sane = core_interaction_is_valid (ci1) .and. &
	core_interaction_is_valid (ci2)
	! Models
	sane = model_get_name (core_interaction_get_model_ptr (ci1)) == &
	model_get_name (core_interaction_get_model_ptr (ci2))
	if (.not. sane) return
	! Particle and QN counts
	sane = sane .and. &
	(core_interaction_get_n_in (ci1) == &
	core_interaction_get_n_in (ci2)) .and. &
	(core_interaction_get_n_out_eff (ci1) == &
	core_interaction_get_n_out_eff (ci2)) .and. &
	(core_interaction_get_n_tot_eff (ci1) == &
	core_interaction_get_n_tot_eff (ci2)) .and. &
	(core_interaction_get_n_out_real (ci1)) == &
	core_interaction_get_n_out_real (ci2) .and. &
	(core_interaction_get_n_tot_real (ci1)) == &
	core_interaction_get_n_tot_real (ci2)
	if (.not. sane) return
	sane = sane .and. &
	(core_interaction_get_n_flv_eff (ci1) == &
	core_interaction_get_n_flv_eff (ci2)) .and. &
	(core_interaction_get_n_flv_real (ci1) == &
	core_interaction_get_n_flv_real (ci2))
	if (.not. sane) return
	! Create flavor map and check for flavor compatibility
	allocate (flavor_map (core_interaction_get_n_flv_real (ci1)))
	n = core_interaction_get_n_tot_real (ci1)
	n_flv = core_interaction_get_n_flv_real (ci1)
	allocate (flv1(n, n_flv), flv2(n, n_flv))
	flv1 = core_interaction_get_flv_states_real (ci1)
	flv2 = core_interaction_get_flv_states_real (ci2)
	sane = sane .and. create_flavor_map (flavor_map, flv1, flv2)
	deallocate (flv1, flv2)
	if (.not. sane) return
	! Check effective flavor assignents
	n = core_interaction_get_n_flv_eff (ci1)
	n_flv = core_interaction_get_n_flv_eff (ci1)
	allocate (flv1(n, n_flv), flv2(n, n_flv))
	flv1 = core_interaction_get_flv_states_eff (ci1)
	flv2 = core_interaction_get_flv_states_eff (ci2)
	sane = sane .and. flavors_match (flavor_map, flv1, flv2)
	deallocate (flv1, flv2)
	if (.not. sane) return
	! We do _NOT_ check for PDG and unstable as this should be covered by model
	! and flavor states
	! We have a match -> transfer maps
	allocate (ci%flavor_map (size (flavor_map)))
	ci%flavor_map = flavor_map
	deallocate (flavor_map)

	contains

	function create_flavor_map (map, flv1, flv2) result (match)
	integer, dimension(:), intent(out) :: map
	integer, dimension(:,:), intent(in) :: flv1, flv2
	logical :: match
	logical, dimension(size (flv1, 2)) :: accounted
	integer :: n, i, j
	match = .false.
	accounted = .false.
	n = size (flv1, 2)
	SCAN: do i = 1, n
	do j = 1, n
	if (all (flv1(:, i) == flv2(:,j))) then
	if (accounted (j)) return
	accounted(j) = .true.
	map(i) = j
	cycle SCAN
	end if
	if (j == n) return
	end do
	end do SCAN
	match = .true.
	end function create_flavor_map

	function flavors_match (map, flv1, flv2) result (match)
	integer, dimension(:), intent(in) :: map
	integer, dimension(:,:), intent(in) :: flv1, flv2
	logical :: match
	integer :: i
	match = .true.
	do i = 1, size (flv1, 2)
	match = match .and. all (flv1(:, i) == flv2(:, map(i)))
	if (.not. match) return
	end do
	end function flavors_match

	end function core_interaction_sum_sane

	recursive function core_interaction_sum_is_valid (ci) result (valid)
	type(core_interaction_sum_t) :: ci
	logical :: valid
	valid = ci%valid
	if (.not. valid) return
	valid = core_interaction_is_valid (ci%ci1) .and. &
	core_interaction_is_valid (ci%ci2)
	end function core_interaction_sum_is_valid

	@ %def core_interaction_sum_is_valid
	@

	Finalization.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_final (ci)
	type(core_interaction_sum_t), intent(inout) :: ci
	if (.not. ci%valid) return
	call core_interaction_final (ci%ci1)
	call core_interaction_final (ci%ci2)
	deallocate (ci%ci1, ci%ci2)
	nullify (ci%ci1, ci%ci2)
	deallocate (ci%flavor_map)
	ci%valid = .false.
	end subroutine core_interaction_sum_final

	@ %def core_interaction_sum_final
	@
	Output.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_write &
	(ci, unit, verbose, show_momentum_sum, show_mass, write_comb)
	type(core_interaction_sum_t), intent(in) :: ci
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: write_comb
	integer :: u
	u = output_unit (unit)
	write (u, "(1X,A)") "Process ID: " // char (ci%id)
	if (.not. ci%valid) then
	write (u, "(1X,A)") "INVALID"
	return
	end if
	write (u, "(1X,A)") "Summand 1:"
	call core_interaction_write (ci%ci1, &
	unit, verbose, show_momentum_sum, show_mass, write_comb)
	write (u)
	write (u, "(1X,A)") "Summand 2:"
	call core_interaction_write (ci%ci2, &
	unit, verbose, show_momentum_sum, show_mass, write_comb)
	end subroutine core_interaction_sum_write

	@ %def core_interaction_write
	@
	Assignment.
	<<Core interactions: interfaces>>=
	interface assignment(=)
	module procedure core_interaction_sum_assign
	end interface
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_assign (ci_out, ci_in)
	type(core_interaction_sum_t), intent(inout) :: ci_out
	type(core_interaction_sum_t), intent(in) :: ci_in
	call core_interaction_sum_final (ci_out)
	ci_out%valid = ci_in%valid
	if (.not. ci_in%valid) return
	allocate (ci_out%ci1, ci_out%ci2)
	ci_out%ci1 = ci_in%ci1
	ci_out%ci2 = ci_in%ci2
	ci_out%id = ci_in%id
	allocate (ci_out%flavor_map (size (ci_in%flavor_map)))
	ci_out%flavor_map = ci_in%flavor_map
	ci_out%nin1 = ci_in%nin1
	ci_out%nin2 = ci_in%nin2
	ci_out%nout1 = ci_in%nout1
	ci_out%nout2 = ci_in%nout2
	ci_out%nx1 = ci_in%nx1
	ci_out%nx2 = ci_in%nx2
	ci_out%valid = .true.
	end subroutine core_interaction_sum_assign

	@ %def core_interaction_sum_assign
	@
	Multiplex indices. Note that the $n_\text{in}=1$ seed kinematics of the two
	interactions are unified.
	<<Core interactions: procedures>>=
	function ci_sum_multiplex_ci_in (cis, index) result (ci)
	type(core_interaction_sum_t), intent(in) :: cis
	integer, intent(in), optional :: index
	type(core_interaction_t), pointer :: ci
	integer :: i
	i = 1; if (present (index)) i = index
	if (i <= cis%nin1) then
	ci => cis%ci1
	else
	ci => cis%ci2
	end if
	end function ci_sum_multiplex_ci_in

	function ci_sum_multiplex_ci_out (cis, index) result (ci)
	type(core_interaction_sum_t), intent(in) :: cis
	integer, intent(in), optional :: index
	type(core_interaction_t), pointer :: ci
	integer :: i
	i = 1; if (present (index)) i = index
	if (i <= cis%nout1) then
	ci => cis%ci1
	else
	ci => cis%ci2
	end if
	end function ci_sum_multiplex_ci_out

	function ci_sum_multiplex_in (cis, index) result (ii)
	type(core_interaction_sum_t), intent(in) :: cis
	integer, intent(in), optional :: index
	integer :: ii, i
	i = 1; if (present (index)) i = index
	if (i <= cis%nin1) then
	ii = i
	else
	ii = i - cis%nin1 + 1
	end if
	end function ci_sum_multiplex_in

	function ci_sum_multiplex_out (cis, index) result (ii)
	type(core_interaction_sum_t), intent(in) :: cis
	integer, intent(in), optional :: index
	integer :: ii, i
	i = 1; if (present (index)) i = index
	if (i <= cis%nout1) then
	ii = i
	else
	ii = i - cis%nout1
	end if
	end function ci_sum_multiplex_out

	@ %def ci_sum_multiplex_ci_in ci_sum_multiplex_ci_out
	@ %def ci_sum_multiplex_in ci_sum_multiplex_out
	@
	Tell us whether a kinematic ``in'' configuration was actually generated
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_kinematics_passed &
	(cis, passed, index)
	type(core_interaction_sum_t), intent(inout) :: cis
	logical, intent(in) :: passed
	integer, intent(in), optional :: index
	integer :: i
	type(core_interaction_t), pointer :: cp
	i = ci_sum_multiplex_in (cis, index)
	cp => ci_sum_multiplex_ci_in (cis, index)
	call core_interaction_kinematics_passed (cp, passed, i)
	if (i == 1) &
	call core_interaction_kinematics_passed (cis%ci2, passed, 1)
	end subroutine core_interaction_sum_kinematics_passed

	@ %def core_interaction_sum_kinematics_passed
	@
	Set the weight for an ``in'' config.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_set_weight (cis, j, index)
	type(core_interaction_sum_t), intent(inout) :: cis
	real(kind=default), intent(in) :: j
	integer, intent(in), optional :: index
	integer :: i
	type(core_interaction_t), pointer :: cp
	i = ci_sum_multiplex_in (cis, index)
	cp => ci_sum_multiplex_ci_in (cis, index)
	call core_interaction_set_weight (cp, j, i)
	if (i == 1) &
	call core_interaction_set_weight (cis%ci2, j, 1)
	end subroutine core_interaction_sum_set_weight

	@ %core_interaction_sum_set_weight
	@
	Write state summary.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_write_state_summary (ci, unit)
	type(core_interaction_sum_t), intent(in) :: ci
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit)
	write (u, '(1X,A)') "Summand 1:"
	call core_interaction_write_state_summary (ci%ci1, u)
	write (u, '()')
	write (u, '(1X,A)') "Summand 2:"
	call core_interaction_write_state_summary (ci%ci2, u)
	end subroutine core_interaction_sum_write_state_summary

	@ %def core_interaction_sum_write_state_summary
	@
	Set random variables.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_set_x (ci, x)
	type(core_interaction_sum_t), intent(inout) :: ci
	real(kind=default), intent(in), dimension(:) :: x
	call core_interaction_set_x (ci%ci1, x(:ci%nx1))
	call core_interaction_set_x (ci%ci2, x(ci%nx1 + 1:))
	end subroutine core_interaction_sum_set_x

	@ %def core_interaction_sum_set_x
	@
	Set the outgoing momenta for an ``in'' point.
	<<Core interactions: procedures>>=
	recursive subroutine core_interaction_sum_set_momenta_out (ci, momenta, index)
	type(core_interaction_sum_t), intent(inout) :: ci
	type(vector4_t), intent(in), dimension(:) :: momenta
	type(core_interaction_t), pointer :: cp
	integer, intent(in), optional :: index
	integer :: i
	i = ci_sum_multiplex_in (ci, index)
	cp => ci_sum_multiplex_ci_in (ci, index)
	call core_interaction_set_momenta_out (cp, momenta, i)
	if (i == 1) &
	call core_interaction_set_momenta_out (ci%ci2, momenta, 1)
	end subroutine core_interaction_sum_set_momenta_out

	@ %def core_interaction_sum_set_momenta_out
	@

	\section{The NLO setup}

	This module encapsulates all options which constitute the setup of a NLO
	process. Modification of the
	setup is performed through a chained list of modification requests which
	directly correspond to the corresponding SINDARIN statements.

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

	module nlo_setup

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use md5
	use models
	use flavors
	use quantum_numbers

	<<Standard module head>>

	<<NLO setup: public>>

	<<NLO setup: parameters>>

	<<NLO setup: types>>

	<<NLO setup: variables>>

	<<NLO setup: interfaces>>

	contains

	<<NLO setup: procedures>>

	end module nlo_setup

	@ %def
	@

	The different directives for modification of the dipole setup.
	<<NLO setup: parameters>>=
	integer, parameter, public :: NLO_SETUP_NOOP = 0
	integer, parameter, public :: NLO_SETUP_SET_MREG = 1
	integer, parameter, public :: NLO_SETUP_SET_MASSES = 2
	integer, parameter, public :: NLO_SETUP_SET_CHARGES = 3
	integer, parameter, public :: NLO_SETUP_SET_MASK = 4
	integer, parameter, public :: NLO_SETUP_CLEAR_MASSES = 5
	integer, parameter, public :: NLO_SETUP_CLEAR_CHARGES = 6
	integer, parameter, public :: NLO_SETUP_CLEAR_MASK = 7
	integer, parameter, public :: NLO_SETUP_SET_RESOLVE = 8
	integer, parameter, public :: NLO_SETUP_SET_RECOMBINATION = 9
	integer, parameter, public :: NLO_SETUP_SET_MRECOMB = 10
	integer, parameter, public :: NLO_SETUP_SET_PHOTON_BEAM_SEPARATION = 11
	integer, parameter, public :: NLO_SETUP_SET_RECOMBINATION_COMPLEMENT = 12

	@ %def
	@
	The different available recombination procedures
	<<NLO setup: parameters>>=
	integer, parameter, public :: NLO_RECOMBINATION_RACOON=1, &
	NLO_RECOMBINATION_IGNORE_PHOTON=2, NLO_RECOMBINATION_BARBARA_WW=3, &
	NLO_RECOMBINATION_INVALID=-1

	@ %def
	@
	A single request for modification consists of a queue of subsequent modification
	directives. The queue is represented as a linked list.
	<<NLO setup: types>>=
	type nlo_setup_node_t
	integer :: type
	real(kind=default) :: mreg
	real(kind=default), dimension(:), allocatable :: masses
	real(kind=default), dimension(:), allocatable :: charges
	integer, dimension(:), allocatable :: mask
	logical :: resolve
	type(nlo_setup_node_t), pointer :: next => null ()
	integer :: recombination
	real(kind=default) :: mrecomb, photon_beam_separation
	logical :: recombination_complement = .false.
	end type nlo_setup_node_t

	public :: nlo_setup_list_t
	<<NLO setup: types>>=
	type nlo_setup_list_t
	private
	type(nlo_setup_node_t), pointer :: root => null ()
	end type nlo_setup_list_t

	@ %def nlo_setup_list_t nlo_setup_node_t
	@
	Create a single node. This is private, all external code is supposed to call
	[[nlo_setup_list_append]] instead.
	<<NLO setup: procedures>>=
	function nlo_setup_node_create (type, mreg, masses, charges, mask, &
	resolve, recombination, mrecomb, photon_beam_separation, &
	recombination_complement) &
	result (node)
	integer :: type
	real(kind=default), intent(in), optional :: mreg
	real(kind=default), intent(in), dimension(:), optional :: masses, charges
	integer, dimension(:), intent(in), optional :: mask
	logical, intent(in), optional :: resolve
	integer, intent(in), optional :: recombination
	real(kind=default), intent(in), optional :: mrecomb
	real(kind=default), intent(in), optional :: photon_beam_separation
	logical, intent(in), optional :: recombination_complement
	type(nlo_setup_node_t), pointer :: node
	allocate (node)
	node%type = type
	select case (type)
	case (NLO_SETUP_SET_MREG)
	node%mreg = mreg
	case (NLO_SETUP_SET_MASSES)
	allocate (node%masses(size (masses)))
	node%masses = masses
	case (NLO_SETUP_SET_CHARGES)
	allocate (node%charges(size (charges)))
	node%charges = charges
	case (NLO_SETUP_SET_MASK)
	allocate (node%mask(size (mask)))
	node%mask = mask
	case (NLO_SETUP_SET_RESOLVE)
	node%resolve = resolve
	case (NLO_SETUP_SET_RECOMBINATION)
	node%recombination = recombination
	case (NLO_SETUP_SET_MRECOMB)
	node%mrecomb = mrecomb
	case (NLO_SETUP_SET_PHOTON_BEAM_SEPARATION)
	node%photon_beam_separation = photon_beam_separation
	case (NLO_SETUP_SET_RECOMBINATION_COMPLEMENT)
	node%recombination_complement = recombination_complement
	end select
	end function nlo_setup_node_create

	@ %def nlo_setup_node_create
	@
	Initialize the whole settings list.
	<<NLO setup: public>>=
	public :: nlo_setup_list_init
	<<NLO setup: procedures>>=
	subroutine nlo_setup_list_init (list)
	type(nlo_setup_list_t), intent(out) :: list
	nullify (list%root)
	end subroutine nlo_setup_list_init

	@ %def nlo_setup_list_init
	@
	Delete the list.
	<<NLO setup: public>>=
	public :: nlo_setup_list_final
	<<NLO setup: procedures>>=
	subroutine nlo_setup_list_final (list)
	type(nlo_setup_list_t), intent(inout) :: list
	type(nlo_setup_node_t), pointer :: node, next
	node => list%root
	do while (associated (node))
	next => node%next
	deallocate (node)
	node => next
	end do
	nullify (list%root)
	end subroutine nlo_setup_list_final

	@ %def nlo_setup_list_final
	@
	Append a settings node to the list. Wraps around
	[[nlo_setup_node_create]].
	<<NLO setup: public>>=
	public :: nlo_setup_list_append
	<<NLO setup: procedures>>=
	subroutine nlo_setup_list_append (list, type, mreg, masses, charges, &
	mask, resolve, recombination, mrecomb, photon_beam_separation, &
	recombination_complement)
	type(nlo_setup_list_t), intent(inout) :: list
	integer :: type
	real(kind=default), intent(in), optional :: mreg
	real(kind=default), intent(in), dimension(:), optional :: masses, charges
	integer, dimension(:), intent(in), optional :: mask
	logical, intent(in), optional :: resolve
	integer, intent(in), optional :: recombination
	real(kind=default), intent(in), optional :: mrecomb
	real(kind=default), intent(in), optional :: photon_beam_separation
	logical, intent(in), optional :: recombination_complement
	type(nlo_setup_node_t), pointer :: new_node, node
	new_node => nlo_setup_node_create (type, mreg, masses, charges, &
	mask, resolve, recombination, mrecomb, &
	photon_beam_separation, recombination_complement)
	if (associated (list%root)) then
	node => list%root
	do while (associated (node%next))
	node => node%next
	end do
	node%next => new_node
	else
	list%root => new_node
	end if
	end subroutine nlo_setup_list_append

	@ %def nlo_setup_list_append
	@

	The actual NLO setup. The respective dipole modules need access, and
	we thus keep the components public in order to avoid a proliferation of access
	methods.
	<<NLO setup: public>>=
	public :: nlo_setup_t
	<<NLO setup: types>>=
	type nlo_setup_t
	logical :: valid = .false.
	real(kind=default) :: mreg = 0
	real(kind=default), dimension(:), allocatable :: charges
	real(kind=default), dimension(:), allocatable :: masses
	integer, dimension(:), allocatable :: mask
	logical :: resolve_set = .false.
	logical :: resolve
	integer :: n_tot = -1
	integer :: recombination = NLO_RECOMBINATION_INVALID
	real(kind=default) :: mrecomb = -1, photon_beam_separation = -1
	logical :: recombination_complement_set = .false.
	logical :: recombination_complement
	end type nlo_setup_t

	@ %def nlo_setup_t
	@
	Initialization. Flavors are supplied upon creation, everything else is setup via
	a settings list.
	<<NLO setup: public>>=
	public :: nlo_setup_init
	<<NLO setup: procedures>>=
	subroutine nlo_setup_init (dpc, n_tot)
	type(nlo_setup_t), intent(out) :: dpc
	integer, intent(in), optional :: n_tot
	dpc%valid = .true.
	if (present (n_tot)) dpc%n_tot = n_tot
	dpc%resolve_set = .false.
	end subroutine nlo_setup_init

	@ %def nlo_setup_init
	@
	Assignment. We first create a temporary, local copy of the [[from]] operand
	(which is intent inout) and
	then assign it to the [[to]] operand. This hack is necessary as we will
	encounter situations where both sides of the assignment are identical, although
	the rhs is passed through several function calls. In this case, gfortran seems
	to just pass along a pointer, and we end up invalidating the operand. Might be a
	compiler bug, dunno what the standard says about this situation.
	<<NLO setup: public>>=
	public :: assignment(=)
	<<NLO setup: interfaces>>=
	interface assignment(=)
	module procedure nlo_setup_assign
	end interface

	<<NLO setup: procedures>>=
	subroutine nlo_setup_assign (to, from)
	type(nlo_setup_t), intent(inout) :: to
	type(nlo_setup_t), intent(in) :: from
	type(nlo_setup_t) :: tmp
	call nlo_setup_assign1 (tmp, from)
	call nlo_setup_assign1 (to, tmp)
	end subroutine nlo_setup_assign

	subroutine nlo_setup_assign1 (to, from)
	type(nlo_setup_t), intent(inout) :: to
	type(nlo_setup_t), intent(in) :: from
	to%valid = from%valid
	to%mreg = from%mreg
	to%resolve_set = from%resolve_set
	to%resolve = from%resolve
	to%n_tot = from%n_tot
	to%recombination = from%recombination
	to%mrecomb = from%mrecomb
	to%photon_beam_separation = from%photon_beam_separation
	to%recombination_complement_set = from%recombination_complement_set
	to%recombination_complement = from%recombination_complement
	if (allocated (to%charges)) deallocate (to%charges)
	if (allocated (from%charges)) then
	allocate (to%charges(size (from%charges)))
	to%charges = from%charges
	end if
	if (allocated (to%masses)) deallocate (to%masses)
	if (allocated (from%masses)) then
	allocate (to%masses(size (from%masses)))
	to%masses = from%masses
	end if
	if (allocated (to%mask)) deallocate (to%mask)
	if (allocated (from%mask)) then
	allocate (to%mask(size (from%mask)))
	to%mask = from%mask
	end if
	end subroutine nlo_setup_assign1

	@ %def nlo_setup_assign
	@
	Check for validity.
	<<NLO setup: public>>=
	public :: nlo_setup_valid
	<<NLO setup: procedures>>=
	function nlo_setup_valid (cfg) result (valid)
	type(nlo_setup_t), intent(in) :: cfg
	logical :: valid
	valid = cfg%valid
	end function nlo_setup_valid

	@ %def nlo_setup_valid
	@
	Apply a settings node.
	<<NLO setup: procedures>>=
	subroutine nlo_setup_apply_node (dpc, node)
	type(nlo_setup_node_t), intent(in) :: node
	type(nlo_setup_t), intent(inout) :: dpc
	logical :: mask_valid
	integer :: i
	if (.not. dpc%valid) return
	select case (node%type)
	case (NLO_SETUP_SET_MREG)
	dpc%mreg = node%mreg
	case (NLO_SETUP_SET_MASSES)
	if (dpc%n_tot < 0) dpc%n_tot = size (node%masses)
	if (size (node%masses) /= dpc%n_tot) then
	call msg_error ("ignoring invalid collinear mass regulator list")
	return
	end if
	if (.not. allocated (dpc%masses)) allocate (dpc%masses(dpc%n_tot))
	dpc%masses = node%masses
	case (NLO_SETUP_SET_CHARGES)
	if (dpc%n_tot < 0) dpc%n_tot = size (node%charges)
	if (size (node%charges) /= dpc%n_tot) then
	call msg_error ("ignoring invalid charge list")
	return
	end if
	if (.not. allocated (dpc%charges)) allocate (dpc%charges(dpc%n_tot))
	dpc%charges = node%charges
	case (NLO_SETUP_SET_MASK)
	if (dpc%n_tot < 0) dpc%n_tot = size (node%mask / 2)
	mask_valid = all (node%mask > 0) .and. all (node%mask <= dpc%n_tot) &
	.and. (mod (size (node%mask), 2) == 0)
	if (mask_valid) then
	do i = 0, size (node%mask) / 2 - 1
	mask_valid = mask_valid .and. (node%mask(2i+1) /= node%mask(2i+2))
	end do
	end if
	if (.not. mask_valid) then
	call msg_error ("ignoring invalid dipole mask")
	return
	end if
	if (allocated (dpc%mask)) deallocate (dpc%mask)
	allocate (dpc%mask(size (node%mask)))
	dpc%mask = node%mask
	case (NLO_SETUP_CLEAR_MASSES)
	if (allocated (dpc%masses)) deallocate (dpc%masses)
	case (NLO_SETUP_CLEAR_CHARGES)
	if (allocated (dpc%charges)) deallocate (dpc%charges)
	case (NLO_SETUP_CLEAR_MASK)
	if (allocated (dpc%mask)) deallocate (dpc%mask)
	case (NLO_SETUP_SET_RESOLVE)
	dpc%resolve_set = .true.
	dpc%resolve = node%resolve
	case (NLO_SETUP_SET_RECOMBINATION)
	dpc%recombination = node%recombination
	case (NLO_SETUP_SET_MRECOMB)
	dpc%mrecomb = node%mrecomb
	case (NLO_SETUP_SET_PHOTON_BEAM_SEPARATION)
	dpc%photon_beam_separation = node%photon_beam_separation
	case (NLO_SETUP_SET_RECOMBINATION_COMPLEMENT)
	dpc%recombination_complement_set = .true.
	dpc%recombination_complement = node%recombination_complement
	end select
	end subroutine nlo_setup_apply_node

	@ %def nlo_setup_apply_node
	@
	Iterate over the list and apply all nodes.
	<<NLO setup: public>>=
	public :: nlo_setup_apply_list
	<<NLO setup: procedures>>=
	subroutine nlo_setup_apply_list (dpc, list)
	type(nlo_setup_t), intent(inout) :: dpc
	type(nlo_setup_list_t), intent(in) :: list
	type(nlo_setup_node_t), pointer :: node
	node => list%root
	do while (associated (node))
	call nlo_setup_apply_node (dpc, node)
	node => node%next
	end do
	end subroutine nlo_setup_apply_list

	@
	@ %def
	Output.
	<<NLO setup: public>>=
	public :: nlo_setup_write
	<<NLO setup: procedures>>=
	subroutine nlo_setup_write (dpc, unit)
	type(nlo_setup_t), intent(in) :: dpc
	integer, intent(in) :: unit
	integer :: i, u
	type(string_t) :: buffer
	if (.not. dpc%valid) return
	call msg_message (" NLO process setup", unit)
	call msg_message (" soft mass regulator = " // real2char (sqrt (dpc%mreg)), &
	unit)
	if (allocated (dpc%masses)) then
	buffer = " collinear mass regulators = " // render_array (dpc%masses)
	else
	buffer = " collinear mass regulators = [from model]"
	end if
	call msg_message (char (buffer), unit)
	if (allocated (dpc%mask)) then
	buffer = " mask = "
	do i = 0, size (dpc%mask) / 2 - 1
	buffer = buffer // " " // int2string (dpc%mask(2*i+1)) &
	// ":" // int2string (dpc%mask(2*i+2))
	end do
	else
	buffer = " no mask"
	end if
	call msg_message (char (buffer), unit)
	if (dpc%resolve_set) call msg_message ( &
	" resolve = " // char (log2str (dpc%resolve)), unit)
	call msg_message (" recombination = " // int2char ( &
	dpc%recombination), unit)
	if (dpc%mrecomb > 0) call msg_message (" mrecomb = " // &
	real2char (dpc%mrecomb), unit)
	if (dpc%photon_beam_separation > 0) call msg_message ( &
	"photon_beam_separation = " // real2char (dpc%photon_beam_separation), &
	unit)
	if (dpc%recombination_complement_set) call msg_message ( &
	"recombination_complement = " // char (log2str ( &
	dpc%recombination_complement)), unit)

	contains

	function render_array (x) result (s)
	real(kind=default), intent(in), dimension(:) :: x
	type(string_t) :: s
	integer :: i
	s = ""
	do i = 1, size (x)
	s = s // real2string (x(i)) // " "
	end do
	s = trim (s)
	end function render_array

	function log2str (l) result (s)
	logical, intent(in) :: l
	type(string_t) :: s
	if (l) then
	s = "true"
	else
	s = "false"
	end if
	end function log2str

	end subroutine nlo_setup_write
	@ %def
	@
	Calculate the MD5.
	<<NLO setup: public>>=
	public :: nlo_setup_md5sum
	<<NLO setup: procedures>>=
	function nlo_setup_md5sum (nlo_setup) result (md5)
	type(nlo_setup_t), intent(in) :: nlo_setup
	character(32) :: md5
	integer :: u
	u = free_unit ()
	open (unit=u, status="scratch")
	call nlo_setup_write (nlo_setup, u)
	rewind (u)
	md5 = md5sum (u)
	close (u)
	end function nlo_setup_md5sum

	@ %def nlo_setup_md5sum
	@

	\section{Dipoles and subtraction terms}

	These modules implement the calculation of integrated and real QED / QCD
	dipoles. HIGHLY EXPERIMENTAL. The logic is split into a configuration module and
	several modules implementing the different types of dipoles. The dipoles are
	split in five different modules:
	%
	\begin{itemize}
	\item [[dipoles_integrated_qed]], [[dipoles_real_qed]],
	[[dipoles_integrated_qcd]], [[dipoles_real_qcd]]: the different types of
	subtraction terms have dedicated modules.
	\end{itemize}

	\subsection{Integrated QED dipoles}

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

	module dipoles_integrated_qed

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use sm_physics !NODEP!
	use md5
	use lorentz !NODEP!
	use models
	use flavors
	use quantum_numbers
	use interactions
	use evaluators
	use particles
	use hard_interactions
	use quantum_numbers
	use nlo_setup
	use process_libraries

	<<Standard module head>>

	<<Integrated QED dipoles: public>>

	<<Integrated QED dipoles: parameters>>

	<<Integrated QED dipoles: types>>

	<<Integrated QED dipoles: variables>>

	<<Integrated QED dipoles: interfaces>>

	contains

	<<Integrated QED dipoles: procedures>>

	end module dipoles_integrated_qed
	@ %def dipoles_integrated_qed
	@ %
	The different types of dipole components.
	<<Integrated QED dipoles: parameters>>=
	integer, parameter :: DIPOLE_FF = 1, DIPOLE_IF = 2, DIPOLE_FI = 3, &
	DIPOLE_II = 4
	@ %def DIPOLE_FF DIPOLE_IF DIPOLE_FI DIPOLE_II
	%
	A single dipole component.
	<<Integrated QED dipoles: types>>=
	type dipole_qed_single_t
	integer :: em, sp
	integer :: type
	end type dipole_qed_single_t

	@ %def
	@ %
	The [[kinematic_configuration_t]] type represents both the ``vanilla'' and the
	twisted kinematics.
	<<Integrated QED dipoles: types>>=
	type kinematic_configuration_t
	! Kinematics
	type(vector4_t), dimension(:), allocatable :: momenta
	real(kind=default) :: weight
	logical :: passed=.true.
	real(default) :: alphas
	! Dipoles, dipole values, charge factors and cache
	integer :: n_components
	integer, dimension(:), allocatable :: components_map
	type(dipole_qed_single_t), dimension(:), allocatable :: components
	real(default), dimension(:), allocatable :: component_values
	real(default), dimension(:,:), allocatable :: charge_factors
	integer, dimension(:), allocatable :: me_factor_map
	real(default), dimension(:), allocatable :: me_factors
	! Interactions and evaluators
	type(evaluator_t) :: eval_square
	type(evaluator_t) :: eval_trace
	type(evaluator_t) :: eval_sqme
	end type kinematic_configuration_t

	@ %def
	@ %
	The actual dipole type.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_t
	<<Integrated QED dipoles: types>>=
	type dipole_integrated_qed_t
	private
	integer :: n_tot
	logical :: have_sqme = .false.
	real(kind=default) :: alpha=0
	real(kind=default) :: mreg=0
	real(kind=default) :: x=0
	logical :: alphas_updated = .false.
	type(flavor_t), dimension(:,:), allocatable :: flavor_states
	real(kind=default), dimension(:), allocatable :: masses
	type(kinematic_configuration_t), dimension(0:2) :: kinematics
	integer, dimension(:), allocatable :: kinematics_map
	type(dipole_qed_single_t), dimension(:), allocatable :: dipoles
	type(hard_interaction_t) :: hi
	end type dipole_integrated_qed_t

	@ %def
	@ %
	Initialization. A lot of stuff.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_init
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_init &
	(dp, prc_lib, process_index, process_id, model, alpha, nlo_setup)
	type(dipole_integrated_qed_t), intent(out) :: dp
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(nlo_setup_t) :: dpc
	type(model_t), target :: model
	real(kind=default), intent(in), optional :: alpha
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	type(dipole_qed_single_t), dimension(:), allocatable :: tmp
	logical, dimension(2) :: splits
	integer :: i, j, k, n, n_flv
	integer, allocatable, dimension(:,:) :: pdg_states
	real(default), dimension(:), allocatable :: charge_sums
	type(flavor_t) :: flv_em, flv_sp
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	if (present (nlo_setup)) then
	dpc = nlo_setup
	else
	dpc = process_library_get_nlo_setup (prc_lib, process_id)
	end if
	! Hard interaction
	call hard_interaction_init (dp%hi, prc_lib, process_index, process_id, model)
	if (hard_interaction_get_n_in (dp%hi) /= 2) call msg_bug ( &
	"dipoles for decay processes are not supported yet.")
	dp%n_tot = hard_interaction_get_n_tot (dp%hi)
	if (dp%n_tot /= dpc%n_tot .and. dpc%n_tot > 0) then
	call msg_error ("mismatch in dipole setup.")
	dpc%n_tot = -1
	if (allocated (dpc%masses)) deallocate (dpc%masses)
	if (allocated (dpc%charges)) deallocate (dpc%charges)
	if (allocated (dpc%mask)) deallocate (dpc%mask)
	end if
	! Flavor states
	n_flv = hard_interaction_get_n_flv (dp%hi)
	allocate (dp%flavor_states(dp%n_tot, n_flv))
	allocate (pdg_states(dp%n_tot, n_flv))
	pdg_states = hard_interaction_get_flv_states (dp%hi)
	do i = 1, n_flv
	call flavor_init (dp%flavor_states(: ,i), pdg_states(:, i), model)
	end do
	! Masses
	allocate (dp%masses(dp%n_tot))
	if (allocated (dpc%masses)) then
	dp%masses = dpc%masses**2
	else
	dp%masses = flavor_get_mass (dp%flavor_states(:, 1))**2
	end if
	! Alpha / mreg
	if (present (alpha)) dp%alpha = alpha
	dp%mreg = dpc%mreg**2
	! Count number of charged flavor (sums)
	allocate (charge_sums(dp%n_tot))
	charge_sums = 0
	do i = 1, n_flv
	charge_sums = charge_sums + abs (flavor_get_charge (dp%flavor_states(:, i)))
	end do
	n = count (charge_sums > epsilon (1._default))
	allocate (tmp(n**2 - n))
	splits = .false.
	! Build dipole list
	n = 1
	do i = 1, dp%n_tot
	do j = 1, dp%n_tot
	if (i == j) cycle
	if (abs (charge_sums(i) * charge_sums(j)) < epsilon (one)) cycle
	if (.not. in_mask (i, j, dpc%mask)) cycle
	tmp(n)%em = i
	tmp(n)%sp = j
	if (max (i, j) == 2) then
	tmp(n)%type = DIPOLE_II
	splits(i) = .true.
	elseif (i <= 2) then
	tmp(n)%type = DIPOLE_IF
	splits(i) = .true.
	elseif (j <= 2) then
	tmp(n)%type = DIPOLE_FI
	splits(j) = .true.
	else
	tmp(n)%type = DIPOLE_FF
	end if
	n = n + 1
	end do
	end do
	allocate (dp%dipoles(n-1))
	if (n > 1) dp%dipoles = tmp(1:n - 1)
	allocate (dp%kinematics_map (count (splits) + 1))
	! Build kinematics map
	dp%kinematics_map(1) = 0
	i = 2
	do j = 1, 2
	if (splits (j)) then
	dp%kinematics_map(i) = j
	i = i + 1
	end if
	end do
	! Initialize kinematic configs
	allocate (qn_mask(dp%n_tot))
	call quantum_numbers_mask_init (qn_mask, .false., .true., .true.)
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	allocate (dp%kinematics(j)%momenta(dp%n_tot))
	call evaluator_init_square (dp%kinematics(j)%eval_square, &
	hard_interaction_get_int_ptr (dp%hi), qn_mask)
	! Count the contributing dipole components and setup arrays
	allocate (dp%kinematics(j)%components_map(size (dp%dipoles)))
	if (j == 0) then
	n = size (dp%dipoles)
	dp%kinematics(j)%n_components = n
	allocate ( &
	dp%kinematics(j)%components(n), &
	dp%kinematics(j)%component_values(n) &
	)
	dp%kinematics(j)%components = dp%dipoles
	dp%kinematics(j)%components_map = (/(k, k = 1, n)/)
	else
	n = 0
	do k = 1, size (dp%dipoles)
	select case (dp%dipoles(k)%type)
	case (DIPOLE_FF)
	case (DIPOLE_IF, DIPOLE_II)
	if (dp%dipoles(k)%em == j) n = n + 1
	case (DIPOLE_FI)
	if (dp%dipoles(k)%sp == j) n = n + 1
	end select
	end do
	allocate ( &
	dp%kinematics(j)%components(n), &
	dp%kinematics(j)%component_values(n) &
	)
	dp%kinematics(j)%n_components = n
	n = 1
	do k = 1, size (dp%dipoles)
	select case (dp%dipoles(k)%type)
	case (DIPOLE_FF)
	cycle
	case (DIPOLE_IF, DIPOLE_II)
	if (dp%dipoles(k)%em /= j) cycle
	case (DIPOLE_FI)
	if (dp%dipoles(k)%sp /= j) cycle
	end select
	dp%kinematics(j)%components_map(k) = n
	dp%kinematics(j)%components(n) = dp%dipoles(k)
	n = n + 1
	end do
	end if
	! Build the list of charge factors
	allocate (dp%kinematics(j)%charge_factors( &
	dp%kinematics(j)%n_components, n_flv))
	do k = 1, n_flv
	do n = 1, dp%kinematics(j)%n_components
	flv_em = dp%flavor_states(dp%kinematics(j)%components(n)%em, k)
	flv_sp = dp%flavor_states(dp%kinematics(j)%components(n)%sp, k)
	dp%kinematics(j)%charge_factors(n, k) = &
	flavor_get_charge (flv_em) * flavor_get_charge (flv_sp)
	end do
	end do
	! Setup the matrix element factor map
	allocate (dp%kinematics(j)%me_factors (n_flv))
	call setup_me_factor_map (dp%kinematics(j))
	end do
	dp%have_sqme = .false.

	contains

	subroutine setup_me_factor_map (kin)
	type(kinematic_configuration_t), intent(inout) :: kin
	type(interaction_t), pointer :: int
	integer :: i, j
	type(flavor_t), dimension(:), allocatable :: flvs
	integer :: iflv
	allocate (flvs(dp%n_tot))
	int => evaluator_get_int_ptr (kin%eval_square)
	allocate (kin%me_factor_map (interaction_get_n_matrix_elements (int)))
	do i = 1, size (kin%me_factor_map)
	flvs = quantum_numbers_get_flavor ( &
	interaction_get_quantum_numbers (int, i))
	iflv = -1
	do j = 1, n_flv
	if (all (flvs == dp%flavor_states (:, j))) then
	iflv = j
	exit
	end if
	end do
	if (iflv < 0) call msg_bug ( &
	"flavor state mismatch in dipole_integrated_qed_init")
	kin%me_factor_map(i) = iflv
	end do
	end subroutine setup_me_factor_map

	end subroutine dipole_integrated_qed_init

	@ %def dipole_integrated_qed_init
	@ %
	Check whether a dipole is allowed by the mask.
	<<Integrated QED dipoles: procedures>>=
	function in_mask (em, sp, mask) result (flag)
	integer, intent(in) :: em, sp
	integer, dimension(:), intent(in), allocatable :: mask
	logical :: flag
	integer :: i
	flag = .true.
	if (.not. allocated(mask)) return
	if (size (mask) == 0) return
	do i = 0, size (mask) / 2 - 1
	if (em == mask(2i + 1) .and. sp == mask(2i + 2)) return
	end do
	flag = .false.
	end function in_mask

	@ %def in_mask
	@ %
	Initialize and finalize the various evaluators.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_init_trace
	public :: dipole_integrated_qed_init_sqme
	public :: dipole_integrated_qed_final_sqme
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_init_trace &
	(dp, qn_mask_in)
	type(dipole_integrated_qed_t), intent(inout), target :: dp
	type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	integer :: i, j
	allocate (qn_mask (dp%n_tot))
	qn_mask(1:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.)
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	call evaluator_init_qn_sum (dp%kinematics(j)%eval_trace, &
	dp%kinematics(j)%eval_square, qn_mask)
	end do
	end subroutine dipole_integrated_qed_init_trace

	subroutine dipole_integrated_qed_init_sqme (dp, qn_mask_in)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask
	integer :: i, j
	qn_mask(:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.)
	if (all (qn_mask_in .eqv. interaction_get_mask (evaluator_get_int_ptr ( &
	dp%kinematics(0)%eval_square), (/1, 2/)))) then
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	call evaluator_init_identity (dp%kinematics(j)%eval_sqme, &
	dp%kinematics(j)%eval_square)
	end do
	else
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	call evaluator_init_qn_sum (dp%kinematics(j)%eval_sqme, &
	dp%kinematics(j)%eval_square, qn_mask)
	end do
	end if
	dp%have_sqme = .true.
	end subroutine dipole_integrated_qed_init_sqme

	subroutine dipole_integrated_qed_final_sqme (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	integer :: i
	if (.not. dp%have_sqme) return
	do i = 1, size (dp%kinematics_map)
	call evaluator_final (dp%kinematics(dp%kinematics_map(i))%eval_sqme)
	end do
	dp%have_sqme = .false.
	end subroutine dipole_integrated_qed_final_sqme

	@ %def dipole_integrated_qed_init_trace
	@ %def dipole_integrated_qed_init_sqme
	@ %def dipole_integrated_qed_final_sqme
	@

	Finalization.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_final
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_final (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	integer :: i, j
	if (allocated (dp%kinematics_map)) then
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	call evaluator_final (dp%kinematics(j)%eval_square)
	call evaluator_final (dp%kinematics(j)%eval_trace)
	deallocate (dp%kinematics(j)%momenta)
	deallocate (dp%kinematics(j)%components_map)
	deallocate (dp%kinematics(j)%components)
	deallocate (dp%kinematics(j)%charge_factors)
	deallocate (dp%kinematics(j)%me_factor_map)
	deallocate (dp%kinematics(j)%me_factors)
	end do
	deallocate (dp%kinematics_map)
	end if
	if (allocated (dp%flavor_states)) deallocate (dp%flavor_states)
	if (allocated (dp%masses)) deallocate (dp%masses)
	if (allocated (dp%dipoles)) deallocate (dp%dipoles)
	call hard_interaction_final (dp%hi)
	end subroutine dipole_integrated_qed_final

	@ %def dipole_integrated_qed_final
	@ %
	Assignment.
	<<Integrated QED dipoles: public>>=
	public :: assignment(=)
	<<Integrated QED dipoles: interfaces>>=
	interface assignment(=)
	module procedure dipole_integrated_qed_assign
	end interface
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_assign (to, from)
	type(dipole_integrated_qed_t), intent(out) :: to
	type(dipole_integrated_qed_t), intent(in) :: from
	integer :: i, j
	to%n_tot = from%n_tot
	to%alpha = from%alpha
	to%mreg = from%mreg
	to%x = from%x
	allocate (to%flavor_states(size ( &
	from%flavor_states, 1), size (from%flavor_states, 2)))
	to%flavor_states = from %flavor_states
	allocate (to%masses (size (from%masses)))
	to%masses = from%masses
	allocate (to%dipoles (size (from%dipoles)))
	to%dipoles = from%dipoles
	to%hi = from%hi
	allocate (to%kinematics_map (size (from%kinematics_map)))
	to%kinematics_map = from%kinematics_map
	do i = 1, size (to%kinematics_map)
	j = to%kinematics_map(j)
	call kinematics_assign (to%kinematics(j), from%kinematics(j))
	call evaluator_replace_interaction (to%kinematics(j)%eval_square, int1 = &
	hard_interaction_get_int_ptr (to%hi))
	end do

	contains

	subroutine kinematics_assign (k_to, k_from)
	type(kinematic_configuration_t), intent(out) :: k_to
	type(kinematic_configuration_t), intent(in) :: k_from
	allocate (k_to%momenta (size ( &
	k_from%momenta)))
	k_to%momenta = k_from%momenta
	k_to%weight = k_from%weight
	k_to%passed = k_from%passed
	k_to%n_components = k_from%n_components
	allocate (k_to%components_map (size (k_from%components_map)))
	k_to%components_map = k_from%components_map
	allocate (k_to%components (size (k_from%components)))
	k_to%components = k_from%components
	allocate (k_to%component_values (size (k_from%component_values)))
	k_to%component_values = k_from%component_values
	allocate (k_to%charge_factors (size (k_from%charge_factors, 1), &
	size (k_from%charge_factors, 2)))
	k_to%charge_factors = k_from%charge_factors
	allocate (k_to%me_factor_map (size (k_from%me_factor_map)))
	k_to%me_factor_map = k_from%me_factor_map
	allocate (k_to%me_factors (size (k_from%me_factors)))
	k_to%me_factors = k_from%me_factors
	k_to%eval_square = k_from%eval_square
	k_to%eval_trace = k_from%eval_trace
	k_to%eval_sqme = k_from%eval_sqme
	call evaluator_replace_interaction (k_to%eval_sqme, &
	hard_interaction_get_int_ptr (to%hi))
	call evaluator_replace_interaction (k_to%eval_trace, int1 = &
	evaluator_get_int_ptr (k_to%eval_square))
	if (from%have_sqme) call evaluator_replace_interaction (k_to%eval_sqme, &
	int1 = evaluator_get_int_ptr (k_to%eval_square))
	end subroutine kinematics_assign

	end subroutine dipole_integrated_qed_assign

	@ %def dipole_integrated_qed_assign
	@
	Prepare for a new evaluation cycle.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_reset
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_reset (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	dp%kinematics(dp%kinematics_map)%passed = .false.
	end subroutine dipole_integrated_qed_reset

	@ %def dipole_integrated_qed_reset
	@
	Set / get $\alpha$.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_get_alpha_qed
	public :: dipole_integrated_qed_set_alpha_qed
	<<Integrated QED dipoles: procedures>>=
	function dipole_integrated_qed_get_alpha_qed (dp) result (alpha)
	type(dipole_integrated_qed_t), intent(in) :: dp
	real(kind=default) :: alpha
	alpha = dp%alpha
	end function dipole_integrated_qed_get_alpha_qed

	subroutine dipole_integrated_qed_set_alpha_qed (dp, alpha)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	real(kind=default), intent(in) :: alpha
	dp%alpha = alpha
	end subroutine dipole_integrated_qed_set_alpha_qed

	@ %def dipole_integrated_qed_set_alpha_qed
	@ %def dipole_integrated_qed_get_alpha_qed
	@ %
	Get the number of in / out kinematics.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_get_n_kinematics
	<<Integrated QED dipoles: procedures>>=
	function dipole_integrated_qed_get_n_kinematics (dp) result (n)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer :: n
	n = size (dp%kinematics_map)
	end function dipole_integrated_qed_get_n_kinematics

	@ %def dipole_integrated_qed_get_n_kinematics
	@ %
	Get / set $x$.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_get_x
	public :: dipole_integrated_qed_set_x
	<<Integrated QED dipoles: procedures>>=
	function dipole_integrated_qed_get_x (dp) result (x)
	type(dipole_integrated_qed_t), intent(in) :: dp
	real(kind=default) :: x
	x = dp%x
	end function dipole_integrated_qed_get_x

	subroutine dipole_integrated_qed_set_x (dp, x)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	real(kind=default), intent(in) :: x
	dp%x = x
	end subroutine dipole_integrated_qed_set_x

	@ %def dipole_integrated_qed_set_x
	@ %def dipole_integrated_qed_get_x
	@ %
	Salvage the seed momenta from the interactions and calculate the twisted momenta.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_process_momenta_in
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_process_momenta_in (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	integer :: n, i, j
	dp%kinematics(0)%momenta = interaction_get_momenta ( &
	evaluator_get_int_ptr (dp%kinematics(0)%eval_square))
	do n = 2, size (dp%kinematics_map)
	i = dp%kinematics_map (n)
	if (i == 1) then
	j = 2
	else
	j = 1
	end if
	dp%kinematics(i)%momenta(i) = dp%x * dp%kinematics(0)%momenta(i)
	dp%kinematics(i)%momenta(j) = dp%kinematics(0)%momenta(j)
	end do
	end subroutine dipole_integrated_qed_process_momenta_in

	@ %def dipole_integrated_qed_process_momenta_in
	@
	<<Integrated QED dipoles: procedures>>=
	pure function get_index (dp, index) result (i)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, intent(in), optional :: index
	integer :: i
	i = 1; if (present (index)) i = dp%kinematics_map(index)
	end function get_index

	@ %def get_index
	@
	Retrieve the incoming momenta.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_get_momenta_in
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_get_momenta_in (dp, momenta, index)
	type(dipole_integrated_qed_t), intent(in) :: dp
	type(vector4_t), dimension(2), intent(out) :: momenta
	integer, intent(in), optional :: index
	momenta = dp%kinematics(get_index (dp, index))%momenta(1:2)
	end subroutine dipole_integrated_qed_get_momenta_in

	@ %def dipole_integrated_qed_get_momenta_in
	@
	Set outgoing momenta.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_set_momenta_out
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_set_momenta_out (dp, momenta, index)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	type(vector4_t), intent(in), dimension(:) :: momenta
	integer, intent(in), optional :: index
	integer :: i
	type(interaction_t), pointer :: int
	i = get_index (dp, index)
	dp%kinematics(i)%momenta(3:) = momenta
	int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square)
	call interaction_set_momenta (int, dp%kinematics(i)%momenta)
	end subroutine dipole_integrated_qed_set_momenta_out

	@ %def dipole_integrated_qed_set_momenta_out
	@ %
	Set / get the phasespace weight (jacobian * volume)
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_set_weight
	public :: dipole_integrated_qed_get_weight
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_set_weight (dp, weight, index)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	real(default), intent(in) :: weight
	integer, intent(in), optional :: index
	dp%kinematics(get_index (dp, index))%weight = weight
	end subroutine dipole_integrated_qed_set_weight

	function dipole_integrated_qed_get_weight (dp, index) result (weight)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, intent(in), optional :: index
	real(default) :: weight
	weight = dp%kinematics(get_index (dp, index))%weight
	end function dipole_integrated_qed_get_weight

	@ %def dipole_integrated_qed_set_weight
	@ %def dipole_integrated_qed_get_weight
	@
	Set / get the cut status.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_get_cut_status
	public :: dipole_integrated_qed_set_cut_status
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_set_cut_status (dp, passed, index)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	logical, intent(in) :: passed
	integer, intent(in), optional :: index
	dp%kinematics(get_index (dp, index))%passed = passed
	end subroutine dipole_integrated_qed_set_cut_status

	function dipole_integrated_qed_get_cut_status (dp, index) result (passed)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, intent(in), optional :: index
	logical :: passed
	passed = dp%kinematics(get_index (dp, index))%passed
	end function dipole_integrated_qed_get_cut_status

	@ %def dipole_integrated_qed_set_cut_status
	@ %def dipole_integrated_qed_get_cut_status
	@
	Evaluate the subtraction term, fill the interactions and evaluate the trace.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_evaluate
	<<Integrated QED dipoles: procedures>>=
	function doublify (str) result (res)
	character(*), intent(in) :: str
	character(255) :: res
	integer :: n
	res = str
	n = scan (res, 'eEdD')
	if (n < 1) then
	res = trim (res) // "d0"
	else
	res(n:n) = "d"
	end if
	end function doublify

	subroutine dipole_integrated_qed_evaluate (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	integer :: em, sp
	integer :: i, j, k, n_me
	real(kind=default) :: p2
	type(interaction_t), pointer :: hi_int, square_int
	real(kind=default) :: dpfac_b, dpfac_c, dpfac_a
	type(vector4_t) :: pcms
	real(default) :: shat, alpi
	forall (i = 1:size (dp%kinematics_map)) &
	dp%kinematics(dp%kinematics_map(i))%component_values = 0
	pcms = dp%kinematics(0)%momenta(1) + dp%kinematics(0)%momenta(2)
	shat = pcms * pcms
	alpi = - dp%alpha / two / pi
	SCAN: do i = 1, size (dp%dipoles)
	em = dp%dipoles(i)%em
	sp = dp%dipoles(i)%sp
	select case (dp%dipoles(i)%type)
	case (DIPOLE_FF)
	if (.not. dp%kinematics(0)%passed) cycle SCAN
	p2 = (dp%kinematics(0)%momenta(em) + &
	dp%kinematics(0)%momenta(sp))**2
	dp%kinematics(0)%component_values(i) = &
	(ll (p2, dp%masses(em), dp%mreg) - pi**2/three + three/two)
	case (DIPOLE_IF)
	if (dp%kinematics(em)%passed) then
	p2 = (dp%kinematics(em)%momenta(sp) - &
	dp%kinematics(em)%momenta(em))**2
	j = dp%kinematics(em)%components_map(i)
	dp%kinematics(em)%component_values(j) = - &
	gai (abs (p2), dp%x, dp%masses(em)) / dp%x
	end if
	if (dp%kinematics(0)%passed) then
	p2 = (dp%kinematics(0)%momenta(sp) - &
	dp%kinematics(0)%momenta(em))**2
	dp%kinematics(0)%component_values(i) = - ( &
	- gai (abs (p2), dp%x, dp%masses(em)) &
	+ (ll (abs (p2), dp%masses(em), dp%mreg) + &
	pi**2/6._default - one) &
	)
	end if
	case (DIPOLE_FI)
	if (dp%kinematics(sp)%passed) then
	p2 = (dp%kinematics(sp)%momenta(em) - &
	dp%kinematics(sp)%momenta(sp))**2
	j = dp%kinematics(sp)%components_map(i)
	dp%kinematics(sp)%component_values(j) = - gia (dp%x) / dp%x
	end if
	if (dp%kinematics(0)%passed) then
	p2 = (dp%kinematics(0)%momenta(em) - &
	dp%kinematics(0)%momenta(sp))**2
	dp%kinematics(0)%component_values(i) = - ( &
	- gia (dp%x) &
	+ (ll (abs (p2), dp%masses(em), dp%mreg) - &
	pi**2/two + three/two) &
	)
	end if
	case (DIPOLE_II)
	if (dp%kinematics(em)%passed) then
	j = dp%kinematics(em)%components_map(i)
	dp%kinematics(em)%component_values(j) = &
	gab(shat, dp%x, dp%masses(em)) / dp%x
	end if
	if (dp%kinematics(0)%passed) then
	dp%kinematics(0)%component_values(i) = ( &
	- gab(shat, dp%x, dp%masses(em)) &
	+ (ll (shat, dp%masses(em), dp%mreg) - &
	pi**2/three + two) &
	)
	end if
	dpfac_a = - (-dp%alpha / two / pi) * &
	gab (shat, dp%x, dp%masses(em))
	dpfac_b = (-dp%alpha / two / pi) * ( &
	ll (shat, dp%masses(em), dp%mreg) - pi**2/three + two)
	end select
	end do SCAN
	hi_int => hard_interaction_get_int_ptr (dp%hi)
	do i = 1, size (dp%kinematics_map)
	j = dp%kinematics_map(i)
	square_int => evaluator_get_int_ptr (dp%kinematics(j)%eval_square)
	n_me = interaction_get_n_matrix_elements (square_int)
	if (dp%alphas_updated) &
	call hard_interaction_update_alpha_s (dp%hi, dp%kinematics(j)%alphas)
	call interaction_set_momenta (hi_int, dp%kinematics(j)%momenta)
	call hard_interaction_evaluate (dp%hi)
	call evaluator_evaluate (dp%kinematics(j)%eval_square)
	forall (k = 1:size (dp%flavor_states, 2)) &
	dp%kinematics(j)%me_factors(k) = dot_product ( &
	dp%kinematics(j)%component_values, &
	dp%kinematics(j)%charge_factors(:, k) &
	)
	do k = 1, n_me
	call interaction_set_matrix_element ( &
	square_int, k, &
	interaction_get_matrix_element (square_int, k) * alpi * &
	dp%kinematics(j)%me_factors( dp%kinematics(j)%me_factor_map(k)) &
	)
	end do
	call evaluator_receive_momenta (dp%kinematics(j)%eval_trace)
	call evaluator_evaluate (dp%kinematics(j)%eval_trace)
	if (dp%have_sqme) then
	call evaluator_receive_momenta (dp%kinematics(j)%eval_sqme)
	call evaluator_evaluate (dp%kinematics(j)%eval_sqme)
	end if
	end do
	! call debug_hook (dp)

	contains

	pure function pp (x) result (y)
	real(kind=default), intent(in) :: x
	real(kind=default) :: y
	y = (one + x*x) / (one - x)
	end function pp

	pure function ll (p2, m2, mreg2) result (y)
	real(kind=default), intent(in) :: p2, m2, mreg2
	real(kind=default) :: y
	real(kind=default) :: lm2, lmreg2
	lm2 = log (m2/p2)
	lmreg2 = log (mreg2/p2)
	y = lm2lmreg2 + lmreg2 - (lm2*2 - lm2) / two
	end function ll

	pure function gai (p2, x, m2) result (y)
	real(kind=default), intent(in) :: p2, x, m2
	real(kind=default) :: y
	y = pp (x) * (log (abs (p2)/m2/x) - one) &
	- twolog (two - x)/(one - x) + (one + x)log (one - x) + one - x
	end function gai

	pure function gia (x) result (y)
	real(kind=default), intent(in) :: x
	real(kind=default) :: y
	y = (two * log ((two - x)/(one - x)) - three/two) / (one - x)
	end function gia

	pure function gab (s, x, m2) result (y)
	real(kind=default), intent(in) :: s, x, m2
	real(kind=default) :: y
	y = pp (x) * (log (s/m2) - one) + (one - x)
	end function gab

	subroutine debug_hook (dp)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, parameter :: max_calls=10
	integer, save :: u
	logical, save :: firstcall=.true., active=.false.
	integer, save :: count
	integer :: err, i, mu
	real(kind=default) :: cached = -1
	type(kinematic_configuration_t) :: k
	if (.not. active) return
	if (firstcall) then
	if (size (dp%dipoles) /= 1) then
	active = .false.
	return
	end if
	u = free_unit ()
	open (unit=u, file="excerpt.out", status="replace", action="write", iostat=err)
	if (err /= 0) then
	active = .false.
	return
	end if
	count = 1
	firstcall = .false.
	end if
	k = dp%kinematics(0)
	write (u, '(A)') " if (i .eq. " // int2char (count) // ") then"
	do i = 1, size (k%momenta)
	do mu = 0, 3
	write (u, '(A)') " p(" // int2char(i) // "," // int2char(mu) // &
	") = " // trim (doublify (real2char (vector4_get_component ( &
	k%momenta(i), mu))))
	end do
	end do
	write (u, '(A)') " s = " // trim (real2char (shat))
	write (u, '(A)') " x = " // trim (real2char (dp%x))
	write (u, '(A)') " me = " // trim (real2char (real ( interaction_sum &
	(evaluator_get_int_ptr (k%eval_trace)), default)))
	write (u, '(A)') " weight = " // trim (real2char (k%weight))
	write (u, '(A)') ""
	count = count + 1
	if (count > max_calls) then
	close (u)
	active = .false.
	end if
	end subroutine debug_hook

	end subroutine dipole_integrated_qed_evaluate

	@ %def dipole_integrated_qed_evaluate
	@ %
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_write
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_write (dp, unit)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, intent(in) :: unit
	integer :: i, u
	type(string_t) :: buffer
	character(*), parameter :: del = repeat ("-", 80)
	u = output_unit (unit); if (u < 0) return
	write (u, '(A)') "massless integrated QED dipole"
	write (u, '(3X,A)') "alpha: " // real2char (dp%alpha)
	write (u, '(3X,A)') "soft mass regulator: " // real2char (sqrt (dp%mreg))
	write (u, '(3X,A)') "collinear mass regulators:"
	buffer = ""
	do i = 1, size (dp%masses)
	buffer = trim (buffer) // real2string (sqrt (dp%masses(i))) // " "
	end do
	write (u, '(5X,A)') trim (char (buffer))
	write (u, '(3X,A)') "Kinematics:"
	write (u, '(3X,A)') del
	do i = 1, size (dp%kinematics_map)
	write (u, '(3X,A,I0)') "Configuration ", i
	call write_kinematic (dp%kinematics(dp%kinematics_map(i)))
	write (u, '(3X,A)') del
	end do

	contains

	subroutine write_kinematic (k)
	type(kinematic_configuration_t), intent(in) :: k
	integer :: i
	write (u, '(3X,A,E20.14)') "weight = ", k%weight
	write (u, '(3X,A,L1)') "passed = ", k%passed
	write (u, '(3X,A,1X)', advance = "no") "dipole components ="
	do i = 1, k%n_components
	write (u, "(I0,':',I0,' ')", advance='no') &
	k%components(i)%em, k%components(i)%sp
	end do
	write (u, '(A)')
	write (u, '(3X,A)') "components map ="
	write (u, '(6X,I0)') k%components_map
	write (u, '(3X,A)') "charge factors ="
	do i = 1, size (k%charge_factors, 2)
	write (u, '(6X,E20.14)') k%charge_factors(:, i)
	end do
	write (u, '(3X,A)') "me_factor_map ="
	write (u, '(6X)', advance = "no")
	do i = 1, size (k%me_factor_map)
	write (u, '(I0,1X)', advance = "no") k%me_factor_map(i)
	end do
	write (u, '(A)')
	write (u, '(6X,I2)') k%me_factor_map
	write (u, '(3X,A)') "me_factors ="
	write (u, '(6X,E20.14)') k%me_factors
	write (u, '(6X,E10.5)') k%charge_factors
	end subroutine

	end subroutine dipole_integrated_qed_write
	@ %def
	@
	Wrappers around the hard interaction object to complete the interface for the
	core interaction type.
	<<Integrated QED dipoles: public>>=
	public :: dipole_integrated_qed_unload
	public :: dipole_integrated_qed_reload
	public :: dipole_integrated_qed_update_parameters
	public :: dipole_integrated_qed_get_model_ptr
	public :: dipole_integrated_qed_get_n_in
	public :: dipole_integrated_qed_get_n_out
	public :: dipole_integrated_qed_get_n_tot
	public :: dipole_integrated_qed_get_n_flv
	public :: dipole_integrated_qed_get_flv_states
	public :: dipole_integrated_qed_get_first_pdg_in
	public :: dipole_integrated_qed_get_first_pdg_out
	public :: dipole_integrated_qed_get_unstable_products
	public :: dipole_integrated_qed_reset_helicity_selection
	public :: dipole_integrated_qed_update_alpha_s
	public :: dipole_integrated_qed_get_int_ptr
	public :: dipole_integrated_qed_get_eval_trace_ptr
	public :: dipole_integrated_qed_get_eval_sqme_ptr
	public :: dipole_integrated_qed_write_state_summary
	public :: dipole_integrated_qed_is_valid
	public :: dipole_integrated_qed_get_id
	<<Integrated QED dipoles: procedures>>=
	subroutine dipole_integrated_qed_unload (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	call hard_interaction_unload (dp%hi)
	end subroutine dipole_integrated_qed_unload

	subroutine dipole_integrated_qed_reload (dp, prc_lib)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	type(process_library_t), intent(in) :: prc_lib
	call hard_interaction_reload (dp%hi, prc_lib)
	end subroutine dipole_integrated_qed_reload

	subroutine dipole_integrated_qed_update_parameters (dp)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	call hard_interaction_update_parameters (dp%hi)
	end subroutine dipole_integrated_qed_update_parameters

	function dipole_integrated_qed_get_model_ptr (dp) result (model)
	type(dipole_integrated_qed_t), intent(in) :: dp
	type(model_t), pointer :: model
	model => hard_interaction_get_model_ptr (dp%hi)
	end function dipole_integrated_qed_get_model_ptr

	function dipole_integrated_qed_get_n_in (dp) result (n)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer :: n
	n = hard_interaction_get_n_in (dp%hi)
	end function dipole_integrated_qed_get_n_in

	function dipole_integrated_qed_get_n_out (dp) result (n)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer :: n
	n = hard_interaction_get_n_out (dp%hi)
	end function dipole_integrated_qed_get_n_out

	function dipole_integrated_qed_get_n_tot (dp) result (n)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer :: n
	n = dp%n_tot
	end function dipole_integrated_qed_get_n_tot

	function dipole_integrated_qed_get_n_flv (dp) result (n)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer :: n
	n = size (dp%flavor_states, 2)
	end function dipole_integrated_qed_get_n_flv

	function dipole_integrated_qed_get_flv_states (dp) result (flv)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, dimension(:,:), allocatable :: flv
	allocate (flv (size (dp%flavor_states, 1), size (dp%flavor_states, 2)))
	flv = hard_interaction_get_flv_states (dp%hi)
	end function dipole_integrated_qed_get_flv_states

	function dipole_integrated_qed_get_first_pdg_in (dp) result (pdg)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, dimension(2) :: pdg
	pdg = hard_interaction_get_first_pdg_in (dp%hi)
	end function dipole_integrated_qed_get_first_pdg_in

	function dipole_integrated_qed_get_first_pdg_out (dp) result (pdg)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, dimension(dp%n_tot - 2) :: pdg
	pdg = hard_interaction_get_first_pdg_out (dp%hi)
	end function dipole_integrated_qed_get_first_pdg_out

	subroutine dipole_integrated_qed_get_unstable_products (dp, flavors)
	type(dipole_integrated_qed_t), intent(in) :: dp
	type(flavor_t), dimension(:), allocatable :: flavors
	call hard_interaction_get_unstable_products (dp%hi, flavors)
	end subroutine dipole_integrated_qed_get_unstable_products

	subroutine dipole_integrated_qed_reset_helicity_selection &
	(dp, threshold, cutoff)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	real(default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	call hard_interaction_reset_helicity_selection (dp%hi, threshold, cutoff)
	end subroutine dipole_integrated_qed_reset_helicity_selection

	subroutine dipole_integrated_qed_update_alpha_s (dp, alphas, index)
	type(dipole_integrated_qed_t), intent(inout) :: dp
	real(default), intent(in) :: alphas
	integer, intent(in), optional :: index
	integer :: i
	dp%kinematics(get_index (dp, index))%alphas = alphas
	dp%alphas_updated = .true.
	end subroutine dipole_integrated_qed_update_alpha_s

	function dipole_integrated_qed_get_int_ptr (dp, index) result (int)
	type(dipole_integrated_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	type(interaction_t), pointer :: int
	int => evaluator_get_int_ptr ( &
	dp%kinematics(get_index (dp, index))%eval_square)
	end function dipole_integrated_qed_get_int_ptr

	function dipole_integrated_qed_get_eval_trace_ptr (dp, index) result (eval)
	type(dipole_integrated_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval
	eval => dp%kinematics(get_index (dp, index))%eval_trace
	end function dipole_integrated_qed_get_eval_trace_ptr

	function dipole_integrated_qed_get_eval_sqme_ptr (dp, index) result (eval)
	type(dipole_integrated_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval
	eval => dp%kinematics(get_index (dp, index))%eval_sqme
	end function dipole_integrated_qed_get_eval_sqme_ptr

	subroutine dipole_integrated_qed_write_state_summary (dp, unit)
	type(dipole_integrated_qed_t), intent(in) :: dp
	integer, intent(in), optional :: unit
	call hard_interaction_write_state_summary (dp%hi, unit)
	end subroutine dipole_integrated_qed_write_state_summary

	function dipole_integrated_qed_is_valid (dp) result (flag)
	type(dipole_integrated_qed_t), intent(in) :: dp
	logical :: flag
	flag = hard_interaction_is_valid (dp%hi)
	end function dipole_integrated_qed_is_valid

	function dipole_integrated_qed_get_id (dp) result (id)
	type(dipole_integrated_qed_t), intent(in) :: dp
	type(string_t) :: id
	id = hard_interaction_get_id (dp%hi)
	end function dipole_integrated_qed_get_id

	@ %def dipole_integrated_qed_unload
	@ %def dipole_integrated_qed_reload
	@ %def dipole_integrated_qed_update_parameters
	@ %def dipole_integrated_qed_get_model_ptr
	@ %def dipole_integrated_qed_get_n_in
	@ %def dipole_integrated_qed_get_n_out
	@ %def dipole_integrated_qed_get_n_tot
	@ %def dipole_integrated_qed_get_n_flv
	@ %def dipole_integrated_qed_get_flv_states
	@ %def dipole_integrated_qed_get_first_pdg_in
	@ %def dipole_integrated_qed_get_first_pdg_out
	@ %def dipole_integrated_qed_get_unstable_products
	@ %def dipole_integrated_qed_reset_helicity_selection
	@ %def dipole_integrated_qed_update_alpha_s
	@ %def dipole_integrated_qed_get_int_ptr
	@ %def dipole_integrated_qed_get_eval_trace_ptr
	@ %def dipole_integrated_qed_get_eval_sqme_ptr
	@ %def dipole_integrated_qed_write_state_summary
	@ %def dipole_integrated_qed_is_valid
	@ %def dipole_integrated_qed_get_id
	@

	\subsection{Real QED Dipoles}

	Real QED dipoles.

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

	module dipoles_real_qed

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use sm_physics !NODEP!
	use md5
	use lorentz !NODEP!
	use models
	use flavors
	use quantum_numbers
	use interactions
	use evaluators
	use particles
	use hard_interactions
	use quantum_numbers
	use nlo_setup
	use process_libraries
	use interactions
	use state_matrices

	<<Standard module head>>

	<<Real QED dipoles: public>>

	<<Real QED dipoles: parameters>>

	<<Real QED dipoles: types>>

	<<Real QED dipoles: variables>>

	<<Real QED dipoles: interfaces>>

	contains

	<<Real QED dipoles: procedures>>

	end module dipoles_real_qed
	@ %def dipoles_integrated_qed
	@ %
	The different dipole types.
	<<Real QED dipoles: parameters>>=
	integer, parameter :: DIPOLE_FF = 1, DIPOLE_IF = 2, DIPOLE_FI = 3, &
	DIPOLE_II = 5
	integer, parameter :: DIPOLE_RAD = 1, DIPOLE_SPLIT = 2
	@ %def DIPOLE_FF DIPOLE_IF DIPOLE_FI DIPOLE_II
	@ %
	A single dipole component.
	<<Real QED dipoles: types>>=
	type dipole_single_t
	integer :: em, sp
	integer :: type, splitting
	end type dipole_single_t

	@ %def dipole_single_t
	@
	Each emitter / spectator combination is associated with a phase space
	configuration.
	<<Real QED dipoles: types>>=
	type kinematic_configuration_t
	! Kinematics
	type(vector4_t), dimension(:), allocatable :: momenta
	logical :: passed = .true.
	real(default) :: alphas
	! Dipole
	type(dipole_single_t) :: component
	real(default) :: component_value
	real(default), dimension(:), allocatable :: charge_factors
	integer, dimension(:), allocatable :: me_factor_map
	real(default), dimension(:), allocatable :: me_factors
	! Evaluators
	type(evaluator_t) :: eval_square
	type(evaluator_t) :: eval_trace
	type(evaluator_t) :: eval_sqme
	end type kinematic_configuration_t

	@ %def kinematics_configuration_t
	@
	The actual subtraction term. If [[resolve]] is switched on, the dipole presents
	a single out interaction including the resolved photon --- this is intented only
	for debugging and benchmarking purposes. If [[resolve]] is off, every dipole
	component corresponds to a distinct out configuration which does not include the
	photon and is equipped with the twisted kinematics of the core matrix element.
	This ensures that the photon is treated similarly both in the numerical and the
	analytical integration.

	Note that [[tot]] and [[eff]] have a different
	meaning here w.r.t. the [[core_interaction]] methods: [[n_eff]] is the number of
	legs of the core $2\rightarrow n$ interaction, why [[n_tot]] is the number of
	legs of the out interactions (either $n+2$ or $n+3$, depending on the status of
	[[resolve]]).
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_t
	<<Real QED dipoles: types>>=
	type dipole_real_qed_t
	private
	logical :: resolve = .false.
	logical :: photon_splittings = .false.
	logical :: have_sqme = .false.
	integer :: n_tot, n_eff
	real(kind=default) :: alpha = 0
	real(kind=default) :: mreg = 0
	logical :: alphas_updated = .false.
	type(flavor_t), dimension(:,:), allocatable :: &
	flavor_states_tot, flavor_states_eff
	real(kind=default), dimension(:), allocatable :: masses
	type(dipole_single_t), dimension(:), allocatable :: dipoles
	type(hard_interaction_t) :: hi
	integer, dimension(:), allocatable :: active_particles
	type(vector4_t), dimension(:), allocatable :: momenta
	real(kind=default) :: weight
	type(kinematic_configuration_t), dimension(:), allocatable :: kinematics
	! Collapse the subtraction terms into a single density matrix if resolve is
	! set
	type(interaction_t) :: int_resolved
	type(evaluator_t) :: trace_resolved
	type(evaluator_t) :: sqme_resolved
	logical :: passed
	! Workspace for evaluation
	real(default), dimension(:,:), allocatable :: inv, xia, xab, yij
	end type dipole_real_qed_t

	@ %def
	@ %
	Initialization. Lotsa stuff.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_init
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_init &
	(dp, prc_lib, process_index, process_id, model, alpha, nlo_setup)
	type(dipole_real_qed_t), intent(out) :: dp
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(model_t), target :: model
	real(kind=default), intent(in), optional :: alpha
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	type(nlo_setup_t) :: dpc
	integer :: n_flv
	integer, dimension(:,:), allocatable :: pdg_states
	real, dimension(:), allocatable :: charge_sum
	logical, dimension(:), allocatable :: active_particle
	type(dipole_single_t), dimension(:), allocatable :: tmp
	integer :: i, j, n, em, sp, n_eff, n_tot
	if (present (nlo_setup)) then
	dpc = nlo_setup
	else
	dpc = process_library_get_nlo_setup (prc_lib, process_id)
	end if
	dp%resolve = .false.
	if (dpc%resolve_set) dp%resolve = dpc%resolve
	! Hard interaction
	call hard_interaction_init (dp%hi, prc_lib, process_index, process_id, model)
	if (hard_interaction_get_n_in (dp%hi) /= 2) call msg_bug ( &
	"dipoles for decay processes are not supported yet.")
	dp%n_eff = hard_interaction_get_n_tot (dp%hi)
	if (dp%n_eff /= dpc%n_tot .and. dpc%n_tot > 0) then
	call msg_error ("mismatch in dipole setup.")
	dpc%n_tot = -1
	if (allocated (dpc%charges)) deallocate (dpc%charges)
	if (allocated (dpc%masses)) deallocate (dpc%masses)
	if (allocated (dpc%mask)) deallocate (dpc%mask)
	end if
	if (dp%resolve) then
	dp%n_tot = dp%n_eff + 1
	else
	dp%n_tot = dp%n_eff
	end if
	! gfortran refuses to refer to the entries directly in the contains section
	n_tot = dp%n_tot
	n_eff = dp%n_eff
	! Flavor states
	n_flv = hard_interaction_get_n_flv (dp%hi)
	allocate (dp%flavor_states_tot(n_tot, n_flv))
	allocate (dp%flavor_states_eff(n_eff, n_flv))
	allocate (pdg_states(n_eff, n_flv))
	pdg_states = hard_interaction_get_flv_states (dp%hi)
	do i = 1, n_flv
	call flavor_init (dp%flavor_states_eff(:, i), pdg_states(:, i), model)
	call flavor_init (dp%flavor_states_tot(:n_eff, i), &
	pdg_states(:, i), model)
	if (dp%resolve) call flavor_init ( &
	dp%flavor_states_tot(n_tot, i), 22, model)
	end do
	! Masses
	allocate (dp%masses (n_eff))
	if (allocated (dpc%masses)) then
	dp%masses = dpc%masses ** 2
	else
	dp%masses = flavor_get_mass (dp%flavor_states_eff(:, 1)) ** 2
	end if
	! Alpha / mreg
	if (present (alpha)) dp%alpha = alpha
	dp%mreg = dpc%mreg
	! Mometa
	allocate (dp%momenta(n_eff+1))
	! Count the charged flavors
	allocate (charge_sum(n_eff))
	charge_sum = 0
	do i = 1, n_flv
	charge_sum = charge_sum + abs (flavor_get_charge ( &
	dp%flavor_states_eff(:, i)))
	end do
	n = count (charge_sum > epsilon (one))
	! Determine dipole components
	allocate (tmp(2(n*2 - n)))
	allocate (active_particle(n_eff))
	active_particle = .false.
	n = 1
	do i = 1, n_eff
	do j = 1, n_eff
	if (i == j) cycle
	if (abs (charge_sum(i) * charge_sum(j)) < epsilon (one)) cycle
	if (.not. in_mask (i, j, dpc%mask)) cycle
	active_particle(i) = .true.
	active_particle(j) = .true.
	tmp(n)%em = i
	tmp(n)%sp = j
	tmp(n)%splitting = DIPOLE_RAD
	if (max (i, j) == 2) then
	tmp(n)%type = DIPOLE_II
	elseif (i <= 2) then
	tmp(n)%type = DIPOLE_IF
	elseif (j <= 2) then
	tmp(n)%type = DIPOLE_FI
	else
	tmp(n)%type = DIPOLE_FF
	end if
	n = n + 1
	end do
	end do
	allocate (dp%dipoles(n-1))
	if (n > 1) dp%dipoles = tmp(1:n-1)
	allocate (dp%active_particles(count (active_particle)))
	i = 1
	do j = 1, n_eff
	if (active_particle(j)) then
	dp%active_particles(i) = j
	i = i + 1
	end if
	end do
	! Workspace
	allocate ( &
	dp%inv(n_eff+1, n_eff+1), &
	dp%xia(3:n_eff, 2), &
	dp%xab(2, 2), &
	dp%yij(3:n_eff, 3:n_eff) &
	)
	! Kinematic configurations
	allocate (dp%kinematics(size (dp%dipoles)))
	do i = 1, size (dp%dipoles)
	call init_kinematic_configuration (i, dp%kinematics(i))
	end do
	if (dp%resolve .and. size (dp%dipoles) > 0) call setup_int_resolved
	dp%have_sqme = .false.

	contains

	subroutine setup_int_resolved
	type(quantum_numbers_mask_t), dimension(n_tot) :: qn_mask
	type(quantum_numbers_t), dimension(n_tot) :: qn
	type(flavor_t) :: flv
	type(interaction_t), pointer :: int_src
	integer :: i, me_index
	int_src => evaluator_get_int_ptr (dp%kinematics(1)%eval_square)
	qn_mask(:n_eff) = interaction_get_mask (int_src)
	call quantum_numbers_mask_init (qn_mask(n_tot), &
	.false., .true., .true.)
	call flavor_init (flv, 22, model)
	call quantum_numbers_init (qn(n_tot), flv)
	call interaction_init (dp%int_resolved, 2, 0, n_tot - 2, &
	mask = qn_mask, &
	resonant = (/interaction_get_resonance_flags (int_src), .false./) &
	)
	do i = 3, n_tot
	call interaction_relate (dp%int_resolved, 1, i)
	call interaction_relate (dp%int_resolved, 2, i)
	end do
	do i = 1, interaction_get_n_matrix_elements (int_src)
	qn(:n_eff) = interaction_get_quantum_numbers (int_src, i)
	call interaction_add_state (dp%int_resolved, qn, &
	me_index = me_index)
	if (me_index /= i) call msg_bug ( &
	"internal error in dipole_real_qed_init")
	end do
	call interaction_freeze (dp%int_resolved)
	end subroutine setup_int_resolved

	subroutine init_kinematic_configuration (i, k)
	integer, intent(in) :: i
	type(kinematic_configuration_t), intent(out) :: k
	type(quantum_numbers_mask_t), dimension(n_eff) :: qn_mask
	integer :: j, l
	type(interaction_t), pointer :: int_square
	type(flavor_t), dimension(n_eff) :: flv
	call quantum_numbers_mask_init (qn_mask, .false., .true., .true.)
	call evaluator_init_square (k%eval_square, &
	hard_interaction_get_int_ptr (dp%hi), qn_mask)
	k%component = dp%dipoles(i)
	allocate (k%charge_factors (n_flv))
	forall (j = 1:n_flv) &
	k%charge_factors (j) = &
	flavor_get_charge (dp%flavor_states_eff(k%component%em, j)) * &
	flavor_get_charge (dp%flavor_states_eff(k%component%sp, j))
	int_square => evaluator_get_int_ptr (k%eval_square)
	allocate (k%me_factors(n_flv))
	allocate (k%me_factor_map(interaction_get_n_matrix_elements (int_square)))
	do j = 1, size (k%me_factor_map)
	flv = quantum_numbers_get_flavor ( &
	interaction_get_quantum_numbers (int_square, j))
	do l = 1, n_flv
	if (all (flv == dp%flavor_states_eff(:, l))) exit
	end do
	k%me_factor_map(j) = l
	end do
	allocate (k%momenta(n_eff))
	end subroutine init_kinematic_configuration

	function in_mask (em, sp, mask) result (flag)
	integer, intent(in) :: em, sp
	integer, dimension(:), intent(in), allocatable :: mask
	logical :: flag
	integer :: i
	flag = .true.
	if (.not. allocated(mask)) return
	if (size (mask) == 0) return
	do i = 0, size (mask) / 2 - 1
	if (em == mask(2i + 1) .and. sp == mask(2i + 2)) return
	end do
	flag = .false.
	end function in_mask

	end subroutine dipole_real_qed_init

	@ %def dipole_real_qed_init
	@ %
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_final
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_final (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	integer :: i
	if (allocated (dp%kinematics)) then
	do i = 1, size (dp%kinematics)
	call kinematic_configuration_final (dp%kinematics(i))
	end do
	deallocate (dp%kinematics)
	end if
	if (allocated (dp%flavor_states_tot)) deallocate (dp%flavor_states_tot)
	if (allocated (dp%flavor_states_eff)) deallocate (dp%flavor_states_eff)
	if (allocated (dp%masses)) deallocate (dp%masses)
	if (allocated (dp%dipoles)) deallocate (dp%dipoles)
	call hard_interaction_final (dp%hi)
	if (allocated (dp%active_particles)) deallocate (dp%active_particles)
	if (allocated (dp%momenta)) deallocate (dp%momenta)
	if (dp%resolve) then
	call interaction_final (dp%int_resolved)
	call evaluator_final (dp%trace_resolved)
	end if
	if (allocated (dp%inv)) deallocate (dp%inv)
	if (allocated (dp%xia)) deallocate (dp%xia)
	if (allocated (dp%xab)) deallocate (dp%xab)
	if (allocated (dp%yij)) deallocate (dp%yij)
	contains

	subroutine kinematic_configuration_final (k)
	type(kinematic_configuration_t), intent(inout) :: k
	deallocate (k%momenta)
	deallocate (k%charge_factors)
	deallocate (k%me_factor_map)
	deallocate (k%me_factors)
	call evaluator_final (k%eval_square)
	call evaluator_final (k%eval_trace)
	end subroutine kinematic_configuration_final

	end subroutine dipole_real_qed_final

	@ %def dipole_real_qed_final
	@ %
	Initialize the trace.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_init_trace
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_init_trace (dp, qn_mask_in)
	type(dipole_real_qed_t), intent(inout) :: dp
	type(quantum_numbers_mask_t), intent(in), dimension(2) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask
	integer :: i
	qn_mask(:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.)
	if (dp%resolve) then
	call evaluator_init_qn_sum (dp%trace_resolved, dp%int_resolved, qn_mask)
	else
	do i = 1, size (dp%kinematics)
	call evaluator_init_qn_sum (dp%kinematics(i)%eval_trace, &
	dp%kinematics(i)%eval_square, qn_mask)
	end do
	end if
	end subroutine dipole_real_qed_init_trace

	@ %def dipole_real_qed_init_trace
	@ %
	Initialize / finalize the sqme evaluator.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_init_sqme
	public :: dipole_real_qed_final_sqme
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_init_sqme (dp, qn_mask_in)
	type(dipole_real_qed_t), intent(inout) :: dp
	type(quantum_numbers_mask_t), intent(in), dimension(2) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask
	integer :: i
	qn_mask(:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.)
	if (dp%resolve) then
	if (all (qn_mask_in .eqv. &
	interaction_get_mask (dp%int_resolved, (/1, 2/)))) then
	call evaluator_init_identity (dp%sqme_resolved, dp%int_resolved)
	else
	call evaluator_init_qn_sum (dp%sqme_resolved, dp%int_resolved, &
	qn_mask)
	end if
	else
	if (size (dp%kinematics) < 1) return
	if (all (qn_mask_in .eqv. interaction_get_mask (evaluator_get_int_ptr ( &
	dp%kinematics(1)%eval_square), (/1, 2/)))) then
	do i = 1, size (dp%kinematics)
	call evaluator_init_identity (dp%kinematics(i)%eval_sqme, &
	dp%kinematics(i)%eval_square)
	end do
	else
	do i = 1, size (dp%kinematics)
	call evaluator_init_qn_sum (dp%kinematics(i)%eval_sqme, &
	dp%kinematics(i)%eval_square, qn_mask)
	end do
	end if
	end if
	dp%have_sqme = .true.
	end subroutine dipole_real_qed_init_sqme

	subroutine dipole_real_qed_final_sqme (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	integer :: i
	if (.not. dp%have_sqme) return
	if (dp%resolve) then
	call evaluator_final (dp%sqme_resolved)
	else
	do i = 1, size (dp%kinematics)
	call evaluator_final (dp%kinematics(i)%eval_sqme)
	end do
	end if
	dp%have_sqme = .false.
	end subroutine dipole_real_qed_final_sqme

	@ %def dipole_real_qed_init_sqme dipole_real_qed_final_sqme
	@
	Assignment. Sigh, allocation on assignment would be a real boon here.
	<<Real QED dipoles: public>>=
	public :: assignment(=)
	<<Real QED dipoles: interfaces>>=
	interface assignment(=)
	module procedure dipole_real_qed_assign
	end interface
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_assign (to, from)
	type(dipole_real_qed_t), intent(out) :: to
	type(dipole_real_qed_t), intent(in) :: from
	integer :: i
	to%resolve = from%resolve
	to%photon_splittings = from%photon_splittings
	to%n_tot = from%n_tot
	to%n_eff = from%n_eff
	to%alpha = from%alpha
	to%mreg = from%mreg
	to%alphas_updated = from%alphas_updated
	to%have_sqme = from%have_sqme
	allocate (to%flavor_states_tot (from%n_tot, &
	size (from%flavor_states_tot, 2)))
	to%flavor_states_tot = from%flavor_states_tot
	allocate (to%flavor_states_eff(from%n_eff, &
	size (from%flavor_states_eff, 2)))
	to%flavor_states_eff = from%flavor_states_eff
	allocate (to%masses(size (from%masses)))
	to%masses = from%masses
	allocate (to%dipoles(size (from%dipoles)))
	to%dipoles = from%dipoles
	to%hi = from%hi
	allocate (to%active_particles(size (from%active_particles)))
	to%active_particles = from%active_particles
	allocate (to%momenta(size (from%momenta)))
	to%momenta = from%momenta
	to%weight = from%weight
	allocate (to%kinematics(size (from%kinematics)))
	do i = 1, size (to%kinematics)
	call kinematic_configuration_assign (to%kinematics(i), &
	from%kinematics(i))
	end do
	to%int_resolved = from%int_resolved
	to%trace_resolved = from%trace_resolved
	to%sqme_resolved = from%sqme_resolved
	to%passed = from%passed
	if (to%resolve) then
	call evaluator_replace_interaction (to%trace_resolved, &
	to%int_resolved)
	if (from%have_sqme) &
	call evaluator_replace_interaction (to%sqme_resolved, &
	to%int_resolved)
	end if
	allocate ( &
	to%inv(to%n_eff+1, to%n_eff+1), &
	to%xia(3:to%n_eff, 2), &
	to%xab(2, 2), &
	to%yij(3:to%n_eff, 3:to%n_eff) &
	)
	to%inv = from%inv
	to%xia = from%xia
	to%xab = from%xab
	to%yij = from%yij

	contains

	subroutine kinematic_configuration_assign (k_to, k_from)
	type(kinematic_configuration_t), intent(in) :: k_from
	type(kinematic_configuration_t), intent(out) :: k_to
	allocate (k_to%momenta(size (k_from%momenta)))
	k_to%momenta = k_from%momenta
	k_to%passed = k_from%passed
	k_to%alphas = k_from%alphas
	k_to%component = k_from%component
	k_to%component_value = k_from%component_value
	allocate (k_to%charge_factors(size (k_from%charge_factors)))
	k_to%charge_factors = k_from%charge_factors
	allocate (k_to%me_factor_map(size (k_from%me_factor_map)))
	k_to%me_factor_map = k_from%me_factor_map
	allocate (k_to%me_factors(size (k_from%me_factors)))
	k_to%me_factors = k_from%me_factors
	k_to%eval_square = k_from%eval_square
	k_to%eval_trace = k_from%eval_trace
	k_to%eval_sqme = k_from%eval_sqme
	call evaluator_replace_interaction (k_to%eval_square, &
	hard_interaction_get_int_ptr (to%hi))
	if (.not. to%resolve) then
	call evaluator_replace_interaction ( &
	k_to%eval_trace, evaluator_get_int_ptr (k_to%eval_square))
	if (from%have_sqme) call evaluator_replace_interaction ( &
	k_to%eval_sqme, evaluator_get_int_ptr (k_to%eval_square))
	end if
	end subroutine kinematic_configuration_assign

	end subroutine dipole_real_qed_assign

	@ %def dipole_real_qed_assign
	@
	Prepare for a new evaluation cycle.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_reset
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_reset (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	integer :: i
	dp%passed = .false.
	do i = 1, size (dp%kinematics)
	dp%kinematics(i)%passed = .false.
	end do
	end subroutine dipole_real_qed_reset

	@ %def dipole_real_qed_reset
	@
	Set / get electroweak $\alpha$.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_get_alpha
	public :: dipole_real_qed_set_alpha
	<<Real QED dipoles: procedures>>=
	function dipole_real_qed_get_alpha (dp) result (alpha)
	type(dipole_real_qed_t), intent(in) :: dp
	real(kind=default) :: alpha
	alpha = dp%alpha
	end function dipole_real_qed_get_alpha

	subroutine dipole_real_qed_set_alpha (dp, alpha)
	type(dipole_real_qed_t), intent(inout) :: dp
	real(kind=default), intent(in) :: alpha
	dp%alpha = alpha
	end subroutine dipole_real_qed_set_alpha

	@ %def dipole_real_qed_set_alpha dipole_real_qed_get_alpha
	@ %
	Get the number of out type kinematics.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_get_n_kinematics_out
	<<Real QED dipoles: procedures>>=
	function dipole_real_qed_get_n_kinematics_out (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	if (dp%resolve) then
	n = 1
	else
	n = size (dp%kinematics)
	end if
	end function dipole_real_qed_get_n_kinematics_out

	@ %def dipole_real_qed_get_n_kinematics_out
	@
	Get the ingoing momenta.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_get_momenta_in
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_get_momenta_in (dp, mom)
	type(dipole_real_qed_t), intent(in) :: dp
	type(vector4_t), dimension(2), intent(out) :: mom
	mom = dp%momenta(:2)
	end subroutine dipole_real_qed_get_momenta_in

	@ %def dipole_real_qed_get_momenta_in
	@
	Set the outgoing momenta.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_set_momenta_out
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_set_momenta_out (dp, mom)
	type(dipole_real_qed_t), intent(inout) :: dp
	type(vector4_t), intent(in), dimension(:) :: mom
	dp%momenta(3:) = mom
	end subroutine dipole_real_qed_set_momenta_out

	@ %def dipole_real_qed_set_momenta_out
	@
	Set / get the phasespace weight.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_set_weight
	public :: dipole_real_qed_get_weight
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_set_weight (dp, weight)
	type(dipole_real_qed_t), intent(inout) :: dp
	real(kind=default), intent(in) :: weight
	dp%weight = weight
	end subroutine dipole_real_qed_set_weight

	function dipole_real_qed_get_weight (dp) result (weight)
	type(dipole_real_qed_t), intent(in) :: dp
	real(kind=default) :: weight
	weight = dp%weight
	end function dipole_real_qed_get_weight

	@ %def dipole_real_qed_get_weight dipole_real_qed_set_weight
	@
	Get / set the cut status.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_kinematics_passed
	public :: dipole_real_qed_get_cut_status
	public :: dipole_real_qed_set_cut_status
	public :: dipole_real_qed_any_passed
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_kinematics_passed (dp, stat)
	type(dipole_real_qed_t), intent(inout) :: dp
	logical, intent(in) :: stat
	integer :: i
	if (dp%resolve) then
	dp%passed = stat
	end if
	dp%kinematics(:)%passed = stat
	end subroutine dipole_real_qed_kinematics_passed

	subroutine dipole_real_qed_set_cut_status (dp, stat, index)
	type(dipole_real_qed_t), intent(inout) :: dp
	logical, intent(in) :: stat
	integer, intent(in), optional :: index
	integer :: i
	i = 1; if (present (index)) i = index
	if (dp%resolve) then
	dp%passed = stat
	end if
	dp%kinematics(i)%passed = stat
	end subroutine dipole_real_qed_set_cut_status

	function dipole_real_qed_get_cut_status (dp, index) result (stat)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, intent(in), optional :: index
	logical :: stat
	integer :: i
	i = 1; if (present (index)) i = index
	if (dp%resolve) then
	stat = dp%passed
	else
	stat = dp%kinematics(i)%passed
	end if
	end function dipole_real_qed_get_cut_status

	function dipole_real_qed_any_passed (dp) result (stat)
	type(dipole_real_qed_t), intent(in) :: dp
	logical :: stat
	if (dp%resolve) then
	stat = dp%passed
	else
	stat = any (dp%kinematics(:)%passed)
	end if
	end function dipole_real_qed_any_passed

	@ %def dipole_real_qed_kinematics_passed
	@ %def dipole_real_qed_set_cut_status
	@ %def dipole_real_qed_get_cut_status
	@ %def dipole_real_qed_any_passed
	@
	Calculate the dipole kinematics.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_digest_kinematics_out
	public :: dipole_real_qed_digest_kinematics_in
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_digest_kinematics_in (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	if (dp%resolve) then
	dp%momenta(:2) = interaction_get_momenta (dp%int_resolved, &
	outgoing = .false.)
	else
	dp%momenta(:2) = interaction_get_momenta (evaluator_get_int_ptr ( &
	dp%kinematics(1)%eval_square), outgoing = .false.)
	end if
	end subroutine dipole_real_qed_digest_kinematics_in

	subroutine dipole_real_qed_digest_kinematics_out (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	integer :: i, j, a, b, m, em, sp
	type(vector4_t) :: k, pab, pabprime, psum
	type(interaction_t), pointer :: int
	real(default) :: pab2
	m = dp%n_eff + 1
	do i = 1, size (dp%active_particles)
	a = dp%active_particles(i)
	dp%inv(a, m) = dp%momenta(a) * dp%momenta(m)
	dp%inv(m, a) = dp%inv(a, m)
	do j = i + 1, size (dp%active_particles)
	b = dp%active_particles(j)
	dp%inv(a, b) = dp%momenta(a) * dp%momenta(b)
	dp%inv(b, a) = dp%inv(a, b)
	end do
	end do
	do i = 1, size (dp%active_particles)
	do j = 1, size (dp%active_particles)
	if (i == j) cycle
	a = dp%active_particles(i)
	b = dp%active_particles(j)
	if (a > 2 .and. b > 2) &
	dp%yij(a, b) = dp%inv(a, m) / (dp%inv(a, b) + &
	dp%inv(a, m) + dp%inv(b, m))
	if (a > 2 .and. b < 3) &
	dp%xia(a, b) = (dp%inv(b, a) + dp%inv(b, m) - dp%inv(a, m)) / &
	(dp%inv(b, a) + dp%inv (b, m))
	if (a < 3 .and. b < 3) &
	dp%xab(a, b) = (dp%inv(a, b) - dp%inv(a, m) - dp%inv(b, m)) / &
	dp%inv(a, b)
	end do
	end do
	k = dp%momenta(m)
	do i = 1, size (dp%kinematics)
	em = dp%kinematics(i)%component%em
	sp = dp%kinematics(i)%component%sp
	select case (dp%kinematics(i)%component%type)
	case (DIPOLE_FF)
	dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff)
	dp%kinematics(i)%momenta(sp) = &
	dp%momenta(sp) / (one - dp%yij(em, sp))
	dp%kinematics(i)%momenta(em) = dp%momenta(em) + k - dp%yij(em, sp) * &
	dp%kinematics(i)%momenta(sp)
	case (DIPOLE_IF)
	dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff)
	dp%kinematics(i)%momenta(em) = dp%xia(sp, em) * dp%momenta(em)
	dp%kinematics(i)%momenta(sp) = &
	dp%momenta(sp) + k - (one - dp%xia(sp, em)) * &
	dp%momenta(em)
	case (DIPOLE_FI)
	dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff)
	dp%kinematics(i)%momenta(em) = &
	dp%momenta(em) + k - (one - dp%xia(em, sp)) * &
	dp%momenta(sp)
	dp%kinematics(i)%momenta(sp) = dp%xia(em, sp) * dp%momenta(sp)
	case (DIPOLE_II)
	dp%kinematics(i)%momenta(em) = dp%xab(em, sp) * dp%momenta(em)
	dp%kinematics(i)%momenta(sp) = dp%momenta(sp)
	pab = dp%momenta(em) + dp%momenta(sp) - k
	pabprime = dp%kinematics(i)%momenta(em) + dp%momenta(sp)
	pab2 = pab * pab
	psum = pab + pabprime
	forall (j = 3:dp%n_eff) dp%kinematics(i)%momenta(j) = dp%momenta(j) - &
	psum * (psum * dp%momenta(j)) / (pab2 + pab * pabprime) + &
	pabprime * (pab * dp%momenta(j)) * two / pab2
	end select
	int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square)
	call interaction_set_momenta (int, dp%kinematics(i)%momenta)
	end do
	if (dp%resolve) call interaction_set_momenta ( &
	dp%int_resolved, dp%momenta)
	end subroutine dipole_real_qed_digest_kinematics_out

	@ %def dipole_real_qed_digest_kinematics_out
	@ %def dipole_real_qed_digest_kinematics_in
	@
	Complete the dipole evaluation and set the matrix elements.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_evaluate
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_evaluate (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	integer :: i, j, a, b, m, em, sp
	real(default), dimension(3:dp%n_eff+1, 3:dp%n_eff+1) :: zij
	real(default), dimension(3:dp%n_eff+1, 2) :: zia
	type(vector4_t) :: k
	type(interaction_t), pointer :: hi_int, int_square
	complex(default), dimension(:), allocatable :: me
	real(default) :: pref
	integer :: n_me

	real(default) :: sqme

	pref = dp%alpha * four * pi
	if (dp%resolve) then
	n_me = interaction_get_n_matrix_elements (dp%int_resolved)
	allocate (me(n_me))
	me = 0
	if (.not. dp%passed) then
	call interaction_set_matrix_element (dp%int_resolved, me)
	call evaluator_evaluate (dp%trace_resolved)
	return
	end if
	end if
	m = dp%n_eff + 1
	do i = 1, size (dp%active_particles)
	do j = 1, size (dp%active_particles)
	if (i == j) cycle
	a = dp%active_particles(i)
	b = dp%active_particles(j)
	if (a > 2 .and. b > 2) &
	zij(a, b) = dp%inv(a, b) / (dp%inv(a, b) + dp%inv(b, m))
	if (a > 2 .and. b < 3) &
	zia(a, b) = dp%inv(b, a) / (dp%inv(b, a) + dp%inv (b, m))
	end do
	end do
	k = dp%momenta(m)
	hi_int => hard_interaction_get_int_ptr (dp%hi)
	do i = 1, size (dp%kinematics)
	em = dp%kinematics(i)%component%em
	sp = dp%kinematics(i)%component%sp
	if (dp%kinematics(i)%passed) then
	select case (dp%kinematics(i)%component%type)
	case (DIPOLE_FF)
	dp%kinematics(i)%component_value = &
	( two / (one - zij(em, sp) * (one - dp%yij(em, sp))) &
	- one - zij(em, sp)) / dp%inv(em, m) / (one - dp%yij(em, sp))
	case (DIPOLE_IF)
	dp%kinematics(i)%component_value = &
	- ( two / (two - dp%xia(sp, em) - zia(sp, em)) &
	- one - dp%xia(sp, em) ) / dp%inv(em, m) / dp%xia(sp, em)
	case (DIPOLE_FI)
	dp%kinematics(i)%component_value = &
	- ( two / (two - dp%xia(em, sp) - zia(em, sp)) &
	- one - zia(em, sp) ) / dp%inv(em, m) / dp%xia(em, sp)
	case (DIPOLE_II)
	dp%kinematics(i)%component_value = &
	(two / (one - dp%xab(em, sp)) - one - dp%xab(em, sp) &
	) / dp%inv(em, m) / dp%xab(em, sp)
	end select
	else
	dp%kinematics(i)%component_value = 0
	end if
	dp%kinematics(i)%me_factors = dp%kinematics(i)%component_value * &
	dp%kinematics(i)%charge_factors * pref
	int_square => evaluator_get_int_ptr (dp%kinematics(i)%eval_square)
	if (dp%alphas_updated) call hard_interaction_update_alpha_s ( &
	dp%hi, dp%kinematics(i)%alphas)
	call interaction_set_momenta (hi_int, dp%kinematics(i)%momenta)
	call hard_interaction_evaluate (dp%hi)
	call evaluator_evaluate (dp%kinematics(i)%eval_square)
	sqme = evaluator_sum (dp%kinematics(i)%eval_square)
	do j = 1, interaction_get_n_matrix_elements (int_square)
	call interaction_set_matrix_element (int_square, j, &
	interaction_get_matrix_element (int_square, j) * &
	dp%kinematics(i)%me_factors( &
	dp%kinematics(i)%me_factor_map(j)) &
	)
	end do
	if (.not. dp%resolve) then
	call evaluator_receive_momenta (dp%kinematics(i)%eval_trace)
	call evaluator_evaluate (dp%kinematics(i)%eval_trace)
	end if
	if (dp%have_sqme .and. .not. dp%resolve) then
	call evaluator_receive_momenta (dp%kinematics(i)%eval_sqme)
	call evaluator_evaluate (dp%kinematics(i)%eval_sqme)
	end if
	end do
	if (dp%resolve) then
	do i = 1, size (dp%kinematics)
	int_square => evaluator_get_int_ptr (dp%kinematics(i)%eval_square)
	do j = 1, n_me
	me(j) = me(j) + interaction_get_matrix_element ( &
	int_square, j)
	end do
	end do
	call interaction_set_matrix_element (dp%int_resolved, me)
	call evaluator_receive_momenta (dp%trace_resolved)
	call evaluator_evaluate (dp%trace_resolved)
	if (dp%have_sqme) then
	call evaluator_receive_momenta (dp%sqme_resolved)
	call evaluator_receive_momenta (dp%sqme_resolved)
	end if
	end if
	! call debug_hook

	contains

	subroutine debug_hook
	logical, save :: first = .true., active = .true.
	integer, save :: u, cnt = 1
	integer :: err, i
	type(quantum_numbers_mask_t), dimension(2) :: qn
	if (first) then
	first = .false.
	u = free_unit ()
	call quantum_numbers_mask_init (qn, .true., .true., .true.)
	call hard_interaction_init_trace (dp%hi, qn)
	open (u, file="dipole_real_debug.out", status="replace", &
	action="write", iostat=err)
	if (err /= 0) then
	active = .false.
	return
	end if
	end if
	write (u, '(A)') "! phase space point " // int2char (cnt)
	do i = 1, 7
	call write_momentum (dp%momenta(i), u)
	end do
	write (u, '(A)') "! dipole value: " // real2char ( &
	real (evaluator_sum (dp%trace_resolved), default) * three)
	if (size (dp%kinematics) == 1) then
	write (u, '(A)') "! matrix element: " // real2char (sqme * three)
	write (u, '(A)') "! matrix element (reference) : " // real2char ( &
	hard_interaction_compute_sqme_sum ( &
	dp%hi, dp%kinematics(1)%momenta) * three)
	write (u, '(A)') "! twisted momenta:"
	do i = 1, 6
	call write_momentum (dp%kinematics(1)%momenta(i), u, "! ")
	end do
	end if
	write (u, '(A)')
	cnt = cnt + 1
	if (cnt > 10) then
	close (u)
	active = .false.
	end if
	end subroutine debug_hook

	subroutine write_momentum (p, u, prefix)
	type(vector4_t), intent(in) :: p
	integer, intent(in) :: u
	character, intent(in), optional :: prefix
	integer :: i
	if (present (prefix)) write (u, '(A)', advance="no") prefix
	do i = 0, 3
	write (u, '(E20.12,2X)', advance="no") vector4_get_component (p, i)
	end do
	write (u, '(A)')
	end subroutine write_momentum

	end subroutine dipole_real_qed_evaluate

	@ %def dipole_real_qed_evaluate
	@
	Output
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_write
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_write (dp, unit, verbose)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	character(*), parameter :: del = repeat ("-", 80)
	logical :: v
	integer :: u, i
	u = output_unit (unit)
	v = .false.; if (present (verbose)) v = verbose
	write (u, '(A)') "massless unintegrated QED dipole"
	write (u, '(3X,A,L1)') "resolve = ", dp%resolve
	write (u, '(3X,A,L1)') "photon_splittings = ", dp%resolve
	write (u, '(3X,A,I2)') "n_tot = ", dp%n_tot
	write (u, '(3X,A,I2)') "n_eff = ", dp%n_eff
	write (u, '(3X,A,E12.5)') "alpha = ", dp%alpha
	write (u, '(3X,A,E12.5)') "mreg = ", dp%mreg
	write (u, '(3X,A)') "flavor_states_tot = "
	do i = 1, size (dp%flavor_states_tot, 2)
	call write_int_list (flavor_get_pdg (dp%flavor_states_tot(:, i)))
	end do
	write (u, '(3X,A)') "flavor_states_eff = "
	do i = 1, size (dp%flavor_states_eff, 2)
	call write_int_list (flavor_get_pdg (dp%flavor_states_eff(:, i)))
	end do
	write (u, '(3X,A)') "masses = "
	call write_real_list (dp%masses)
	write (u, '(3X,A)') "active_particles = "
	call write_int_list (dp%active_particles)
	write (u, '(3X,A)') "dipoles = "
	write (u, '(6X)', advance="no")
	do i = 1, size (dp%dipoles)
	write (u, '(A,2X)', advance="no") char (dipole (dp%dipoles(i)))
	end do
	write (u, '(A)')
	if (v) then
	if (dp%resolve) write (u, '(3X,L1)') "passed = ", dp%passed
	call section ("Hard interaction:")
	call hard_interaction_write (dp%hi)
	if (dp%resolve) then
	call section ("Interaction:")
	call interaction_write (dp%int_resolved)
	call section ("Evaluator:")
	call evaluator_write (dp%trace_resolved)
	write (u, '(A)') del
	write (u, '(A)')
	end if
	end if
	do i = 1, size (dp%kinematics)
	write (u, '(3X,A,I3,A)') "kinematics(", i, ") = "
	call write_kinematic_config (dp%kinematics(i))
	end do

	contains

	subroutine section (n)
	character(*), intent(in) :: n
	write (u, '(A)')
	write (u, '(A)') n
	write (u, '(A)') del
	end subroutine section

	subroutine write_real_list (x, indent)
	real(default), dimension(:), intent(in) :: x
	integer, intent(in), optional :: indent
	integer :: i, ind
	ind = 6; if (present (indent)) ind = indent
	write (u, '(A)', advance="no") repeat (" ", ind)
	do i = 1, size (x)
	write (u, '(E12.5,2X)', advance="no") x(i)
	end do
	write (u, '(A)')
	end subroutine write_real_list

	subroutine write_int_list (j, indent)
	integer, intent(in), dimension(:) :: j
	integer, intent(in), optional :: indent
	integer :: i, ind
	ind = 6; if (present (indent)) ind = indent
	write (u, '(A)', advance="no") repeat (" ", ind)
	do i = 1, size (j)
	write (u, '(A,2X)', advance="no") int2char (j(i))
	end do
	write (u, '(A)')
	end subroutine write_int_list

	function dipole (dp) result (str)
	type(dipole_single_t) :: dp
	type(string_t) :: str
	str = int2string (dp%em) // ":" // int2string (dp%sp)
	end function dipole

	subroutine write_kinematic_config (k)
	type(kinematic_configuration_t), intent(in) :: k
	write (u, '(6X,A)') "component = " // char (dipole (k%component))
	write (u, '(6X,A)') "charge factors = "
	call write_real_list (k%charge_factors, 9)
	write (u, '(6X,A)') "me_factor_map = "
	call write_int_list (k%me_factor_map, 9)
	if (v) then
	write (u, '(6X,A,L1)') "passed = ", k%passed
	write (u, '(6X,A,E12.5)') "component_value = ", k%component_value
	write (u, '(6X,A)') "me_factors = "
	call write_real_list (k%me_factors)
	call section ("Evaluator (square):")
	call evaluator_write (k%eval_square)
	call section ("Evaluator (trace):")
	call evaluator_write (k%eval_trace)
	write (u, '(A)') del
	write (u, '(A)')
	end if
	end subroutine write_kinematic_config

	end subroutine dipole_real_qed_write

	@ %def dipole_real_qed_write
	@
	Particle number queries:
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_get_n_in
	public :: dipole_real_qed_get_n_out_eff
	public :: dipole_real_qed_get_n_out_real
	public :: dipole_real_qed_get_n_tot_eff
	public :: dipole_real_qed_get_n_tot_real
	public :: dipole_real_qed_get_n_flv
	<<Real QED dipoles: procedures>>=
	function dipole_real_qed_get_n_in (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = 2
	end function dipole_real_qed_get_n_in

	function dipole_real_qed_get_n_out_eff (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = dp%n_tot - 2
	end function dipole_real_qed_get_n_out_eff

	function dipole_real_qed_get_n_out_real (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = dp%n_eff - 1
	end function dipole_real_qed_get_n_out_real

	function dipole_real_qed_get_n_tot_eff (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = dp%n_tot
	end function dipole_real_qed_get_n_tot_eff

	function dipole_real_qed_get_n_tot_real (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = dp%n_eff + 1
	end function dipole_real_qed_get_n_tot_real

	function dipole_real_qed_get_n_flv (dp) result (n)
	type(dipole_real_qed_t), intent(in) :: dp
	integer :: n
	n = size (dp%flavor_states_eff, 2)
	end function dipole_real_qed_get_n_flv

	@ %def dipole_real_qed_get_n_in
	@ %def dipole_real_qed_get_n_out_eff
	@ %def dipole_real_qed_get_n_out_real
	@ %def dipole_real_qed_get_n_tot_eff
	@ %def dipole_real_qed_get_n_tot_real
	@ %def dipole_real_qed_get_n_flv
	@
	Flavor states.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_get_flv_states_eff
	public :: dipole_real_qed_get_flv_states_real
	public :: dipole_real_qed_get_first_pdg_in
	public :: dipole_real_qed_get_first_pdg_out_eff
	public :: dipole_real_qed_get_first_pdg_out_real
	<<Real QED dipoles: procedures>>=
	function dipole_real_qed_get_flv_states_eff (dp) result (flv)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, dimension(:,:), allocatable :: flv
	integer :: i
	allocate (flv (size (dp%flavor_states_tot, 1), size (dp%flavor_states_tot, 2)))
	forall (i = 1:size (flv, 2)) &
	flv(:, i) = flavor_get_pdg (dp%flavor_states_tot(:, i))
	end function dipole_real_qed_get_flv_states_eff

	function dipole_real_qed_get_flv_states_real (dp) result (flv)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, dimension(:,:), allocatable :: flv
	integer :: i
	allocate (flv (size (dp%flavor_states_eff, 1) + 1, size (dp%flavor_states_eff, 2)))
	forall (i = 1:size (flv, 2)) &
	flv(:dp%n_eff, i) = flavor_get_pdg (dp%flavor_states_eff(:, i))
	flv(dp%n_eff + 1, :) = 22
	end function dipole_real_qed_get_flv_states_real

	function dipole_real_qed_get_first_pdg_in (dp) result (pdg)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, dimension(2) :: pdg
	pdg = flavor_get_pdg (dp%flavor_states_eff(:2, 1))
	end function dipole_real_qed_get_first_pdg_in

	function dipole_real_qed_get_first_pdg_out_eff (dp) result (pdg)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, dimension(dp%n_tot-2) :: pdg
	pdg = flavor_get_pdg (dp%flavor_states_tot(3:, 1))
	end function dipole_real_qed_get_first_pdg_out_eff

	function dipole_real_qed_get_first_pdg_out_real (dp) result (pdg)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, dimension(dp%n_eff-1) :: pdg
	pdg(:dp%n_eff-2) = flavor_get_pdg (dp%flavor_states_eff(3:, 1))
	pdg(dp%n_eff-1) = 22
	end function dipole_real_qed_get_first_pdg_out_real

	@ %def dipole_real_qed_get_flv_states_eff
	@ %def dipole_real_qed_get_flv_states_real
	@ %def dipole_real_qed_get_first_pdg_in
	@ %def dipole_real_qed_get_first_pdg_out_eff
	@ %def dipole_real_qed_get_first_pdg_out_real
	@
	Complete the core interaction interface with wrappers around the contained hard
	interaction object.
	<<Real QED dipoles: public>>=
	public :: dipole_real_qed_unload
	public :: dipole_real_qed_reload
	public :: dipole_real_qed_update_parameters
	public :: dipole_real_qed_get_model_ptr
	public :: dipole_real_qed_get_unstable_products
	public :: dipole_real_qed_reset_helicity_selection
	public :: dipole_real_qed_update_alpha_s
	public :: dipole_real_qed_get_int_ptr
	public :: dipole_real_qed_get_eval_trace_ptr
	public :: dipole_real_qed_get_eval_sqme_ptr
	public :: dipole_real_qed_write_state_summary
	public :: dipole_real_qed_is_valid
	public :: dipole_real_qed_get_id
	<<Real QED dipoles: procedures>>=
	subroutine dipole_real_qed_unload (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	call hard_interaction_unload (dp%hi)
	end subroutine dipole_real_qed_unload

	subroutine dipole_real_qed_reload (dp, prc_lib)
	type(dipole_real_qed_t), intent(inout) :: dp
	type(process_library_t), intent(in) :: prc_lib
	call hard_interaction_reload (dp%hi, prc_lib)
	end subroutine dipole_real_qed_reload

	subroutine dipole_real_qed_update_parameters (dp)
	type(dipole_real_qed_t), intent(inout) :: dp
	call hard_interaction_update_parameters (dp%hi)
	end subroutine dipole_real_qed_update_parameters

	function dipole_real_qed_get_model_ptr (dp) result (model)
	type(dipole_real_qed_t), intent(in) :: dp
	type(model_t), pointer :: model
	model => hard_interaction_get_model_ptr (dp%hi)
	end function dipole_real_qed_get_model_ptr

	subroutine dipole_real_qed_get_unstable_products (dp, flavors)
	type(dipole_real_qed_t), intent(in) :: dp
	type(flavor_t), dimension(:), allocatable :: flavors
	call hard_interaction_get_unstable_products (dp%hi, flavors)
	end subroutine dipole_real_qed_get_unstable_products

	subroutine dipole_real_qed_reset_helicity_selection &
	(dp, threshold, cutoff)
	type(dipole_real_qed_t), intent(inout) :: dp
	real(default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	call hard_interaction_reset_helicity_selection (dp%hi, threshold, cutoff)
	end subroutine dipole_real_qed_reset_helicity_selection

	subroutine dipole_real_qed_update_alpha_s (dp, alphas, index)
	type(dipole_real_qed_t), intent(inout) :: dp
	real(default), intent(in) :: alphas
	integer, intent(in), optional :: index
	integer :: i
	i = 1; if (present (index)) i = index
	dp%kinematics(i)%alphas = alphas
	dp%alphas_updated = .true.
	end subroutine dipole_real_qed_update_alpha_s

	function dipole_real_qed_get_int_ptr (dp, index) result (int)
	type(dipole_real_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	integer :: i
	type(interaction_t), pointer :: int
	i = 1; if (present (index)) i = index
	if (dp%resolve) then
	int => dp%int_resolved
	else
	int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square)
	end if
	end function dipole_real_qed_get_int_ptr

	function dipole_real_qed_get_eval_trace_ptr (dp, index) result (eval)
	type(dipole_real_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval
	integer :: i
	i = 1; if (present (index)) i = index
	if (dp%resolve) then
	eval => dp%trace_resolved
	else
	eval => dp%kinematics(i)%eval_trace
	end if
	end function dipole_real_qed_get_eval_trace_ptr

	function dipole_real_qed_get_eval_sqme_ptr (dp, index) result (eval)
	type(dipole_real_qed_t), intent(in), target :: dp
	integer, intent(in), optional :: index
	type(evaluator_t), pointer :: eval
	integer :: i
	i = 1; if (present (index)) i = index
	if (dp%resolve) then
	eval => dp%sqme_resolved
	else
	eval => dp%kinematics(i)%eval_sqme
	end if
	end function dipole_real_qed_get_eval_sqme_ptr

	subroutine dipole_real_qed_write_state_summary (dp, unit)
	type(dipole_real_qed_t), intent(in) :: dp
	integer, intent(in), optional :: unit
	call hard_interaction_write_state_summary (dp%hi, unit)
	end subroutine dipole_real_qed_write_state_summary

	function dipole_real_qed_is_valid (dp) result (flag)
	type(dipole_real_qed_t), intent(in) :: dp
	logical :: flag
	flag = hard_interaction_is_valid (dp%hi)
	end function dipole_real_qed_is_valid

	function dipole_real_qed_get_id (dp) result (id)
	type(dipole_real_qed_t), intent(in) :: dp
	type(string_t) :: id
	id = hard_interaction_get_id (dp%hi)
	end function dipole_real_qed_get_id

	@ %def dipole_real_qed_unload
	@ %def dipole_real_qed_reload
	@ %def dipole_real_qed_update_parameters
	@ %def dipole_real_qed_get_model_ptr
	@ %def dipole_real_qed_get_unstable_products
	@ %def dipole_real_qed_reset_helicity_selection
	@ %def dipole_real_qed_update_alpha_s
	@ %def dipole_real_qed_get_int_ptr
	@ %def dipole_real_qed_get_eval_trace_ptr
	@ %def dipole_real_qed_get_eval_sqme_ptr
	@ %def dipole_real_qed_write_state_summary
	@ %def dipole_real_qed_is_valid
	@ %def dipole_real_qed_get_id
	@

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Recombinators}

	Recombinators are core interactions which map a hard interaction with an extra
	soft or collinear emission to a interaction where the emission is recombined
	with the emitter. We currently only implement this for an extra photon emission,
	QCD and photon splitting are more complicated. Also, the recombination criterion
	is currently hardcoded, but a flexible solution invoking WHIZARD's %'
	powerful expressions is desirable as the final solution.

	In order to simplify the integration over the phasespace in which no
	recombination happens, the recombinators support a ``complement'' mode of
	operation. In the mode, the contained hard interaction is wrapped directly, and
	the only modification is an enforced cut on the complement of the recombination
	criterion.

	\subsection{Photon recombination}

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

	module photon_recombination

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use sm_physics !NODEP!
	use md5
	use lorentz !NODEP!
	use models
	use flavors
	use quantum_numbers
	use interactions
	use evaluators
	use particles
	use hard_interactions
	use quantum_numbers
	use nlo_setup
	use process_libraries

	<<Standard module head>>

	<<Photon recombination: public>>

	<<Photon recombination: parameters>>

	<<Photon recombination: types>>

	<<Photon recombination: variables>>

	<<Photon recombination: interfaces>>

	contains

	<<Photon recombination: procedures>>

	end module photon_recombination
	@ %def photon_recombination
	@
	The [[photon_recombination_t]] type.
	<<Photon recombination: public>>=
	public :: photon_recombination_t
	<<Photon recombination: types>>=
	type :: photon_recombination_t
	private
	integer :: recombination_method = NLO_RECOMBINATION_RACOON
	type(hard_interaction_t) :: hi
	type(evaluator_t) :: eval_square, eval_rec
	type(evaluator_t) :: eval_trace, eval_sqme
	integer :: iphoton
	integer :: n_tot, n_flv
	integer, dimension(:,:), allocatable :: flv_states_orig, flv_states
	integer, dimension(:), allocatable :: first_pdg_orig, first_pdg
	integer, dimension(:), allocatable :: index_map
	logical, dimension(:), allocatable :: charged
	logical :: valid = .false.
	real(kind=default) :: mrecomb, photon_beam_separation
	type(vector4_t), dimension(:), allocatable :: p_orig, p_rec
	logical :: passed
	real(kind=default) :: weight
	logical :: complement = .false.
	end type photon_recombination_t

	@ %def photon_recombination_t
	@
	Initialization.
	<<Photon recombination: public>>=
	public :: photon_recombination_init
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_init (pr, prc_lib, process_index, process_id, &
	model, nlo_setup)
	type(photon_recombination_t), intent(out) :: pr
	type(process_library_t), intent(in) :: prc_lib
	integer, intent(in) :: process_index
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	type(nlo_setup_t), intent(in), optional :: nlo_setup
	integer :: i, j
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
	type(nlo_setup_t) :: setup
	logical, dimension(:), allocatable :: drop
	call hard_interaction_init (pr%hi, prc_lib, process_index, process_id, model)
	pr%valid = hard_interaction_is_valid (pr%hi)
	if (.not. pr%valid) then
	call cleanup
	return
	end if
	if (hard_interaction_get_n_in (pr%hi) /= 2) then
	call cleanup
	return
	end if
	pr%n_tot = hard_interaction_get_n_tot (pr%hi) - 1
	pr%n_flv = hard_interaction_get_n_flv (pr%hi)
	allocate (pr%flv_states_orig(pr%n_tot + 1, pr%n_flv))
	pr%flv_states_orig = hard_interaction_get_flv_states (pr%hi)
	! Identify photon
	pr%iphoton = find_index (pr%flv_states_orig(:,1), 22)
	if (pr%iphoton < 3) then
	call cleanup
	return
	end if
	! Build index map
	allocate (pr%index_map(pr%n_tot))
	i = 1
	do j = 1, pr%n_tot + 1
	if (pr%flv_states_orig(j, 1) == 22) cycle
	pr%index_map(i) = j
	i = i + 1
	end do
	! Check for consinstency and build reduced state list
	allocate (pr%flv_states(pr%n_tot, pr%n_flv))
	do i = 1, pr%n_flv
	if (count (pr%flv_states_orig(:, i) == 22) /= 1 .or. &
	pr%flv_states_orig(pr%iphoton, i) /= 22) then
	call cleanup
	return
	end if
	pr%flv_states(:, i) = pr%flv_states_orig(pr%index_map, i)
	end do
	! Identify charged final states and check for consistency
	allocate (pr%charged (pr%n_tot + 1))
	pr%charged = is_charged (pr%flv_states_orig(:,1))
	do i = 2, pr%n_flv
	if (.not. all (pr%charged(3:) .eqv. &
	is_charged (pr%flv_states_orig(3:,i)))) then
	call cleanup
	call msg_warning (&
	"mixed neutral-charged flavor products in the final state")
	call msg_warning ("are not supported by photon recombination yet")
	return
	end if
	end do
	! Effective and original 1st outgoing PDGs
	allocate (pr%first_pdg_orig (pr%n_tot - 1), &
	pr%first_pdg(pr%n_tot - 2))
	pr%first_pdg_orig = hard_interaction_get_first_pdg_out (pr%hi)
	pr%first_pdg = pr%first_pdg_orig (pr%index_map(3:) - 2)
	allocate (qn_mask(pr%n_tot + 1))
	! Allocate momenta
	allocate (pr%p_orig(pr%n_tot + 1), pr%p_rec(pr%n_tot))
	! Setup the recombination method
	if (present (nlo_setup)) then
	setup = nlo_setup
	else
	setup = process_library_get_nlo_setup (prc_lib, process_id)
	end if
	pr%recombination_method = NLO_RECOMBINATION_RACOON
	pr%mrecomb = 1
	pr%photon_beam_separation = 5._default * degree
	if (setup%recombination > 0) &
	pr%recombination_method = setup%recombination
	if (setup%mrecomb > 0) pr%mrecomb = setup%mrecomb
	if (setup%photon_beam_separation > 0) &
	pr%photon_beam_separation = setup%photon_beam_separation
	if (setup%recombination_complement_set) &
	pr%complement = setup%recombination_complement
	! Complement mode?
	if (.not. pr%complement) then
	! Init the square evaluator
	call quantum_numbers_mask_init (qn_mask, .false., .true., .false.)
	call evaluator_init_square (pr%eval_square, &
	hard_interaction_get_int_ptr (pr%hi), qn_mask)
	! Init the recombination evaluator which drops the photon
	allocate (drop(pr%n_tot + 1))
	drop = .false.
	drop(pr%iphoton) = .true.
	call evaluator_init_qn_sum (pr%eval_rec, pr%eval_square, qn_mask, drop)
	end if

	contains

	function find_index (i, j) result (k)
	integer, intent(in), dimension(:) :: i
	integer, intent(in) :: j
	integer :: k
	do k = 1, size (i)
	if (i(k) == j) return
	end do
	k = -1
	end function find_index

	subroutine cleanup
	call msg_warning ("process " // char (process_id) // &
	" not suitable for photon recombination")
	if (allocated (pr%flv_states_orig)) deallocate (pr%flv_states_orig)
	if (allocated (pr%flv_states)) deallocate (pr%flv_states)
	if (allocated (pr%p_orig)) deallocate (pr%p_orig)
	if (allocated (pr%p_rec)) deallocate (pr%p_rec)
	if (allocated (pr%charged)) deallocate (pr%charged)
	if (allocated (pr%first_pdg_orig)) deallocate (pr%first_pdg_orig)
	if (allocated (pr%first_pdg)) deallocate (pr%first_pdg)
	if (allocated (pr%index_map)) deallocate (pr%index_map)
	pr%valid = .false.
	end subroutine cleanup

	function is_charged (flv) result (chrg)
	integer, dimension(:) :: flv
	logical, dimension(size (flv)) :: chrg
	integer :: i
	do i = 1, size (flv)
	chrg(i) = abs (particle_data_get_charge (model_get_particle_ptr ( &
	model, flv(i)))) > 0
	end do
	end function is_charged

	end subroutine photon_recombination_init

	@ %def photon_recombination_init
	Finalization
	<<Photon recombination: public>>=
	public :: photon_recombination_final
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_final (pr)
	type(photon_recombination_t), intent(inout) :: pr
	call hard_interaction_final (pr%hi)
	if (.not. pr%valid) return
	call evaluator_final (pr%eval_square)
	call evaluator_final (pr%eval_rec)
	call evaluator_final (pr%eval_trace)
	call evaluator_final (pr%eval_sqme)
	if (allocated (pr%flv_states_orig)) deallocate (pr%flv_states_orig)
	if (allocated (pr%flv_states)) deallocate (pr%flv_states)
	if (allocated (pr%p_orig)) deallocate (pr%p_orig)
	if (allocated (pr%p_rec)) deallocate (pr%p_rec)
	if (allocated (pr%charged)) deallocate (pr%charged)
	if (allocated (pr%first_pdg_orig)) deallocate (pr%first_pdg_orig)
	if (allocated (pr%first_pdg)) deallocate (pr%first_pdg)
	if (allocated (pr%index_map)) deallocate (pr%index_map)
	pr%valid = .false.
	end subroutine photon_recombination_final

	@ %def photon_recombination_final
	@
	Init the trace evaluator.
	<<Photon recombination: public>>=
	public :: photon_recombination_init_trace
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_init_trace (pr, qn_mask_in)
	type(photon_recombination_t), intent(inout) :: pr
	type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(pr%n_tot) :: qn_mask
	if (pr%complement) then
	call hard_interaction_init_trace (pr%hi, qn_mask_in)
	else
	qn_mask(:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.)
	call evaluator_init_qn_sum (pr%eval_trace, pr%eval_rec, qn_mask)
	end if
	end subroutine photon_recombination_init_trace

	@ %def photon_recombination_init_trace
	@
	Init the sqme evaluator.
	<<Photon recombination: public>>=
	public :: photon_recombination_init_sqme
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_init_sqme (pr, qn_mask_in)
	type(photon_recombination_t), intent(inout) :: pr
	type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in
	type(quantum_numbers_mask_t), dimension(pr%n_tot) :: qn_mask
	if (pr%complement) then
	call hard_interaction_init_sqme (pr%hi, qn_mask_in)
	else
	qn_mask(:2) = qn_mask_in
	call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.)
	call evaluator_init_qn_sum (pr%eval_sqme, pr%eval_rec, qn_mask)
	end if
	end subroutine photon_recombination_init_sqme

	@ %def photon_recombination_init_sqme
	@
	Set the momenta and perform the recombination.
	<<Photon recombination: public>>=
	public :: photon_recombination_set_momenta
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_set_momenta (pr, p)
	type(photon_recombination_t), intent(inout) :: pr
	type(vector4_t), dimension(:), intent(in) :: p
	type(interaction_t), pointer :: int
	if (pr%complement) then
	int => hard_interaction_get_int_ptr (pr%hi)
	else
	int => evaluator_get_int_ptr (pr%eval_rec)
	end if
	pr%p_orig(:2) = interaction_get_momenta (int, (/1, 2/))
	pr%p_orig(3:) = p
	pr%passed = .false.
	pr%p_rec = pr%p_orig(pr%index_map)
	select case (pr%recombination_method)
	case (NLO_RECOMBINATION_RACOON)
	call recombination_racoon
	case (NLO_RECOMBINATION_IGNORE_PHOTON)
	pr%passed = .true.
	case (NLO_RECOMBINATION_BARBARA_WW)
	call recombination_barbara_ww
	case default
	call msg_bug ("photon_recombination_set_momenta: invalid " // &
	"photon recombination prescription")
	end select
	if (pr%complement) then
	call interaction_set_momenta (int, pr%p_orig)
	pr%passed = .not. pr%passed
	else
	call interaction_set_momenta (int, pr%p_rec)
	end if

	contains

	subroutine recombination_racoon
	real(kind=default) :: thetaph
	integer :: i, j, imin
	real(default) :: mmin, m
	thetaph = polar_angle (pr%p_orig(pr%iphoton))
	if (thetaph < pr%photon_beam_separation) then
	pr%passed = .true.
	pr%p_rec(1) = pr%p_rec(1) - pr%p_orig(pr%iphoton)
	elseif (thetaph > pi - pr%photon_beam_separation) then
	pr%passed = .true.
	pr%p_rec(2) = pr%p_rec(2) - pr%p_orig(pr%iphoton)
	else
	mmin = huge (1._default)
	imin = -1
	do i = 3, pr%n_tot
	if (.not. pr%charged (pr%index_map(i))) cycle
	m = invariant_mass (pr%p_orig(pr%iphoton) + pr%p_rec(i))
	if (m < mmin) then
	mmin = m
	imin = i
	end if
	end do
	if (mmin < pr%mrecomb .and. imin > 0) then
	pr%passed = .true.
	pr%p_rec(imin) = pr%p_rec(imin) + pr%p_orig(pr%iphoton)
	end if
	end if
	end subroutine recombination_racoon

	subroutine recombination_barbara_ww
	real(default), parameter :: drrec = 0.1_default, ymax = 5._default, &
	ptmax = 1._default
	real(default) :: y, drmin, dr
	integer :: i, imin
	y = rapidity (pr%p_orig(pr%iphoton))
	if (abs (y) > ymax) then
	pr%passed = .true.
	return
	end if
	imin = -1
	drmin = huge (1._default)
	do i = 3, pr%n_tot
	if (.not. pr%charged (pr%index_map (i))) cycle
	dr = eta_phi_distance (pr%p_orig(pr%iphoton), pr%p_rec (i))
	if (dr < drmin) then
	drmin = dr
	imin = i
	end if
	end do
	if (drmin < drrec .and. imin > 0) then
	pr%passed = .true.
	pr%p_rec(imin) = pr%p_rec(imin) + pr%p_orig(pr%iphoton)
	return
	end if
	if (transverse_part (pr%p_orig(pr%iphoton)) < ptmax) then
	pr%passed = .true.
	end if
	end subroutine recombination_barbara_ww

	end subroutine photon_recombination_set_momenta

	@ %def photon_recombination_set_momenta
	@
	Evaluate.
	<<Photon recombination: public>>=
	public :: photon_recombination_evaluate
	public :: photon_recombination_evaluate_sqme
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_evaluate (pr)
	type(photon_recombination_t), intent(inout) :: pr
	type(interaction_t), pointer :: int
	if (pr%complement) then
	call hard_interaction_evaluate (pr%hi)
	call evaluator_evaluate (pr%eval_trace)
	else
	int => hard_interaction_get_int_ptr (pr%hi)
	call interaction_set_momenta (int, pr%p_orig)
	call evaluator_receive_momenta (pr%eval_square)
	call hard_interaction_evaluate (pr%hi)
	call evaluator_evaluate (pr%eval_square)
	call evaluator_evaluate (pr%eval_rec)
	call evaluator_evaluate (pr%eval_trace)
	end if
	end subroutine photon_recombination_evaluate

	subroutine photon_recombination_evaluate_sqme (pr)
	type(photon_recombination_t), intent(inout) :: pr
	if (pr%complement) then
	call hard_interaction_evaluate_sqme (pr%hi)
	else
	call evaluator_receive_momenta (pr%eval_sqme)
	call evaluator_evaluate (pr%eval_sqme)
	end if
	end subroutine photon_recombination_evaluate_sqme

	@ %def photon_recombination_evaluate
	@ %def photon_recombination_evaluate_sqme
	@
	Output.
	<<Photon recombination: public>>=
	public :: photon_recombination_write
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_write (pr, unit, &
	verbose, show_momentum_sum, show_mass, write_comb)
	type(photon_recombination_t), intent(in) :: pr
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	logical, intent(in), optional :: write_comb
	integer :: u
	u = output_unit (unit)
	write (u, '(A)') "QED photon recombination"
	if (.not. pr%valid) then
	write (u, '(A)') " invalid"
	return
	end if
	select case (pr%recombination_method)
	case (NLO_RECOMBINATION_RACOON)
	write (u, '(A)') " recombination method: racoon (beam separation: " // &
	trim (real2char (pr%photon_beam_separation)) // &
	", recmbination scale: " // trim (real2char (pr%mrecomb)) // ")"
	case (NLO_RECOMBINATION_IGNORE_PHOTON)
	write (u, '(A)') " recombination method: ignore photon"
	case default
	write (u, '(A)') " recombination method: invalid"
	end select
	if (pr%complement) write (u, '(A)') " complement mode"
	write (u, '(A)') "hard interaction"
	call hard_interaction_write &
	(pr%hi, u, verbose, show_momentum_sum, show_mass, write_comb)
	if (pr%complement) return
	write (u, '(A)') "Square evaluator"
	call evaluator_write &
	(pr%eval_square, u, verbose, show_momentum_sum, show_mass, write_comb)
	write (u, '(A)') "Recombination evaluator"
	call evaluator_write &
	(pr%eval_rec, u, verbose, show_momentum_sum, show_mass, write_comb)
	write (u, '(A)') "Trace evaluator"
	call evaluator_write &
	(pr%eval_trace, u, verbose, show_momentum_sum, show_mass, write_comb)
	write (u, '(A)') "Sqme evaluator"
	call evaluator_write &
	(pr%eval_sqme, u, verbose, show_momentum_sum, show_mass, write_comb)
	end subroutine photon_recombination_write

	@ %def photon_recombination_write
	@
	Assignment.
	<<Photon recombination: public>>=
	public :: assignment(=)
	<<Photon recombination: interfaces>>=
	interface assignment(=)
	module procedure photon_recombination_assign
	end interface

	<<Photon recombination: procedures>>=
	subroutine photon_recombination_assign (pr_out, pr_in)
	type(photon_recombination_t), intent(inout) :: pr_out
	type(photon_recombination_t), intent(in) :: pr_in
	call photon_recombination_final (pr_out)
	if (.not. pr_in%valid) return
	pr_out%recombination_method = pr_in%recombination_method
	pr_out%hi = pr_in%hi
	pr_out%eval_square = pr_in%eval_square
	call evaluator_replace_interaction (pr_out%eval_square, &
	hard_interaction_get_int_ptr (pr_out%hi))
	pr_out%eval_rec = pr_in%eval_rec
	call evaluator_replace_interaction (pr_out%eval_rec, &
	evaluator_get_int_ptr (pr_out%eval_square))
	pr_out%eval_trace = pr_in%eval_trace
	call evaluator_replace_interaction (pr_out%eval_trace, &
	evaluator_get_int_ptr (pr_out%eval_rec))
	pr_out%eval_sqme = pr_in%eval_sqme
	call evaluator_replace_interaction (pr_out%eval_sqme, &
	evaluator_get_int_ptr (pr_out%eval_rec))
	pr_out%iphoton = pr_in%iphoton
	pr_out%n_tot = pr_in%n_tot
	pr_out%n_flv = pr_in%n_flv
	allocate ( &
	pr_out%flv_states_orig (pr_in%n_tot + 1, pr_in%n_flv), &
	pr_out%flv_states (pr_in%n_tot, pr_in%n_flv), &
	pr_out%first_pdg_orig(pr_in%n_tot - 1), &
	pr_out%first_pdg(pr_in%n_tot - 2), &
	pr_out%charged(pr_in%n_tot + 1), &
	pr_out%p_orig(pr_in%n_tot + 1), &
	pr_out%p_rec(pr_in%n_tot), &
	pr_out%index_map(pr_in%n_tot) &
	)
	pr_out%flv_states_orig = pr_in%flv_states_orig
	pr_out%flv_states = pr_in%flv_states
	pr_out%first_pdg_orig = pr_in%first_pdg_orig
	pr_out%first_pdg = pr_in%first_pdg
	pr_out%charged = pr_in%charged
	pr_out%valid = pr_in%valid
	pr_out%mrecomb = pr_in%mrecomb
	pr_out%photon_beam_separation = pr_in%photon_beam_separation
	pr_out%p_orig = pr_in%p_orig
	pr_out%p_rec = pr_in%p_rec
	pr_out%valid = pr_in%valid
	pr_out%weight = pr_in%weight
	pr_out%index_map = pr_in%index_map
	pr_out%complement = pr_in%complement
	end subroutine photon_recombination_assign

	@ %def photon_recombination_assign
	@
	Misc glue to [[core_interaction]].
	<<Photon recombination: public>>=
	public :: photon_recombination_unload
	public :: photon_recombination_reload
	public :: photon_recombination_update_parameters
	public :: photon_recombination_is_valid
	public :: photon_recombination_get_id
	public :: photon_recombination_get_model_ptr
	public :: photon_recombination_get_n_out_eff
	public :: photon_recombination_get_n_tot_eff
	public :: photon_recombination_get_n_out_real
	public :: photon_recombination_get_n_tot_real
	public :: photon_recombination_get_n_flv
	public :: photon_recombination_get_flv_states_eff
	public :: photon_recombination_get_flv_states_real
	public :: photon_recombination_get_first_pdg_in
	public :: photon_recombination_get_first_pdg_out_eff
	public :: photon_recombination_get_first_pdg_out_real
	public :: photon_recombination_get_unstable_products
	public :: photon_recombination_final_sqme
	public :: photon_recombination_update_alpha_s
	public :: photon_recombination_reset_helicity_selection
	public :: photon_recombination_compute_sqme_sum
	public :: photon_recombination_get_int_ptr
	public :: photon_recombination_get_eval_trace_ptr
	public :: photon_recombination_get_eval_sqme_ptr
	public :: photon_recombination_write_state_summary
	public :: photon_recombination_get_momenta_in
	public :: photon_recombination_set_cut_status
	public :: photon_recombination_get_cut_status
	public :: photon_recombination_kinematics_passed
	public :: photon_recombination_set_weight
	public :: photon_recombination_get_weight
	<<Photon recombination: procedures>>=
	subroutine photon_recombination_unload (pr)
	type(photon_recombination_t), intent(inout) :: pr
	call hard_interaction_unload (pr%hi)
	end subroutine photon_recombination_unload

	subroutine photon_recombination_reload (pr, prc_lib)
	type(photon_recombination_t), intent(inout) :: pr
	type(process_library_t), intent(in) :: prc_lib
	call hard_interaction_reload (pr%hi, prc_lib)
	end subroutine photon_recombination_reload

	subroutine photon_recombination_update_parameters (pr)
	type(photon_recombination_t), intent(inout) :: pr
	call hard_interaction_update_parameters (pr%hi)
	end subroutine photon_recombination_update_parameters

	function photon_recombination_is_valid (pr) result (valid)
	type(photon_recombination_t), intent(in) :: pr
	logical :: valid
	valid = pr%valid
	end function photon_recombination_is_valid

	function photon_recombination_get_id (pr) result (id)
	type(photon_recombination_t), intent(in) :: pr
	type(string_t) :: id
	id = hard_interaction_get_id (pr%hi)
	end function photon_recombination_get_id

	function photon_recombination_get_model_ptr (pr) result (model)
	type(photon_recombination_t), intent(in) :: pr
	type(model_t), pointer :: model
	model => hard_interaction_get_model_ptr (pr%hi)
	end function photon_recombination_get_model_ptr

	function photon_recombination_get_n_out_eff (pr) result (n)
	type(photon_recombination_t), intent(in) :: pr
	integer :: n
	if (pr%complement) then
	n = hard_interaction_get_n_out (pr%hi)
	else
	n = pr%n_tot - 2
	end if
	end function photon_recombination_get_n_out_eff

	function photon_recombination_get_n_tot_eff (pr) result (n)
	type(photon_recombination_t), intent(in) :: pr
	integer :: n
	if (pr%complement) then
	n = hard_interaction_get_n_tot (pr%hi)
	else
	n = pr%n_tot
	end if
	end function photon_recombination_get_n_tot_eff

	function photon_recombination_get_n_out_real (pr) result (n)
	type(photon_recombination_t), intent(in) :: pr
	integer :: n
	if (pr%complement) then
	n = hard_interaction_get_n_out (pr%hi)
	else
	n = pr%n_tot - 1
	end if
	end function photon_recombination_get_n_out_real

	function photon_recombination_get_n_tot_real (pr) result (n)
	type(photon_recombination_t), intent(in) :: pr
	integer :: n
	if (pr%complement) then
	n = hard_interaction_get_n_tot (pr%hi)
	else
	n = pr%n_tot + 1
	end if
	end function photon_recombination_get_n_tot_real

	function photon_recombination_get_n_flv (pr) result (n)
	type(photon_recombination_t), intent(in) :: pr
	integer :: n
	n = pr%n_flv
	end function photon_recombination_get_n_flv

	function photon_recombination_get_flv_states_eff (pr) result (flv)
	type(photon_recombination_t), intent(in) :: pr
	integer, dimension(:,:), allocatable :: flv
	if (pr%complement) then
	allocate (flv(pr%n_tot + 1, pr%n_flv))
	flv = pr%flv_states_orig
	else
	allocate (flv(pr%n_tot, pr%n_flv))
	flv = pr%flv_states
	end if
	end function photon_recombination_get_flv_states_eff

	function photon_recombination_get_flv_states_real (pr) result (flv)
	type(photon_recombination_t), intent(in) :: pr
	integer, dimension(:,:), allocatable :: flv
	allocate (flv(pr%n_tot + 1, pr%n_flv))
	flv = pr%flv_states_orig
	end function photon_recombination_get_flv_states_real

	function photon_recombination_get_first_pdg_in (pr) result (pdg)
	type(photon_recombination_t), intent(in) :: pr
	integer, dimension(2) :: pdg
	pdg = hard_interaction_get_first_pdg_in (pr%hi)
	end function photon_recombination_get_first_pdg_in

	function photon_recombination_get_first_pdg_out_eff (pr) result (pdg)
	type(photon_recombination_t), intent(in) :: pr
	integer, dimension(:), allocatable :: pdg
	if (pr%complement) then
	allocate (pdg(pr%n_tot - 1))
	pdg = pr%first_pdg_orig
	else
	allocate (pdg(pr%n_tot - 2))
	pdg = pr%first_pdg
	end if
	end function photon_recombination_get_first_pdg_out_eff

	function photon_recombination_get_first_pdg_out_real (pr) result (pdg)
	type(photon_recombination_t), intent(in) :: pr
	integer, dimension(:), allocatable :: pdg
	allocate (pdg(pr%n_tot - 1))
	pdg = pr%first_pdg_orig
	end function photon_recombination_get_first_pdg_out_real

	subroutine photon_recombination_get_unstable_products (pr, flavors)
	type(photon_recombination_t), intent(in) :: pr
	type(flavor_t), dimension(:), allocatable, intent(out) :: flavors
	call hard_interaction_get_unstable_products (pr%hi, flavors)
	end subroutine photon_recombination_get_unstable_products

	subroutine photon_recombination_final_sqme (pr)
	type(photon_recombination_t), intent(inout) :: pr
	if (pr%complement) then
	call hard_interaction_final_sqme (pr%hi)
	else
	call evaluator_final (pr%eval_sqme)
	end if
	end subroutine photon_recombination_final_sqme

	subroutine photon_recombination_update_alpha_s (pr, as)
	type(photon_recombination_t), intent(inout) :: pr
	real(kind=default), intent(in) :: as
	call hard_interaction_update_alpha_s (pr%hi, as)
	end subroutine photon_recombination_update_alpha_s

	subroutine photon_recombination_reset_helicity_selection (pr, threshold, cutoff)
	type(photon_recombination_t), intent(inout) :: pr
	real(kind=default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	call hard_interaction_reset_helicity_selection (pr%hi, threshold, cutoff)
	end subroutine photon_recombination_reset_helicity_selection

	function photon_recombination_compute_sqme_sum (pr, p) result (f)
	type(photon_recombination_t), intent(inout) :: pr
	type(vector4_t), intent(in), dimension(:) :: p
	real(kind=default) :: f
	type(interaction_t), pointer :: int
	if (pr%complement) then
	f = hard_interaction_compute_sqme_sum (pr%hi, p)
	return
	end if
	int => evaluator_get_int_ptr (pr%eval_rec)
	call interaction_set_momenta (int, p(:2), outgoing = .false.)
	call photon_recombination_set_momenta (pr, p(3:))
	if (.not. pr%passed) then
	f = 0
	return
	end if
	call evaluator_receive_momenta (pr%eval_trace)
	call photon_recombination_evaluate (pr)
	f = evaluator_sum (pr%eval_trace)
	end function photon_recombination_compute_sqme_sum

	function photon_recombination_get_int_ptr (pr) result (int)
	type(photon_recombination_t), intent(in), target :: pr
	type(interaction_t), pointer :: int
	if (pr%complement) then
	int => hard_interaction_get_int_ptr (pr%hi)
	else
	int => evaluator_get_int_ptr (pr%eval_rec)
	end if
	end function photon_recombination_get_int_ptr

	function photon_recombination_get_eval_trace_ptr (pr) result (eval)
	type(photon_recombination_t), intent(in), target :: pr
	type(evaluator_t), pointer :: eval
	if (pr%complement) then
	eval => hard_interaction_get_eval_trace_ptr (pr%hi)
	else
	eval => pr%eval_trace
	end if
	end function photon_recombination_get_eval_trace_ptr

	function photon_recombination_get_eval_sqme_ptr (pr) result (eval)
	type(photon_recombination_t), intent(in), target :: pr
	type(evaluator_t), pointer :: eval
	if (pr%complement) then
	eval => hard_interaction_get_eval_sqme_ptr (pr%hi)
	else
	eval => pr%eval_sqme
	end if
	end function photon_recombination_get_eval_sqme_ptr

	subroutine photon_recombination_write_state_summary (pr, unit)
	type(photon_recombination_t), intent(in) :: pr
	integer, intent(in), optional :: unit
	call hard_interaction_write_state_summary (pr%hi, unit)
	end subroutine photon_recombination_write_state_summary

	function photon_recombination_get_momenta_in (pr) result (p)
	type(photon_recombination_t), intent(in) :: pr
	type(vector4_t), dimension(2) :: p
	if (pr%complement) then
	p = interaction_get_momenta (hard_interaction_get_int_ptr (pr%hi), &
	outgoing = .false.)
	else
	p = interaction_get_momenta (evaluator_get_int_ptr (pr%eval_rec), &
	outgoing = .false.)
	end if
	end function photon_recombination_get_momenta_in

	subroutine photon_recombination_set_cut_status (pr, stat)
	type(photon_recombination_t), intent(inout) :: pr
	logical, intent(in) :: stat
	pr%passed = pr%passed .and. stat
	end subroutine photon_recombination_set_cut_status

	subroutine photon_recombination_kinematics_passed (pr, stat)
	type(photon_recombination_t), intent(inout) :: pr
	logical, intent(in) :: stat
	pr%passed = stat
	end subroutine photon_recombination_kinematics_passed

	function photon_recombination_get_cut_status (pr) result (stat)
	type(photon_recombination_t), intent(in) :: pr
	logical :: stat
	stat = pr%passed
	end function photon_recombination_get_cut_status

	subroutine photon_recombination_set_weight (pr, weight)
	type(photon_recombination_t), intent(inout) :: pr
	real(kind=default), intent(in) :: weight
	pr%weight = weight
	end subroutine photon_recombination_set_weight

	function photon_recombination_get_weight (pr) result (weight)
	type(photon_recombination_t), intent(in) :: pr
	real(kind=default) :: weight
	weight = pr%weight
	end function photon_recombination_get_weight

	@ %def photon_recombination_unload
	@ %def photon_recombination_reload
	@ %def photon_recombination_update_parameters
	@ %def photon_recombination_is_valid
	@ %def photon_recombination_get_id
	@ %def photon_recombination_get_model_ptr
	@ %def photon_recombination_get_n_out_eff
	@ %def photon_recombination_get_n_tot_eff
	@ %def photon_recombination_get_n_out_real
	@ %def photon_recombination_get_n_tot_real
	@ %def photon_recombination_get_n_flv
	@ %def photon_recombination_get_flv_states_eff
	@ %def photon_recombination_get_flv_states_real
	@ %def photon_recombination_get_first_pdg_in
	@ %def photon_recombination_get_first_pdg_out_eff
	@ %def photon_recombination_get_first_pdg_out_real
	@ %def photon_recombination_get_unstable_products
	@ %def photon_recombination_final_sqme
	@ %def photon_recombination_update_alpha_s
	@ %def photon_recombination_reset_helicity_selection
	@ %def photon_recombination_compute_sqme_sum
	@ %def photon_recombination_get_int_ptr
	@ %def photon_recombination_get_eval_trace_ptr
	@ %def photon_recombination_get_eval_sqme_ptr
	@ %def photon_recombination_write_state_summary
	@ %def photon_recombination_get_momenta_in
	@ %def photon_recombination_set_cut_status
	@ %def photon_recombination_get_cut_status
	@ %def photon_recombination_kinematics_passed
	@ %def photon_recombination_set_weight
	@ %def photon_recombination_get_weight
	@

	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{BLHA interface}

	These modules implement the communication with one loop matrix element providers
	according to the Binoth LesHouches Accord Interface. The actual matrix
	element(s) are loaded as a dynamic library.

	The module is split into a configuration interface which manages configuration
	and handles the request and contract files, a module which interfaces the OLP
	matrix elements and a driver.

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

	module blha_config

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use md5
	use models
	use flavors
	use quantum_numbers
	use pdg_arrays
	use sorting
	use lexers
	use parser
	use syntax_rules
	use ifiles
	use limits, only: EOF !NODEP!

	<<Standard module head>>

	<<BLHA config: public>>

	<<BLHA config: parameters>>

	<<BLHA config: types>>

	<<BLHA config: variables>>

	<<BLHA config: interfaces>>

	contains

	<<BLHA config: procedures>>

	end module blha_config

	@ %def blha_config
	@
	<<[[blha_interface.f90]]>>=
	<<File header>>

	module blha_interface

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use sm_physics !NODEP!
	use md5
	use lorentz !NODEP!
	use models
	use flavors
	use quantum_numbers
	use interactions
	use evaluators
	use particles
	use quantum_numbers
	use blha_config
	use, intrinsic :: iso_c_binding !NODEP!
	use os_interface

	<<Standard module head>>

	<<BLHA interface: public>>

	<<BLHA interface: parameters>>

	<<BLHA interface: types>>

	<<BLHA interface: variables>>

	<<BLHA interface: interfaces>>

	contains

	<<BLHA interface: procedures>>

	end module blha_interface
	@ %def blha_interface
	@ %
	<<[[blha_driver.f90]]>>=
	<<File header>>

	module blha_driver

	<<Use kinds>>
	<<Use strings>>
	use constants !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use sm_physics !NODEP!
	use md5
	use lorentz !NODEP!
	use models
	use flavors
	use quantum_numbers
	use interactions
	use evaluators
	use particles
	use quantum_numbers
	use blha_config
	use blha_interface

	<<Standard module head>>

	<<BLHA driver: public>>

	<<BLHA driver: parameters>>

	<<BLHA driver: types>>

	<<BLHA driver: variables>>

	<<BLHA driver: drivers>>

	contains

	<<BLHA driver: procedures>>

	end module blha_driver
	@ %def blha_driver
	@ %

	\subsection{Configuration}

	Parameters to enumerate the different options in the order.
	<<BLHA config: parameters>>=
	integer, public, parameter :: &
	BLHA_MEST_SUM=1, BLHA_MEST_AVG=2, BLHA_MEST_OTHER=3
	integer, public, parameter :: &
	BLHA_CT_QCD=1, BLHA_CT_EW=2, BLHA_CT_QED=3, BLHA_CT_OTHER=4
	integer, public, parameter :: &
	BLHA_IRREG_CDR=1, BLHA_IRREG_DRED=2, BLHA_IRREG_THV=3, &
	BLHA_IRREG_MREG=4, BLHA_IRREG_OTHER=5
	integer, public, parameter :: &
	BLHA_SUBMODE_NONE = 1, BLHA_SUBMODE_OTHER = 2
	integer, public, parameter :: &
	BLHA_MPS_ONSHELL=1, BLHA_MPS_OTHER=2
	integer, public, parameter :: &
	BLHA_MODE_GOSAM=1, BLHA_MODE_GENERIC=2
	integer, public, parameter :: &
	BLHA_OM_NONE=1, BLHA_OM_NOCPL=2, BLHA_OM_OTHER=3
	@ %def
	@
	This type encapsulates a BLHA request.
	<<BLHA config: public>>=
	public :: blha_configuration_t
	public :: blha_cfg_process_node_t
	<<BLHA config: types>>=
	type :: blha_cfg_process_node_t
	integer, dimension(:), allocatable :: pdg_in, pdg_out
	integer, dimension(:), allocatable :: fingerprint
	integer :: nsub
	integer, dimension(:), allocatable :: ids
	type(blha_cfg_process_node_t), pointer :: next => null ()
	end type blha_cfg_process_node_t

	type :: blha_configuration_t
	type(string_t) :: name
	type(model_t), pointer :: model
	type(string_t) :: md5
	logical :: dirty = .true.
	integer :: n_proc = 0
	integer :: mode = BLHA_MODE_GENERIC
	type(blha_cfg_process_node_t), pointer :: processes => null ()
	integer, dimension(2) :: matrix_element_square_type = BLHA_MEST_SUM
	type(string_t), dimension (2) :: matrix_element_square_type_other
	integer :: correction_type = BLHA_CT_QCD
	type(string_t) :: correction_type_other
	integer :: irreg = BLHA_IRREG_THV
	type(string_t) :: irreg_other
	integer :: massive_particle_scheme = BLHA_MPS_ONSHELL
	type(string_t) :: massive_particle_scheme_other
	integer :: subtraction_mode = BLHA_SUBMODE_NONE
	type(string_t) :: subtraction_mode_other
	type(string_t) :: model_file
	logical :: subdivide_subprocesses = .false.
	integer :: alphas_power = -1, alpha_power = -1
	integer :: operation_mode = BLHA_OM_NONE
	type(string_t) :: operation_mode_other
	end type blha_configuration_t

	@ %def
	@
	Creation.
	<<BLHA config: public>>=
	public :: blha_configuration_init
	<<BLHA config: procedures>>=
	subroutine blha_configuration_init (cfg, name, model, mode)
	type(blha_configuration_t), intent(out) :: cfg
	type(string_t), intent(in) :: name
	type(model_t), target, intent(in) :: model
	integer, intent(in), optional :: mode
	cfg%name = name
	cfg%model => model
	if (present (mode)) cfg%mode = mode
	end subroutine blha_configuration_init

	@ %def
	@
	Destruction.
	<<BLHA config: public>>=
	public :: blha_configuration_final
	<<BLHA config: procedures>>=
	subroutine blha_configuration_final (cfg)
	type(blha_configuration_t), intent(inout) :: cfg
	type(blha_cfg_process_node_t), pointer :: cur, next
	cur => cfg%processes
	do while (associated (cur))
	next => cur%next
	deallocate (cur)
	nullify (cur)
	cur => next
	end do
	end subroutine blha_configuration_final

	@ %def
	@
	Merge sort a process list w.r.t. to the process fingerprints. This is necessary
	for canonicalizing the process list prior to calculating the MD5 sum.
	<<BLHA config: procedures>>=
	subroutine sort_processes (list, n)
	type(blha_cfg_process_node_t), pointer :: list
	integer, intent(in), optional :: n
	integer :: cout
	type :: pnode
	type(blha_cfg_process_node_t), pointer :: p
	end type pnode
	type(pnode), dimension(:), allocatable :: array
	integer :: count, i, s, i1, i2, i3
	type(blha_cfg_process_node_t), pointer :: node
	if (present (n)) then
	count = n
	else
	node => list
	count = 0
	do while (associated (node))
	node => node%next
	count = count + 1
	end do
	end if
	! Store list nodes into an array
	if (count == 0) return
	allocate (array(count))
	i = 1
	node => list
	do i = 1, count
	array(i)%p => node
	node => node%next
	end do
	s = 1
	! Merge sort the array
	do while (s < count)
	i = 0
	i1 = 1
	i2 = s
	do while (i2 < count)
	i3 = min (s*(i+2), count)
	array(i1:i3) = merge (array(i1:i2), array(i2+1:i3))
	i = i + 2
	i1 = s*i+1
	i2 = s*(i+1)
	end do
	s = s * 2
	end do
	! Relink according to their new order
	list => array(1)%p
	nullify (array(count)%p%next)
	node => list
	do i = 2, count
	node%next => array(i)%p
	node => node%next
	end do

	contains

	! .le. comparision
	function lt (n1, n2) result (predicate)
	type(blha_cfg_process_node_t), intent(in) :: n1, n2
	logical :: predicate
	integer :: i
	predicate = .true.
	do i = 1, size (n1%fingerprint)
	if (n1%fingerprint(i) < n2%fingerprint(i)) return
	if (n1%fingerprint(i) > n2%fingerprint(i)) then
	predicate = .false.
	return
	end if
	end do
	end function lt

	! Sorting core --- merge two sorted chunks
	function merge (l1, l2) result (lo)
	type(pnode), dimension(:), intent(in) :: l1, l2
	type(pnode), dimension(size (l1) + size (l2)) :: lo
	integer :: i, i1, i2
	i1 = 1
	i2 = 1
	do i = 1, size (lo)
	if (i1 > size (l1)) then
	lo(i)%p => l2(i2)%p
	i2 = i2 + 1
	elseif (i2 > size (l2)) then
	lo(i)%p => l1(i1)%p
	i1 = i1 + 1
	elseif (lt (l1(i1)%p, l2(i2)%p)) then
	lo(i)%p => l1(i1)%p
	i1 = i1 + 1
	else
	lo(i)%p => l2(i2)%p
	i2 = i2 + 1
	end if
	end do
	end function merge

	end subroutine sort_processes
	@ %def
	@
	Append a process. This expands the flavor sum, sorts it and then eliminates
	any duplicates.
	<<BLHA config: public>>=
	public :: blha_configuration_append_process
	<<BLHA config: procedures>>=
	subroutine blha_configuration_append_process (cfg, pdg_in, pdg_out, nsub, ids)
	type(blha_configuration_t), intent(inout) :: cfg
	type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
	integer, optional, intent(in) :: nsub
	integer, optional, dimension(:), intent(in) :: ids
	type(blha_cfg_process_node_t), pointer :: root, node, tmp
	! Multiindex for counting through the PDG numbers
	integer, dimension(size (pdg_in)) :: i_in
	integer, dimension(size (pdg_out)) :: i_out
	! Handle the list of lists
	type :: ilist
	integer, dimension(:), allocatable :: i
	end type ilist
	type(ilist), dimension(size (pdg_in)) :: ilist_i
	type(ilist), dimension(size (pdg_out)) :: ilist_o
	integer :: i, j, nproc
	logical :: inc
	! Extract PDGs into integer lists
	do i = 1, size (pdg_in)
	ilist_i(i)%i = pdg_in(i)
	end do
	do i = 1, size (pdg_out)
	ilist_o(i)%i = pdg_out(i)
	end do
	i_in = 1
	i_out = 1
	allocate (root)
	node => root
	! Perform the expansion
	nproc = 0
	EXPAND: do
	! Transfer the PDG selection...
	allocate (node%pdg_in(size (pdg_in)))
	allocate (node%pdg_out(size (pdg_out)))
	allocate (node%fingerprint (size (pdg_in) + size (pdg_out)))
	if (present (nsub)) node%nsub = nsub
	if (present (ids)) then
	allocate (node%ids(size (ids)))
	node%ids = ids
	end if
	forall (j=1:size(ilist_i)) &
	node%pdg_in(j) = ilist_i(j)%i(i_in(j))
	forall (j=1:size(ilist_o)) &
	node%pdg_out(j) = ilist_o(j)%i(i_out(j))
	node%fingerprint = (/ node%pdg_in, sort (node%pdg_out) /)
	nproc = nproc + 1
	inc = .false.
	! ... and increment the multiindex
	do j = 1, size (i_out)
	if (i_out(j) < size (ilist_o(j)%i)) then
	i_out(j) = i_out(j) + 1
	inc = .true.
	exit
	else
	i_out(j) = 1
	end if
	end do
	if (.not. inc) then
	do j = 1, size (i_in)
	if (i_in(j) < size (ilist_i(j)%i)) then
	i_in(j) = i_in(j) + 1
	inc = .true.
	exit
	else
	i_in(j) = 1
	end if
	end do
	end if
	if (.not. inc) exit EXPAND
	allocate (node%next)
	node => node%next
	end do EXPAND
	! Do the sorting
	call sort_processes (root, nproc)
	! Kill duplicates
	node => root
	do while (associated (node))
	if (.not. associated (node%next)) exit
	if (all (node%fingerprint == node%next%fingerprint)) then
	tmp => node%next%next
	deallocate (node%next)
	node%next => tmp
	nproc = nproc - 1
	else
	node => node%next
	end if
	end do
	! Append the remaining list
	if (associated (cfg%processes)) then
	node => cfg%processes
	do while (associated (node%next))
	node => node%next
	end do
	node%next => root
	else
	cfg%processes => root
	end if
	cfg%n_proc = cfg%n_proc + nproc
	cfg%dirty = .true.

	end subroutine blha_configuration_append_process

	@ %def
	@
	Change parameter(s).
	<<BLHA config: public>>=
	public :: blha_configuration_set
	<<BLHA config: procedures>>=
	subroutine blha_configuration_set ( cfg, &
	matrix_element_square_type_hel, matrix_element_square_type_hel_other, &
	matrix_element_square_type_col, matrix_element_square_type_col_other, &
	correction_type, correction_type_other, &
	irreg, irreg_other, &
	massive_particle_scheme, massive_particle_scheme_other, &
	subtraction_mode, subtraction_mode_other, &
	model_file, subdivide_subprocesses, alphas_power, alpha_power, &
	operation_mode, operation_mode_other)
	type(blha_configuration_t), intent(inout) :: cfg
	integer, optional, intent(in) :: matrix_element_square_type_hel
	type(string_t), optional, intent(in) :: matrix_element_square_type_hel_other
	integer, optional, intent(in) :: matrix_element_square_type_col
	type(string_t), optional, intent(in) :: matrix_element_square_type_col_other
	integer, optional, intent(in) :: correction_type
	type(string_t), optional, intent(in) :: correction_type_other
	integer, optional, intent(in) :: irreg
	type(string_t), optional, intent(in) :: irreg_other
	integer, optional, intent(in) :: massive_particle_scheme
	type(string_t), optional, intent(in) :: massive_particle_scheme_other
	integer, optional, intent(in) :: subtraction_mode
	type(string_t), optional, intent(in) :: subtraction_mode_other
	type(string_t), optional, intent(in) :: model_file
	logical, optional, intent(in) :: subdivide_subprocesses
	integer, intent(in), optional :: alphas_power, alpha_power
	integer, intent(in), optional :: operation_mode
	type(string_t), intent(in), optional :: operation_mode_other
	if (present (matrix_element_square_type_hel)) &
	cfg%matrix_element_square_type(1) = matrix_element_square_type_hel
	if (present (matrix_element_square_type_hel_other)) &
	cfg%matrix_element_square_type_other(1) = matrix_element_square_type_hel_other
	if (present (matrix_element_square_type_col)) &
	cfg%matrix_element_square_type(2) = matrix_element_square_type_col
	if (present (matrix_element_square_type_col_other)) &
	cfg%matrix_element_square_type_other(2) = matrix_element_square_type_col_other
	if (present (correction_type)) &
	cfg%correction_type = correction_type
	if (present (correction_type_other)) &
	cfg%correction_type_other = correction_type_other
	if (present (irreg)) &
	cfg%irreg = irreg
	if (present (irreg_other)) &
	cfg%irreg_other = irreg_other
	if (present (massive_particle_scheme)) &
	cfg%massive_particle_scheme = massive_particle_scheme
	if (present (massive_particle_scheme_other)) &
	cfg%massive_particle_scheme_other = massive_particle_scheme_other
	if (present (subtraction_mode)) &
	cfg%subtraction_mode = subtraction_mode
	if (present (subtraction_mode_other)) &
	cfg%subtraction_mode_other = subtraction_mode_other
	if (present (model_file)) &
	cfg%model_file = model_file
	if (present (subdivide_subprocesses)) &
	cfg%subdivide_subprocesses = subdivide_subprocesses
	if (present (alphas_power)) &
	cfg%alphas_power = alphas_power
	if (present (alpha_power)) &
	cfg%alpha_power = alpha_power
	if (present (operation_mode)) &
	cfg%operation_mode = operation_mode
	if (present (operation_mode_other)) &
	cfg%operation_mode_other = operation_mode_other
	cfg%dirty = .true.
	end subroutine blha_configuration_set

	@ %def
	@
	Print the BLHA file. Internal mode is intented for md5summing only.
	<<BLHA config: public>>=
	public :: blha_configuration_write
	<<BLHA config: procedures>>=
	subroutine blha_configuration_write (cfg, unit, internal)
	type(blha_configuration_t), intent(in) :: cfg
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: internal
	integer :: u
	logical :: full
	type(string_t) :: buf
	type(blha_cfg_process_node_t), pointer :: node
	integer :: i
	character(3) :: pdg_char
	character(len=25), parameter :: pad = " "
	u = output_unit (unit)
	full = .true.; if (present (internal)) full = .not. internal
	if (full .and. cfg%dirty) call msg_bug ( &
	"BUG: attempted to write out a dirty BLHA configuration")
	if (full) then
	write (u,'(A)') "# BLHA order written by WHIZARD <<Version>>"
	write (u,'(A)')
	end if
	select case (cfg%mode)
	case (BLHA_MODE_GOSAM); buf = "GoSam"
	case default; buf = "vanilla"
	end select
	write (u,'(A)') "# BLHA interface mode: " // char (buf)
	write (u,'(A)') "# process: " // char (cfg%name)
	write (u,'(A)') "# model: " // char (model_get_name (cfg%model))
	if (full) then
	write (u,'(A)')
	write (u,'(A)') '#@WO MD5 "' // char (cfg%md5) // '"'
	write (u,'(A)')
	end if
	if (all (cfg%matrix_element_square_type == BLHA_MEST_SUM)) then
	buf = "CHsummed"
	elseif (all (cfg%matrix_element_square_type == BLHA_MEST_AVG)) then
	buf = "CHaveraged"
	else
	buf = (render_mest ("H", cfg%matrix_element_square_type(1), &
	cfg%matrix_element_square_type_other(1)) // " ") // &
	render_mest ("C", cfg%matrix_element_square_type(2), &
	cfg%matrix_element_square_type_other(2))
	end if
	write (u,'(A25,A)') "MatrixElementSquareType" // pad, char (buf)
	select case (cfg%correction_type)
	case (BLHA_CT_QCD); buf = "QCD"
	case (BLHA_CT_EW); buf = "EW"
	case (BLHA_CT_QED); buf = "QED"
	case default; buf = cfg%correction_type_other
	end select
	write (u,'(A25,A)') "CorrectionType" // pad, char (buf)
	select case (cfg%irreg)
	case (BLHA_IRREG_CDR); buf = "CDR"
	case (BLHA_IRREG_DRED); buf = "DRED"
	case (BLHA_IRREG_THV); buf = "tHV"
	case (BLHA_IRREG_MREG); buf = "MassReg"
	case default; buf = cfg%irreg_other
	end select
	write (u,'(A25,A)') "IRregularisation" // pad, char (buf)
	select case (cfg%massive_particle_scheme)
	case (BLHA_MPS_ONSHELL); buf = "OnShell"
	case default; buf = cfg%massive_particle_scheme_other
	end select
	write (u,'(A25,A)') "MassiveParticleScheme" // pad, char (buf)
	select case (cfg%subtraction_mode)
	case (BLHA_SUBMODE_NONE); buf = "None"
	case default; buf = cfg%subtraction_mode_other
	end select
	write (u,'(A25,A)') "IRsubtractionMethod" // pad, char (buf)
	write (u,'(A25,A)') "ModelFile" // pad, char (cfg%model_file)
	if (cfg%subdivide_subprocesses) then
	write (u,'(A25,A)') "SubdivideSubprocesses" // pad, "yes"
	else
	write (u,'(A25,A)') "SubdivideSubprocess" // pad, "no"
	end if
	if (cfg%alphas_power >= 0) write (u,'(A25,A)') &
	"AlphasPower" // pad, int2char (cfg%alphas_power)
	if (cfg%alpha_power >= 0) write (u,'(A25,A)') &
	"AlphaPower " // pad, int2char (cfg%alpha_power)
	if (full) then
	write (u,'(A)')
	write (u,'(A)') "# Process definitions"
	write (u,'(A)')
	end if
	node => cfg%processes
	do while (associated (node))
	buf = ""
	do i = 1, size (node%pdg_in)
	write (pdg_char,'(I3)') node%pdg_in(i)
	buf = (buf // pdg_char) // " "
	end do
	buf = buf // "-> "
	do i = 1, size (node%pdg_out)
	write (pdg_char,'(I3)') node%pdg_out(i)
	buf = (buf // pdg_char) // " "
	end do
	write (u,'(A)') char (trim (buf))
	node => node%next
	end do

	contains

	function render_mest (prefix, mest, other) result (tag)
	character, intent(in) :: prefix
	integer, intent(in) :: mest
	type(string_t), intent(in) :: other
	type(string_t) :: tag
	select case (mest)
	case (BLHA_MEST_AVG); tag = prefix // "averaged"
	case (BLHA_MEST_SUM); tag = prefix // "summed"
	case default; tag = other
	end select
	end function render_mest

	end subroutine blha_configuration_write

	@ %def
	@
	``Freeze'' the configuration by calculating the MD5 sum.
	<<BLHA config: public>>=
	public :: blha_configuration_freeze
	<<BLHA config: procedures>>=
	subroutine blha_configuration_freeze (cfg)
	type(blha_configuration_t), intent(inout) :: cfg
	integer u
	if (.not. cfg%dirty) return
	call sort_processes (cfg%processes)
	u = free_unit ()
	open (unit=u, status="scratch", action="readwrite")
	call blha_configuration_write (cfg, u, internal=.true.)
	rewind (u)
	cfg%md5 = md5sum (u)
	cfg%dirty = .false.
	close (u)
	end subroutine blha_configuration_freeze

	@ %def
	@
	Read a contract file, again creating a [[blha_configuration_t]] object.
	<<BLHA config: public>>=
	public :: blha_read_contract
	<<BLHA config: interfaces>>=
	interface blha_read_contract
	module procedure blha_read_contract_unit, blha_read_contract_file
	end interface
	<<BLHA config: procedures>>=
	subroutine blha_read_contract_file (cfg, ok, fname, success)
	type(blha_configuration_t), intent(inout) :: cfg
	logical, intent(out) :: ok
	type(string_t), intent(in) :: fname
	logical, intent(out), optional :: success
	integer :: u, stat
	u = free_unit ()
	open (u, file=char (fname), status="old", action="read", iostat=stat)
	if (stat /= 0) then
	if (present (success)) then
	success = .false.
	return
	else
	call msg_bug ('Unable to open contract file "' // char (fname) // '"')
	end if
	end if
	call blha_read_contract_unit (cfg, ok, u, success)
	close (u)
	end subroutine blha_read_contract_file

	subroutine blha_read_contract_unit (cfg, ok, u, success)
	type(blha_configuration_t), intent(inout) :: cfg
	logical, intent(out) :: ok
	integer, intent(in) :: u
	logical, intent(out), optional :: success
	type(stream_t) :: stream
	type(ifile_t) :: preprocessed
	type(lexer_t) :: lexer
	type(parse_tree_t) :: parse_tree
	type(string_t) :: md5
	call stream_init (stream, u)
	call contract_preprocess (stream, preprocessed)
	call stream_final (stream)
	call stream_init (stream, preprocessed)
	call blha_init_lexer (lexer)
	call lexer_assign_stream (lexer, stream)
	call parse_tree_init (parse_tree, syntax_blha_contract, lexer)
	call blha_transfer_contract (cfg, ok, parse_tree, success)
	call blha_configuration_write (cfg, internal=.true.)
	call lexer_final (lexer)
	call stream_final (stream)
	call ifile_final (preprocessed)
	if (ok) then
	md5 = cfg%md5
	call blha_configuration_freeze (cfg)
	if (char (trim (md5 )) /= "") then
	if (md5 /= cfg%md5) then
	call msg_warning ("BLHA contract does not match the recorded " &
	// "checksum --- this counts as an error!")
	ok = .false.
	end if
	else
	call msg_warning ("It seems the OLP scrubbed our checksum, unable " &
	// "to check contract consistency.")
	end if
	end if
	end subroutine blha_read_contract_unit

	@ %def
	@
	Walk the parse tree and transfer the results to the [[blha_configuration]]
	object. The [[goto]] is a poor man's %'
	replacement for exceptions which would be an appropiate error handling
	mechanism here.
	<<BLHA config: procedures>>=
	subroutine blha_transfer_contract (cfg, ok, parse_tree, success)
	type(blha_configuration_t), intent(inout) :: cfg
	logical, intent(out) :: ok
	type(parse_tree_t), intent(in), target :: parse_tree
	logical, intent(out), optional :: success
	type(parse_node_t), pointer :: pn_root, pn_line, pn_request, pn_result, &
	pn_key, pn_opt, pn_state_in, pn_state_out, pn_pdg
	type(string_t) :: emsg
	integer :: nopt, i, nsub
	integer, dimension(:), allocatable :: ids
	logical, dimension(2) :: flags
	type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
	ok = .true.
	pn_root => parse_tree_get_root_ptr (parse_tree)
	pn_line => parse_node_get_sub_ptr (pn_root)
	do while (associated (pn_line))
	pn_request => parse_node_get_sub_ptr (pn_line)
	if (.not. associated (pn_request)) cycle
	if (char (parse_node_get_rule_key (pn_request)) == "process") then
	pn_result => parse_node_get_sub_ptr (pn_line, 2)
	pn_state_in => parse_node_get_sub_ptr (pn_request, 1)
	pn_state_out => parse_node_get_sub_ptr (pn_request, 3)
	allocate (pdg_in (parse_node_get_n_sub (pn_state_in)))
	allocate (pdg_out (parse_node_get_n_sub (pn_state_out)))
	i = 1
	pn_pdg => parse_node_get_sub_ptr (pn_state_in)
	do while (associated (pn_pdg))
	pdg_in(i) = (/get_int (pn_pdg)/)
	pn_pdg => parse_node_get_next_ptr (pn_pdg)
	i = i + 1
	end do
	i = 1
	pn_pdg => parse_node_get_sub_ptr (pn_state_out)
	do while (associated (pn_pdg))
	pdg_out(i) = (/get_int (pn_pdg)/)
	pn_pdg => parse_node_get_next_ptr (pn_pdg)
	i = i + 1
	end do
	i = parse_node_get_n_sub (pn_result)
	emsg = "broken process line"
	if (i < 2) goto 10
	pn_opt => parse_node_get_sub_ptr (pn_result, 2)
	do while (associated (pn_opt))
	if (char (parse_node_get_rule_key (pn_opt)) == "string") then
	call msg_warning ("While reading the BLHA contract: " // &
	'the OLP returned an error for a process: "' // &
	char (parse_node_get_string (pn_opt)) // '"')
	ok = .false.
	return
	end if
	pn_opt => parse_node_get_next_ptr (pn_opt)
	end do
	pn_opt => parse_node_get_sub_ptr (pn_result, 2)
	nsub = get_int (pn_opt)
	if (nsub /= i - 2) goto 10
	allocate (ids(nsub))
	i = 1
	pn_opt => parse_node_get_next_ptr (pn_opt)
	do while (associated (pn_opt))
	ids(i) = get_int (pn_opt)
	pn_opt => parse_node_get_next_ptr (pn_opt)
	end do
	call blha_configuration_append_process (cfg, pdg_in, pdg_out, &
	nsub=nsub, ids=ids)
	deallocate (pdg_in, pdg_out, ids)
	else
	pn_result => parse_node_get_sub_ptr (parse_node_get_next_ptr (pn_request), 2)
	pn_key => parse_node_get_sub_ptr (pn_request)
	pn_opt => parse_node_get_next_ptr (pn_key)
	nopt = parse_node_get_n_sub (pn_request) - 1
	select case (char (parse_node_get_rule_key (pn_key)))
	case ("md5")
	cfg%md5 = parse_node_get_string (pn_opt)
	case ("modelfile")
	cfg%model_file = get_fname (pn_opt)
	call check_result (pn_result, "ModelFile")
	case ("irregularisation")
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("cdr"); cfg%irreg = BLHA_IRREG_CDR
	case ("dred"); cfg%irreg = BLHA_IRREG_DRED
	case ("thv"); cfg%irreg = BLHA_IRREG_THV
	case ("mreg"); cfg%irreg = BLHA_IRREG_MREG
	case default
	cfg%irreg = BLHA_IRREG_OTHER
	cfg%irreg_other = parse_node_get_string (pn_opt)
	end select
	call check_result (pn_result, "IRRegularisation")
	case ("irsubtractionmethod")
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("none"); cfg%subtraction_mode = BLHA_SUBMODE_NONE
	case default
	cfg%subtraction_mode = BLHA_SUBMODE_OTHER
	cfg%subtraction_mode_other = parse_node_get_string(pn_opt)
	end select
	call check_result (pn_result, "IRSubtractionMethod")
	case ("massiveparticlescheme")
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("onshell")
	cfg%massive_particle_scheme = BLHA_MPS_ONSHELL
	case default
	cfg%massive_particle_scheme = BLHA_MPS_OTHER
	cfg%massive_particle_scheme_other = &
	parse_node_get_string (pn_opt)
	end select
	call check_result (pn_result, "MassiveParticleScheme")
	case ("matrixelementsquaretype")
	select case (nopt)
	case (1)
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("chsummed")
	cfg%matrix_element_square_type = BLHA_MEST_SUM
	case ("chaveraged")
	cfg%matrix_element_square_type = BLHA_MEST_AVG
	case default
	emsg = "invalid MatrixElementSquareType: " // &
	parse_node_get_string (pn_opt)
	goto 10
	end select
	case (2)
	do i = 1, 2
	pn_opt => parse_node_get_next_ptr (pn_key, i)
	select case (lower_case (char (parse_node_get_string ( &
	pn_opt))))
	case ("csummed")
	cfg%matrix_element_square_type(2) = BLHA_MEST_SUM
	flags(2) = .true.
	case ("caveraged")
	cfg%matrix_element_square_type(2) = BLHA_MEST_AVG
	flags(2) = .true.
	case ("hsummed")
	cfg%matrix_element_square_type(1) = BLHA_MEST_SUM
	flags(1) = .true.
	case ("haveraged")
	cfg%matrix_element_square_type(1) = BLHA_MEST_AVG
	flags(1) = .true.
	case default
	emsg = "invalid MatrixElementSquareType: " // &
	parse_node_get_string (pn_opt)
	goto 10
	end select
	end do
	if (.not. all (flags)) then
	emsg = "MatrixElementSquareType: setup not exhaustive"
	goto 10
	end if
	case default
	emsg = "MatrixElementSquareType: too many options"
	goto 10
	end select
	call check_result (pn_result, "MatrixElementSquareType")
	case ("correctiontype")
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("qcd"); cfg%correction_type = BLHA_CT_QCD
	case ("qed"); cfg%correction_type = BLHA_CT_QED
	case ("ew"); cfg%correction_type = BLHA_CT_EW
	case default
	cfg%correction_type = BLHA_CT_OTHER
	cfg%correction_type_other = parse_node_get_string (pn_opt)
	end select
	call check_result (pn_result, "CorrectionType")
	case ("alphaspower")
	cfg%alphas_power = get_int (pn_opt)
	call check_result (pn_result, "AlphasPower")
	case ("alphapower")
	cfg%alpha_power = get_int (pn_opt)
	call check_result (pn_result, "AlphaPower")
	case ("subdividesubprocess")
	select case (lower_case (char (parse_node_get_string (pn_opt))))
	case ("yes"); cfg%subdivide_subprocesses = .true.
	case ("no"); cfg%subdivide_subprocesses = .false.
	case default
	emsg = 'SubdivideSubprocess: invalid argument "' // &
	parse_node_get_string (pn_opt) // '"'
	goto 10
	end select
	call check_result (pn_result, "SubdivideSubprocess")
	case default
	emsg = "unknown statement: " // parse_node_get_rule_key (pn_key)
	goto 10
	end select
	end if
	pn_line => parse_node_get_next_ptr (pn_line)
	end do
	if (present (success)) success = .true.
	return
	10 continue
	if (present (success)) then
	call msg_error ("Error reading BLHA contract: " // char (emsg))
	success = .false.
	return
	else
	call msg_fatal ("Error reading BLHA contract: " // char (emsg))
	end if

	contains

	function get_int (pn) result (i)
	type(parse_node_t), pointer :: pn
	integer :: i
	if (char (parse_node_get_rule_key (pn)) == "integer") then
	i = parse_node_get_integer (pn)
	else
	i = parse_node_get_integer (parse_node_get_sub_ptr (pn, 2))
	if (char (parse_node_get_rule_key (parse_node_get_sub_ptr (pn))) &
	== "-") i = -i
	end if
	end function get_int

	subroutine check_result (pn, step)
	type(parse_node_t), pointer :: pn
	character(*), intent(in) :: step
	type(string_t) :: res
	res = parse_node_get_string (pn)
	if (char (trim (res)) == "") then
	call msg_warning ("BLHA contract file: " // step // &
	": OLP didn't return a status --- assuming an error")
	ok = .false.
	elseif (char (upper_case (res)) /= "OK") then
	call msg_warning ("BLHA contract file: " // step // ': OLP error "' // &
	char (res) // '"')
	ok = .false.
	end if
	end subroutine check_result

	function get_fname (pn) result (fname)
	type(parse_node_t), pointer :: pn
	type(string_t) :: fname
	type(parse_node_t), pointer :: pn_component
	if (char (parse_node_get_rule_key (pn)) == "string") then
	fname = parse_node_get_string (pn)
	else
	fname = ""
	pn_component => parse_node_get_sub_ptr (pn)
	do while (associated (pn_component))
	if (char (parse_node_get_rule_key (pn_component)) == "id") then
	fname = fname // parse_node_get_string (pn_component)
	else
	fname = fname // parse_node_get_key (pn_component)
	end if
	pn_component => parse_node_get_next_ptr (pn_component)
	end do
	end if
	end function get_fname

	end subroutine blha_transfer_contract

	@ %def
	@
	Init the lexer.
	<<BLHA config: procedures>>=
	subroutine blha_init_lexer (lexer)
	type(lexer_t), intent(inout) :: lexer
	call lexer_init (lexer, &
	comment_chars = "#", &
	quote_chars = '"', &
	quote_match = '"', &
	single_chars = '{}\|./\:', &
	special_class = (/"->"/), &
	keyword_list = syntax_get_keyword_list_ptr (syntax_blha_contract), &
	upper_case_keywords = .false. &
	)
	end subroutine blha_init_lexer

	@ %def
	@
	Define the parser syntax table.
	<<BLHA config: variables>>=
	type(syntax_t), target :: syntax_blha_contract
	<<BLHA config: public>>=
	public :: syntax_blha_contract_init
	<<BLHA config: procedures>>=
	subroutine syntax_blha_contract_init ()
	type(ifile_t) :: ifile
	call ifile_append (ifile, "SEQ contract = line*")
	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, "KEY '\|'")
	call ifile_append (ifile, "KEY ':'")
	call ifile_append (ifile, "IDE id")
	call ifile_append (ifile, "INT integer")
	call ifile_append (ifile, "ALT sign = '+' \| '-'")
	call ifile_append (ifile, "SEQ signed_integer = sign integer")
	call ifile_append (ifile, "QUO string = '""'...'""'")
	call ifile_append (ifile, "GRO line = '{' line_contents '}'")
	call ifile_append (ifile, "SEQ line_contents = request result?")
	call ifile_append (ifile, "ALT request = definition \| process")
	call ifile_append (ifile, "ALT definition = option_unary \| option_nary \| " &
	// "option_path \| option_numeric")
	call ifile_append (ifile, "KEY matrixelementsquaretype")
	call ifile_append (ifile, "KEY irregularisation")
	call ifile_append (ifile, "KEY massiveparticlescheme")
	call ifile_append (ifile, "KEY irsubtractionmethod")
	call ifile_append (ifile, "KEY modelfile")
	call ifile_append (ifile, "KEY operationmode")
	call ifile_append (ifile, "KEY subdividesubprocess")
	call ifile_append (ifile, "KEY alphaspower")
	call ifile_append (ifile, "KEY alphapower")
	call ifile_append (ifile, "KEY correctiontype")
	call ifile_append (ifile, "KEY md5")
	call ifile_append (ifile, "SEQ option_unary = key_unary arg")
	call ifile_append (ifile, "SEQ option_nary = key_nary arg+")
	call ifile_append (ifile, "SEQ option_path = key_path arg_path")
	call ifile_append (ifile, "SEQ option_numeric = key_numeric arg_numeric")
	call ifile_append (ifile, "ALT key_unary = irregularisation \| " &
	// "massiveparticlescheme \| irsubtractionmethod \| subdividesubprocess \| " &
	// "correctiontype \| md5")
	call ifile_append (ifile, "ALT key_nary = matrixelementsquaretype \| " &
	// "operationmode")
	call ifile_append (ifile, "ALT key_numeric = alphaspower \| alphapower")
	call ifile_append (ifile, "ALT key_path = modelfile")
	call ifile_append (ifile, "ALT arg = id \| string")
	call ifile_append (ifile, "ALT arg_numeric = integer \| signed_integer")
	call ifile_append (ifile, "ALT arg_path = filename \| string")
	call ifile_append (ifile, "SEQ filename = filename_atom+")
	call ifile_append (ifile, "ALT filename_atom = id \| '.' \| '/' \| '\' \| ':'")
	call ifile_append (ifile, "SEQ process = state '->' state")
	call ifile_append (ifile, "SEQ state = pdg+")
	call ifile_append (ifile, "ALT pdg = integer \| signed_integer")
	call ifile_append (ifile, "SEQ result = '\|' result_atom+")
	call ifile_append (ifile, "ALT result_atom = integer \| string")
	call syntax_init (syntax_blha_contract, ifile)
	call ifile_final (ifile)
	end subroutine syntax_blha_contract_init

	@ %def
	@
	<<BLHA config: public>>=
	public :: syntax_blha_contract_final
	<<BLHA config: procedures>>=
	subroutine syntax_blha_contract_final
	call syntax_final (syntax_blha_contract)
	end subroutine syntax_blha_contract_final

	@ %def
	@
	As the contract file is line-oriented, we apply a preprocessing step which
	reformats the file in a way suitable for our free-form parser.
	<<BLHA config: procedures>>=
	subroutine contract_preprocess (stream, ifile)
	type(stream_t), intent(inout) :: stream
	type(ifile_t), intent(out) :: ifile
	type(string_t) :: buf, reg, transformed
	integer :: stat, n
	buf = ""
	LINES: do
	call stream_get_record (stream, reg, stat)
	select case (stat)
	case (0)
	case (EOF); exit LINES
	case default
	call msg_bug ("I/O error while reading BLHA contract file")
	end select
	buf = buf // trim (reg)
	! Take care of continuation lines
	if (char (extract (buf, len (buf), len(buf))) == '&') then
	buf = extract (buf, 1, len (buf) - 1) // " "
	cycle LINES
	end if
	buf = adjustl (buf)
	! Transform #@WO comments into ordinary statements
	if (char (extract (buf, 1, 4)) == "#@WO") &
	buf = extract (buf, 5)
	! Kill comments and blank lines
	if ((char (trim (buf)) == "") .or. &
	(char (extract (buf, 1, 1)) == "#")) then
	buf = ""
	cycle LINES
	end if
	! Chop off any end-of-line comments
	call split (buf, reg, "#")
	! Split line into order and result
	call split (reg, buf, "\|")
	reg = trim (adjustl (reg))
	buf = trim (adjustl (buf))
	! Check whether the order is a process definition
	n = scan (buf, ">")
	if (n == 0) then
	! No -> quote result
	reg = ('"' // reg) // '"'
	else
	! Yes -> leave any numbers as they are, quote any leftovers
	n = scan (reg, "0123456789", back=.true.)
	if (n < len (reg)) &
	reg = char (extract (reg, 1, n)) // ' "' // &
	char (trim (adjustl (extract (reg, n+1)))) // '"'
	end if
	! Enclose the line into curly brackets
	transformed = "{" // char (buf) // " \| " // char (reg) // "}"
	call ifile_append (ifile, transformed)
	buf = ""
	end do LINES
	end subroutine contract_preprocess

	@ %def
	@
	Test.
	<<BLHA config: public>>=
	public :: blha_config_test
	<<BLHA config: procedures>>=
	subroutine blha_config_test (model, cfg, ok)
	type(pdg_array_t), dimension(2) :: pdg_in
	type(pdg_array_t), dimension(4) :: pdg_out
	type(model_t), pointer :: model
	type(blha_configuration_t), intent(out) :: cfg
	logical, intent(out) :: ok
	integer :: u
	logical :: flag
	ok = .false.
	pdg_in(1) = (/1, 2, -1, -2/)
	pdg_in(2) = pdg_in(1)
	pdg_out(1) = pdg_in(1)
	pdg_out(2) = (/11/)
	pdg_out(3) = (/-11/)
	pdg_out(4) = pdg_out(1)
	call blha_configuration_init (cfg, var_str ("test"), model)
	call blha_configuration_set (cfg, alphas_power = 2, alpha_power = 3)
	call blha_configuration_append_process (cfg, pdg_in, pdg_out)
	call blha_configuration_freeze (cfg)
	print *
	call blha_configuration_write (cfg)
	print *
	call blha_configuration_final (cfg)
	call blha_configuration_init (cfg, var_str ("test"), model, &
	mode=BLHA_MODE_GOSAM)
	call blha_configuration_set (cfg, alphas_power = 0, &
	model_file = var_str ("test.slha"))
	pdg_in(1) = (/1/)
	pdg_in(2) = (/-1/)
	pdg_out(1) = (/22/)
	pdg_out(2) = (/22/)
	call blha_configuration_append_process (cfg, pdg_in, pdg_out(1:2))
	call blha_configuration_freeze (cfg)
	u = free_unit ()
	open (u, file="test.blha.order", action="write", status="replace")
	call blha_configuration_write (cfg, u)
	call blha_configuration_final (cfg)
	inquire (file="test.blha.contract", exist=flag)
	if (.not. flag) return
	call blha_configuration_init (cfg, var_str ("test"), model, mode=BLHA_MODE_GOSAM)
	call blha_read_contract (cfg, ok, var_str ("test.blha.contract"), success=flag)
	print *, "Reading back processed configuration: success? ", ok
	end subroutine blha_config_test

	@ %def
	@

	\subsection{OLP matrix element interface}

	The prototypes of the OLP functions.
	<<BLHA interface: interfaces>>=
	abstract interface
	subroutine ext_olp_start (file, status) bind(c)
	import
	character(c_char), dimension(*), intent(in) :: file
	integer(c_int), intent(out) :: status
	end subroutine ext_olp_Start

	subroutine ext_olp_evalsubprocess (label, momenta, scale, parameters, amp) &
	bind(c)
	import
	integer(c_int), intent(in), value :: label
	real(c_double), dimension(*), intent(in) :: momenta
	real(c_double), intent(in), value :: scale
	real(c_double), dimension(*), intent(in) :: parameters
	real(c_double), dimension(*), intent(out) :: amp
	end subroutine ext_olp_evalsubprocess

	subroutine ext_olp_finalize () bind(c)
	end subroutine ext_olp_finalize

	subroutine ext_olp_option (assignment, status) bind(c)
	import
	character(c_char), dimension(*), intent(in) :: assignment
	integer(c_int), intent(out) :: status
	end subroutine ext_olp_option
	end interface

	@ %def
	@
	The OLP library is encapsulated together with the configuration in derived type:
	<<BLHA interface: public>>=
	public :: blha_olp_t
	<<BLHA interface: types>>=
	type :: blha_olp_t
	private
	type(blha_configuration_t) :: cfg
	type(string_t) :: library
	integer :: n_in, n_out, n_flv, n_hel, n_col
	integer, dimension(:,:), allocatable :: flv_state
	logical :: color_summed = .true., flavor_summed = .true.
	logical :: loaded = .false.
	type(dlaccess_t) :: lib_handle
	procedure(ext_olp_start), pointer, nopass :: olp_start => null ()
	procedure(ext_olp_evalsubprocess), pointer, nopass :: &
	olp_evalsubprocess => null ()
	procedure(ext_olp_finalize), pointer, nopass :: olp_finalize => null ()
	procedure(ext_olp_option), pointer, nopass :: olp_option => null ()
	end type blha_olp_t

	@ %def
	@
	Init the [[blha_olp_t]] object and try to dlopen the library.
	<<BLHA interface: public>>=
	public :: blha_olp_init
	<<BLHA interface: procedures>>=
	subroutine blha_olp_init (olp, cfg, library, success)
	type(blha_olp_t), intent(out) :: olp
	type(string_t), intent(in), optional :: library
	type(blha_configuration_t), intent(in) :: cfg
	logical, intent(out), optional :: success
	type(blha_cfg_process_node_t), pointer :: node
	type(string_t) :: prefix, libname
	type(c_funptr) :: fptr
	integer :: olp_status
	success = .true.
	node => cfg%processes
	if (.not. associated (node)) then
	call error ("blha_interface_init: empty process list")
	return
	end if
	olp%n_in = size (node%pdg_in)
	olp%n_out = size (node%pdg_out)
	do while (associated (node))
	if ((olp%n_in /= size (node%pdg_in)) .or. &
	(olp%n_out /= size (node%pdg_out))) then
	call error ("blha_interface_init: inconsistent process list")
	return
	end if
	node => node%next
	end do
	if (present (library)) then
	olp%library = library
	else
	olp%library = cfg%name // ".so"
	end if
	if (char (extract (olp%library, 1, 1)) == "/") then
	prefix = ""
	libname = extract (olp%library, 2)
	else
	prefix = "."
	libname = olp%library
	end if
	call dlaccess_init (olp%lib_handle, prefix, libname)
	if (dlaccess_has_error (olp%lib_handle)) then
	call error ("blha_interface_init: error opening library: " // &
	char (dlaccess_get_error (olp%lib_handle)))
	call dlaccess_final (olp%lib_handle)
	return
	end if
	fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Start"))
	if (.not. check_dlstate ()) return
	call c_f_procpointer (fptr, olp%olp_start)
	fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_EvalSubProcess"))
	if (.not. check_dlstate ()) return
	call c_f_procpointer (fptr, olp%olp_evalsubprocess)
	if (olp%cfg%mode == BLHA_MODE_GOSAM) then
	fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Finalize"))
	if (.not. check_dlstate ()) return
	call c_f_procpointer (fptr, olp%olp_finalize)
	fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Option"))
	if (.not. check_dlstate ()) return
	call c_f_procpointer (fptr, olp%olp_option)
	end if
	call olp%olp_start (string_f2c (cfg%model_file), olp_status)
	if (olp_status /= 1) then
	call error ("blha_interface_init: OLP initialization failed")
	call dlaccess_final (olp%lib_handle)
	end if
	success = .true.
	olp%loaded = .true.

	contains

	function check_dlstate () result (ok)
	logical :: ok
	ok = .not. dlaccess_has_error (olp%lib_handle)
	if (.not. ok) then
	call error ("blha_interface_init: error loading library: " // &
	char (dlaccess_get_error (olp%lib_handle)))
	call dlaccess_final (olp%lib_handle)
	end if
	end function check_dlstate


	subroutine error (msg)
	character(*), intent(in) :: msg
	if (present (success)) then
	call msg_error (msg)
	success = .false.
	else
	call msg_fatal (msg)
	end if
	end subroutine error

	end subroutine blha_olp_init

	@ %def
	@

	Finalization
	<<BLHA interface: public>>=
	public :: blha_olp_final
	<<BLHA interface: procedures>>=
	subroutine blha_olp_final (olp)
	type(blha_olp_t), intent(inout) :: olp
	if (.not. olp%loaded) return
	if (associated (olp%olp_finalize)) call olp%olp_finalize
	call dlaccess_final (olp%lib_handle)
	olp%loaded = .false.
	end subroutine blha_olp_final

	@ %def blha_olp_final
	@

	Test.
	<<BLHA interface: public>>=
	public :: blha_interface_test
	<<BLHA interface: procedures>>=
	subroutine blha_interface_test (cfg, ok)
	type(blha_configuration_t), intent(inout) :: cfg
	type(blha_olp_t) :: olp
	logical, intent(out) :: ok
	call blha_olp_init (olp, cfg, library=var_str ("blha_test.so"), success=ok)
	print *, "loading OLP library: success?", ok
	call blha_olp_final (olp)
	end subroutine blha_interface_test

	@ %def
	@

	\subsection{OLP driver}

	<<BLHA driver: public>>=
	public :: blha_test
	<<BLHA driver: procedures>>=
	subroutine blha_test (model)
	type(model_t), pointer :: model
	type (blha_configuration_t) :: cfg
	logical :: ok
	call blha_config_test (model, cfg, ok)
	if (ok) call blha_interface_test (cfg, ok)
	end subroutine blha_test

	@ %def
	@
	\subsection{Phase-space workspace}
	This is not yet implemented:

	% Global kinematics is described by the two parameters [[sqrts]]
	% (c.m.\ energy) and [[lt]], which implements the relation between lab
	% and c.m.\ frame.
	%
	% The [[n_trees]] and [[n_groves]] refer to the [[forest]] component,
	% they denote the number of integration parameterizations
	% (channels/trees) and channel groups (groves), respectively.
	%
	% The [[forest]] component is the workspace where for each sampling
	% point, integration parameters are related to kinematic variables. It
	% consists of an array of trees, each of which describes a particular
	% relation between parameters and kinematics that belongs to a
	% particular channel in the multichannel sampling algorithm.
	%
	% The [[x]] component is the array of integration parameters. In the
	% multi-channel integration setup, one row of parameters
	% corresponds to the sampling channel selected for the current sampling
	% point. The other rows are computed backwards from the kinematics,
	% they are the parameter values that belong to the same kinematics in
	% another channel.
	%
	% Each channel is, after kinematics evaluation, associated with a weight
	% which we denote as the [[phs_factor]]. There is also a global
	% [[phs_volume]] factor and a [[vamp_phs_factor]] which are common to
	% all channels.
	<<XXX Processes: types>>=
	! real(default) :: sqrts = 0
	! type(lorentz_transformation_t) :: lt = identity
	! integer :: n_trees = 0
	! integer :: n_groves = 0
	! type(phs_forest_t) :: forest
	! real(default), dimension(:,:), allocatable :: x
	! real(default), dimension(:), allocatable :: factor
	! real(default) :: volume = 0
	! real(default) :: vamp_phs_factor = 0
	<<XXX Processes: procedures>>=
	@
	@
	\subsection{VAMP Configuration}
	This object contains all configuration data that are specific for a
	setup of VAMP grids. It also contains the grids themselves.

	The [[filename]] string will be used for reading/writing grids from/to disk.

	The [[grid_parameters]] object contains all VAMP-related configuration
	data.

	[[n_channels]] is the number of distinct parameterizations (channels)
	for the current VAMP dataset. This is the dimension of the grid array.

	[[n_dim]] is the number of integration dimensions for the current VAMP
	dataset.

	The [[grids]] component is the actual grid array. An instance of the
	process will take a copy of this and use it as workspace.

	The [[vamp_eq]] object declares equivalences between different
	channels in the VAMP grid array, which may involve permutations and
	reflections of the grid dimensions.

	The two [[history]] entries record the VAMP integration history for
	the current process object and VAMP data set.
	<<Processes: process part types>>=
	type :: process_vamp_data_t
	private
	! type(string_t) :: grid_filename
	! type(grid_parameters_t) :: grid_parameters
	! integer :: n_channels = 0
	! integer :: n_dim = 0
	! type(vamp_grids) :: grids
	! type(vamp_equivalences_t) :: equivalences
	! type(vamp_history), dimension(:), allocatable :: history
	! type(vamp_history), dimension(:,:), allocatable :: histories
	contains
	<<Processes: process vamp data: TBP>>
	end type process_vamp_data_t

	@ %def process_vamp_data_t
	@ We can choose whether we write the equivalences and the histories.
	The grids will not be written; they are usually on file.
	<<Processes: process vamp data: TBP>>=
	procedure :: write => process_vamp_data_write
	<<Processes: procedures>>=
	subroutine process_vamp_data_write (vamp, u, equivalences, history, histories)
	class(process_vamp_data_t), intent(in) :: vamp
	integer, intent(in) :: u
	logical, intent(in) :: equivalences, history, histories
	! write (u, *) " Grid base filename = '", char (vamp%grid_filename), "'"
	! call vamp%grid_parameters%write (u)
	! write (u, *) " Number of channels = ", vamp%n_channels
	! write (u, *) " Number of dimensions = ", vamp%n_dim
	! write (u, *) " VAMP grids [not shown / on file]"
	! if (equivalences) then
	! write (u, *) " List of channel equivalences:"
	! call vamp_equivalences_write (vamp%equivalences, u)
	! else
	! write (u, *) " List of channel equivalences: [not shown]"
	! end if
	! if (allocated (vamp%history)) then
	! if (history) then
	! write (u, *) " VAMP global history:"
	! call vamp_write_history (u, vamp%history)
	! else
	! write (u, *) " VAMP global history: [not shown]"
	! end if
	! else
	! write (u, *) " VAMP global history: [not allocated]"
	! end if
	! if (allocated (vamp%histories)) then
	! if (histories) then
	! write (u, *) " VAMP channel histories:"
	! call vamp_write_history (u, vamp%histories)
	! else
	! write (u, *) " VAMP channel histories: [not shown]"
	! end if
	! else
	! write (u, *) " VAMP channel histories: [not allocated]"
	! end if
	end subroutine process_vamp_data_write

	@ %def process_vamp_data_write
	@
	@
	\subsection{Grid parameters}
	This is a transparent container. It holds the parameters that are
	stored in grid files, and are checked when grid files are read.
	<<Processes: public>>=
	public :: grid_parameters_t
	<<Processes: types>>=
	type :: grid_parameters_t
	integer :: threshold_calls = 0
	integer :: min_calls_per_channel = 10
	integer :: min_calls_per_bin = 10
	integer :: min_bins = 3
	integer :: max_bins = 20
	logical :: stratified = .true.
	logical :: use_vamp_equivalences = .true.
	real(default) :: channel_weights_power = 0.25_default
	contains
	<<Processes: grid parameters: TBP>>
	end type grid_parameters_t

	@ %def grid_parameters_t
	@ I/O:
	<<Processes: grid parameters: TBP>>=
	procedure :: write => grid_parameters_write
	<<Processes: procedures>>=
	subroutine grid_parameters_write (grid_par, unit)
	class(grid_parameters_t), intent(in) :: grid_par
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit)
	write (u, *) "threshold_calls = ", grid_par%threshold_calls
	write (u, *) "min_calls_per_channel = ", grid_par%min_calls_per_channel
	write (u, *) "min_calls_per_bin = ", grid_par%min_calls_per_bin
	write (u, *) "min_bins = ", grid_par%min_bins
	write (u, *) "max_bins = ", grid_par%max_bins
	write (u, *) "stratified = ", grid_par%stratified
	write (u, *) "use_vamp_equivalences = ", grid_par%use_vamp_equivalences
	write (u, *) "channel_weights_power = ", grid_par%channel_weights_power
	end subroutine grid_parameters_write

	@ %def grid_parameters_write
	<<XXX Processes: procedures>>=
	subroutine grid_parameters_read (grid_par, unit)
	type(grid_parameters_t), intent(out) :: grid_par
	integer, intent(in) :: unit
	character(30) :: dummy
	character :: equals
	read (unit, *) dummy, equals, grid_par%threshold_calls
	read (unit, *) dummy, equals, grid_par%min_calls_per_channel
	read (unit, *) dummy, equals, grid_par%min_calls_per_bin
	read (unit, *) dummy, equals, grid_par%min_bins
	read (unit, *) dummy, equals, grid_par%max_bins
	read (unit, *) dummy, equals, grid_par%stratified
	read (unit, *) dummy, equals, grid_par%use_vamp_equivalences
	read (unit, *) dummy, equals, grid_par%channel_weights_power
	end subroutine grid_parameters_read

	@ %def grid_parameters_read
	<<XXX Processes: interfaces>>=
	interface operator(==)
	module procedure grid_parameters_eq
	end interface
	<<XXX Processes: procedures>>=
	function grid_parameters_eq (gp1, gp2) result (eq)
	logical :: eq
	type(grid_parameters_t), intent(in) :: gp1, gp2
	eq = gp1%threshold_calls == gp2%threshold_calls &
	.and. gp1%min_calls_per_channel == gp2%min_calls_per_channel &
	.and. gp1%min_calls_per_bin == gp2%min_calls_per_bin &
	.and. gp1%min_bins == gp2%min_bins &
	.and. gp1%max_bins == gp2%max_bins &
	.and.(gp1%stratified .eqv. gp2%stratified )&
	.and.(gp1%use_vamp_equivalences .eqv. gp2%use_vamp_equivalences)&
	.and. gp1%channel_weights_power == gp2%channel_weights_power
	end function grid_parameters_eq

	@ %def grid_parameters_eq
	<<XXX Processes: interfaces>>=
	interface operator(/=)
	module procedure grid_parameters_ne
	end interface
	<<XXX Processes: procedures>>=
	function grid_parameters_ne (gp1, gp2) result (ne)
	logical :: ne
	type(grid_parameters_t), intent(in) :: gp1, gp2
	ne = gp1%threshold_calls /= gp2%threshold_calls &
	.or. gp1%min_calls_per_channel /= gp2%min_calls_per_channel &
	.or. gp1%min_calls_per_bin /= gp2%min_calls_per_bin &
	.or. gp1%min_bins /= gp2%min_bins &
	.or. gp1%max_bins /= gp2%max_bins &
	.or.(gp1%stratified .neqv. gp2%stratified )&
	.or.(gp1%use_vamp_equivalences .neqv. gp2%use_vamp_equivalences)&
	.or. gp1%channel_weights_power /= gp2%channel_weights_power
	end function grid_parameters_ne

	@ %def grid_parameters_ne
	@
	\subsection{MD5 sum collection for grid files}
	For checking input in detail, grid files hold various MD5 sums that
	correspond to input data. This is a transparent container.
	<<Processes: public>>=
	public :: md5sum_grids_t
	<<Processes: types>>=
	type :: md5sum_grids_t
	character(32) :: process = ""
	character(32) :: model = ""
	character(32) :: parameters = ""
	character(32) :: phs = ""
	character(32) :: beams = ""
	character(32) :: sf_list = ""
	character(32) :: mappings = ""
	character(32) :: cuts = ""
	character(32) :: weight = ""
	character(32) :: scale = ""
	character(32) :: fac_scale = ""
	character(32) :: ren_scale = ""
	character(32) :: alpha_s = ""
	character(32) :: nlo_setup = ""
	end type md5sum_grids_t

	@ %def md5sum_grids_t
	<<Processes: procedures>>=
	subroutine md5sum_grids_write (md5sum, unit)
	type(md5sum_grids_t), intent(in) :: md5sum
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit)
	write (u, *) " md5sum_process = ", '"', md5sum%process, '"'
	write (u, *) " md5sum_model = ", '"', md5sum%model, '"'
	write (u, *) " md5sum_parameters = ", '"', md5sum%parameters, '"'
	write (u, *) " md5sum_phase_space = ", '"', md5sum%phs, '"'
	write (u, *) " md5sum_beams = ", '"', md5sum%beams, '"'
	write (u, *) " md5sum_sf_list = ", '"', md5sum%sf_list, '"'
	write (u, *) " md5sum_mappings = ", '"', md5sum%mappings, '"'
	write (u, *) " md5sum_cuts = ", '"', md5sum%cuts, '"'
	write (u, *) " md5sum_weight = ", '"', md5sum%weight, '"'
	write (u, *) " md5sum_scale = ", '"', md5sum%scale, '"'
	write (u, *) " md5sum_fac_scale = ", '"', md5sum%fac_scale, '"'
	write (u, *) " md5sum_ren_scale = ", '"', md5sum%ren_scale, '"'
	write (u, *) " md5sum_alpha_s = ", '"', md5sum%alpha_s, '"'
	write (u, *) " md5sum_nlo_setup = ", '"', md5sum%nlo_setup, '"'
	end subroutine md5sum_grids_write

	@ %def md5sum_grids_write


	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Processes}

	\subsection{Copy routines}

	The copying routine performs a deep copy, which then can be used as a
	process instance for generating new sampling points or complete
	events. This means, that all information is self-contained
	with no pointers pointing back to the original process object or its
	subobjects. Data is copied from
	initialization and structural information up to the developed
	integration grids. Information specific for the sampling point may be
	copied or left empty; the assumption is that the copy will be used for
	creating new, independent sampling points.

	The target process must be provided with the [[target]] attribute,
	because there will be pointers pointing to it or its subobjects.
	Conversely, the procedure should not create persistent pointers to the
	source process, so this does not need the attribute.

	The source of the copy is polymorphic in principle, so we may apply
	this for an extension of the [[process_t]] type. However, the target
	must be a plain [[process_t]] object.

	To emphasize that this is neither a complete snapshot not a shallow
	copy, we do not overload assignment with this routine. Furthermore, keeping
	pointer consistency requires extra arguments for some of the
	sub-copies. This would not be possible via defined assignment.
	<<XXX Processes: process: TBP>>=
	procedure :: copy_to => process_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_copy_to (process, copy)
	class(process_t), intent(in) :: process
	type(process_t), intent(out), target :: copy
	integer :: i
	copy%type = process%type
	call process%meta%copy_to (copy%meta)
	call process%config%copy_to (copy%config)
	call process%beams%copy_to (copy%beams)
	if (allocated (process%strfun)) then
	allocate (copy%strfun (size (process%strfun)))
	do i = 1, size (process%strfun)
	call process%strfun(i)%copy_to (copy%strfun(i))
	end do
	end if
	if (allocated (process%vamp)) then
	allocate (copy%vamp (size (process%vamp)))
	do i = 1, size (process%vamp)
	call process%vamp(i)%copy_to (copy%vamp(i))
	end do
	end if
	if (allocated (process%technical_phs)) then
	allocate (copy%technical_phs (size (process%technical_phs)))
	do i = 1, size (process%technical_phs)
	call process%technical_phs(i)%copy_to (copy%technical_phs(i))
	end do
	end if
	if (allocated (process%effective_state)) then
	allocate (copy%effective_state (size (process%effective_state)))
	do i = 1, size (process%effective_state)
	call process%effective_state(i)%copy_to &
	(copy%effective_state(i), copy)
	end do
	end if
	if (allocated (process%component)) then
	allocate (copy%component (size (process%component)))
	do i = 1, size (process%component)
	call process%component(i)%copy_to (copy%component(i))
	end do
	end if
	if (allocated (process%results)) then
	allocate (copy%results (size (process%results)))
	do i = 1, size (process%results)
	call process%results(i)%copy_to (copy%results(i))
	end do
	end if
	end subroutine process_copy_to

	@ %def process_copy_to
	@ The process instance inherits all data.
	Deep-copying a variable list is done by the [[snapshot]] subroutine.
	<<XXX Processes: process metadata: TBP>>=
	procedure :: copy_to => process_metadata_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_metadata_copy_to (meta, copy)
	class(process_metadata_t), intent(in) :: meta
	type(process_metadata_t), intent(out) :: copy
	copy%id = meta%id
	copy%run_id = meta%run_id
	call var_list_init_snapshot (copy%var_list, meta%var_list)
	end subroutine process_metadata_copy_to

	@ %def process_metadata_copy_to
	@ The configuration data contain pointers, which should be just
	shallow-copied. The QCD record contains only atomic data. Therefore,
	a straightforward assignment is sufficient.
	<<XXX Processes: process config data: TBP>>=
	procedure :: copy_to => process_config_data_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_config_data_copy_to (config, copy)
	class(process_config_data_t), intent(in) :: config
	type(process_config_data_t), intent(out) :: copy
	copy = config
	end subroutine process_config_data_copy_to

	@ %def process_config_data_copy_to
	@
	<<XXX Processes: process beam data: TBP>>=
	procedure :: copy_to => process_beam_data_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_beam_data_copy_to (beam, copy)
	class(process_beam_data_t), intent(in) :: beam
	type(process_beam_data_t), intent(out) :: copy
	copy%sqrts = beam%sqrts
	copy%use_beams = beam%use_beams
	if (beam%use_beams) call beam%data%copy_to (copy%data)
	copy%azimuthal_dependence = beam%azimuthal_dependence
	copy%lab_is_cm_frame = beam%lab_is_cm_frame
	end subroutine process_beam_data_copy_to

	@ %def process_beam_data_copy_to
	@ For copying the structure function chain, there is defined assignment.
	We have to call this explicitly, since the assignment is not type-bound.
	<<XXX Processes: process strfun data: TBP>>=
	procedure :: copy_to => process_strfun_data_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_strfun_data_copy_to (strfun, copy)
	class(process_strfun_data_t), intent(in) :: strfun
	type(process_strfun_data_t), intent(out) :: copy
	copy%n_strfun = strfun%n_strfun
	copy%n_mcvar = strfun%n_mcvar
	copy%sfchain = strfun%sfchain
	end subroutine process_strfun_data_copy_to

	@ %def process_strfun_data_copy_to
	@ Here we have to use VAMP's support for deep copy. For histories,
	there is currently no support, so we have to skip them. For the
	equivalence set, there is defined assignment.
	<<XXX Processes: process vamp data: TBP>>=
	procedure :: copy_to => process_vamp_data_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_vamp_data_copy_to (vamp, copy)
	class(process_vamp_data_t), intent(in) :: vamp
	type(process_vamp_data_t), intent(out) :: copy
	copy%grid_filename = vamp%grid_filename
	copy%grid_parameters = vamp%grid_parameters
	copy%n_channels = vamp%n_channels
	copy%n_dim = vamp%n_dim
	call vamp_copy_grids (copy%grids, vamp%grids)
	copy%equivalences = vamp%equivalences
	! should copy histories here
	end subroutine process_vamp_data_copy_to

	@ %def process_vamp_data_copy_to
	@ The forest needs a copy of structure, not content. The arrays are
	allocated with matching shape, but left empty. (MOLD argument would
	be more elegant.) The [[passed]] component is default-initialized as
	false.
	<<XXX Processes: process technical phs: TBP>>=
	procedure :: copy_to => process_technical_phs_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_technical_phs_copy_to (phs, copy)
	class(process_technical_phs_t), intent(in) :: phs
	type(process_technical_phs_t), intent(out) :: copy
	copy%is_seed = phs%is_seed
	copy%sqrts = phs%sqrts
	copy%lt = phs%lt
	copy%n_trees = phs%n_trees
	copy%n_groves = phs%n_groves
	call phs%forest%copy_to (copy%forest)
	allocate (copy%x (size (phs%x, 1), size (phs%x, 2))); copy%x = 0
	allocate (copy%factor (size (phs%factor))); copy%factor = 0
	copy%volume = phs%volume
	copy%vamp_phs_factor = 0
	end subroutine process_technical_phs_copy_to

	@ %def process_technical_phs_copy_to
	call state%fac_scale_expr%copy_to (copy%fac_scale_expr)
	call state%ren_scale_expr%copy_to (copy%ren_scale_expr)
	call state%reweighting_expr%copy_to (copy%reweighting_expr)
	copy%alpha_s_at_scale = state%alpha_s_at_scale
	copy%sqme = state%sqme
	copy%has_separate_evaluators = state%has_separate_evaluators
	if (state%has_separate_evaluators) then
	allocate (state%eval_trace)
	allocate (state%eval_sqme)
	allocate (state%eval_flows)
	call state%eval_trace%copy_to (copy%eval_trace)
	call state%eval_sqme%copy_to (copy%eval_sqme)
	call state%eval_flows%copy_to (copy%eval_flows)
	else
	copy%eval_trace => &
	process_copy%component(copy%i_component)%get_eval_trace_ptr ()
	copy%eval_sqme => &
	process_copy%component(copy%i_component)%get_eval_sqme_ptr ()
	copy%eval_flows => &
	process_copy%component(copy%i_component)%get_eval_flows_ptr ()
	end if
	end subroutine process_effective_state_copy_to

	@ %def process_effective_state_copy_to
	@ The process pointer must point to the process copy.

	The evaluation status indicates a fresh instance. Index arrays are
	assigned via allocation-on-assignment.

	The copy has rely on the copy method of the core component.
	Assuming that we cannot (yet) take advantage of the MOLD argument (for
	allocate), we call a separate method of the process-variant object
	which creates a new uninitialized instance of identical type.
	<<XXX Processes: process component: TBP>>=
	procedure :: copy_to => process_component_copy_to
	<<XXX Processes: procedures>>=
	subroutine process_component_copy_to (component, copy, process_copy)
	class(process_component_t), intent(in) :: component
	type(process_component_t), intent(out) :: copy
	type(process_t), intent(in), target :: process_copy
	copy%process_ptr => process_copy
	select case (component%evaluation_status)
	case (CI_STATE_UNDEFINED)
	copy%evaluation_status = CI_STATE_UNDEFINED
	case default
	copy%evaluation_status = CI_STATE_CLEAR
	end select
	copy%i_mcset = component%i_mcset
	copy%i_vamp = component%i_vamp
	copy%i_sfchain = component%i_sfchain
	copy%i_technical_phs = component%i_technical_phs
	copy%i_effective_state = component%i_effective_state
	call component%core%allocate_instance (copy%core)
	call component%core%copy_to (copy%core)
	end subroutine process_component_copy_to

	@ %def process_component_copy_to
	@


	\subsection{Process status}
	This is a block that allows to follow the evaluation status of the
	current call, and to trace the status of the current sample.
	<<XXX Processes: public>>=
	public :: process_status_t
	<<XXX Processes: types>>=
	type :: process_status_t
	logical :: called = .false.
	logical :: passed_strfun_chain = .false.
	logical :: passed_mass_threshold = .false.
	logical :: passed_kinematics = .false.
	logical :: passed_cuts = .false.
	logical :: passed_evaluation = .false.
	integer :: n_called = 0
	integer :: n_passed_strfun_chain = 0
	integer :: n_passed_mass_threshold = 0
	integer :: n_passed_kinematics = 0
	integer :: n_passed_cuts = 0
	integer :: n_passed_evaluation = 0
	end type process_status_t

	@ %def process_status_t
	@ Complete account (for the process log)
	<<XXX Processes: procedures>>=
	subroutine process_status_write (status, unit)
	type(process_status_t), intent(in) :: status
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit); if (u < 0) return
	1 format (1x,A,L1,3x,I9)
	write (u, *) "Process evaluation status (count):"
	write (u, 1) " called = ", status%called, &
	status%n_called
	write (u, 1) " passed strfun_chain = ", status%passed_strfun_chain, &
	status%n_passed_strfun_chain
	write (u, 1) " passed mass_threshold = ", status%passed_mass_threshold, &
	status%n_passed_mass_threshold
	write (u, 1) " passed kinematics = ", status%passed_kinematics, &
	status%n_passed_kinematics
	write (u, 1) " passed cuts = ", status%passed_cuts, &
	status%n_passed_cuts
	write (u, 1) " passed evaluation = ", status%passed_evaluation, &
	status%n_passed_evaluation
	end subroutine process_status_write

	@ %def process_status_write
	@ Counters only (for evaluating complete samples)
	<<XXX Processes: public>>=
	public :: process_status_write_counters
	<<XXX Processes: procedures>>=
	subroutine process_status_write_counters (status, unit)
	type(process_status_t), intent(in) :: status
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit); if (u < 0) return
	1 format (2x,A,1x,I9)
	call msg_message ("Process evaluation counters:", unit=u)
	write (msg_buffer, 1) "called = ", &
	status%n_called
	call msg_message (unit=u)
	write (msg_buffer, 1) "passed strfun_chain = ", &
	status%n_passed_strfun_chain
	call msg_message (unit=u)
	write (msg_buffer, 1) "passed mass_threshold = ", &
	status%n_passed_mass_threshold
	call msg_message (unit=u)
	write (msg_buffer, 1) "passed kinematics = ", &
	status%n_passed_kinematics
	call msg_message (unit=u)
	write (msg_buffer, 1) "passed cuts = ", &
	status%n_passed_cuts
	call msg_message (unit=u)
	write (msg_buffer, 1) "passed evaluation = ", &
	status%n_passed_evaluation
	call msg_message (unit=u)
	end subroutine process_status_write_counters

	@ %def process_status_write_counters
	<<XXX Processes: procedures>>=
	subroutine process_status_reset_flags (status)
	type(process_status_t), intent(inout) :: status
	status%called = .false.
	status%passed_strfun_chain = .false.
	status%passed_mass_threshold = .false.
	status%passed_kinematics = .false.
	status%passed_cuts = .false.
	status%passed_evaluation = .false.
	end subroutine process_status_reset_flags

	@ %def process_status_reset_flags
	@ Complete reset. Make use of default initialization.
	<<XXX Processes: procedures>>=
	subroutine process_status_reset_counters (status)
	type(process_status_t), intent(out) :: status
	end subroutine process_status_reset_counters

	@ %def process_status_reset_counters
	@ Set a flag and increment the associated counters:
	<<XXX Processes: procedures>>=
	subroutine process_status_called (status)
	type(process_status_t), intent(inout) :: status
	status%called = .true.
	status%n_called = status%n_called + 1
	end subroutine process_status_called

	subroutine process_status_passed_strfun_chain (status)
	type(process_status_t), intent(inout) :: status
	status%passed_strfun_chain = .true.
	status%n_passed_strfun_chain = status%n_passed_strfun_chain + 1
	end subroutine process_status_passed_strfun_chain

	subroutine process_status_passed_mass_threshold (status)
	type(process_status_t), intent(inout) :: status
	status%passed_mass_threshold = .true.
	status%n_passed_mass_threshold = status%n_passed_mass_threshold + 1
	end subroutine process_status_passed_mass_threshold

	subroutine process_status_passed_kinematics (status)
	type(process_status_t), intent(inout) :: status
	status%passed_kinematics = .true.
	status%n_passed_kinematics = status%n_passed_kinematics + 1
	end subroutine process_status_passed_kinematics

	subroutine process_status_passed_cuts (status)
	type(process_status_t), intent(inout) :: status
	status%passed_cuts = .true.
	status%n_passed_cuts = status%n_passed_cuts + 1
	end subroutine process_status_passed_cuts

	subroutine process_status_passed_evaluation (status)
	type(process_status_t), intent(inout) :: status
	status%passed_evaluation = .true.
	status%n_passed_evaluation = status%n_passed_evaluation + 1
	end subroutine process_status_passed_evaluation

	@ %def process_status_called
	@ %def process_status_passed_strfun_chain
	@ %def process_status_passed_mass_threshold
	@ %def process_status_passed_kinematics
	@ %def process_status_passed_cuts
	@ %def process_status_passed_evaluation
	@
	\subsection{Kinematics data}

	Two additional derived types encapsulate the information associated to the
	``in'' and ``out'' phasespace points. As the first ``out'' point is the only
	one in the usual case of ordinary matrix elements, it is treated special. In
	particular, the identity evaluator used for snapshotting the structure function
	chain is unset, and the corresponding interaction points directly into the
	chain.
	<<XXX Processes: types>>=
	type :: kinematic_configuration_in_t
	! type(phs_forest_t) :: forest
	! real(default), dimension(:,:), allocatable :: x
	! real(default), dimension(:), allocatable :: phs_factor
	! real(default) :: phs_volume = 0
	! real(default) :: vamp_phs_factor = 0
	! real(default) :: sqrts = 0
	! type(lorentz_transformation_t) :: lt = identity
	! logical :: passed
	end type kinematic_configuration_in_t

	type :: kinematic_configuration_out_t
	! type(subevt_t) :: subevt
	! type(eval_tree_t) :: cut_expr
	! type(eval_tree_t) :: scale_expr
	! type(eval_tree_t) :: fac_scale_expr
	! type(eval_tree_t) :: ren_scale_expr
	! type(eval_tree_t) :: reweighting_expr
	! real(kind=default) :: sqme
	! real(kind=default) :: phs_weight = 0
	! real(kind=default) :: reweighting_factor = 0
	! real(kind=default) :: scale = 0
	! real(kind=default) :: fac_scale = 0
	! real(kind=default) :: ren_scale = 0
	! real(kind=default) :: alpha_s_at_scale = 0
	! type(evaluator_t) :: eval_trace
	type(evaluator_t) :: eval_beam_flows
	! type(evaluator_t) :: eval_sqme
	! type(evaluator_t) :: eval_flows
	type(interaction_t), pointer :: strfun
	type(evaluator_t) :: strfun_snapshot
	! logical :: passed
	end type kinematic_configuration_out_t

	@ %def kinematic_configuration_in_t
	@ %def kinematic_configuration_out_t
	@
	\subsection{The process type}
	<<XXX Processes: public>>=
	public :: process_t
	<<XXX Processes: types>>=
	type :: process_t_obsolete
	private
	! integer :: type = PRC_UNKNOWN
	type(process_t), pointer :: copy => null ()
	logical :: is_original = .true.
	type(process_t), pointer :: original => null ()
	type(process_t), pointer :: working_copy => null ()
	logical :: in_use = .true.
	! type(string_t) :: id
	logical :: initialized = .false.
	logical :: has_matrix_element = .false.
	logical :: use_hi_color_factors = .false.
	! logical :: use_beams = .true.
	logical :: has_extra_evaluators = .true.
	logical :: beams_are_set = .false.
	logical :: is_cascade_decay = .false.
	type(flavor_t), dimension(:), allocatable :: flv_in
	type(flavor_t), dimension(:), allocatable :: flv_out_eff
	type(flavor_t), dimension(:), allocatable :: flv_out_real
	! type(beam_data_t) :: beam_data
	! character(32) :: md5sum = ""
	type(process_library_t), pointer :: prc_lib => null ()
	integer :: lib_index = 0
	integer :: store_index = 0
	! type(model_t), pointer :: model
	! integer :: n_strfun = 0
	! integer :: n_par_strfun = 0
	integer :: n_par_phs = 0
	integer :: n_par_ci = 0
	integer :: n_par = 0
	! logical :: azimuthal_dependence = .false.
	logical :: vamp_grids_defined = .false.
	! logical :: sqrts_known = .false.
	logical :: sqrts_hat_known = .false.
	! real(default) :: sqrts = 0
	real(default) :: sqrts_hat = 0
	real(default), dimension(:), allocatable :: x_strfun
	real(default), dimension(:), allocatable :: x_phs
	real(default), dimension(:), allocatable :: x_ci
	integer :: n_channels = 0
	integer :: n_bins = 0
	integer :: channel = 0
	! logical :: lab_is_cm_frame = .true.
	type(lorentz_transformation_t) :: lt_cm_to_lab = identity
	type(process_status_t) :: status
	real(default), dimension(:), allocatable :: mass_in
	real(default) :: flux_factor = 0
	real(default) :: averaging_factor = 0
	real(default) :: sf_mapping_factor = 0
	real(default) :: sample_function_value = 0
	logical :: negative_weights = .false.
	! type(qcd_parameters_t) :: qcd
	character(32) :: md5sum_alpha_s
	! type(strfun_chain_t) :: sfchain
	! type(core_interaction_t) :: ci
	! integer :: ci_type = CI_UNDEFINED
	logical :: fatal_beam_decay = .true.
	character(32) :: md5sum_phs = ""
	! type(vamp_equivalences_t) :: vamp_eq
	integer, dimension(:), allocatable :: j_beam
	integer, dimension(:), allocatable :: j_in
	! j_out applies to the _effective_ final state
	integer, dimension(:), allocatable :: j_out
	! type(var_list_t) :: var_list
	! type(parse_node_t), pointer :: cut_pn => null ()
	! type(parse_node_t), pointer :: weight_pn => null ()
	! type(parse_node_t), pointer :: scale_pn => null ()
	! type(parse_node_t), pointer :: fac_scale_pn => null ()
	! type(parse_node_t), pointer :: ren_scale_pn => null ()
	logical, dimension(:), allocatable :: active_channel
	! type(string_t) :: filename_current_grid
	! type(string_t) :: filename_best_grid
	type(md5sum_grids_t) :: md5sum_grids
	! type(grid_parameters_t) :: grid_parameters
	integer, dimension(:), allocatable :: pass_array
	integer, dimension(:), allocatable :: n_calls_array
	! type(vamp_grids) :: grids
	! type(vamp_history), dimension(:), allocatable :: v_history
	! type(vamp_history), dimension(:,:), allocatable :: v_histories
	type(integration_results_t) :: results
	! type(kinematic_configuration_in_t), allocatable, dimension(:) :: &
	! kinematics_in
	! type(kinematic_configuration_out_t), allocatable, dimension(:) :: &
	! kinematics_out
	! integer :: n_kinematics_in = 0
	! integer :: n_kinematics_out = 0
	logical :: trivial_kinematics = .false.
	integer, dimension(:), allocatable :: sqme_diagonal_entries
	character(32) :: md5sum_nlo_setup
	end type process_t_obsolete

	@ %def process_t
	@ Initialization. We set up the hard-interaction parameters and make
	them available in the variable list (which extends the variable list
	of the current model). Finally, we initialize the subevent that
	is used for evaluating expressions.

	The flag [[use_beams]] may be set false. In that case, beam (and
	structure function) data are meaningless or are skipped. For a
	scattering process, a head-to-head collision is assumed. For a decay
	process, the particle is assumed to decay in its rest frame. The
	initial state is assumed unpolarized.

	If a variable list is provided as an argument, it replaces the model
	variable list. This implies that it should be linked to the model
	variable list.
	<<XXX Processes: procedures>>=
	subroutine process_init &
	(process, prc_lib, process_lib_index, process_store_index, &
	process_id, model, var_list, use_beams)
	type(process_t), intent(out), target :: process
	type(process_library_t), intent(in), target :: prc_lib
	integer, intent(in) :: process_lib_index
	integer, intent(in) :: process_store_index
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(in), target :: var_list
	logical, intent(in), optional :: use_beams
	integer :: n_in, n_out_eff, n_tot_eff
	integer :: n_out_real, n_tot_real
	integer :: n_beam
	integer :: i
	process%prc_lib => prc_lib
	process%lib_index = process_lib_index
	process%store_index = process_store_index
	process%id = process_id
	process%md5sum = process_library_get_process_md5sum &
	(process%prc_lib, process%lib_index)
	call core_interaction_init (process%ci, prc_lib, process_lib_index, &
	process_id, model)
	process%has_matrix_element = &
	core_interaction_get_n_flv_eff (process%ci) /= 0
	process%use_hi_color_factors = &
	var_list_get_lval (var_list, var_str ("?read_color_factors"))
	process%model => core_interaction_get_model_ptr (process%ci)
	if (.not. core_interaction_is_valid (process%ci)) then
	return
	else
	process%id = core_interaction_get_id (process%ci)
	if (.not. process%has_matrix_element) then
	process%initialized = .true.
	return
	end if
	end if
	if (present (use_beams)) then
	process%use_beams = use_beams
	process%has_extra_evaluators = use_beams
	end if
	! n_in = core_interaction_get_n_in (process%ci)
	n_out_real = core_interaction_get_n_out_real (process%ci)
	n_tot_real = core_interaction_get_n_tot_real (process%ci)
	n_out_eff = core_interaction_get_n_out_eff (process%ci)
	n_tot_eff = core_interaction_get_n_tot_eff (process%ci)
	select case (n_in)
	case (1); process%type = PRC_DECAY
	case (2); process%type = PRC_SCATTERING
	end select
	allocate (process%flv_in (n_in))
	call flavor_init (process%flv_in, &
	core_interaction_get_first_pdg_in (process%ci), process%model)
	allocate (process%flv_out_real (n_out_real))
	call flavor_init (process%flv_out_real, &
	core_interaction_get_first_pdg_out_real (process%ci), process%model)
	allocate (process%flv_out_eff (n_out_eff))
	call flavor_init (process%flv_out_eff, &
	core_interaction_get_first_pdg_out_eff (process%ci), process%model)
	allocate (process%mass_in (n_in))
	process%mass_in = flavor_get_mass (process%flv_in)
	if (process%use_beams) then
	n_beam = n_in
	process%averaging_factor = 1
	else
	n_beam = 0
	process%averaging_factor = &
	1._default / product (flavor_get_multiplicity (process%flv_in))
	end if
	call process_assign_global_var_list (process, var_list)

	process%fatal_beam_decay = &
	var_list_get_lval (var_list, var_str ("?fatal_beam_decay"))

	call var_list_append_int (process%var_list, &
	var_str ("n_in"), n_in, intrinsic=.true.)
	call var_list_append_int (process%var_list, &
	var_str ("n_out_eff"), n_out_eff, intrinsic=.true.)
	call var_list_append_int (process%var_list, &
	var_str ("n_tot_eff"), n_tot_eff, intrinsic=.true.)
	call var_list_append_int (process%var_list, &
	var_str ("n_out_real"), n_out_real, intrinsic=.true.)
	call var_list_append_int (process%var_list, &
	var_str ("n_tot_real"), n_tot_real, intrinsic=.true.)
	call var_list_append_real_ptr (process%var_list, &
	var_str ("sqrts"), process%sqrts, process%sqrts_known, &
	intrinsic=.true.)
	call var_list_append_real_ptr (process%var_list, &
	var_str ("sqrts_hat"), process%sqrts_hat, process%sqrts_hat_known, &
	intrinsic=.true.)
	allocate (process%j_beam (n_beam))
	allocate (process%j_in (n_in))
	allocate (process%j_out (n_out_eff))
	process%filename_current_grid = ""
	process%filename_best_grid = ""
	process%initialized = .true.
	process%trivial_kinematics = core_interaction_trivial_kinematics ( &
	process%ci)
	process%n_kinematics_in = core_interaction_get_n_kinematics_in ( &
	process%ci)
	process%n_kinematics_out = core_interaction_get_n_kinematics_out ( &
	process%ci)
	allocate (process%kinematics_in (process%n_kinematics_in))
	allocate (process%kinematics_out (process%n_kinematics_out))
	process%ci_type = core_interaction_get_type (process%ci)
	if (process%trivial_kinematics) then
	process%negative_weights = &
	var_list_get_lval (var_list, var_str ("?negative_weights"))
	else
	process%negative_weights = .true.
	end if
	process%n_par_ci = core_interaction_get_n_x (process%ci)
	do i = 1, process%n_kinematics_out
	call subevt_init (process%kinematics_out(i)%subevt, &
	n_beam + n_in + n_out_eff)
	end do
	process%md5sum_nlo_setup = nlo_setup_md5sum ( &
	process_library_get_nlo_setup (prc_lib, process_id))
	end subroutine process_init

	@ %def process_init
	@ The QCD parameters, i.e., the treatment of $\alpha_s$, is an issue of
	its own, so we delegate this to a separate subroutine. The input data
	pointers should be assigned if there is a structure function setup which
	contains those data. Otherwise they are null, and we take the info from
	the variable list.

	If LHAPDF is required and not yet initialized, initialization is done
	here as a side-effect, and the status change is recorded.
	<<XXX Processes: public>>=
	public :: process_setup_qcd
	<<XXX Processes: procedures>>=
	subroutine process_setup_qcd (process, lhapdf_status, pdf_builtin_status, &
	lhapdf_data, pdf_builtin_data, os_data, var_list)
	type(process_t), intent(inout) :: process
	type(lhapdf_status_t), intent(inout) :: lhapdf_status
	type(pdf_builtin_status_t), intent(inout) :: pdf_builtin_status
	type(lhapdf_data_t), intent(in), pointer :: lhapdf_data
	type(pdf_builtin_data_t), intent(in), pointer :: pdf_builtin_data
	type(os_data_t), intent(in) :: os_data
	type(var_list_t), intent(in) :: var_list
	type(string_t) :: lhapdf_dir, lhapdf_file
	integer :: lhapdf_member
	type(string_t) :: pdf_builtin_set
	call qcd_parameters_basic_setup (process%qcd, var_list)
	if (associated (lhapdf_data)) then
	call lhapdf_data_get_public_info (lhapdf_data, &
	lhapdf_dir, lhapdf_file, lhapdf_member)
	call qcd_parameters_setup_lhapdf (process%qcd, lhapdf_status, &
	lhapdf_dir, lhapdf_file, lhapdf_member)
	else
	call qcd_parameters_setup_lhapdf (process%qcd, lhapdf_status, &
	var_list=var_list)
	end if
	if (associated (pdf_builtin_data)) then
	pdf_builtin_set = pdf_builtin_get_name (pdf_builtin_data)
	call qcd_parameters_setup_pdf_builtin (process%qcd, pdf_builtin_status, &
	os_data%pdf_builtin_datapath, pdf_builtin_set)
	else
	call qcd_parameters_setup_pdf_builtin (process%qcd, pdf_builtin_status, &
	os_data%pdf_builtin_datapath, var_list=var_list)
	end if
	process%md5sum_alpha_s = qcd_parameters_get_md5sum (process%qcd)
	end subroutine process_setup_qcd

	@ %def process_setup_qcd
	Return the type of PDFs
	<<XXX Processes: public>>=
	public :: process_get_strfun_type
	<<XXX Processes: procedures>>=
	function process_get_strfun_type(process) result(type)
	type(process_t), intent(in) :: process
	integer :: type
	type = strfun_chain_get_strfun_type(process%sfchain)
	end function process_get_strfun_type
	@ %def process_get_strfun_type
	Return the member of the PDF used
	<<XXX Processes: public>>=
	public :: process_get_strfun_set
	<<XXX Processes: procedures>>=
	function process_get_strfun_set(process) result(set)
	type(process_t), intent(in) :: process
	integer :: set
	set = strfun_chain_get_strfun_set(process%sfchain)
	end function process_get_strfun_set
	@ %def process_get_strfun_set
	@ Make a snapshot of the global variable list and link it to the process
	variables. This can be redone, so make sure a previous snapshot is deleted.
	<<XXX Processes: public>>=
	public :: process_assign_global_var_list
	<<XXX Processes: procedures>>=
	subroutine process_assign_global_var_list (process, var_list)
	type(process_t), intent(inout) :: process
	type(var_list_t), intent(in), optional, target :: var_list
	type(var_list_t), pointer :: var_list_snapshot
	var_list_snapshot => var_list_get_next_ptr (process%var_list)
	if (associated (var_list_snapshot)) then
	call var_list_final (var_list_snapshot)
	deallocate (var_list_snapshot)
	end if
	allocate (var_list_snapshot)
	call var_list_link (process%var_list, var_list_snapshot)
	if (present (var_list)) then
	call var_list_init_snapshot (var_list_snapshot, var_list)
	else
	call var_list_init_snapshot (var_list_snapshot, &
	model_get_var_list_ptr (process%model))
	end if
	end subroutine process_assign_global_var_list

	@ %def process_assign_global_var_list
	@ Finalization. In process copies, some components are just pointers
	to the original, so they should not be finalized separately.
	<<XXX Processes: procedures>>=
	recursive subroutine process_final (process)
	type(process_t), intent(inout), target :: process
	integer :: i
	call process_delete_copies (process)
	process%initialized = .false.
	process%type = PRC_UNKNOWN
	process%sqrts_known = .false.
	process%sqrts_hat_known = .false.
	if (allocated (process%sqme_diagonal_entries)) &
	deallocate (process%sqme_diagonal_entries)
	call strfun_chain_final (process%sfchain)
	call core_interaction_final (process%ci)
	do i = 1, process%n_kinematics_in
	call phs_forest_final (process%kinematics_in(i)%forest)
	end do
	do i = 1, process%n_kinematics_out
	call evaluator_final (process%kinematics_out(i)%eval_trace)
	call evaluator_final (process%Kinematics_out(i)%eval_beam_flows)
	call evaluator_final (process%kinematics_out(i)%eval_sqme)
	call evaluator_final (process%kinematics_out(i)%eval_flows)
	if (i /= 1) &
	call evaluator_final (process%kinematics_out(i)%strfun_snapshot)
	if (process%is_original) then
	call eval_tree_final (process%kinematics_out(i)%cut_expr)
	call eval_tree_final (process%kinematics_out(i)%reweighting_expr)
	call eval_tree_final (process%kinematics_out(i)%scale_expr)
	call eval_tree_final (process%kinematics_out(i)%fac_scale_expr)
	call eval_tree_final (process%kinematics_out(i)%ren_scale_expr)
	end if
	end do
	call vamp_equivalences_final (process%vamp_eq)
	if (process%is_original) then
	call var_list_final (process%var_list)
	end if
	if (process%vamp_grids_defined) then
	call vamp_delete_grids (process%grids)
	end if
	call process_final_vamp_history (process)
	end subroutine process_final

	@ %def process_final
	@ Output. This prints lots of stuff. The [[verbose]] option is for
	state matrices, the [[show_momentum_sum]] option prints the sums of
	incoming and outgoing momenta for all interactions, and the
	[[show_mass]] option computes and prints the signed invariant mass for
	all four-momenta.
	<<XXX Processes: public>>=
	public :: process_write
	<<XXX Processes: procedures>>=
	subroutine process_write &
	(process, unit, verbose, show_momentum_sum, show_mass)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	integer :: u, i, j
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)") repeat ("=", 72)
	write (u, *) "Process data:", process%lib_index, &
	"(", char (process%id), ")"
	select case (process%type)
	case (PRC_UNKNOWN); write (u, *) " [unknown]"
	case (PRC_DECAY); write (u, *) " [decay]"
	case (PRC_SCATTERING); write (u, *) " [scattering]"
	end select
	write (u, *) " is cascade decay = ", process%is_cascade_decay
	write (u, *) " use separate beam setup = ", process%use_beams
	call beam_data_write (process%beam_data, u)
	if (process%use_beams) then
	write (u, *) " number of structure functions = ", process%n_strfun
	write (u, *) " number of strfun parameters = ", process%n_par_strfun
	end if
	write (u, *) " number of auxilliary parameters = ", process%n_par_ci
	write (u, *) " number of phase space parameters = ", process%n_par_phs
	write (u, *) " number of parameters total = ", process%n_par
	write (u, *) " number of integration channels = ", process%n_channels
	write (u, *) " number of bins per channel = ", process%n_bins
	if (process%sqrts_known) then
	write (u, *) " c.m. energy (sqrts) = ", process%sqrts
	else
	write (u, *) " c.m. energy (sqrts) = [unknown]"
	end if
	write (u, *) " number of in type phase space configurations = ", &
	process%n_kinematics_in
	write (u, *) " number of out type phase space configuration = ", &
	process%n_kinematics_out
	write (u, *) repeat ("-", 72)
	call process_status_write (process%status, u)
	write (u, *) repeat ("-", 72)
	write (u, *) "Evaluation results:"
	if (process%sqrts_hat_known) then
	write (u, *) " c.m. energy (sqrts_hat) = ", process%sqrts_hat
	else
	write (u, *) " c.m. energy (sqrts_hat) = [unknown]"
	end if
	write (u, "(1x,A)", advance="no") " Colliding partons = "
	if (allocated (process%flv_in)) then
	do i = 1, size (process%flv_in)
	if (i == 2) write (u, "(1x)", advance="no")
	call flavor_write (process%flv_in(i), u)
	end do
	write (u, *)
	else
	write (u, *) "[undefined]"
	end if
	if (allocated (process%mass_in)) then
	write (u, *) " Incoming parton masses = ", process%mass_in
	else
	write (u, *) " Incoming parton masses = [unknown]"
	end if
	write (u, *) " In-state flux factor = ", process%flux_factor
	write (u, *) " Strfun mapping factor = ", process%sf_mapping_factor
	if (.not. process%use_beams) then
	write (u, *) " Spin averaging factor = ", process%averaging_factor
	end if
	write (u, *) " Sample-function value = ", &
	process%sample_function_value
	write (u, *) repeat ("-", 72)
	write (u, *) "Structure function parameters ="
	write (u, *) " Use beams = ", process%use_beams
	write (u, *) " x values = "
	if (allocated (process%x_strfun)) then
	write (u, *) process%x_strfun
	else
	write (u, *) " [not allocated]"
	end if
	write (u, *) "Phase space integration parameters = "
	if (allocated (process%x_phs)) then
	write (u, *) process%x_phs
	else
	write (u, *) "[empty]"
	end if
	write (u, *) "Auxiliary parameters = "
	if (allocated (process%x_ci)) then
	write (u, *) process%x_ci
	else
	write (u, *) "[empty]"
	end if
	write (u, *) repeat ("-", 72)
	call qcd_parameters_write (process%qcd, u)
	write (u, *) repeat ("-", 72)
	write (u, *) "Phase-space integration parameters (input) ="
	if (allocated (process%x_phs)) then
	write (u, *) process%x_phs
	else
	write (u, *) "[empty]"
	end if
	write (u, *) "Integration channel =", process%channel
	if (.not. process%lab_is_cm_frame) then
	write (u, *) "Tranformation c.m. -> lab ="
	call lorentz_transformation_write (process%lt_cm_to_lab, u)
	end if
	if (process%use_beams) then
	call strfun_chain_write &
	(process%sfchain, unit, verbose, show_momentum_sum, show_mass)
	end if
	write (u, *) repeat ("-", 72)
	call qcd_parameters_write (process%qcd, u)
	write (u, "(A)") repeat ("-", 72)
	call core_interaction_write &
	(process%ci, unit, verbose, show_momentum_sum, show_mass)
	write (u, "(A)") repeat ("-", 72)
	call phs_forest_write (process%kinematics_in(1)%forest, unit)
	write (u, "(A)") repeat ("-", 72)
	call vamp_equivalences_write (process%vamp_eq, unit)
	write (u, "(A)") repeat ("-", 72)
	call var_list_write (process%var_list, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "Cut expression:"
	call eval_tree_write (process%kinematics_out(1)%cut_expr, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "Weight expression:"
	call eval_tree_write (process%kinematics_out(1)%reweighting_expr, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "General scale expression:"
	call eval_tree_write (process%kinematics_out(1)%scale_expr, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "Factorization scale expression:"
	call eval_tree_write (process%kinematics_out(1)%fac_scale_expr, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "Renormalization scale expression:"
	call eval_tree_write (process%kinematics_out(1)%ren_scale_expr, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)", advance="no") &
	" Beam indices (in the trace evaluator): "
	if (allocated (process%j_beam)) then
	write (u, *) process%j_beam
	else
	write (u, *) "[undefined]"
	end if
	write (u, "(A)", advance="no") &
	" In-parton indices (in the trace evaluator): "
	if (allocated (process%j_out)) then
	write (u, *) process%j_in
	else
	write (u, *) "[undefined]"
	end if
	write (u, "(A)", advance="no") &
	" Out-parton indices (in the trace evaluator): "
	if (allocated (process%j_out)) then
	write (u, *) process%j_out
	else
	write (u, *) "[undefined]"
	end if
	write (u, "(A)") repeat ("-", 72)
	write (u, *) "in type phase space configurations:"
	do i = 1, process%n_kinematics_in
	write (u, ) "** configuration", i, ":"
	write (u, *) " passed: ", process%kinematics_in(i)%passed
	write (u, *) " Phase-space integration parameters (complete) ="
	if (allocated (process%kinematics_in(i)%x)) then
	do j = 1, size (process%kinematics_in(i)%x, 2)
	write (u, *) " ", process%kinematics_in(i)%x(:,j)
	end do
	else
	write (u, *) " [empty]"
	end if
	write (u, *) " Channels: phase-space factors ="
	if (allocated (process%kinematics_in(i)%phs_factor)) then
	write (u, *) " ", process%kinematics_in(i)%phs_factor
	else
	write (u, *) " [not allocated]"
	end if
	write (u, *) " VAMP phs factor = ", &
	process%kinematics_in(i)%vamp_phs_factor
	write (u, *) " Phase space volume = ", &
	process%kinematics_in(i)%phs_volume
	if (i == 1) cycle
	write (u, *) " sqrts = ", process%kinematics_in(i)%sqrts
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, *) " Lorentz transformation ="
	call lorentz_transformation_write (process%kinematics_in(i)%lt)
	write (u, "(A)") " " // repeat ("-", 68)
	end do
	write (u, "(A)") repeat ("-", 72)
	write (u, *) "out type phase space configurations:"
	do i = 1, process%n_kinematics_out
	write (u, ) "** configuration", i, ":"
	write (u, *) " passed: ", process%kinematics_out(i)%passed
	write (u, *) " Squared matrix element = ", &
	process%kinematics_out(i)%sqme
	write (u, *) " Phasespace weight = ", &
	process%kinematics_out(i)%phs_weight
	write (u, *) " General scale = ", process%kinematics_out(i)%scale
	write (u, *) " Renormalization scale = ", &
	process%kinematics_out(i)%ren_scale
	write (u, *) " Factorization scale = ", &
	process%kinematics_out(i)%fac_scale
	if (process%has_extra_evaluators) then
	write (u, "(A)") " " // &
	"Trace including color factors (beams + strfun + hard interaction)"
	write (u, "(A)") " " // repeat ("-", 68)
	call evaluator_write (process%kinematics_out(i)%eval_trace, &
	unit, verbose, show_momentum_sum, show_mass)
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, "(A)") " " // &
	"Exclusive sqme including color factors (beams + strfun + hard interaction)"
	call evaluator_write (process%kinematics_out(i)%eval_sqme, &
	unit, verbose, show_momentum_sum, show_mass)
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, "(A)") " " // &
	"Color flow coefficients (beams + strfun + hard interaction)"
	call evaluator_write (process%kinematics_out(i)%eval_flows, &
	unit, verbose, show_momentum_sum, show_mass)
	end if
	if (process%use_beams) then
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, "(A)") "Incoming beams with all color contractions"
	call evaluator_write (process%kinematics_out(i)%eval_beam_flows, &
	unit, verbose, show_momentum_sum, show_mass)
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, *) " Structure function chain snapshot:"
	call interaction_write (process%kinematics_out(i)%strfun, &
	unit, verbose, show_momentum_sum, show_mass)
	end if
	write (u, "(A)") " " // repeat ("-", 68)
	write (u, "(A)") "Subevent used by cuts, weight, and scale:"
	call subevt_write (process%kinematics_out(i)%subevt, unit)
	end do
	write (u, "(A)") repeat ("-", 72)
	if (process%vamp_grids_defined) then
	write (u, "(A)") "Integration grid data"
	write (u, *)
	write (u, "(A)") "Grid file name (current) = " // '"' &
	// char (process%filename_current_grid) // '"'
	write (u, "(A)") "Grid file name (best) = " // '"' &
	// char (process%filename_best_grid) // '"'
	write (u, *)
	write (u, "(A)") "MD5 sums stored in grid file"
	call md5sum_grids_write (process%md5sum_grids, u)
	write (u, *)
	write (u, "(A)") "Grid parameters stored in grid file"
	call grid_parameters_write (process%grid_parameters, u)
	write (u, *)
	write (u, "(A)", advance="no") "Iterations: pass array = "
	if (allocated (process%pass_array)) then
	write (u, *) process%pass_array
	else
	write (u, *) "[not allocated]"
	end if
	write (u, "(A)", advance="no") "Iterations: n_calls array = "
	if (allocated (process%n_calls_array)) then
	write (u, *) process%n_calls_array
	else
	write (u, *) "[not allocated]"
	end if
	write (u, *)
	write (u, "(A)", advance="no") "VAMP grids:"
	call vamp_write_grids (process%grids, u)
	else
	write (u, "(A)") "VAMP grids: [empty]"
	end if
	write (u, "(A)") repeat ("-", 72)
	if (allocated (process%v_history)) then
	call msg_message (" Global history [vamp]:", unit=u)
	call vamp_write_history (u, process%v_history)
	else
	call msg_message (" Global history [vamp]: [undefined]", unit=u)
	end if
	write (u, "(A)") repeat ("-", 72)
	if (allocated (process%v_histories)) then
	call msg_message (" Channel histories [vamp]:", unit=u)
	call vamp_write_history (u, process%v_histories)
	else
	call msg_message (" Channel histories [vamp]: [undefined]", unit=u)
	end if
	write (u, *)
	call integration_results_write (process%results, unit)
	call integration_results_write_grove_weights (process%results, unit)
	end subroutine process_write

	@ %def process_write
	\subsection{Process pointers}
	We will need arrays of process pointers, therefore this type, which we keep
	transparent:
	<<XXX Processes: public>>=
	public :: process_p
	<<XXX Processes: types>>=
	type :: process_p
	type(process_t), pointer :: ptr
	end type process_p

	@ %def process_p
	@ Set up an array of process pointers, given the process IDs.
	<<XXX Processes: public>>=
	public :: process_ptr_array_create
	<<XXX Processes: procedures>>=
	subroutine process_ptr_array_create (prc_array, process_id)
	type(process_p), dimension(:), intent(out), allocatable :: prc_array
	type(string_t), dimension(:), intent(in) :: process_id
	integer :: proc, n_proc
	n_proc = size (process_id)
	allocate (prc_array (n_proc))
	do proc = 1, n_proc
	prc_array(proc)%ptr => process_store_get_process_ptr (process_id(proc))
	end do
	end subroutine process_ptr_array_create

	@ %def process_ptr_array_create
	@
	\subsection{Accessing contents}
	Check if the process has been successfully initialized:
	<<XXX Processes: public>>=
	public :: process_is_valid
	<<XXX Processes: procedures>>=
	function process_is_valid (process) result (flag)
	logical :: flag
	type(process_t), intent(in) :: process
	flag = process%initialized
	end function process_is_valid

	@ %def process_is_valid
	@
	Check whether we have trivial kinematics (aka non-subtraction).
	<<XXX Processes: public>>=
	public :: process_has_trivial_kinematics
	<<XXX Processes: procedures>>=
	pure function process_has_trivial_kinematics (process) result (flag)
	type(process_t), intent(in) :: process
	logical :: flag
	flag = process%trivial_kinematics
	end function process_has_trivial_kinematics

	@ %def process_has_trivial_kinematics
	@
	Check if the process has a nonvanishing matrix element:
	<<XXX Processes: public>>=
	public :: process_has_matrix_element
	<<XXX Processes: procedures>>=
	function process_has_matrix_element (process) result (flag)
	logical :: flag
	type(process_t), intent(in) :: process
	flag = process%has_matrix_element
	end function process_has_matrix_element

	@ %def process_has_matrix_element
	@ Check if the process has been integrated:
	<<XXX Processes: public>>=
	public :: process_has_integral
	<<XXX Processes: procedures>>=
	function process_has_integral (process) result (flag)
	logical :: flag
	type(process_t), intent(in) :: process
	flag = integration_results_exist (process%results)
	end function process_has_integral

	@ %def process_has_integral
	@ Check if the uses a nontrivial beam setup:
	<<XXX Processes: public>>=
	public :: process_uses_beams
	<<XXX Processes: procedures>>=
	function process_uses_beams (process) result (flag)
	logical :: flag
	type(process_t), intent(in) :: process
	flag = process%use_beams
	end function process_uses_beams

	@ %def process_uses_beams
	@ Return the process ID.
	<<XXX Processes: public>>=
	public :: process_get_id
	<<XXX Processes: procedures>>=
	function process_get_id (process) result (process_id)
	type(string_t) :: process_id
	type(process_t), intent(in) :: process
	process_id = process%id
	end function process_get_id

	@ %def process_get_id
	@ Return the index in the process library:
	<<XXX Processes: public>>=
	public :: process_get_lib_index
	<<XXX Processes: procedures>>=
	function process_get_lib_index (process) result (index)
	integer :: index
	type(process_t), intent(in) :: process
	index = process%lib_index
	end function process_get_lib_index

	@ %def process_get_store_index
	@ Return the index in the process store:
	<<XXX Processes: public>>=
	public :: process_get_store_index
	<<XXX Processes: procedures>>=
	function process_get_store_index (process) result (index)
	integer :: index
	type(process_t), intent(in) :: process
	index = process%store_index
	end function process_get_store_index

	@ %def process_get_store_index
	@ Return the MD5 sum of the process configuration.
	<<XXX Processes: public>>=
	public :: process_get_md5sum
	public :: process_get_md5sum_parameters
	public :: process_get_md5sum_results
	public :: process_get_md5sum_polarized
	<<XXX Processes: procedures>>=
	function process_get_md5sum (process) result (md5sum)
	character(32) :: md5sum
	type(process_t), intent(in) :: process
	md5sum = process%md5sum
	end function process_get_md5sum

	function process_get_md5sum_parameters (process) result (md5sum)
	character(32) :: md5sum
	type(process_t), intent(in) :: process
	md5sum = model_get_parameters_md5sum (process%model)
	end function process_get_md5sum_parameters

	function process_get_md5sum_results (process) result (md5sum)
	character(32) :: md5sum
	type(process_t), intent(in) :: process
	md5sum = integration_results_get_md5sum (process%results)
	end function process_get_md5sum_results

	function process_get_md5sum_polarized (process) result (md5sum)
	character(32) :: md5sum
	type(process_t), intent(in) :: process
	md5sum = model_get_polarized_md5sum (process%model)
	end function process_get_md5sum_polarized

	@ %def process_get_md5sum
	@ %def process_get_md5sum_parameters
	@ %def process_get_md5sum_results
	@ Return the model pointer.
	<<XXX Processes: public>>=
	public :: process_get_model_ptr
	<<XXX Processes: procedures>>=
	function process_get_model_ptr (process) result (model)
	type(model_t), pointer :: model
	type(process_t), intent(in) :: process
	model => process%model
	end function process_get_model_ptr

	@ %def process_get_model_ptr
	@ Return the number of partons for the hard interaction
	<<XXX Processes: public>>=
	public :: process_get_n_in
	public :: process_get_n_out_real
	public :: process_get_n_out_eff
	public :: process_get_n_tot_real
	public :: process_get_n_tot_eff
	<<XXX Processes: procedures>>=
	function process_get_n_in (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_in (process%ci)
	end function process_get_n_in

	function process_get_n_out_eff (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_out_eff (process%ci)
	end function process_get_n_out_eff

	function process_get_n_out_real (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_out_real (process%ci)
	end function process_get_n_out_real

	function process_get_n_tot_real (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_tot_real (process%ci)
	end function process_get_n_tot_real

	function process_get_n_tot_eff (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_tot_eff (process%ci)
	end function process_get_n_tot_eff

	function process_get_n_flv_real (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_flv_real (process%ci)
	end function process_get_n_flv_real

	function process_get_n_flv_eff (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = core_interaction_get_n_flv_eff (process%ci)
	end function process_get_n_flv_eff

	@ %def process_get_n_in
	@ %def process_get_n_out_real
	@ %def process_get_n_tot_real
	@ %def process_get_n_flv_real
	@ %def process_get_n_out_eff
	@ %def process_get_n_tot_eff
	@ %def process_get_n_flv_eff
	@ Return the indices of incoming beams / partons. These indices apply
	to the subevents in the evaluator interactions.

	Without allocate-on-assignment, let us use subroutines. Note that the outgoing
	parton indices correspond to the \emph{effective} partons in a dipole /
	recombination setup.
	<<XXX Processes: public>>=
	public :: process_get_beam_index
	public :: process_get_incoming_parton_index
	public :: process_get_outgoing_parton_index
	<<XXX Processes: procedures>>=
	subroutine process_get_beam_index (process, index)
	type(process_t), intent(in) :: process
	integer, dimension(:), allocatable, intent(out) :: index
	allocate (index (size (process%j_beam)))
	index = process%j_beam
	end subroutine process_get_beam_index

	subroutine process_get_incoming_parton_index (process, index)
	type(process_t), intent(in) :: process
	integer, dimension(:), allocatable, intent(out) :: index
	allocate (index (size (process%j_in)))
	index = process%j_in
	end subroutine process_get_incoming_parton_index

	subroutine process_get_outgoing_parton_index (process, index)
	type(process_t), intent(in) :: process
	integer, dimension(:), allocatable, intent(out) :: index
	allocate (index (size (process%j_out)))
	index = process%j_out
	end subroutine process_get_outgoing_parton_index

	@ %def process_get_beam_index
	@ %def process_get_incoming_parton_index
	@ %def process_get_outgoing_parton_index
	@ Return the beam/incoming particle flavors and energies.
	<<XXX Processes: public>>=
	public :: process_get_beam_flv
	public :: process_get_beam_energy
	<<XXX Processes: procedures>>=
	function process_get_beam_flv (process) result (flv_in)
	type(flavor_t), dimension(:), allocatable :: flv_in
	type(process_t), intent(in) :: process
	allocate (flv_in (process_get_n_in (process)))
	if (process%beam_data%initialized) flv_in = process%beam_data%flv
	end function process_get_beam_flv

	function process_get_beam_energy (process) result (energy)
	real(default), dimension(:), allocatable :: energy
	type(process_t), intent(in) :: process
	allocate (energy (process_get_n_in (process)))
	energy = beam_data_get_energy (process%beam_data)
	end function process_get_beam_energy

	@ %def process_get_beam_flv process_get_beam_energy
	@ Return the number of integration parameters.
	<<XXX Processes: public>>=
	public :: process_get_n_parameters
	<<XXX Processes: procedures>>=
	function process_get_n_parameters (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = process%n_par
	end function process_get_n_parameters

	@ %def process_get_n_parameters
	@ Return the number of integration channels.
	<<XXX Processes: public>>=
	public :: process_get_n_channels
	<<XXX Processes: procedures>>=
	function process_get_n_channels (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = process%n_channels
	end function process_get_n_channels

	@ %def process_get_n_channels
	@ Return the number of bins per integration channel.
	<<XXX Processes: public>>=
	public :: process_get_n_bins
	<<XXX Processes: procedures>>=
	function process_get_n_bins (process) result (n)
	integer :: n
	type(process_t), intent(in) :: process
	n = process%n_bins
	end function process_get_n_bins

	@ %def process_get_n_bins
	@ Return the process status record.
	<<XXX Processes: public>>=
	public :: process_get_status
	<<XXX Processes: procedures>>=
	function process_get_status (process) result (status)
	type(process_status_t) :: status
	type(process_t), intent(in) :: process
	status = process%status
	end function process_get_status

	@ %def process_get_status
	@ Return the process scales and the $\alpha_s$ value. If no index is supplied,
	the first out configuration is used.
	<<XXX Processes: public>>=
	public :: process_get_scale
	public :: process_get_fac_scale
	public :: process_get_ren_scale
	public :: process_get_alpha_s
	<<XXX Processes: procedures>>=
	function process_get_scale (process, i) result (scale)
	real(default) :: scale
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	scale = process%kinematics_out(idx)%scale
	end function process_get_scale

	function process_get_fac_scale (process, i) result (scale)
	real(default) :: scale
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	scale = process%kinematics_out(idx)%fac_scale
	end function process_get_fac_scale

	function process_get_ren_scale (process, i) result (scale)
	real(default) :: scale
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	scale = process%kinematics_out(idx)%ren_scale
	end function process_get_ren_scale

	function process_get_alpha_s (process, i) result (alpha_s)
	real(default) :: alpha_s
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	alpha_s = process%kinematics_out(idx)%alpha_s_at_scale
	end function process_get_alpha_s

	@ %def process_get_scale
	@ %def process_get_fac_scale
	@ %def process_get_ren_scale
	@ %def process_get_alpha_s
	@ Return the c.m. energy and the partonic c.m. energy.
	<<XXX Processes: public>>=
	public :: process_get_sqrts
	public :: process_get_sqrts_hat
	<<XXX Processes: procedures>>=
	function process_get_sqrts (process) result (sqrts)
	real(default) :: sqrts
	type(process_t), intent(in) :: process
	sqrts = process%sqrts
	end function process_get_sqrts

	function process_get_sqrts_hat (process) result (sqrts_hat)
	real(default) :: sqrts_hat
	type(process_t), intent(in) :: process
	sqrts_hat = process%sqrts_hat
	end function process_get_sqrts_hat

	@ %def process_get_sqrts
	@ %def process_get_sqrts_hat
	@ Return the squared matrix element. This includes structure
	function factors and the hard interaction squared matrix element,
	traced over all quantum numbers, but no phase space factors. If no index
	supplied, we use the first out configuration.
	<<XXX Processes: public>>=
	public :: process_get_sqme
	<<XXX Processes: procedures>>=
	function process_get_sqme (process, i) result (sqme)
	real(default) :: sqme
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	sqme = process%kinematics_out(idx)%sqme
	end function process_get_sqme

	@ %def process_get_sqme
	@ Return the user-defined reweighting factor that should be applied to the
	matrix element. In the sample-function value (integration and event
	generation), this is already included. Same procedure as everywhere regarding
	[[i]].
	<<XXX Processes: public>>=
	public :: process_get_reweighting_factor
	<<XXX Processes: procedures>>=
	function process_get_reweighting_factor (process, i) result (weight)
	real(default) :: weight
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	weight = process%kinematics_out(idx)%reweighting_factor
	end function process_get_reweighting_factor

	@ %def process_get_reweighting_factor
	@ Return the final integration results. If [[last]] is present and
	set, the final iteration; otherwise, the final average.
	<<XXX Processes: public>>=
	public :: process_get_n_calls
	public :: process_get_integral
	public :: process_get_error
	public :: process_get_accuracy
	public :: process_get_chi2
	public :: process_get_rel_error
	public :: process_get_time_per_event
	public :: process_get_efficiency
	public :: process_get_sample_function_value
	<<XXX Processes: procedures>>=
	function process_get_n_calls (process, last, it, pass) result (n_calls)
	integer :: n_calls
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	n_calls = integration_results_get_n_calls &
	(process%results, last, it, pass)
	end function process_get_n_calls

	function process_get_integral (process, last, it, pass) result (integral)
	real(default) :: integral
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	integral = integration_results_get_integral &
	(process%results, last, it, pass)
	end function process_get_integral

	function process_get_error (process, last, it, pass) result (error)
	real(default) :: error
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	error = integration_results_get_error &
	(process%results, last, it, pass)
	end function process_get_error

	function process_get_accuracy (process, last, it, pass) result (accuracy)
	real(default) :: accuracy
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	accuracy = integration_results_get_accuracy &
	(process%results, last, it, pass)
	end function process_get_accuracy

	function process_get_chi2 (process, last, it, pass) result (chi2)
	real(default) :: chi2
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	chi2 = integration_results_get_chi2 &
	(process%results, last, it, pass)
	end function process_get_chi2

	function process_get_efficiency (process, last, it, pass) result (efficiency)
	real(default) :: efficiency
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	efficiency = integration_results_get_efficiency &
	(process%results, last, it, pass)
	end function process_get_efficiency

	function process_get_rel_error (process, last, it, pass) result (error)
	real(default) :: error
	type(process_t), intent(in) :: process
	logical, intent(in), optional :: last
	integer, intent(in), optional :: it, pass
	real(default) :: integral, abs_error
	integral = integration_results_get_integral &
	(process%results, last, it, pass)
	abs_error = integration_results_get_error &
	(process%results, last, it, pass)
	if (integral /= 0) then
	error = abs_error / abs (integral)
	else
	error = 0
	end if
	end function process_get_rel_error

	function process_get_time_per_event (process) result (tpe)
	real(default) :: tpe
	type(process_t), intent(in) :: process
	tpe = integration_results_get_time_per_event (process%results)
	end function process_get_time_per_event

	function process_get_sample_function_value (process) result (value)
	real(default) :: value
	type(process_t), intent(in) :: process
	value = process%sample_function_value
	end function process_get_sample_function_value

	@ %def process_get_n_calls
	@ %def process_get_integral
	@ %def process_get_error
	@ %def process_get_accuracy
	@ %def process_get_chi2
	@ %def process_get_efficiency
	@ %def process_get_rel_error
	@ %def process_get_time_per_event
	@ %def process_get_sample_function_value
	@ Return the current (i.e., last) integration pass index, and the
	index of the last iteration \emph{within} this pass. The third
	routine returns the absolute index of the last iteration.
	<<XXX Processes: public>>=
	public :: process_get_current_pass
	public :: process_get_current_it
	<<XXX Processes: procedures>>=
	function process_get_current_pass (process) result (pass)
	integer :: pass
	type(process_t), intent(in) :: process
	pass = integration_results_get_current_pass (process%results)
	end function process_get_current_pass

	function process_get_current_it (process) result (it)
	integer :: it
	type(process_t), intent(in) :: process
	it = integration_results_get_current_it (process%results)
	end function process_get_current_it

	function process_get_last_it (process) result (it)
	integer :: it
	type(process_t), intent(in) :: process
	it = integration_results_get_last_it (process%results)
	end function process_get_last_it

	@ %def process_get_current_pass
	@ %def process_get_current_it
	@ Get the number of ``out'' kinematics.
	<<XXX Processes: public>>=
	public :: process_get_n_kinematics_out
	<<XXX Processes: procedures>>=
	function process_get_n_kinematics_out (proc) result (n)
	type(process_t), intent(in) :: proc
	integer :: n
	n = size (proc%kinematics_out)
	end function process_get_n_kinematics_out

	@ %def process_get_n_kinematics_out
	@ Query whether the process (aka the core interaction) supports sqme and flow
	evaluators.
	<<XXX Processes: public>>=
	public :: process_has_eval_sqme
	public :: process_has_eval_flows
	<<XXX Processes: procedures>>=
	function process_has_eval_sqme (process) result (flag)
	type(process_t), intent(in) :: process
	logical :: flag
	flag = core_interaction_has_eval_sqme (process%ci)
	end function process_has_eval_sqme

	function process_has_eval_flows (process) result (flag)
	type(process_t), intent(in) :: process
	logical :: flag
	flag = core_interaction_has_eval_flows (process%ci)
	end function process_has_eval_flows
	@ %def process_has_eval_sqme
	@ %def process_has_eval_flows
	@ Query whether the core interaction represents a physical (aka positive) matrix
	elements. This influences the event generation.
	<<XXX Processes: public>>=
	public :: process_is_physical
	<<XXX Processes: procedures>>=
	function process_is_physical (process) result (flag)
	type(process_t), intent(in) :: process
	logical :: flag
	flag = core_interaction_is_physical (process%ci)
	end function process_is_physical

	@ %def process_is_physical
	@ Return pointers to the sqme and flows evaluators. If no beams are
	used, these are identical to the evaluators of the hard interaction.
	<<XXX Processes: public>>=
	public :: process_get_eval_sqme_ptr
	public :: process_get_eval_flows_ptr
	<<XXX Processes: procedures>>=
	function process_get_eval_sqme_ptr (process, i) result (eval)
	type(evaluator_t), pointer :: eval
	type(process_t), intent(in), target :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	if (process%has_extra_evaluators) then
	eval => process%kinematics_out(idx)%eval_sqme
	else
	eval => core_interaction_get_eval_sqme_ptr (process%ci, idx)
	end if
	end function process_get_eval_sqme_ptr

	function process_get_eval_flows_ptr (process, i) result (eval)
	type(evaluator_t), pointer :: eval
	type(process_t), intent(in), target :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	if (process%has_extra_evaluators) then
	eval => process%kinematics_out(idx)%eval_flows
	else
	eval => core_interaction_get_eval_flows_ptr (process%ci, idx)
	end if
	end function process_get_eval_flows_ptr

	@ %def process_get_eval_sqme_ptr process_get_eval_flows_ptr
	@ Return pointers to the interaction and to the sqme and flows
	evaluators of the hard interaction.
	<<XXX Processes: public>>=
	public :: process_get_ci_int_ptr
	public :: process_get_ci_eval_sqme_ptr
	public :: process_get_ci_eval_flows_ptr
	<<XXX Processes: procedures>>=
	function process_get_ci_int_ptr (process, i) result (int)
	type(interaction_t), pointer :: int
	type(process_t), intent(in), target :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	int => core_interaction_get_int_ptr (process%ci, idx)
	end function process_get_ci_int_ptr

	function process_get_ci_eval_sqme_ptr (process, i) result (eval)
	type(evaluator_t), pointer :: eval
	type(process_t), intent(in), target :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	eval => core_interaction_get_eval_sqme_ptr (process%ci, idx)
	end function process_get_ci_eval_sqme_ptr

	function process_get_ci_eval_flows_ptr (process, i) result (eval)
	type(evaluator_t), pointer :: eval
	type(process_t), intent(in), target :: process
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	eval => core_interaction_get_eval_flows_ptr (process%ci, idx)
	end function process_get_ci_eval_flows_ptr

	@ %def process_get_ci_int_ptr
	@ %def process_get_ci_eval_sqme_ptr process_get_ci_eval_flows_ptr
	@ Return any s-channel mapping for a particular tree in the decay
	forest.
	<<XXX Processes: public>>=
	! public :: process_get_s_mapping
	<<XXX Processes: procedures>>=
	! subroutine process_get_s_mapping (process, channel, flag, mass, width)
	! type(process_t), intent(in) :: process
	! integer, intent(in) :: channel
	! logical, intent(out) :: flag
	! real(default), intent(out) :: mass, width
	! call phs_forest_get_s_mapping &
	! (process%forest, channel, flag, mass, width)
	! end subroutine process_get_s_mapping

	@ %def process_get_s_mapping
	@
	\subsection{Setting values directly}
	Mark a process as a cascade decay. The effect is that the process
	subevent will be boosted to the incoming c.m. frame (i.e., the
	rest frame of the decaying particle) before applying cuts etc.
	<<XXX Processes: public>>=
	public :: process_mark_as_cascade_decay
	<<XXX Processes: procedures>>=
	subroutine process_mark_as_cascade_decay (process)
	type(process_t), intent(inout) :: process
	process%is_cascade_decay = .true.
	end subroutine process_mark_as_cascade_decay

	@ %def process_mark_as_cascade_decay
	@
	Some values can be set directly; this is used when reading an event
	from file.
	<<XXX Processes: public>>=
	public :: process_set_scale
	public :: process_set_fac_scale
	public :: process_set_ren_scale
	public :: process_set_alpha_s
	public :: process_set_sqme
	<<XXX Processes: procedures>>=
	subroutine process_set_scale (process, scale, i)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: scale
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	process%kinematics_out(idx)%scale = scale
	end subroutine process_set_scale

	subroutine process_set_fac_scale (process, scale, i)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: scale
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	process%kinematics_out(idx)%fac_scale = scale
	end subroutine process_set_fac_scale

	subroutine process_set_ren_scale (process, scale, i)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: scale
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	process%kinematics_out(idx)%ren_scale = scale
	end subroutine process_set_ren_scale

	subroutine process_set_alpha_s (process, alpha_s)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: alpha_s
	process%qcd%alpha_s_at_scale = alpha_s
	end subroutine process_set_alpha_s

	subroutine process_set_sqme (process, sqme, i)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: sqme
	integer, intent(in), optional :: i
	integer :: idx
	idx = 1; if (present (i)) idx = i
	process%kinematics_out(idx)%sqme = sqme
	end subroutine process_set_sqme

	@ %def process_set_scale
	@ %def process_set_fac_scale
	@ %def process_set_ren_scale
	@ %def process_set_alpha_s
	@ %def process_set_sqme
	@

	Setting $\alpha$ is required for evaluating electroweak dipoles.
	<<XXX Processes: public>>=
	public :: process_set_alpha_qed
	<<XXX Processes: procedures>>=
	subroutine process_set_alpha_qed (process, alpha)
	type(process_t), intent(inout) :: process
	real(kind=default), intent(in) :: alpha
	call core_interaction_set_alpha_qed (process%ci, alpha)
	end subroutine process_set_alpha_qed

	@ %def process_set_alpha_qed
	@

	Discard previous results, starting from the current iteration.
	<<XXX Processes: public>>=
	public :: process_discard_results
	<<XXX Processes: procedures>>=
	subroutine process_discard_results (process, it)
	type(process_t), intent(inout) :: process
	integer, intent(in) :: it
	call integration_results_discard (process%results, it)
	end subroutine process_discard_results

	@ %def process_discard_results
	@

	\subsection{Process preparation: beams and structure functions}
	Set up the chain of structure functions. The individual types of
	structure functions need specific instances. These are just wrappers
	around the corresponding [[strfun_chain]] procedures.

	If [[use_beams]] is false, only [[sqrts]] and [[flv]] is set, using
	the decaying particle mass (decay) or the [[sqrts]] value in the
	argument list (scattering) to set up a local beam record.
	<<XXX Processes: public>>=
	public :: process_setup_beams
	<<XXX Processes: procedures>>=
	subroutine process_setup_beams (process, beam_data, n_strfun, sqrts, flv)
	type(process_t), intent(inout), target :: process
	type(beam_data_t), intent(in) :: beam_data
	integer, intent(in) :: n_strfun
	real(default), intent(in), optional :: sqrts
	type(flavor_t), dimension(:), intent(in), optional :: flv
	if (.not. process_has_matrix_element (process)) return
	if (process%use_beams) then
	process%beam_data = beam_data
	process%sqrts = beam_data%sqrts
	process%sqrts_known = .true.
	process%n_strfun = n_strfun
	process%azimuthal_dependence = &
	.not. all (polarization_is_diagonal (beam_data%pol))
	process%lab_is_cm_frame = beam_data%lab_is_cm_frame .and. n_strfun == 0
	call strfun_chain_init (process%sfchain, beam_data, n_strfun)
	else
	select case (process%type)
	case (PRC_DECAY)
	process%sqrts = process%mass_in(1)
	call beam_data_init_decay (process%beam_data, process%flv_in)
	case (PRC_SCATTERING)
	if (present (sqrts)) then
	process%sqrts = sqrts
	call beam_data_init_sqrts &
	(process%beam_data, process%sqrts, process%flv_in)
	else
	call msg_fatal ("Process setup: neither beams nor sqrts are known")
	process%sqrts = 0
	end if
	end select
	process%sqrts_known = .true.
	end if
	end subroutine process_setup_beams

	@ %def process_setup_beams
	@ Set the beam momenta directly without changing anything else. This
	is a shortcut that is needed for initiating cascade decays (i.e., the
	single beam is the decaying particle).
	<<XXX Processes: public>>=
	public :: process_set_beam_momenta
	<<XXX Processes: procedures>>=
	subroutine process_set_beam_momenta (process, p)
	type(process_t), intent(inout), target :: process
	type(vector4_t), dimension(:), intent(in) :: p
	type(interaction_t), pointer :: ci_int
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"process_set_beam_momenta not yet implemented for dipole kinematics!")
	if (.not. process_has_matrix_element (process)) return
	if (process%use_beams) then
	call strfun_chain_set_beam_momenta (process%sfchain, p)
	else
	ci_int => core_interaction_get_int_ptr (process%ci, 1)
	call interaction_set_momenta (ci_int, p, outgoing=.false.)
	end if
	process%sqrts_hat = process%sqrts
	process%lab_is_cm_frame = .false.
	process%beams_are_set = .true.
	end subroutine process_set_beam_momenta

	@ %def process_set_beam_momenta
	@ Configure structure functions. EPA: support only a single data set.

	The index [[i]] is the overall structure function counter. [[line]]
	indicates the beam(s) for which the structure function applies, either
	1 or 2, or 0 for both beams.
	<<XXX Processes: public>>=
	public :: process_set_strfun
	<<XXX Processes: interfaces>>=
	interface process_set_strfun
	module procedure process_set_strfun_lhapdf
	module procedure process_set_strfun_pdf_builtin
	module procedure process_set_strfun_isr
	module procedure process_set_strfun_epa
	module procedure process_set_strfun_ewa
	module procedure process_set_strfun_circe1
	module procedure process_set_strfun_circe2
	module procedure process_set_strfun_escan
	module procedure process_set_strfun_beam_events
	module procedure process_set_strfun_user
	end interface

	<<XXX Processes: procedures>>=
	subroutine process_set_strfun_lhapdf &
	(process, i, line, lhapdf_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(lhapdf_data_t), intent(in) :: lhapdf_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, lhapdf_data, n_parameters)
	end if
	end subroutine process_set_strfun_lhapdf

	subroutine process_set_strfun_pdf_builtin &
	(process, i, line, pdf_builtin_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(pdf_builtin_data_t), intent(in) :: pdf_builtin_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, pdf_builtin_data, n_parameters)
	end if
	end subroutine process_set_strfun_pdf_builtin

	subroutine process_set_strfun_isr &
	(process, i, line, isr_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(isr_data_t), intent(in) :: isr_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, isr_data, n_parameters)
	end if
	end subroutine process_set_strfun_isr

	subroutine process_set_strfun_epa &
	(process, i, line, epa_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	! type(epa_data_t), dimension(:), intent(in) :: epa_data
	type(epa_data_t), intent(in) :: epa_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, epa_data, n_parameters)
	end if
	end subroutine process_set_strfun_epa

	subroutine process_set_strfun_ewa &
	(process, i, line, ewa_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	! type(ewa_data_t), dimension(:), intent(in) :: ewa_data
	type(ewa_data_t), intent(inout) :: ewa_data
	integer :: k
	integer, dimension(:,:), allocatable :: flvs_tot
	integer, dimension(:), allocatable :: flvs
	allocate (flvs_tot(process_get_n_tot_real (process), &
	process_get_n_flv_real (process)))
	allocate (flvs(process_get_n_flv_real (process)))
	flvs_tot = core_interaction_get_flv_states_real (process%ci)
	flvs(:) = abs(flvs_tot (line,:))
	do k = 1, size (flvs)
	if (flvs(1) /= flvs (k)) &
	call msg_fatal ("EWA approximation is not applicable when " &
	// "mixing W and Z for a single beam.")
	end do
	if (flvs(1) < 23 .or. flvs(1) > 24) &
	call msg_fatal ("Hard scattering process does not match EWA.")
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, ewa_data, n_parameters, flvs(1))
	end if
	end subroutine process_set_strfun_ewa

	subroutine process_set_strfun_circe1 &
	(process, i, line, circe1_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(circe1_data_t), intent(in) :: circe1_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, circe1_data, n_parameters)
	end if
	end subroutine process_set_strfun_circe1

	subroutine process_set_strfun_circe2 &
	(process, i, line, circe2_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(circe2_data_t), intent(in) :: circe2_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, circe2_data, n_parameters)
	end if
	end subroutine process_set_strfun_circe2

	subroutine process_set_strfun_escan &
	(process, i, line, escan_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(escan_data_t), intent(in) :: escan_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, escan_data, n_parameters)
	end if
	end subroutine process_set_strfun_escan

	subroutine process_set_strfun_beam_events &
	(process, i, line, beam_events_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(beam_events_data_t), intent(in) :: beam_events_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, beam_events_data, n_parameters)
	end if
	end subroutine process_set_strfun_beam_events

	subroutine process_set_strfun_user &
	(process, i, line, user_data, n_parameters)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: i, line, n_parameters
	type(sf_user_data_t), intent(in) :: user_data
	if (process%use_beams) then
	call strfun_chain_set_strfun &
	(process%sfchain, i, line, user_data, n_parameters)
	end if
	end subroutine process_set_strfun_user

	@ %def process_set_strfun
	@ Configure structure function mappings.
	<<XXX Processes: public>>=
	public :: process_allocate_strfun_mappings
	public :: process_set_strfun_mapping
	<<XXX Processes: procedures>>=
	subroutine process_allocate_strfun_mappings &
	(process, multichannel, n_mapping)
	type(process_t), intent(inout) :: process
	logical, intent(in) :: multichannel
	integer, intent(in), optional :: n_mapping
	if (.not. multichannel .and. present (n_mapping)) then
	call strfun_chain_allocate_mappings &
	(process%sfchain, multichannel, n_mapping, 1)
	else if (multichannel .and. .not. present (n_mapping)) then
	call msg_bug ("multichannel structure functions not supported")
	call strfun_chain_allocate_mappings &
	(process%sfchain, multichannel, 1, process%n_channels)
	! allocate (process%sf_factor (process%n_channels))
	else
	print *, "multichannel = ", multichannel
	call msg_bug ("allocate strfun mappings: inconsistent parameters")
	end if
	end subroutine process_allocate_strfun_mappings

	subroutine process_set_strfun_mapping (process, i, ch, index, type, par)
	type(process_t), intent(inout) :: process
	integer, intent(in) :: i, ch
	integer, intent(in) :: type
	integer, dimension(:), intent(in) :: index
	real(default), dimension(:), intent(in) :: par
	call strfun_chain_set_mapping (process%sfchain, i, ch, index, type, par)
	end subroutine process_set_strfun_mapping

	@ %def process_allocate_strfun_mappings
	@ %def process_set_strfun_mapping
	@ Complete structure function initialization. Make evaluators within
	the structure function chain, and the trace evaluator within the hard
	interaction. Connect the two, and make another trace evaluator which
	sums over all quantum numbers. This evaluator should have only a
	single matrix element.

	NB: For a beam setup without structure functions and nontrivial
	([[n_kinematics_out]] $>1$), a slight optimization might be gained by ommiting
	the snapshot and directly linking all interactions / evaluators to the beam
	interaction.
	<<XXX Processes: public>>=
	public :: process_connect_strfun
	<<XXX Processes: procedures>>=
	subroutine process_connect_strfun (process, ok)
	type(process_t), intent(inout), target :: process
	logical, intent(out), optional :: ok
	integer, dimension(:), allocatable :: coll_index
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
	type(quantum_numbers_mask_t) :: mask_tr
	type(evaluator_t), pointer :: eval_sfchain, eval_ci
	type(interaction_t), pointer :: int_beam, int_ci
	integer :: n_in, i, j
	if (.not. process_has_matrix_element (process)) return
	n_in = core_interaction_get_n_in (process%ci)
	allocate (mask_in (n_in))
	if (process%use_beams) then
	call strfun_chain_make_evaluators (process%sfchain, ok)
	allocate (coll_index (n_in))
	coll_index = strfun_chain_get_colliding_particles (process%sfchain)
	mask_in = strfun_chain_get_colliding_particles_mask (process%sfchain)
	else
	mask_in = new_quantum_numbers_mask (.true., .true., .true.)
	end if
	call core_interaction_init_trace &
	(process%ci, mask_in, process%use_hi_color_factors)
	if (process%use_beams) then
	int_beam => strfun_chain_get_beam_int_ptr (process%sfchain)
	eval_sfchain => strfun_chain_get_last_evaluator_ptr (process%sfchain)
	mask_tr = new_quantum_numbers_mask (.true., .true., .true.)
	do j = 1, process%n_kinematics_out
	eval_ci => core_interaction_get_eval_trace_ptr (process%ci, j)
	int_ci => core_interaction_get_int_ptr (process%ci, j)
	if (associated (eval_sfchain)) then
	if (j == 1) then
	process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( &
	eval_sfchain)
	else
	call evaluator_init_identity ( &
	process%kinematics_out(j)%strfun_snapshot, eval_sfchain)
	process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( &
	process%kinematics_out(j)%strfun_snapshot)
	end if
	else
	if (j == 1) then
	process%kinematics_out(j)%strfun => int_beam
	else
	call evaluator_init_identity ( &
	process%kinematics_out(j)%strfun_snapshot, int_beam)
	process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( &
	process%kinematics_out(j)%strfun_snapshot)
	end if
	end if
	do i = 1, n_in
	call interaction_set_source_link &
	(int_ci, i, process%kinematics_out(j)%strfun, coll_index(i))
	! call evaluator_set_source_link &
	! (eval_ci, i, process%kinematics_out(j)%strfun, coll_index(i))
	end do
	call evaluator_init_product &
	(process%kinematics_out(j)%eval_trace, &
	process%kinematics_out(j)%strfun, eval_ci, mask_tr, mask_tr)
	if (evaluator_is_empty (process%kinematics_out(j)%eval_trace)) then
	call msg_fatal ("Mismatch between structure functions and hard process")
	if (present (ok)) ok = .false.
	return
	end if
	end do
	process%n_par_strfun = &
	strfun_chain_get_n_parameters_tot (process%sfchain)
	allocate (process%x_strfun (process%n_par_strfun))
	else
	! Even without a beam setup, we make sure that all sfchain pointers point
	! to a valid (albeit empty) interaction
	int_beam => strfun_chain_get_beam_int_ptr (process%sfchain)
	do j = 1, process%n_kinematics_out
	process%kinematics_out(j)%strfun => int_beam
	end do
	end if
	process%n_par = process%n_par_strfun + process%n_par_ci + process%n_par_phs
	if (present (ok)) ok = .true.
	end subroutine process_connect_strfun

	@ %def process_connect_strfun
	@ Check whether the current setting of relevant variables matches the
	current beam setup.
	<<XXX Processes: public>>=
	public :: process_check_beam_setup
	<<XXX Processes: procedures>>=
	subroutine process_check_beam_setup (process, var_list)
	type(process_t), intent(in) :: process
	type(var_list_t), intent(in) :: var_list
	logical :: sqrts_known
	real(default) :: sqrts
	sqrts_known = var_list_is_known (var_list, "sqrts")
	sqrts = var_list_get_rval (var_list, "sqrts")
	if (process%use_beams) then
	select case (process%type)
	case (PRC_SCATTERING)
	if (sqrts_known) then
	call beam_data_check_scattering (process%beam_data, sqrts)
	else
	call beam_data_check_scattering (process%beam_data)
	end if
	end select
	end if
	end subroutine process_check_beam_setup

	@ %def process_check_beam_setup
	@
	\subsection{Process preparation: phase space}
	Initialize the phase-space forest. First check whether the process
	exists in [[filename_in]], if present, and try to read it there. If
	this fails, generate a new phase-space forest and write it to
	[[filename_out]], if present, otherwise to a temporary file. Then
	read again.

	Because [[variable_limits]] depends on the structure function setup,
	structure functions should be done first.
	<<XXX Processes: public>>=
	public :: process_setup_phase_space
	<<XXX Processes: procedures>>=
	subroutine process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out, &
	filename_in, filename_vis, vis_channels, check_phs_file, ok)
	type(process_t), intent(inout), target :: process
	logical, intent(in) :: rebuild_phs
	type(os_data_t), intent(in) :: os_data
	type(phs_parameters_t), intent(inout) :: phs_par
	type(mapping_defaults_t), intent(in) :: mapping_defaults
	type(string_t), intent(in), optional :: &
	filename_out, filename_in, filename_vis
	logical, intent(in) :: vis_channels
	logical, intent(in), optional :: check_phs_file
	logical, intent(out), optional :: ok
	type(string_t) :: filename, setenv_tex, setenv_mp, &
	pipe, pipe_dvi
	logical :: exist, check
	integer :: extra_off_shell
	type(cascade_set_t) :: cascade_set
	logical :: variable_limits
	integer :: n_in, n_out, n_tot, n_flv
	type(flavor_t), dimension(:,:), allocatable :: flv
	integer :: n_par_strfun
	logical, dimension(:), allocatable :: strfun_rigid
	character(32) :: md5sum_process, md5sum_model, md5sum_parameters
	integer :: unit, unit_tex, unit_dev, status
	logical :: phs_ok, phs_match, wrote_file
	integer :: i
	type(phs_forest_t) :: forest
	phs_ok = .false.
	phs_match = .false.
	variable_limits = process%n_strfun /= 0
	n_in = core_interaction_get_n_in (process%ci)
	n_out = core_interaction_get_n_out_real (process%ci)
	n_tot = core_interaction_get_n_tot_real (process%ci)
	n_flv = core_interaction_get_n_flv_real (process%ci)
	allocate (flv (n_tot, n_flv))
	call flavor_init (flv, &
	core_interaction_get_flv_states_real (process%ci), process%model)
	md5sum_process = process%md5sum
	md5sum_model = model_get_md5sum (process%model)
	md5sum_parameters = model_get_parameters_md5sum (process%model)
	phs_par%sqrts = process%sqrts
	if (present (filename_in)) then
	filename = filename_in
	check = .false.
	else if (.not. rebuild_phs .and. present (filename_out)) then
	filename = filename_out
	if (present (check_phs_file)) then
	check = check_phs_file
	else
	check = .true.
	end if
	else
	filename = ""
	end if
	if (filename /= "") then
	inquire (file=char(filename), exist=exist)
	if (exist) then
	if (check) then
	call phs_forest_read (forest, filename, &
	process%id, n_in, n_out, process%model, phs_ok, &
	md5sum_process, md5sum_model, md5sum_parameters, phs_par, &
	phs_match)
	else
	call msg_warning &
	("Validity checks turned off for phase-space file " &
	// "'" // char (filename) // "'")
	call phs_forest_read (forest, filename, &
	process%id, n_in, n_out, process%model, phs_ok)
	phs_match = .true.
	end if
	if (phs_match) call msg_message &
	("Reading phase-space configuration from file '" &
	// char (filename) // "'...")
	unit = free_unit ()
	open (unit = unit, file = char (filename), action = "read", &
	status = "old")
	process%md5sum_phs = md5sum (unit)
	close (unit)
	if (.not. phs_ok) then
	call msg_fatal ("Phase space file '" // char (filename) &
	// "': No valid phase space for process '" &
	// char (process%id) // "'")
	if (present (ok)) ok = .false.
	return
	end if
	else
	call msg_message ("Phase space file '" // char (filename) &
	// "' not found.")
	phs_match = .false.
	end if
	end if
	wrote_file = .false.
	if (.not. phs_match) then
	call msg_message ("Generating phase space configuration ...")
	LOOP_OFF_SHELL: do extra_off_shell = 0, max (n_tot - 3, 0)
	call cascade_set_generate (cascade_set, &
	process%model, n_in, n_out, flv, phs_par, process%fatal_beam_decay)
	if (cascade_set_is_valid (cascade_set)) then
	exit LOOP_OFF_SHELL
	else if (phs_par%off_shell >= max (n_tot - 3, 0)) then
	call msg_error ("Process '" // char (process%id) &
	// "': no valid phase-space channels found")
	if (present (ok)) ok = .false.
	call cascade_set_final (cascade_set)
	return
	else
	write (msg_buffer, "(A,1x,I0)") &
	"Process '" // char (process%id) &
	// "': no valid phase-space channels found for " &
	// "phs_off_shell =", phs_par%off_shell
	call msg_warning ()
	call msg_message ("Increasing phs_off_shell")
	phs_par%off_shell = phs_par%off_shell + 1
	end if
	end do LOOP_OFF_SHELL
	unit = free_unit ()
	if (present (filename_out)) then
	open (unit, file=char(filename_out), &
	action="readwrite", status="replace")
	else
	open (unit, action="readwrite", status="scratch")
	end if
	write (unit, *) "process ", char (process%id)
	write (unit, *)
	call cascade_set_write_process_bincode_format (cascade_set, unit)
	write (unit, *)
	write (unit, *) " md5sum_process = ", '"', md5sum_process, '"'
	write (unit, *) " md5sum_model = ", '"', md5sum_model, '"'
	write (unit, *) " md5sum_parameters = ", '"', md5sum_parameters, '"'
	call phs_parameters_write (phs_par, unit)
	call cascade_set_write_file_format (cascade_set, unit)
	if (vis_channels) then
	unit_tex = free_unit ()
	open (unit=unit_tex, file=char(filename_vis // ".tex"), &
	action="write", status="replace")
	call cascade_set_write_graph_format (cascade_set, &
	filename_vis // "-graphs", process_get_id (process), unit_tex)
	close (unit_tex)
	call msg_message ("Writing visualized phase space channels file " &
	// char(trim(filename_vis)) // "...")
	if (os_data%event_analysis_ps) then
	BLOCK: do
	unit_dev = free_unit ()
	open (file = "/dev/null", unit = unit_dev, &
	action = "write", iostat = status)
	if (status /= 0) then
	pipe = ""
	pipe_dvi = ""
	else
	pipe = " > /dev/null"
	pipe_dvi = " 2>/dev/null 1>/dev/null"
	end if
	close (unit_dev)
	if (os_data%whizard_texpath /= "") then
	setenv_tex = &
	"TEXINPUTS=" // os_data%whizard_texpath // ":$TEXINPUTS "
	setenv_mp = &
	"MPINPUTS=" // os_data%whizard_texpath // ":$MPINPUTS "
	else
	setenv_tex = ""
	setenv_mp = ""
	end if
	call os_system_call (setenv_tex // os_data%latex // " " // &
	filename_vis // ".tex " // pipe, status)
	if (status /= 0) exit BLOCK
	if (os_data%mpost /= "") then
	call os_system_call (setenv_mp // os_data%mpost // " " // &
	filename_vis // "-graphs.mp" // pipe, status)
	else
	call msg_fatal ("Could not use MetaPOST.")
	end if
	if (status /= 0) exit BLOCK
	call os_system_call (setenv_tex // os_data%latex // " " // &
	filename_vis // ".tex" // pipe, status)
	if (status /= 0) exit BLOCK
	call os_system_call (os_data%dvips // " -o " // filename_vis &
	// ".ps " // filename_vis // ".dvi" // pipe_dvi, status)
	if (status /= 0) exit BLOCK
	if (os_data%event_analysis_pdf) then
	call os_system_call (os_data%ps2pdf // " " // &
	filename_vis // ".ps", status)
	if (status /= 0) exit BLOCK
	end if
	exit BLOCK
	end do BLOCK
	if (status /= 0) then
	call msg_error ("Unable to compile analysis output file")
	end if
	end if
	end if
	call msg_message ("... done.")
	call cascade_set_final (cascade_set)
	rewind (unit)
	call phs_forest_read (forest, unit, &
	process%id, n_in, n_out, process%model, phs_ok)
	rewind (unit)
	process%md5sum_phs = md5sum (unit)
	close (unit)
	wrote_file = present (filename_out)
	if (.not. phs_ok) then
	call msg_bug ("Generated phase space file: " &
	// "No valid phase space for process '" &
	// char (process%id) // "'")
	end if
	end if
	call phs_forest_set_flavors (forest, flv(:,1))
	call phs_forest_set_parameters &
	(forest, mapping_defaults, variable_limits)
	call phs_forest_setup_prt_combinations (forest)
	call phs_forest_set_equivalences (forest)
	if (process%use_beams) then
	n_par_strfun = strfun_chain_get_n_parameters_tot (process%sfchain)
	allocate (strfun_rigid (n_par_strfun))
	strfun_rigid = strfun_chain_dimension_is_rigid (process%sfchain)
	else
	n_par_strfun = 0
	allocate (strfun_rigid (0))
	end if
	call phs_forest_setup_vamp_equivalences (forest, &
	n_par_strfun + process%n_par_ci, &
	(/strfun_rigid, (/(.false., i = 1, process%n_par_ci)/)/), &
	process%azimuthal_dependence, &
	process%vamp_eq)
	! call phs_forest_set_global_mappings (forest)
	process%n_channels = phs_forest_get_n_channels (forest)
	process%n_par_phs = phs_forest_get_n_parameters (forest)
	process%n_par = process%n_par_strfun + process%n_par_ci + process%n_par_phs
	allocate (process%x_phs (process%n_par_phs))
	process%x_phs = 0
	allocate (process%x_ci (process%n_par_ci))
	process%x_ci = 0
	do i = 1, process%n_kinematics_in
	allocate (process%kinematics_in(i)%x(process%n_par, process%n_channels))
	allocate (process%kinematics_in(i)%phs_factor(process%n_channels))
	process%kinematics_in(i)%x = 0
	process%kinematics_in(i)%phs_factor = 0
	process%kinematics_in(i)%forest = forest
	call phs_forest_set_parameters (process%kinematics_in(i)%forest, &
	mapping_defaults, variable_limits .or. &
	core_interaction_varying_sqrts (process%ci, i))
	if (mapping_defaults%enable_s_mapping) then
	call phs_forest_set_s_mappings (process%kinematics_in(i)%forest)
	end if
	end do
	allocate (process%active_channel (process%n_channels))
	process%active_channel = .true.
	write (msg_buffer, "(A,I0,A,I0,A)") "... found ", process%n_channels, &
	" phase space channels, collected in ", &
	phs_forest_get_n_groves (forest), &
	" groves."
	call msg_message ()
	write (msg_buffer, "(A,I0,A)") "Phase space: found ", &
	phs_forest_get_n_equivalences (forest), &
	" equivalences between channels."
	call msg_message ()
	if (wrote_file) &
	call msg_message ("Wrote phase-space configuration file '" &
	// char (filename_out) // "'.")
	if (present (ok)) ok = .true.
	call phs_forest_final (forest)
	end subroutine process_setup_phase_space

	@ %def process_setup_phase_space
	@
	\subsection{Process preparation: cuts, weight and scale}
	Create a [[subevt]] which holds the relevant event data which are
	accessible to cuts, weight and scale. We store beams, incoming
	partons, and outgoing partons. Beam remnants and any further virtual
	particles are not used, neither are decay products or hadrons (which
	do not exist at the integration level). There is flavor information
	(as far as possible in the presence of flavor sums), but no helicity
	information.

	Allocation has been done in [[process_init]]. Here, we determine the
	relevant particle indices in the process (trace) evaluator and fill
	the particles initially with zero momenta, but flavors taken from the
	beam and hard-interaction definition. If there are flavor sums, we
	choose the first flavor in the list.

	The assignment of indices relies on the assumptions that (1) the beams
	come first, (2) the incoming partons are located immediately after all
	structure-function virtual particles, (3) the outgoing partons are the
	children of the first incoming parton.
	<<XXX Processes: public>>=
	public :: process_setup_subevt
	<<XXX Processes: procedures>>=
	subroutine process_setup_subevt (process)
	type(process_t), intent(inout), target :: process
	type(interaction_t), pointer :: int
	integer :: n_beam, n_in, n_out
	integer :: i
	n_beam = size (process%j_beam)
	n_in = size (process%j_in)
	n_out = size (process%j_out)
	process%j_beam = (/ (i, i = 1, n_beam) /)
	process%j_in = (/ (i + strfun_chain_get_n_vir (process%sfchain), &
	i = 1, n_in) /)
	do i = 1, process%n_kinematics_out
	if (process%use_beams) then
	int => evaluator_get_int_ptr (process%kinematics_out(i)%eval_trace)
	else
	int => core_interaction_get_int_ptr (process%ci, i)
	end if
	if (i == 1) process%j_out = &
	interaction_get_children (int, process%j_in(1))
	call interaction_to_subevt (int, &
	process%j_beam, process%j_in, process%j_out, &
	process%kinematics_out(i)%subevt)
	call subevt_set_pdg_beam (process%kinematics_out(i)%subevt, &
	flavor_get_pdg (beam_data_get_flavor (process%beam_data)))
	call subevt_set_pdg_incoming (process%kinematics_out(i)%subevt, &
	flavor_get_pdg (process%flv_in))
	call subevt_set_pdg_outgoing (process%kinematics_out(i)%subevt, &
	flavor_get_pdg (process%flv_out_eff))
	end do
	end subroutine process_setup_subevt

	@ %def process_setup_subevt
	@ Compile the cut expression and store it as an evaluation tree inside
	the process object. Also store the parse node. In subsequent calls,
	the setup may be called without providing the parse node, but simply
	looking it up.
	<<XXX Processes: public>>=
	public :: process_setup_cuts
	<<XXX Processes: procedures>>=
	subroutine process_setup_cuts (process, parse_node, md5sum)
	type(process_t), intent(inout), target :: process
	type(parse_node_t), intent(in), optional, target :: parse_node
	character(32), intent(out), optional :: md5sum
	integer :: i
	if (present (parse_node)) process%cut_pn => parse_node
	if (associated (process%cut_pn)) then
	do i = 1, process%n_kinematics_out
	call eval_tree_init_lexpr &
	(process%kinematics_out(i)%cut_expr, process%cut_pn, &
	process%var_list, process%kinematics_out(i)%subevt)
	end do
	end if
	if (present (md5sum)) &
	md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%cut_expr)
	end subroutine process_setup_cuts

	@ %def process_setup_cuts
	@ Compile the weight expression and store it as an evaluation tree inside
	the process object.
	<<XXX Processes: public>>=
	public :: process_setup_weight
	<<XXX Processes: procedures>>=
	subroutine process_setup_weight (process, parse_node, md5sum)
	type(process_t), intent(inout), target :: process
	type(parse_node_t), intent(in), optional, target :: parse_node
	character(32), intent(out), optional :: md5sum
	integer :: i
	if (present (parse_node)) process%weight_pn => parse_node
	if (associated (process%weight_pn)) then
	do i = 1, process%n_kinematics_out
	call eval_tree_init_expr &
	(process%kinematics_out(i)%reweighting_expr, process%weight_pn, &
	process%var_list, process%kinematics_out(i)%subevt)
	end do
	end if
	if (present (md5sum)) &
	md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%reweighting_expr)
	end subroutine process_setup_weight

	@ %def process_setup_weight
	@ Compile the scale expression and store it as an evaluation tree inside
	the process object.
	<<XXX Processes: public>>=
	public :: process_setup_scale
	<<XXX Processes: procedures>>=
	subroutine process_setup_scale (process, parse_node, md5sum)
	type(process_t), intent(inout), target :: process
	type(parse_node_t), intent(in), optional, target :: parse_node
	character(32), intent(out), optional :: md5sum
	integer :: i
	if (present (parse_node)) process%scale_pn => parse_node
	if (associated (process%scale_pn)) then
	do i = 1, process%n_kinematics_out
	call eval_tree_init_expr &
	(process%kinematics_out(i)%scale_expr, process%scale_pn, &
	process%var_list, process%kinematics_out(i)%subevt)
	end do
	end if
	if (present (md5sum)) &
	md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%scale_expr)
	end subroutine process_setup_scale

	@ %def process_setup_scale
	@
	<<XXX Processes: public>>=
	public :: process_setup_fac_scale
	<<XXX Processes: procedures>>=
	subroutine process_setup_fac_scale (process, parse_node, md5sum)
	type(process_t), intent(inout), target :: process
	type(parse_node_t), intent(in), optional, target :: parse_node
	character(32), intent(out), optional :: md5sum
	integer :: i
	if (present (parse_node)) process%fac_scale_pn => parse_node
	if (associated (process%fac_scale_pn)) then
	do i = 1, process%n_kinematics_out
	call eval_tree_init_expr &
	(process%kinematics_out(i)%fac_scale_expr, process%fac_scale_pn, &
	process%var_list, process%kinematics_out(i)%subevt)
	end do
	end if
	if (present (md5sum)) &
	md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%fac_scale_expr)
	end subroutine process_setup_fac_scale

	@ %def process_setup_fac_scale
	@
	<<XXX Processes: public>>=
	public :: process_setup_ren_scale
	<<XXX Processes: procedures>>=
	subroutine process_setup_ren_scale (process, parse_node, md5sum)
	type(process_t), intent(inout), target :: process
	type(parse_node_t), intent(in), optional, target :: parse_node
	character(32), intent(out), optional :: md5sum
	integer :: i
	if (present (parse_node)) process%ren_scale_pn => parse_node
	if (associated (process%ren_scale_pn)) then
	do i = 1, process%n_kinematics_out
	call eval_tree_init_expr &
	(process%kinematics_out(i)%ren_scale_expr, process%ren_scale_pn, &
	process%var_list, process%kinematics_out(i)%subevt)
	end do
	end if
	if (present (md5sum)) &
	md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%ren_scale_expr)
	end subroutine process_setup_ren_scale

	@ %def process_setup_ren_scale
	@
	\subsection{Process preparation: VAMP grids}
	@ Initialize the grids with uniform channel weight.
	<<XXX Processes: public>>=
	public :: process_setup_grids
	<<XXX Processes: procedures>>=
	subroutine process_setup_grids (process, grid_parameters, calls)
	type(process_t), intent(inout), target :: process
	type(grid_parameters_t), intent(in) :: grid_parameters
	integer, intent(in) :: calls
	integer, dimension(:), allocatable :: num_div
	real(default), dimension(:), allocatable :: weights
	real(default), dimension(:,:), allocatable :: region
	integer :: min_calls
	allocate (num_div (process%n_par))
	min_calls = grid_parameters%min_calls_per_bin * process%n_channels
	if (min_calls /= 0) then
	process%n_bins = max (grid_parameters%min_bins, &
	min (calls / min_calls, grid_parameters%max_bins))
	else
	process%n_bins = grid_parameters%max_bins
	end if
	allocate (region (2, process%n_par))
	region(1,:) = 0
	region(2,:) = 1
	allocate (weights (process%n_channels))
	weights = 1
	num_div = process%n_bins
	call msg_message ("Creating VAMP integration grids:")
	if (grid_parameters%use_vamp_equivalences) &
	call msg_message ("Using phase-space channel equivalences.")
	call vamp_create_grids (process%grids, region, calls, weights, &
	num_div=num_div, stratified=grid_parameters%stratified)
	process%vamp_grids_defined = .true.
	end subroutine process_setup_grids

	@ %def process_setup_grids
	@
	\subsection{Process preparation: Helicity selection counters}
	The helicity selection counters can be activated and reset at startup,
	removing unnecessary helicities after [[cutoff]] tries.
	<<XXX Processes: public>>=
	public :: process_reset_helicity_selection
	<<XXX Processes: procedures>>=
	subroutine process_reset_helicity_selection (process, threshold, cutoff)
	type(process_t), intent(inout) :: process
	real(default), intent(in) :: threshold
	integer, intent(in) :: cutoff
	call core_interaction_reset_helicity_selection &
	(process%ci, threshold, cutoff)
	end subroutine process_reset_helicity_selection

	@ %def process_reset_helicity_selection
	@
	\subsection{Matrix element evaluation}
	Kinematics. This evaluates structure functions as far as momenta are
	concerned. The evaluator links automatically transfer the incoming
	momenta to the hard interaction. All phase space factors are
	evaluated, and the resulting momenta are stored back in the hard
	interaction, from there transferred to the appropriate evaluators.

	Once the particle momenta are known, they are transferred to the
	[[subevt]] that is used for cut/weight/scale evaluation. The energy
	scale is computed right here.

	If [[ok]] is false, there is no valid momentum assignement for the given
	$x$ parameters, and the event must be dropped.
	<<XXX Processes: procedures>>=
	subroutine process_set_kinematics (process, x_in, channel, ok)
	type(process_t), intent(inout), target :: process
	real(default), dimension(:), intent(in) :: x_in
	integer, intent(in) :: channel
	logical, intent(out) :: ok
	integer :: n, i, off_phs, off_strfun, off_ci, n1, n2
	real(default) :: lda
	real(default) :: sqrts
	type(lorentz_transformation_t) :: lt
	type(interaction_t), pointer :: int
	type(evaluator_t), pointer :: eval
	type(vector4_t), dimension(:), allocatable :: pin
	type(vector4_t) :: pcm
	! Compute MC variable offsets
	off_phs = 1
	off_strfun = off_phs + process%n_par_phs
	off_ci = off_strfun + process%n_par_strfun
	process%x_phs = x_in(off_phs:off_strfun - 1)
	if (process%n_par_strfun > 0) &
	process%x_strfun = x_in(off_strfun:off_ci - 1)
	if (process%n_par_ci > 0) &
	process%x_ci = x_in(off_ci:)
	process%channel = channel
	! We need this array later
	if (process%type == PRC_DECAY) then
	allocate (pin(1))
	else
	allocate (pin(2))
	end if
	! Calculate incoming seed momenta
	if (process%use_beams) then
	! ! Use beams? -> Evaluate structure function chain
	!!! Commented this out because allow_s_channel_mapping no longer exists
	! if (process%allow_s_channel_mapping) then
	! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, &
	! phs_forest_tree_has_global_mapping ( &
	! process%kinematics_in(1)%forest, channel), &
	! ok=ok)
	! else
	call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, ok=ok)
	!!! Previous version: Commented this out because n_par_hi no longer exists.
	! n1 = process%n_par_hi
	! n2 = process%n_par_hi + process%n_par_strfun
	! if (strfun_chain_multichannel_enabled (process%sfchain)) then
	! process%x(n1+1:n2, channel) = process%x_strfun
	! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, &
	! channel, n1, process%x, process%sf_factor, &
	! ok=ok)
	! else
	! forall (i = 1:size(process%x,2)) &
	! process%x(n1+1:n2,i) = process%x_strfun
	! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, &
	! ok=ok)
	! end if
	! end if
	if (.not. ok) return
	do i = process%n_kinematics_out, 1, -1
	if (i > 1) call evaluator_receive_momenta ( &
	process%kinematics_out(i)%strfun_snapshot)
	int => core_interaction_get_int_ptr (process%ci, i)
	call interaction_receive_momenta (int)
	end do
	process%beams_are_set = .true.
	process%sqrts_hat = sqrt (max (interaction_get_s (int), 0._default))
	else if (.not. process%beams_are_set) then
	! No Beams -> set the momenta directly
	if (process%type == PRC_DECAY) then
	pin = (/vector4_at_rest (process%mass_in(1))/)
	else
	pin = colliding_momenta (process%sqrts, process%mass_in)
	end if
	process%sqrts_hat = process%sqrts
	do i = process%n_kinematics_out, 1, -1
	int => core_interaction_get_int_ptr (process%ci, i)
	call interaction_set_momenta (int, pin, outgoing=.false.)
	end do
	else
	! We must still make sure that int is valid
	int => core_interaction_get_int_ptr (process%ci, 1)
	!!! Previous version
	! if (process%n_par_strfun /= 0) call msg_bug &
	! ("Mismatch in structure function setup: n_parameters /= 0")
	! select case (process%type)
	! case (PRC_DECAY)
	! call interaction_set_momenta (int, &
	! (/ vector4_at_rest (process%mass_in(1)) /), &
	! outgoing=.false.)
	! case (PRC_SCATTERING)
	! call interaction_set_momenta (int, &
	! colliding_momenta (process%sqrts, process%mass_in), &
	! outgoing=.false.)
	! end select
	! process%sqrts_hat = process%sqrts
	! else
	! if (process%n_par_strfun /= 0) call msg_bug &
	! ("Mismatch in beams/structure function setup: n_parameters /= 0")
	end if
	int => core_interaction_get_int_ptr (process%ci, 1)
	call process_status_passed_strfun_chain (process%status)
	process%sqrts_hat_known = .true.
	! Calculate flux factor
	if (process%type == PRC_DECAY) then
	process%flux_factor = twopi4 / (2 * process%mass_in(1))
	else
	lda = lambda (process%sqrts_hat ** 2, &
	process%mass_in(1) ** 2, &
	process%mass_in(2) ** 2)
	if (lda <= 0) then
	ok = .false.
	return
	end if
	process%flux_factor = conv * twopi4 / (2 * sqrt (lda))
	end if
	call process_status_passed_mass_threshold (process%status)
	! Set the MC variables for the core interaction and tell it that we have
	! completed the ingoing seed kinematics
	call core_interaction_set_x (process%ci, process%x_ci)
	call core_interaction_set_state (process%ci, CI_STATE_SEED_MOMENTA_SET)
	! Setup MC hypercube
	forall (n = 1 : process%n_kinematics_in)
	process%kinematics_in(n)%x(:off_strfun - 1, channel) = process%x_phs
	forall (i = 1 : process%n_par_strfun) &
	process%kinematics_in(n)%x(off_strfun + i - 1, :) = process%x_strfun(i)
	forall (i = 1 : process%n_par_ci) &
	process%kinematics_in(n)%x(off_ci + i - 1, :) = process%x_ci(i)
	end forall
	!!! Previous version. forest is no longer part of process.
	! process%sqrts_hat_known = .true.
	! if (.not. process%lab_is_cm_frame) then
	! process%lt_cm_to_lab = interaction_get_cm_transformation (int)
	! call phs_forest_set_prt_in (process%forest, int, process%lt_cm_to_lab)
	! else
	! call phs_forest_set_prt_in (process%forest, int)
	! end if
	! Complete the kinematics by evaluating the phs forests for all ``in''
	! configuration
	process%kinematics_in(1)%sqrts = process%sqrts_hat
	do i = 1, process%n_kinematics_in
	if (i > 1) then
	call core_interaction_get_momenta_in (process%ci, pin, i)
	pcm = sum (pin)
	process%kinematics_in(i)%sqrts = sqrt (pcm * pcm)
	process%kinematics_in(i)%lt = boost (pcm, process%kinematics_in(i)%sqrts)
	call phs_forest_set_prt_in (process%kinematics_in(i)%forest, &
	pin, process%kinematics_in(i)%lt)
	else
	if (.not. process%lab_is_cm_frame) then
	process%lt_cm_to_lab = interaction_get_cm_transformation (int)
	process%kinematics_in(i)%lt = process%lt_cm_to_lab
	call phs_forest_set_prt_in (process%kinematics_in(i)%forest, &
	int, process%lt_cm_to_lab)
	else
	call phs_forest_set_prt_in (process%kinematics_in(i)%forest, int)
	end if
	end if
	call phs_forest_evaluate_momenta (&
	process%kinematics_in(i)%forest, &
	channel, process%active_channel, &
	process%kinematics_in(i)%sqrts, &
	process%kinematics_in(i)%x, &
	process%kinematics_in(i)%phs_factor, &
	process%kinematics_in(i)%phs_volume, &
	ok=process%kinematics_in(i)%passed)
	end do
	! The hypercube point remains valid as long as any of the phasespace points
	! passes
	ok = any (process%kinematics_in(:)%passed)
	if (.not. ok) return
	! Passed? -> Propagate the kinematics to the core interaction
	do i = 1, process%n_kinematics_in
	call core_interaction_kinematics_passed (process%ci, &
	process%kinematics_in(i)%passed, i)
	if (process%kinematics_in(i)%passed) then
	if (i > 1 .or. .not. process%lab_is_cm_frame) then
	call core_interaction_set_momenta_out (process%ci, &
	phs_forest_get_momenta_out ( &
	process%kinematics_in(i)%forest, &
	process%kinematics_in(i)%lt), &
	i)
	else
	call core_interaction_set_momenta_out (process%ci, &
	phs_forest_get_momenta_out (process%kinematics_in(i)%forest), &
	i)
	end if
	end if
	end do
	! Advance the core interaction state, triggering the calculation of the
	! effective kinematics at the ``out'' points...
	call core_interaction_set_state (process%ci, CI_STATE_MOMENTA_SET)
	! ... and forward them to the evaluators
	do i = 1, process%n_kinematics_out
	process%kinematics_out(i)%passed = core_interaction_get_cut_status ( &
	process%ci, i)
	if (process%kinematics_out(i)%passed) then
	eval => core_interaction_get_eval_trace_ptr (process%ci, i)
	call evaluator_receive_momenta (eval)
	if (process%use_beams) call evaluator_receive_momenta ( &
	process%kinematics_out(i)%eval_trace)
	end if
	end do
	call process_status_passed_kinematics (process%status)
	end subroutine process_set_kinematics

	@ %def process_set_kinematics
	@ Complete phase space evaluation
	<<XXX Processes: public>>=
	public :: process_complete_kinematics
	<<XXX Processes: procedures>>=
	subroutine process_complete_kinematics (process, channel)
	type(process_t), intent(inout), target :: process
	integer, intent(in) :: channel
	integer :: i
	do i = 1, process%n_kinematics_in
	if (process%kinematics_in(i)%passed) &
	call phs_forest_evaluate_other_channels ( &
	process%kinematics_in(i)%forest, &
	channel, process%active_channel, &
	process%kinematics_in(i)%sqrts, &
	process%kinematics_in(i)%x, &
	process%kinematics_in(i)%phs_factor)
	end do
	end subroutine process_complete_kinematics

	@ %def process_complete_kinematics
	@ Recover momenta from a given particle set.
	<<XXX Processes: public>>=
	public :: process_recover_kinematics
	<<XXX Processes: procedures>>=
	subroutine process_recover_kinematics (process, particle_set)
	type(process_t), intent(inout), target :: process
	type(particle_set_t), intent(in) :: particle_set
	integer :: n_in, n_out
	real(default) :: lda
	type(evaluator_t), pointer :: eval
	type(interaction_t), pointer :: int
	! Will propably never be implemented ;)
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"Recovering process with subtraction kinematics not implemented")
	! To be implemented later
	if (process%use_beams) &
	call msg_bug ("Recovering process with beams not implemented yet")

	call core_interaction_recover_kinematics (process%ci, particle_set)
	int => core_interaction_get_int_ptr (process%ci, 1)

	process%sqrts_hat = process%sqrts
	select case (process%type)
	case (PRC_DECAY)
	process%flux_factor = &
	twopi4 / (2 * process%mass_in(1))
	case (PRC_SCATTERING)
	lda = lambda (process%sqrts_hat ** 2, &
	process%mass_in(1) ** 2, &
	process%mass_in(2) ** 2)
	if (lda <= 0) then
	process%flux_factor = 0
	else
	process%flux_factor = &
	conv * twopi4 / (2 * sqrt (lda))
	end if
	end select
	process%sqrts_hat_known = .true.
	if (.not. process%lab_is_cm_frame) then
	process%lt_cm_to_lab = interaction_get_cm_transformation (int)
	call phs_forest_set_prt_in ( &
	process%kinematics_in(1)%forest, int, process%lt_cm_to_lab)
	else
	call phs_forest_set_prt_in (process%kinematics_in(1)%forest, int)
	end if

	eval => core_interaction_get_eval_trace_ptr (process%ci, 1)
	call evaluator_receive_momenta (eval)
	process%kinematics_in(1)%sqrts = process%sqrts
	process%kinematics_in(1)%passed = .true.
	end subroutine process_recover_kinematics

	@ %def process_recover_kinematics
	@ Fill the [[subevt]] which is used by cuts, weight, scale with
	momenta from the [[eval_trace]] interaction. This can be done once
	kinematics has been set up or recovered.

	If the optional [[transform]] flag is set, boost the momenta from the
	lab to the c.m.\ frame.

	Caveat: If we want to implement casce decays @ NLO, we will have to revisit this,
	I am pretty sure that handling of the boost is not consisten for this case.
	<<XXX Processes: public>>=
	public :: process_fill_subevt
	<<XXX Processes: procedures>>=
	subroutine process_fill_subevt (process, transform)
	type(process_t), intent(inout), target :: process
	logical, intent(in), optional :: transform
	type(interaction_t), pointer :: int
	integer :: i
	logical :: tr
	tr = .false.; if (present (transform)) tr = transform
	do i = 1, process%n_kinematics_out
	if (process%use_beams) then
	int => evaluator_get_int_ptr (process%kinematics_out(i)%eval_trace)
	else
	int => core_interaction_get_int_ptr (process%ci, i)
	end if
	if (tr) then
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"NLO cascade decays not implemented yet")
	call interaction_momenta_to_subevt &
	(int, process%j_beam, process%j_in, process%j_out, &
	inverse (process%lt_cm_to_lab), process%kinematics_out(i)%subevt)
	else
	call interaction_momenta_to_subevt &
	(int, process%j_beam, process%j_in, process%j_out, &
	process%kinematics_out(i)%subevt)
	end if
	end do
	end subroutine process_fill_subevt

	@ %def process_fill_subevt
	@ Evaluate the cut expression and return a boolean flag (true means to
	continue evaluation, false to drop the event).
	<<XXX Processes: procedures>>=
	function process_passes_cuts (process) result (flag)
	logical :: flag
	type(process_t), intent(inout), target :: process
	integer :: i
	logical :: passed
	flag = .false.
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	if (eval_tree_is_defined (process%kinematics_out(i)%cut_expr)) then
	call eval_tree_evaluate (process%kinematics_out(i)%cut_expr)
	if (eval_tree_result_is_known (process%kinematics_out(i)%cut_expr)) then
	passed = eval_tree_get_log (process%kinematics_out(i)%cut_expr)
	else
	passed = .true.
	end if
	else
	passed = .true.
	end if
	call core_interaction_set_cut_status (process%ci, passed, i)
	process%kinematics_out(i)%passed = passed
	flag = flag .or. passed
	end do
	end function process_passes_cuts

	@ %def process_passes_cuts
	@ Evaluate the weight expression and set the value.
	<<XXX Processes: public>>=
	public :: process_compute_reweighting_factor
	<<XXX Processes: procedures>>=
	subroutine process_compute_reweighting_factor (process)
	type(process_t), intent(inout), target :: process
	integer :: i
	do i = 1, process%n_kinematics_out
	if (eval_tree_is_defined (process%kinematics_out(i)%reweighting_expr)) then
	if (.not. process%kinematics_out(i)%passed) cycle
	call eval_tree_evaluate (process%kinematics_out(i)%reweighting_expr)
	if (eval_tree_result_is_known ( &
	process%kinematics_out(i)%reweighting_expr)) &
	then
	process%kinematics_out(i)%reweighting_factor = &
	eval_tree_get_real (process%kinematics_out(i)%reweighting_expr)
	else
	process%kinematics_out(i)%reweighting_factor = 1
	end if
	else
	process%kinematics_out(i)%reweighting_factor = 1
	end if
	end do
	end subroutine process_compute_reweighting_factor

	@ %def process_compute_reweighting_factor
	@ Evaluate the scale expression(s) and return a real value. If the scale
	expression is essentially undefined, return the c.m. energy of the hard
	interaction. The factorization scale and renormalization scale always supersede
	the general expression.
	<<XXX Processes: public>>=
	public :: process_compute_scale
	<<XXX Processes: procedures>>=
	subroutine process_compute_scale (process)
	type(process_t), intent(inout), target :: process
	integer :: i
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	if (eval_tree_is_defined (process%kinematics_out(i)%scale_expr)) then
	call eval_tree_evaluate (process%kinematics_out(i)%scale_expr)
	if (eval_tree_result_is_known ( &
	process%kinematics_out(i)%scale_expr)) &
	then
	process%kinematics_out(i)%scale = &
	eval_tree_get_real (process%kinematics_out(i)%scale_expr)
	else
	process%kinematics_out(i)%scale = process%sqrts_hat
	end if
	else
	process%kinematics_out(i)%scale = process%sqrts_hat
	end if
	if (eval_tree_is_defined (process%kinematics_out(i)%fac_scale_expr)) then
	call eval_tree_evaluate (process%kinematics_out(i)%fac_scale_expr)
	if (eval_tree_result_is_known ( &
	process%kinematics_out(i)%fac_scale_expr)) &
	then
	process%kinematics_out(i)%fac_scale = &
	eval_tree_get_real (process%kinematics_out(i)%fac_scale_expr)
	else
	process%kinematics_out(i)%fac_scale = process%kinematics_out(i)%scale
	end if
	else
	process%kinematics_out(i)%fac_scale = process%kinematics_out(i)%scale
	end if
	if (eval_tree_is_defined (process%kinematics_out(i)%ren_scale_expr)) then
	call eval_tree_evaluate (process%kinematics_out(i)%ren_scale_expr)
	if (eval_tree_result_is_known ( &
	process%kinematics_out(i)%ren_scale_expr)) &
	then
	process%kinematics_out(i)%ren_scale = &
	eval_tree_get_real (process%kinematics_out(i)%ren_scale_expr)
	else
	process%kinematics_out(i)%ren_scale = process%kinematics_out(i)%scale
	end if
	else
	process%kinematics_out(i)%ren_scale = process%kinematics_out(i)%scale
	end if
	end do
	end subroutine process_compute_scale

	@ %def process_compute_scale
	@ Evaluate the (jacobian) factor associated to the VAMP grids and the
	phase-space factor array for the given integration channel.

	!!! JRR: WK please check:
	has been taken over into mci_vamp_instance_compute_weights. The
	structure function factors are missing, but should (have) be(en) taken
	into account elsewhere. What about the active_channel stuff?
	<<XXX Processes: procedures>>=
	subroutine process_compute_vamp_phs_factor (process, weights)
	type(process_t), intent(inout), target :: process
	real(default), dimension(:), intent(in) :: weights
	real(default), dimension(process%n_channels) :: vamp_prob
	real(default) :: dp
	integer :: i, n
	do n = 1, process%n_kinematics_in
	if (.not. process%kinematics_in(n)%passed) cycle
	!$OMP PARALLEL PRIVATE(i) SHARED(process,vamp_prob)
	!$OMP DO
	do i = 1, process%n_channels
	if (process%active_channel(i)) then
	vamp_prob(i) = &
	vamp_probability (process%grids%grids(i), &
	process%kinematics_in(n)%x(:,i))
	else
	vamp_prob(i) = 0
	end if
	end do
	!$OMP END DO
	!$OMP END PARALLEL
	dp = dot_product (weights, vamp_prob / process%kinematics_in(n)%phs_factor)
	if (dp /= 0) then
	process%kinematics_in(n)%vamp_phs_factor = &
	vamp_prob(process%channel) / dp
	else
	process%kinematics_in(n)%vamp_phs_factor = 0
	end if
	end do
	!!! Previous version
	! !$OMP END DO
	! !$OMP END PARALLEL
	! if (allocated (process%sf_factor)) then
	! dp = dot_product (weights, &
	! vamp_prob / (process%phs_factor * process%sf_factor))
	! else
	! dp = dot_product (weights, vamp_prob / process%phs_factor)
	! end if
	! if (dp /= 0) then
	! process%vamp_phs_factor = vamp_prob(process%channel) / dp
	! else
	! process%vamp_phs_factor = 0
	! end if
	end subroutine process_compute_vamp_phs_factor

	@ %def process_compute_vamp_phs_factor
	@ Update the model parameters used by the matrix element code.
	<<XXX Processes: public>>=
	public :: process_update_parameters
	<<XXX Processes: procedures>>=
	subroutine process_update_parameters (process)
	type(process_t), intent(inout) :: process
	call core_interaction_update_parameters (process%ci)
	end subroutine process_update_parameters

	@ %def process_update_parameters
	@ Update the $\alpha_s$ value used by the matrix element code,
	depending on the computed renormalization scale.
	<<XXX Processes: interfaces>>=
	interface
	double precision function alphasPDF (Q)
	double precision, intent(in) :: Q
	end function alphasPDF
	end interface
	@ %def alphasPDF
	@
	<<XXX Processes: public>>=
	public :: process_update_alpha_s
	<<XXX Processes: procedures>>=
	subroutine process_update_alpha_s (process)
	type(process_t), intent(inout) :: process
	integer :: i
	if (process%qcd%alpha_s_is_fixed) return
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	call qcd_parameters_update_alpha_s (process%qcd, &
	process%kinematics_out(i)%ren_scale)
	call core_interaction_update_alpha_s &
	(process%ci, process%qcd%alpha_s_at_scale, i)
	end do
	end subroutine process_update_alpha_s

	@ %def process_update_alpha_s
	@ Evaluate the structure function values, the hard matrix element, and
	the follow-up evaluators. We obtain the squared matrix element value
	for the current event.
	<<XXX Processes: public>>=
	public :: process_evaluate
	<<XXX Processes: procedures>>=
	subroutine process_evaluate (process)
	type(process_t), intent(inout), target :: process
	integer :: i
	call core_interaction_evaluate (process%ci)
	do i = process%n_kinematics_out, 1, -1
	if (.not. process%kinematics_out(i)%passed) cycle
	if (process%use_beams) then
	call strfun_chain_evaluate (process%sfchain, &
	process%kinematics_out(i)%fac_scale)
	if (i > 1) call evaluator_evaluate ( &
	process%kinematics_out(i)%strfun_snapshot)
	end if
	if (process%has_extra_evaluators) then
	call evaluator_evaluate (process%kinematics_out(i)%eval_trace)
	process%kinematics_out(i)%sqme = &
	evaluator_sum (process%kinematics_out(i)%eval_trace)
	else
	process%kinematics_out(i)%sqme = evaluator_sum &
	(core_interaction_get_eval_trace_ptr (process%ci, i)) &
	* process%averaging_factor
	end if
	end do
	if (process%use_beams) then
	process%sf_mapping_factor = strfun_chain_get_mapping_factor ( &
	process%sfchain)
	else
	process%sf_mapping_factor = 1
	end if
	! call process_write (process, 66); stop
	end subroutine process_evaluate

	@ %def process_evaluate
	@ Return the squared matrix element of the hard interaction for the
	given momenta, traced over all quantum numbers. This is independent
	of beam setup, structure functions, phase space etc. Makes sense only
	for ordinary (as in no subtraction / dipole) matrix elements.
	<<XXX Processes: procedures>>=
	function process_compute_sqme_sum (process, p) result (sqme)
	real(default) :: sqme
	type(process_t), intent(inout), target :: process
	type(vector4_t), dimension(:), intent(in) :: p
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"process_compute_sqme_sum makes no sense for subtraction kinematics")
	sqme = core_interaction_compute_sqme_sum (process%ci, p, 1)
	end function process_compute_sqme_sum

	@ %def process_compute_sqme_sum
	@
	\subsection{Access VAMP data}
	Compute the reweighting efficiency for the current grids, suitable
	averaged over all active channels.
	<<XXX Processes: procedures>>=
	function process_get_vamp_efficiency_array (process) result (efficiency)
	real(default), dimension(:), allocatable :: efficiency
	type(process_t), intent(in) :: process
	allocate (efficiency (process%n_channels))
	where (process%grids%grids%f_max /= 0)
	efficiency = process%grids%grids%mu(1) / abs (process%grids%grids%f_max)
	elsewhere
	efficiency = 0
	end where
	end function process_get_vamp_efficiency_array

	function process_get_vamp_efficiency (process) result (efficiency)
	real(default) :: efficiency
	type(process_t), intent(in) :: process
	real(default), dimension(:), allocatable :: weight
	real(default) :: norm
	allocate (weight (process%n_channels))
	weight = process%grids%weights * abs (process%grids%grids%f_max)
	norm = sum (weight)
	if (norm /= 0) then
	efficiency = &
	dot_product (process_get_vamp_efficiency_array (process), weight) &
	/ norm
	else
	efficiency = 1
	end if
	end function process_get_vamp_efficiency

	@ %def process_get_vamp_efficiency_array process_get_vamp_efficiency
	@
	\subsection{Integration}
	This executes one or more iterations of the VAMP integration routine.
	The flags determine whether to discard previous results, to adapt
	grids before integration, and to adapt the relative channel weights.
	The final result is entered into the results record.

	If there is a grid filename provided, we write the current grid to file, once
	after each iteration. If the flag [[write_best_grid]] is also set, we
	write the grid with the lowest (i.e., best) accuracy to file. This may
	be the current grid, or it may be a previous 'best' grid.
	<<XXX Processes: public>>=
	public :: process_integrate
	<<XXX Processes: procedures>>=
	subroutine process_integrate (process, rng, &
	grid_parameters, pass, it1, it2, calls, &
	discard_integrals, adapt_grids, adapt_weights, print_current, &
	time_estimate, &
	grids_filename, write_best_grid, md5sum, history_filename, log_filename)
	type(process_t), intent(inout), target :: process
	type(tao_random_state), intent(inout) :: rng
	type(grid_parameters_t), intent(in) :: grid_parameters
	integer, intent(in) :: pass, it1, it2, calls
	logical, intent(in) :: discard_integrals
	logical, intent(in) :: adapt_grids
	logical, intent(in) :: adapt_weights
	logical, intent(in) :: print_current
	logical, intent(in) :: time_estimate
	type(string_t), intent(in), optional :: grids_filename
	logical, intent(in), optional :: write_best_grid
	type(md5sum_grids_t), intent(in), optional :: md5sum
	type(string_t), intent(in), optional :: history_filename, log_filename
	integer :: it
	real(default) :: integral, error, efficiency
	type(time_t) :: time_start, time_end
	real(default) :: sqrts
	real(default), dimension(:), allocatable :: grove_weight
	integer :: u
	if (it1 > it2) return
	u = logfile_unit ()
	if (present (md5sum)) then
	process%md5sum_grids = process_collect_md5sum (process, md5sum)
	end if
	process%grid_parameters = grid_parameters
	sqrts = process%sqrts
	if (discard_integrals .and. it1==1) then
	if (grid_parameters%use_vamp_equivalences) then
	call vamp_discard_integrals (process%grids, &
	calls, stratified=grid_parameters%stratified, eq=process%vamp_eq)
	else
	call vamp_discard_integrals (process%grids, &
	calls, stratified=grid_parameters%stratified)
	end if
	end if
	process%beams_are_set = .false.
	do it = it1, it2
	if (adapt_grids) then
	call process_adapt_grids (process)
	end if
	if (adapt_weights) then
	call process_adapt_channel_weights (process, grid_parameters, calls)
	end if
	call process_status_reset_counters (process%status)
	if (time_estimate) time_start = time_current ()
	if (grid_parameters%use_vamp_equivalences) then
	call vamp_sample_grids &
	(rng, process%grids, sample_function, process%store_index, 1, &
	eq=process%vamp_eq, &
	history=process%v_history(it:), &
	histories=process%v_histories(it:,:), &
	integral=integral, std_dev=error, negative_weights=&
	process%negative_weights)
	else
	call vamp_sample_grids &
	(rng, process%grids, sample_function, process%store_index, 1, &
	history=process%v_history(it:), &
	histories=process%v_histories(it:,:), &
	integral=integral, std_dev=error, negative_weights=&
	process%negative_weights)
	end if
	if (time_estimate) time_end = time_current ()
	efficiency = process_get_vamp_efficiency (process)
	call process_get_grove_weights (process, grove_weight)
	if (time_estimate) then
	call integration_results_append (process%results, &
	process%type, pass, 1, calls, &
	integral, error, efficiency, grove_weight, time_start, time_end)
	else
	call integration_results_append (process%results, &
	process%type, pass, 1, calls, &
	integral, error, efficiency, grove_weight)
	end if
	process%filename_current_grid = ""
	process%filename_best_grid = ""
	if (present (grids_filename)) then
	process%filename_current_grid = grids_filename
	call write_grid_file (grids_filename, process%id, &
	process%md5sum_grids, grid_parameters, &
	process%results, process%grids)
	if (present (write_best_grid)) then
	if (write_best_grid) then
	process%filename_best_grid = grids_filename // "b"
	call write_best_grid_file (process%filename_best_grid, &
	process%id, &
	process%md5sum_grids, grid_parameters, &
	process%results, process%grids)
	end if
	end if
	end if
	if (print_current) then
	call integration_results_write_current (process%results)
	call integration_results_write_current (process%results, unit=u)
	if (u >= 0) flush (u)
	end if
	if (present (history_filename)) then
	call integration_results_write_driver &
	(process%results, history_filename)
	end if
	if (present (log_filename)) then
	call process_write_logfile (process, log_filename)
	end if
	end do
	end subroutine process_integrate

	@ %def process_integrate
	@ Collect the MD5 sums that are relevant for reading/writing grid files.
	<<XXX Processes: procedures>>=
	function process_collect_md5sum (process, md5sum_global) &
	result (md5sum_local)
	type(md5sum_grids_t) :: md5sum_local
	type(process_t), intent(in) :: process
	type(md5sum_grids_t), intent(in) :: md5sum_global
	md5sum_local = md5sum_global
	md5sum_local%process = process%md5sum
	md5sum_local%model = model_get_md5sum (process%model)
	md5sum_local%parameters = model_get_parameters_md5sum (process%model)
	md5sum_local%phs = process%md5sum_phs
	md5sum_local%alpha_s = process%md5sum_alpha_s
	md5sum_local%nlo_setup = process%md5sum_nlo_setup
	end function process_collect_md5sum

	@ %def process_collect_md5sum
	@ This should be executed instead if the process has no matrix
	element.
	<<XXX Processes: public>>=
	public :: process_do_dummy_integration
	<<XXX Processes: procedures>>=
	subroutine process_do_dummy_integration (process)
	type(process_t), intent(inout) :: process
	call integration_results_append (process%results, &
	process%type, 1, 1, 0, &
	0._default, 0._default, 0._default)
	end subroutine process_do_dummy_integration

	@ %def process_do_dummy_integration
	@ Similarly, write a number of dummy entries to the results record
	which indicate skipped iterations.
	<<XXX Processes: public>>=
	public :: process_skip_iterations
	<<XXX Processes: procedures>>=
	subroutine process_skip_iterations (process, pass, it, n_skip)
	type(process_t), intent(inout) :: process
	integer, intent(in) :: pass, it, n_skip
	integer :: i
	do i = 1, n_skip
	call integration_results_append_null (process%results, &
	pass, it + i)
	end do
	end subroutine process_skip_iterations

	@ %def process_skip_iterations
	@ In preparation for a new pass or for event generation, load a
	previously stored best grid if it does not coincide with the current one.
	<<XXX Processes: public>>=
	public :: process_choose_best_grid
	<<XXX Processes: procedures>>=
	subroutine process_choose_best_grid (process, check_grid_file)
	type(process_t), intent(inout) :: process
	logical, intent(in) :: check_grid_file
	integer :: it_last, it_best
	type(md5sum_grids_t) :: md5sum_local
	type(integration_results_t) :: results_on_file
	logical :: ok
	it_last = integration_results_get_last_it (process%results)
	it_best = integration_results_get_best_it (process%results)
	if (it_best /= 0 .and. it_best /= it_last &
	.and. process%filename_best_grid /= "") then
	write (msg_buffer, "(A,A,A,I0)") &
	"Process ", char (process%id), &
	": Using integration grids from iteration #", &
	it_best
	call msg_message
	call read_grid_file (process%filename_best_grid, process%id, &
	check_grid_file, process%md5sum_grids, process%grid_parameters, &
	results_on_file, process%grids, &
	process%pass_array, process%n_calls_array, ok)
	end if
	end subroutine process_choose_best_grid

	@ %def process_choose_best_grid
	@ This just calls the sampling function a given number of times,
	discarding the results. VAMP is bypassed.

	Constructs like this are candidates for elimination by the optimizer
	-- as long as the sampling function is impure, this should not happen,
	however.
	<<XXX Processes: public>>=
	public :: process_me_test
	<<XXX Processes: procedures>>=
	subroutine process_me_test &
	(process, rng, n_calls, time_in_seconds, sample_function_sum)
	type(process_t), intent(inout), target :: process
	type(tao_random_state), intent(inout) :: rng
	integer, intent(in) :: n_calls
	real(default), intent(out), optional :: time_in_seconds, sample_function_sum
	integer :: prc_index, i
	type(time_t) :: time_start, time_end
	real(default), dimension(:), allocatable :: weights
	real(default) :: s
	process%beams_are_set = .false.
	s = 0
	allocate (weights (process%n_channels))
	weights = 1._default / size (weights)
	call process_status_reset_counters (process%status)
	if (present (time_in_seconds)) time_start = time_current ()
	do i = 1, n_calls
	s = s + sample_function &
	(random_xi (), process%store_index, &
	weights=weights, &
	channel=random_channel ())
	end do
	if (present (time_in_seconds)) then
	time_end = time_current ()
	time_in_seconds = time_end - time_start
	end if
	if (present (sample_function_sum)) then
	sample_function_sum = s
	end if
	contains
	function random_channel () result (channel)
	integer :: channel
	real(default) :: x
	call tao_random_number (rng, x)
	channel = ceiling (x * process%n_channels)
	end function random_channel
	function random_xi () result (xi)
	real(default), dimension (process%n_par) :: xi
	integer :: i
	do i = 1, size (xi)
	call tao_random_number (rng, xi(i))
	end do
	end function random_xi
	end subroutine process_me_test

	@ %def process_me_test
	@ Create the VAMP history information:
	<<XXX Processes: public>>=
	public :: process_init_vamp_history
	public :: process_final_vamp_history
	<<XXX Processes: procedures>>=
	subroutine process_init_vamp_history (process, n_iterations)
	type(process_t), intent(inout) :: process
	integer, intent(in) :: n_iterations
	call process_final_vamp_history (process)
	allocate (process%v_history (n_iterations))
	allocate (process%v_histories &
	(n_iterations, process_get_n_channels (process)))
	call vamp_create_history (process%v_history, verbose=.false.)
	call vamp_create_history (process%v_histories, verbose=.false.)
	end subroutine process_init_vamp_history

	subroutine process_final_vamp_history (process)
	type(process_t), intent(inout) :: process
	if (allocated (process%v_history)) then
	call vamp_delete_history (process%v_history)
	deallocate (process%v_history)
	end if
	if (allocated (process%v_histories)) then
	call vamp_delete_history (process%v_histories)
	deallocate (process%v_histories)
	end if
	end subroutine process_final_vamp_history

	@ %def process_init_vamp_history
	@ %def process_final_vamp_history
	@ Display the time estimate on screen
	<<XXX Processes: public>>=
	public :: process_write_time_estimate
	<<XXX Processes: procedures>>=
	subroutine process_write_time_estimate (process, unit)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	real(default) :: time_per_event, time_per_10k
	time_per_event = integration_results_get_time_per_event (process%results)
	time_per_10k = 10000 * time_per_event
	write (msg_buffer, "(A)") "Process '" // char (process%id) // "': "
	call msg_message ()
	write (msg_buffer, "(A)") " time estimate for generating " &
	// "10000 unweighted events: " &
	// char (time2string (int (time_per_10k)))
	call msg_message (unit=unit)
	call write_hline (unit)
	end subroutine process_write_time_estimate

	@ %def process_write_time_estimate
	@ Write the VAMP grid file including a header containing metadata.
	<<XXX Processes: procedures>>=
	subroutine write_grid_file (filename, process_id, md5sum, &
	grid_parameters, results, grids)
	type(string_t), intent(in) :: filename, process_id
	type(md5sum_grids_t), intent(in) :: md5sum
	type(grid_parameters_t), intent(in) :: grid_parameters
	type(integration_results_t), intent(in) :: results
	type(vamp_grids), intent(in) :: grids
	integer :: u
	u = free_unit ()
	open (file = char (filename), unit = u, &
	action = "write", status = "replace")
	write (u, *) "process ", char (process_id)
	call md5sum_grids_write (md5sum, u)
	write (u, *)
	call grid_parameters_write (grid_parameters, u)
	write (u, *)
	call integration_results_write &
	(results, u, verbose = .true.)
	write (u, *)
	call vamp_write_grids (grids, u, write_integrals = .true.)
	close (u)
	end subroutine write_grid_file

	@ %def write_grid_file
	@ Attempt to read the VAMP grid file, checking metadata for
	consistency. Also read the integration results as far as they are
	known.
	<<XXX Processes: procedures>>=
	subroutine read_grid_file (filename, process_id, &
	check, md5sum, grid_parameters, results, grids, &
	pass, n_calls, ok)
	type(string_t), intent(in) :: filename, process_id
	logical, intent(in) :: check
	type(md5sum_grids_t), intent(in) :: md5sum
	type(grid_parameters_t), intent(in) :: grid_parameters
	type(integration_results_t), intent(out) :: results
	type(vamp_grids), intent(inout) :: grids
	integer, dimension(:), intent(in) :: pass, n_calls
	logical, intent(out) :: ok
	integer :: u
	logical :: exist
	character(80) :: buffer
	character :: equals
	character(32) :: md5sum_file
	type(grid_parameters_t) :: grid_parameters_file
	type(integration_results_t) :: results_file
	ok = .false.
	if (.not. check) call msg_warning &
	("Validity checks turned off for grid file '" &
	// char (filename) // "'")
	inquire (file = char (filename), exist = exist)
	if (.not. exist) return
	call msg_message ("Reading integration grids and results from file '" &
	// char (filename) // "':")
	u = free_unit ()
	open (file = char (filename), unit = u, action = "read", status = "old")
	read (u, *) buffer
	if (check .and. trim (adjustl (buffer)) /= "process") then
	call msg_fatal ("Grid file: missing 'process' tag")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%process) then
	call msg_message &
	("Process configuration has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%model) then
	call msg_message &
	("Model has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%parameters) then
	call msg_message &
	("Model parameters have changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%phs) then
	call msg_message &
	("Phase-space setup has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%beams) then
	call msg_message &
	("Beam setup has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%sf_list) then
	call msg_message &
	("Structure-function setup has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%mappings) then
	call msg_message &
	("Mapping scale parameters have changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%cuts) then
	call msg_message &
	("Cut configuration has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%weight) then
	call msg_message &
	("Weight expression has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%scale) then
	call msg_message &
	("General scale expression has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%fac_scale) then
	call msg_message &
	("Factorization scale expression has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%ren_scale) then
	call msg_message &
	("Renormalization scale expression has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (check .and. md5sum_file /= md5sum%alpha_s) then
	call msg_message &
	("Alpha(QCD) specifications have changed, discarding old grid file")
	close (u); return
	end if
	read (u, *) buffer, equals, md5sum_file
	if (md5sum_file /= md5sum%nlo_setup) then
	call msg_message &
	("NLO setup has changed, discarding old grid file")
	close (u); return
	end if
	read (u, *)
	call grid_parameters_read (grid_parameters_file, u)
	if (check .and. grid_parameters_file /= grid_parameters) then
	call msg_message &
	("Grid parameters have changed, discarding old grid file")
	close (u); return
	end if
	read (u, *)
	call integration_results_read (results_file, u)
	if (check .and. .not. integration_results_iterations_are_consistent &
	(results_file, pass, n_calls)) then
	call msg_message &
	("Iteration parameters have changed, discarding old grid file")
	close (u); return
	end if
	results = results_file
	read (u, *)
	call vamp_read_grids (grids, u)
	close (u)
	ok = .true.
	end subroutine read_grid_file

	@ %def read_grid_file
	@ Write the grid that has the optimal parameters so far, within the
	current integration pass. This is determined from the current
	integration results. If the best grid is not the current one, we do
	nothing.
	<<XXX Processes: procedures>>=
	subroutine write_best_grid_file (filename, process_id, md5sum, &
	grid_parameters, results, grids)
	type(string_t), intent(in) :: filename, process_id
	type(md5sum_grids_t), intent(in) :: md5sum
	type(grid_parameters_t), intent(in) :: grid_parameters
	type(integration_results_t), intent(in) :: results
	type(vamp_grids), intent(in) :: grids
	type(vamp_grids) :: grids_on_file
	type(integration_results_t) :: results_on_file
	integer :: it_current, it_best
	logical :: ok
	integer :: u
	it_current = integration_results_get_current_it (results)
	it_best = integration_results_get_best_it (results)
	if (it_best == it_current) then
	call write_grid_file (filename, process_id, md5sum, &
	grid_parameters, results, grids)
	end if
	end subroutine write_best_grid_file

	@ %def write_best_grid_file
	@ Store the pass and calls arrays that are currently active. They are
	checked when grid files are re-read for event generation.
	<<XXX Processes: public>>=
	public :: process_store_iteration_parameters
	<<XXX Processes: procedures>>=
	subroutine process_store_iteration_parameters &
	(process, pass_array, n_calls_array)
	type(process_t), intent(inout) :: process
	integer, dimension(:), intent(in) :: pass_array, n_calls_array
	allocate (process%pass_array (size (pass_array)))
	process%pass_array = pass_array
	allocate (process%n_calls_array (size (n_calls_array)))
	process%n_calls_array = n_calls_array
	end subroutine process_store_iteration_parameters

	@ %def process_store_iteration_parameters
	@ Wrapper for grid file reading. We supplement the MD5 sum block with extra
	entries that we can determine from the process object.
	<<XXX Processes: public>>=
	public :: process_read_grid_file
	<<XXX Processes: procedures>>=
	subroutine process_read_grid_file (process, filename, &
	check_grid_file, md5sum, grid_parameters, pass, n_calls, ok)
	type(process_t), intent(inout) :: process
	type(string_t), intent(in) :: filename
	logical, intent(in) :: check_grid_file
	type(md5sum_grids_t), intent(in) :: md5sum
	type(grid_parameters_t), intent(in) :: grid_parameters
	integer, dimension(:), intent(in) :: pass, n_calls
	logical, intent(out) :: ok
	type(md5sum_grids_t) :: md5sum_local
	md5sum_local = process_collect_md5sum (process, md5sum)
	call read_grid_file (filename, process%id, &
	check_grid_file, md5sum_local, grid_parameters, &
	process%results, process%grids, pass, n_calls, ok)
	end subroutine process_read_grid_file

	@ %def process_read_grid_file
	@ Adapt the binning of the VAMP grids. This is just a wrapper.
	<<XXX Processes: procedures>>=
	subroutine process_adapt_grids (process)
	type(process_t), intent(inout), target :: process
	call vamp_refine_grids (process%grids)
	end subroutine process_adapt_grids

	@ %def process_adapt_grids
	@ Refine the channel weights. We use a power weight just as for the
	individual bins. The results are averaged within each grove. Then,
	we check if the resulting weights would lead to a too small number of
	calls within any channel, which is corrected. The result is fed into
	VAMP.
	<<XXX Processes: procedures>>=
	subroutine process_adapt_channel_weights (process, grid_parameters, calls)
	type(process_t), intent(inout), target :: process
	type(grid_parameters_t), intent(in) :: grid_parameters
	integer, intent(in) :: calls
	real(default), dimension(:), allocatable :: weights
	integer :: g, i0, i1, n
	real(default) :: sum_weights, weight_min
	logical, dimension(:), allocatable :: weight_underflow
	real(default) :: sum_weight_underflow
	integer :: n_underflow
	allocate (weights (process%n_channels))
	weights = process%grids%weights &
	* vamp_get_variance (process%grids%grids) &
	** grid_parameters%channel_weights_power
	do g = 1, phs_forest_get_n_groves (process%kinematics_in(1)%forest)
	call phs_forest_get_grove_bounds ( &
	process%kinematics_in(1)%forest, g, i0, i1, n)
	weights(i0:i1) = sum (weights(i0:i1)) / n
	end do
	sum_weights = sum (weights)
	if (sum_weights /= 0) then
	weights = weights / sum (weights)
	if (grid_parameters%threshold_calls /= 0) then
	weight_min = &
	real (grid_parameters%threshold_calls, default) &
	/ calls
	allocate (weight_underflow (process%n_channels))
	weight_underflow = weights /= 0 .and. weights < weight_min
	n_underflow = count (weight_underflow)
	sum_weight_underflow = sum (weights, mask=weight_underflow)
	where (weight_underflow)
	weights = weight_min
	elsewhere
	weights = weights &
	* (1 - n_underflow * weight_min) / (1 - sum_weight_underflow)
	end where
	end if
	call vamp_update_weights (process%grids, weights)
	end if
	end subroutine process_adapt_channel_weights

	@ %def process_adapt_channel_weights
	@ Return a concise table of channel weights: sum over all channels that
	contribute to a grove and return the grove weights.
	<<XXX Processes: procedures>>=
	subroutine process_get_grove_weights (process, grove_weight)
	type(process_t), intent(in) :: process
	real(default), dimension(:), allocatable, intent(out) :: grove_weight
	integer :: n_groves, g, i0, i1, n
	n_groves = phs_forest_get_n_groves (process%kinematics_in(1)%forest)
	allocate (grove_weight (n_groves))
	do g = 1, n_groves
	call phs_forest_get_grove_bounds (process%kinematics_in(1)%forest, &
	g, i0, i1, n)
	grove_weight(g) = sum (process%grids%weights(i0:i1))
	end do
	end subroutine process_get_grove_weights

	@ %def process_get_grove_weights
	@
	\subsection{Event generation}
	Initialize event generation. For the process setup, this means that
	the evaluators for the exclusive matrix element with and without
	color-flow decomposition is activated.

	For the hard-interaction evaluators, we select only those entries
	which are supported by the beam/structure function setup. E.g., we
	select diagonal helicity only, or sum over helicity if the beams are
	unpolarized. When constructing the process evaluators, we multiply
	the beams by the hard-interaction evaluators and trace over all
	incoming-particle quantum numbers (except for color in the color-flow
	evaluator).
	<<XXX Processes: public>>=
	public :: process_setup_event_generation
	<<XXX Processes: procedures>>=
	subroutine process_setup_event_generation (process, qn_mask_in)
	type(process_t), intent(inout), target :: process
	type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_in
	integer, dimension(:), allocatable :: coll_index
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
	type(quantum_numbers_mask_t) :: mask_conn_sqme, mask_conn_flows
	type(evaluator_t), pointer :: eval_sqme, eval_flows
	type(interaction_t), pointer :: int_hi
	integer :: n_in, n_out, n_tot, i, j
	type(evaluator_t), target :: eval_con
	logical :: has_sqme, has_flows
	if (.not. process_has_matrix_element (process)) then
	call msg_warning ("Process '" // char (process%id) // "': " &
	// "matrix element vanishes, no events can be generated")
	return
	end if
	has_sqme = core_interaction_has_eval_sqme (process%ci)
	has_flows = core_interaction_has_eval_flows (process%ci)
	if (.not. has_sqme) call msg_bug ("event generation for " &
	// char (core_interaction_type_description ( &
	core_interaction_get_type (process%ci))) &
	// " is not supported yet")
	call process_status_reset_counters (process%status)
	n_in = core_interaction_get_n_in(process%ci)
	n_out = core_interaction_get_n_out_eff (process%ci)
	n_tot = core_interaction_get_n_tot_eff (process%ci)
	allocate (mask_in (n_in))
	if (process%use_beams) then
	allocate (coll_index (n_in))
	coll_index = strfun_chain_get_colliding_particles (process%sfchain)
	mask_in = strfun_chain_get_colliding_particles_mask (process%sfchain)
	mask_conn_sqme = new_quantum_numbers_mask (.false., .true., .true.)
	mask_conn_flows = new_quantum_numbers_mask (.false., .false., .true.)
	else if (present (qn_mask_in)) then
	mask_in = qn_mask_in
	else
	mask_in = new_quantum_numbers_mask (.false., .false., .true.)
	end if
	if (has_sqme) then
	call core_interaction_final_sqme (process%ci)
	call core_interaction_init_sqme (process%ci, mask_in, &
	process%use_hi_color_factors)
	call interaction_get_diagonal_entries (evaluator_get_int_ptr ( &
	core_interaction_get_eval_sqme_ptr (process%ci, 1)), &
	process%sqme_diagonal_entries)
	end if
	if (has_flows) then
	call core_interaction_final_flows (process%ci)
	call core_interaction_init_flows (process%ci, mask_in)
	end if
	do i = 1, process%n_kinematics_out
	int_hi => core_interaction_get_int_ptr (process%ci, i)
	call interaction_reset_momenta (int_hi)
	if (has_sqme) then
	call evaluator_final (process%kinematics_out(i)%eval_sqme)
	if (process%use_beams) then
	eval_sqme => core_interaction_get_eval_sqme_ptr (process%ci, i)
	do j = 1, n_in
	call evaluator_set_source_link (eval_sqme, j, &
	process%kinematics_out(i)%strfun, coll_index(j))
	end do
	if (process%has_extra_evaluators) &
	call evaluator_init_product (process%kinematics_out(i)%eval_sqme, &
	process%kinematics_out(i)%strfun, eval_sqme, mask_conn_sqme)
	end if
	end if
	if (has_flows) then
	call evaluator_final (process%kinematics_out(i)%eval_beam_flows)
	call evaluator_final (process%kinematics_out(i)%eval_flows)
	if (process%use_beams) then
	eval_flows => core_interaction_get_eval_flows_ptr (process%ci, i)
	call evaluator_init_color_contractions ( &
	process%kinematics_out(i)%eval_beam_flows, &
	process%kinematics_out(i)%strfun)
	do j = 1, n_in
	call evaluator_set_source_link (eval_flows, j, &
	process%kinematics_out(i)%eval_beam_flows, coll_index(j))
	end do
	if (process%has_extra_evaluators) &
	call evaluator_init_product (process%kinematics_out(i)%eval_flows, &
	process%kinematics_out(i)%eval_beam_flows, eval_flows, mask_conn_flows)
	end if
	end if
	end do
	end subroutine process_setup_event_generation

	@ %def process_setup_event_generation
	@ Generate a weighted event. We have to select a channel. The output
	is the event weight, unmodified. The [[sample_function]] fully
	constructs the event in the [[process]] object, so the output [[x]]
	array is not needed.

	Analysis is not yet implemented; we need a means to pass the event
	weight to the recording functions.
	<<XXX Processes: public>>=
	public :: process_generate_weighted_event
	<<XXX Processes: procedures>>=
	subroutine process_generate_weighted_event (process, rng, weight)
	type(process_t), intent(inout), target :: process
	type(tao_random_state), intent(inout) :: rng
	real(default), intent(out) :: weight
	real(default), dimension(process%n_par) :: x
	call vamp_next_event &
	(x, rng, process%grids, &
	sample_function, process%store_index, phi_trivial, &
	weight=weight)
	call process_complete_evaluators (process)
	end subroutine process_generate_weighted_event

	@ %def process_generate_weighted_event
	@ Generate an unweighted event. Rejection is done by \vamp. The
	optional [[excess]] is nonzero by the excess weight if an event weight
	exceeds the precalculated maximum that is used for rejection. After
	the event has been generated, it can be analyzed.

	The transformation function [[phi]] is trivial but has to be supplied.
	<<XXX Processes: public>>=
	public :: process_generate_unweighted_event
	<<XXX Processes: procedures>>=
	subroutine process_generate_unweighted_event (process, rng, excess)
	type(process_t), intent(inout), target :: process
	type(tao_random_state), intent(inout) :: rng
	real(default), intent(out), optional :: excess
	real(default), dimension(process%n_par) :: x
	call vamp_next_event &
	(x, rng, process%grids, &
	sample_function, process%store_index, phi_trivial, &
	excess=excess)
	call process_complete_evaluators (process)
	end subroutine process_generate_unweighted_event

	function phi_trivial (xi, channel_dummy) result (x)
	real(default), dimension(:), intent(in) :: xi
	integer, intent(in) :: channel_dummy
	real(default), dimension(size(xi)) :: x
	x = xi
	end function phi_trivial

	@ %def process_generate_unweighted_event
	@ Complete the event: compute amplitudes/probabilities for exclusive
	quantum numbers.
	<<XXX Processes: public>>=
	public :: process_complete_evaluators
	<<XXX Processes: procedures>>=
	subroutine process_complete_evaluators (process)
	type(process_t), intent(inout), target :: process
	integer :: i
	if (process%use_beams) then
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	call evaluator_receive_momenta ( &
	process%kinematics_out(i)%eval_beam_flows)
	call evaluator_evaluate ( &
	process%kinematics_out(i)%eval_beam_flows)
	end do
	end if
	call core_interaction_evaluate_sqme (process%ci)
	call core_interaction_evaluate_flows (process%ci)
	if (process%has_extra_evaluators) then
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	call evaluator_receive_momenta ( &
	process%kinematics_out(i)%eval_sqme)
	call evaluator_receive_momenta ( &
	process%kinematics_out(i)%eval_flows)
	call evaluator_evaluate ( &
	process%kinematics_out(i)%eval_sqme)
	call evaluator_evaluate ( &
	process%kinematics_out(i)%eval_flows)
	end do
	end if
	end subroutine process_complete_evaluators

	@ %def process_complete_evaluators
	@ This procedure is used for checking whether some of the final-state
	particles can initiate decay cascades.
	<<XXX Processes: public>>=
	public :: process_get_unstable_products
	<<XXX Processes: procedures>>=
	subroutine process_get_unstable_products (process, flv_unstable)
	type(process_t), intent(in) :: process
	type(flavor_t), dimension(:), intent(out), allocatable :: flv_unstable
	call core_interaction_get_unstable_products (process%ci, flv_unstable)
	end subroutine process_get_unstable_products

	@ %def process_get_unstable_products
	@ When the event is generated externally (e.g., read from file), we
	need to fill the subevent with the process record in order to
	analyze it. This is done here:
	<<XXX Processes: public>>=
	public :: process_set_particles
	<<XXX Processes: procedures>>=
	subroutine process_set_particles (process, particle_set)
	type(process_t), intent(inout) :: process
	type(particle_set_t), intent(in) :: particle_set
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"reading events is not yet implemented for subtraction kinematics")
	call particle_set_to_subevt (particle_set, process%kinematics_out(1)%subevt)
	end subroutine process_set_particles

	@ %def process_set_particles
	@
	\subsection{Results output}
	<<XXX Processes: public>>=
	public :: process_results_write_header
	public :: process_results_write_entry
	public :: process_results_write_current
	public :: process_results_write_average
	public :: process_results_write_current_average
	public :: process_results_write_footer
	public :: process_results_write
	<<XXX Processes: procedures>>=
	subroutine process_results_write_header (process, unit, logfile)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: logfile
	call write_dline (unit)
	call write_header (process%type, unit, logfile)
	call write_dline (unit)
	end subroutine process_results_write_header

	subroutine process_results_write_entry (process, it, unit)
	type(process_t), intent(in) :: process
	integer, intent(in) :: it
	integer, intent(in), optional :: unit
	call integration_results_write_entry (process%results, it, unit)
	end subroutine process_results_write_entry

	subroutine process_results_write_current (process, unit)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	call integration_results_write_current (process%results, unit)
	end subroutine process_results_write_current

	subroutine process_results_write_average (process, pass, unit)
	type(process_t), intent(in) :: process
	integer, intent(in) :: pass
	integer, intent(in), optional :: unit
	call write_hline (unit)
	call integration_results_write_average (process%results, pass, unit)
	call write_hline (unit)
	end subroutine process_results_write_average

	subroutine process_results_write_current_average (process, unit)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	call write_hline (unit)
	call integration_results_write_current_average (process%results, unit)
	call write_hline (unit)
	end subroutine process_results_write_current_average

	subroutine process_results_write_footer (process, unit, no_line)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: no_line
	if (present (no_line)) then
	if (.not. no_line) call write_dline (unit)
	else
	call write_dline (unit)
	end if
	call integration_results_write_current_average (process%results, unit)
	call write_dline (unit)
	end subroutine process_results_write_footer

	subroutine process_results_write (process, unit)
	type(process_t), intent(in) :: process
	integer, intent(in), optional :: unit
	call integration_results_write (process%results, unit)
	end subroutine process_results_write

	@ %def process_results_write
	@ Record the integration results in the process library entry.
	<<XXX Processes: public>>=
	public :: process_record_integral
	<<XXX Processes: procedures>>=
	subroutine process_record_integral (process, var_list)
	type(process_t), intent(inout) :: process
	type(var_list_t), intent(inout) :: var_list
	integer :: n_calls
	real(default) :: integral, error, accuracy, chi2, efficiency
	n_calls = integration_results_get_n_calls (process%results)
	integral = integration_results_get_integral (process%results)
	error = integration_results_get_error (process%results)
	accuracy = integration_results_get_accuracy (process%results)
	chi2 = integration_results_get_chi2 (process%results)
	efficiency = integration_results_get_efficiency (process%results)
	call var_list_init_process_results (var_list, process%id, &
	n_calls, integral, error, accuracy, chi2, efficiency)
	end subroutine process_record_integral

	@ %def process_record_integral
	@
	\subsection{Copies}
	Process copies are used for decay chains (and such). We deep-copy
	most components, in particular the hard-interaction and decay-forest
	workspaces. Read-only components (variable list) and eval trees are
	transferred as shallow copies.

	We do not copy the extra evaluators that convolute beams and hard
	matrix elements. Actually, beams should not be defined for a cascade
	decay process in the first place, but we do not enforce this.
	We also skip the integration results.

	Furthermore, we have to reassign all external links between interactions
	within the process copy to point to the copy, not the original.

	The copy is linked to the original by a pointer. Its initial state is
	[[in_use]].

	Copies of processes with nontrivial (subtraction) kinematics are currenly
	disabled, although most of the infrastructure should be in place.
	<<XXX Processes: procedures>>=
	subroutine process_make_copy (process, original)
	type(process_t), intent(inout), target :: process
	type(process_t), intent(in), target :: original
	type(process_t), pointer :: copy
	type(interaction_t), pointer :: copy_beam_int, strfun_int, copy_strfun_int
	type(interaction_t), pointer :: hi_int, copy_hi_int
	type(evaluator_t), pointer :: hi_eval_trace, copy_hi_eval_trace
	type(evaluator_t), pointer :: hi_eval_sqme, copy_hi_eval_sqme
	type(evaluator_t), pointer :: hi_eval_flows, copy_hi_eval_flows
	integer :: i
	if (.not. process%trivial_kinematics) call msg_bug ( &
	"copies of processes with subtraction kinematics are not implemented yet")
	if (process%type /= PRC_DECAY) call msg_bug ( &
	"copies of scattering processes are not implemented")
	allocate (copy)
	copy%type = original%type
	copy%is_original = .false.
	copy%original => original
	copy%initialized = original%initialized
	copy%has_matrix_element = original%has_matrix_element
	copy%use_hi_color_factors = original%use_hi_color_factors
	copy%use_beams = original%use_beams
	copy%has_extra_evaluators = .false.
	copy%beams_are_set = original%beams_are_set
	copy%is_cascade_decay = original%is_cascade_decay
	copy%id = original%id
	copy%prc_lib => original%prc_lib
	copy%lib_index = original%lib_index
	copy%store_index = original%store_index
	copy%model => original%model
	if (original%use_beams) then
	copy%n_strfun = original%n_strfun
	copy%n_par_strfun = original%n_par_strfun
	end if
	copy%n_par_phs = original%n_par_phs
	copy%n_par_ci = original%n_par_ci
	copy%n_par = original%n_par
	copy%azimuthal_dependence = original%azimuthal_dependence
	copy%vamp_grids_defined = original%vamp_grids_defined
	copy%sqrts_known = original%sqrts_known
	copy%sqrts = original%sqrts
	if (original%use_beams) then
	if (allocated (original%x_strfun)) &
	allocate (copy%x_strfun (size (original%x_strfun)))
	end if
	if (allocated (original%x_ci)) allocate (copy%x_ci ( &
	size (original%x_ci)))
	if (allocated (original%x_phs)) &
	allocate (copy%x_phs (size (original%x_phs)))
	copy%n_channels = original%n_channels
	!!! Previous version
	! if (allocated (original%x)) &
	! allocate (copy%x (size (original%x, 1), size (original%x, 2)))
	! if (allocated (original%sf_factor)) &
	! allocate (copy%sf_factor (size (original%sf_factor)))
	! if (allocated (original%phs_factor)) &
	! allocate (copy%phs_factor (size (original%phs_factor)))
	if (allocated (original%mass_in)) then
	allocate (copy%mass_in (size (original%mass_in)))
	copy%mass_in = original%mass_in
	end if
	copy%averaging_factor = original%averaging_factor
	copy%ci = original%ci
	copy%vamp_eq = original%vamp_eq
	allocate (copy%j_beam (size (original%j_beam)))
	copy%j_beam = original%j_beam
	allocate (copy%j_in (size (original%j_in)))
	copy%j_in = original%j_in
	allocate (copy%j_out (size (original%j_out)))
	copy%j_out = original%j_out
	copy%var_list = original%var_list
	copy%cut_pn => original%cut_pn
	copy%weight_pn => original%weight_pn
	copy%scale_pn => original%scale_pn
	copy%fac_scale_pn => original%fac_scale_pn
	copy%ren_scale_pn => original%ren_scale_pn
	if (allocated (original%active_channel)) then
	allocate (copy%active_channel (size (original%active_channel)))
	copy%active_channel = original%active_channel
	end if
	copy%filename_current_grid = original%filename_current_grid
	copy%filename_best_grid = original%filename_best_grid
	copy%md5sum_grids = original%md5sum_grids
	copy%grid_parameters = original%grid_parameters
	if (allocated (original%pass_array)) then
	allocate (copy%pass_array (size (original%pass_array)))
	copy%pass_array = original%pass_array
	end if
	if (allocated (original%n_calls_array)) then
	allocate (copy%n_calls_array (size (original%n_calls_array)))
	copy%n_calls_array = original%n_calls_array
	end if
	call vamp_copy_grids (copy%grids, original%grids)
	copy%n_kinematics_in = original%n_kinematics_in
	copy%n_kinematics_out = original%n_kinematics_out
	allocate (copy%kinematics_in(copy%n_kinematics_in))
	allocate (copy%kinematics_out(copy%n_kinematics_out))
	do i = 1, original%n_kinematics_in
	copy%kinematics_in(i)%forest = original%kinematics_in(i)%forest
	if (allocated (original%kinematics_in(i)%x)) &
	allocate (copy%kinematics_in(i)%x( &
	size (original%kinematics_in(i)%x, dim=1), &
	size (original%kinematics_in(i)%x, dim=2)))
	if (allocated (original%kinematics_in(i)%phs_factor)) &
	allocate (copy%kinematics_in(i)%phs_factor( &
	size (original%kinematics_in(i)%phs_factor)))
	end do
	if (original%use_beams) copy%sfchain = original%sfchain
	copy_beam_int => strfun_chain_get_beam_int_ptr (copy%sfchain)
	do i = 1, original%n_kinematics_out
	copy%kinematics_out(i)%subevt = original%kinematics_out(i)%subevt
	copy%kinematics_out(i)%cut_expr = original%kinematics_out(i)%cut_expr
	copy%kinematics_out(i)%scale_expr = original%kinematics_out(i)%scale_expr
	copy%kinematics_out(i)%fac_scale_expr = &
	original%kinematics_out(i)%fac_scale_expr
	copy%kinematics_out(i)%ren_scale_expr = &
	original%kinematics_out(i)%ren_scale_expr
	copy%kinematics_out(i)%reweighting_expr = &
	original%kinematics_out(i)%reweighting_expr
	if (i > 1) then
	call evaluator_init_identity (copy%kinematics_out(i)%strfun_snapshot, &
	copy_beam_int)
	copy%kinematics_out(i)%strfun => evaluator_get_int_ptr ( &
	copy%kinematics_out(i)%strfun_snapshot)
	else
	copy%kinematics_out(i)%strfun => copy_beam_int
	end if
	if (original%use_beams) copy%kinematics_out(i)%eval_trace = &
	original%kinematics_out(i)%eval_trace
	strfun_int => original%kinematics_out(i)%strfun
	copy_strfun_int => copy%kinematics_out(i)%strfun
	hi_int => core_interaction_get_int_ptr (original%ci, i)
	hi_eval_trace => core_interaction_get_eval_trace_ptr (original%ci, i)
	hi_eval_sqme => core_interaction_get_eval_sqme_ptr (original%ci, i)
	hi_eval_flows => core_interaction_get_eval_flows_ptr (original%ci, i)
	copy_hi_int => core_interaction_get_int_ptr (copy%ci, i)
	copy_hi_eval_trace => core_interaction_get_eval_trace_ptr (copy%ci, i)
	copy_hi_eval_sqme => core_interaction_get_eval_sqme_ptr (copy%ci, i)
	copy_hi_eval_flows => core_interaction_get_eval_flows_ptr (copy%ci, i)
	call interaction_reassign_links &
	(copy_hi_int, strfun_int, copy_strfun_int)
	call evaluator_reassign_links &
	(copy_hi_eval_trace, strfun_int, copy_strfun_int)
	call evaluator_reassign_links &
	(copy_hi_eval_sqme, strfun_int, copy_strfun_int)
	call evaluator_reassign_links &
	(copy_hi_eval_flows, strfun_int, copy_strfun_int)
	call evaluator_reassign_links &
	(copy_hi_eval_trace, hi_int, copy_hi_int)
	call evaluator_reassign_links &
	(copy_hi_eval_sqme, hi_int, copy_hi_int)
	call evaluator_reassign_links &
	(copy_hi_eval_flows, hi_int, copy_hi_int)
	call evaluator_reassign_links &
	(copy%kinematics_out(i)%eval_trace, strfun_int, copy_strfun_int)
	! call evaluator_reassign_links &
	! (copy%kinematics_out(i)%eval_sqme, strfun_int, copy_strfun_int)
	! call evaluator_reassign_links &
	! (copy%kinematics_out(i)%eval_flows, strfun_int, copy_strfun_int)
	call evaluator_reassign_links &
	(copy%kinematics_out(i)%eval_trace, hi_eval_trace, copy_hi_eval_trace)
	! call evaluator_reassign_links &
	! (copy%kinematics_out(i)%eval_sqme, hi_eval_sqme, copy_hi_eval_sqme)
	! call evaluator_reassign_links &
	! (copy%kinematics_out(i)%eval_flows, hi_eval_flows, copy_hi_eval_flows)
	end do
	copy%trivial_kinematics = original%trivial_kinematics
	if (allocated (original%flv_in)) then
	allocate (copy%flv_in(size (original%flv_in)))
	copy%flv_in = original%flv_in
	end if
	if (allocated (original%flv_out_eff)) then
	allocate (copy%flv_out_eff(size (original%flv_out_eff)))
	copy%flv_out_eff = original%flv_out_eff
	end if
	if (allocated (original%flv_out_real)) then
	allocate (copy%flv_out_real(size (original%flv_out_real)))
	copy%flv_out_real = original%flv_out_real
	end if
	if (allocated (original%sqme_diagonal_entries)) then
	allocate (copy%sqme_diagonal_entries( &
	size (original%sqme_diagonal_entries)))
	copy%sqme_diagonal_entries = copy%sqme_diagonal_entries
	end if
	process%copy => copy
	end subroutine process_make_copy

	@ %def process_make_copy
	@ Request a process copy. If there is a copy currently not in use,
	activate it. Otherwise, make a new copy. In the original process,
	point to this copy as the working copy.
	<<XXX Processes: public>>=
	public :: process_request_copy
	<<XXX Processes: procedures>>=
	recursive subroutine process_request_copy (process, copy, original)
	type(process_t), intent(inout), target :: process
	type(process_t), pointer :: copy
	type(process_t), intent(inout), target, optional :: original
	if (associated (process%copy)) then
	if (process%copy%in_use) then
	if (present (original)) then
	call process_request_copy (process%copy, copy, original)
	else
	call process_request_copy (process%copy, copy, process)
	end if
	else
	copy => process%copy
	copy%in_use = .true.
	if (present (original)) then
	original%working_copy => copy
	else
	process%working_copy => copy
	end if
	end if
	else
	if (present (original)) then
	call process_make_copy (process, original)
	else
	call process_make_copy (process, original=process)
	end if
	copy => process%copy
	copy%in_use = .true.
	if (present (original)) then
	original%working_copy => copy
	else
	process%working_copy => copy
	end if
	end if
	end subroutine process_request_copy

	@ %def process_request_copy
	@ Return the working copy of a process. If there is none, return the
	process itself.
	<<XXX Processes: procedures>>=
	function process_get_working_copy_ptr (process) result (copy)
	type(process_t), intent(in), target :: process
	type(process_t), pointer :: copy
	if (associated (process%working_copy)) then
	copy => process%working_copy
	else
	copy => process
	end if
	end function process_get_working_copy_ptr

	@ %def process_get_working_copy_ptr
	@ Tag a given process copy as the working copy. When looking for the working
	copy, a pointer to this one will be returned.
	<<XXX Processes: public>>=
	public :: process_tag_as_working_copy
	<<XXX Processes: procedures>>=
	subroutine process_tag_as_working_copy (process)
	type(process_t), intent(inout), target :: process
	type(process_t), pointer :: original
	if (associated (process%original)) then
	original => process%original
	original%working_copy => process
	else
	call msg_bug ("Process tag as working copy failed")
	end if
	end subroutine process_tag_as_working_copy

	@ %def process_tag_as_working_copy
	@ Mark this copy of the current process as not in use, so it can be
	requested again. (Use with care! The copy will not reflect changes made to
	the original process.)
	<<XXX Processes: public>>=
	public :: process_free_copy
	<<XXX Processes: procedures>>=
	subroutine process_free_copy (process)
	type(process_t), intent(inout), target :: process
	process%in_use = .false.
	if (associated (process%original)) then
	process%original%working_copy => null ()
	end if
	end subroutine process_free_copy

	@ %def process_free_copy
	@ Delete all copies.
	<<Process: public>>=
	public :: process_delete_copy
	<<XXX Processes: procedures>>=
	recursive subroutine process_delete_copies (process)
	type(process_t), intent(inout), target :: process
	if (associated (process%copy)) then
	call process_final (process%copy)
	deallocate (process%copy)
	end if
	end subroutine process_delete_copies

	@ %def process_delete_copies
	@
	\subsection{Process store}
	The process store is a container for the list of all processes. The
	list is expanded as needed during program execution. The container is
	implemented as a module variable. Thus, there is only one process
	store in the program.

	The reason for this is the sampling function, which needs to access it
	without referencing it as an argument. Instead, it takes an integer
	argument which identifies the process. For direct access, we maintain
	a process pointer array as a shortcut to the list.
	\subsubsection{Type and object}
	<<XXX Processes: types>>=
	type :: process_entry_t
	type(process_t) :: process
	type(process_entry_t), pointer :: next => null ()
	end type process_entry_t

	@ %def process_entry_t
	<<XXX Processes: types>>=
	type :: process_store_t
	integer :: n = 0
	type(process_entry_t), pointer :: first => null ()
	type(process_entry_t), pointer :: last => null ()
	type(process_p), dimension(:), allocatable :: proc
	end type process_store_t

	@ %def process_store_t
	<<XXX Processes: variables>>=
	type(process_store_t), save :: store

	@ %def process_store
	@ Finalize. Delete the list explicitly, the pointer array is just
	deallocated.
	<<XXX Processes: public>>=
	public :: process_store_final
	<<XXX Processes: procedures>>=
	subroutine process_store_final ()
	type(process_entry_t), pointer :: current
	if (allocated (store%proc)) deallocate (store%proc)
	store%last => null ()
	do while (associated (store%first))
	current => store%first
	store%first => current%next
	call process_final (current%process)
	deallocate (current)
	end do
	store%n = 0
	end subroutine process_store_final

	@ %def process_store_final
	@ Handlers for unloading and reloading process libraries
	<<XXX Processes: public>>=
	public :: process_store_unload
	public :: process_store_reload
	<<XXX Processes: procedures>>=
	subroutine process_store_unload (libname)
	type(string_t), intent(in) :: libname
	type(process_entry_t), pointer :: entry
	entry => store%first
	do while (associated (entry))
	if (process_library_get_name (entry%process%prc_lib) == libname) &
	call worker (entry%process)
	entry => entry%next
	end do

	contains

	recursive subroutine worker (process)
	type(process_t), intent(inout), target :: process
	call core_interaction_unload (process%ci)
	if (associated (process%copy)) call worker (process%copy)
	end subroutine worker

	end subroutine process_store_unload

	subroutine process_store_reload (libname)
	type(string_t), intent(in) :: libname
	type(process_entry_t), pointer :: entry
	entry => store%first
	do while (associated (entry))
	if (process_library_get_name (entry%process%prc_lib) == libname) &
	call worker (entry%process)
	entry => entry%next
	end do

	contains

	recursive subroutine worker (process)
	type(process_t), intent(inout), target :: process
	call core_interaction_reload (process%ci, process%prc_lib)
	if (associated (process%copy)) call worker (process%copy)
	end subroutine worker

	end subroutine process_store_reload

	@ %def process_store_unload
	@ %def process_store_reaload
	@ Write all contents. This produces lots of output.
	<<XXX Processes: public>>=
	public :: process_store_write
	<<XXX Processes: procedures>>=
	subroutine process_store_write (unit)
	integer, intent(in), optional :: unit
	type(process_t), pointer :: process
	integer :: u, i
	u = output_unit (unit); if (u < 0) return
	write (u, *) repeat ("%", 78)
	write (u, *) "Process store contents"
	do i = 1, store%n
	write (u, *) repeat ("%", 78)
	write (u, *) "Process No.", i
	process => store%proc(i)%ptr
	call process_write (process, unit)
	end do
	write (u, *) "Process store end"
	write (u, *) repeat ("%", 78)
	end subroutine process_store_write

	@ %def process_store_write
	@ Write integration results (summary)
	<<XXX Processes: public>>=
	public :: process_store_write_results
	<<XXX Processes: procedures>>=
	subroutine process_store_write_results (unit)
	integer, intent(in), optional :: unit
	type(process_t), pointer :: process
	type(string_t), dimension(:), allocatable :: process_id
	real(default), dimension(:), allocatable :: integral, error
	type(string_t), dimension(:), allocatable :: phys_unit
	integer :: u, i, process_id_len
	character(12) :: fmt
	u = output_unit (unit); if (u < 0) return
	allocate (process_id (store%n), phys_unit (store%n))
	allocate (integral (store%n), error (store%n))
	do i = 1, store%n
	process => store%proc(i)%ptr
	if (process%initialized) then
	process_id(i) = process%id
	integral(i) = process_get_integral (process)
	error(i) = process_get_error (process)
	select case (process%type)
	case (PRC_DECAY); phys_unit(i) = "GeV"
	case (PRC_SCATTERING); phys_unit(i) = "fb"
	case default; phys_unit(i) = "[undefined]"
	end select
	else
	process_id(i) = ""
	end if
	end do
	write (u, "(A)") "\|========================= Results Summary =========================\|"
	if (store%n == 0) then
	write (u, *) "[empty]"
	else
	process_id_len = maxval (len (process_id))
	write (fmt, "(A,I0,A)") "(1x,A", process_id_len + 1, ")"
	do i = 1, store%n
	if (process_id(i) /= "") then
	write (u, fmt, advance="no") char (process_id(i)) // ":"
	write (u, "(1x, 1PE15.8, 1x, '+-', 1x, 1PE8.2)", advance="no") &
	integral(i), error(i)
	write (u, "(1x, A)") char (phys_unit(i))
	end if
	end do
	end if
	write (u, "(A)") "\|=============================================================================\|"
	end subroutine process_store_write_results

	@ %def process_store_write_results
	@
	\subsubsection{Accessing contents}
	Return the current number of processes.
	<<XXX Processes: procedures>>=
	function process_store_get_n_processes () result (n)
	integer :: n
	n = store%n
	end function process_store_get_n_processes

	@ %def process_store_get_n_processes
	@ Return a pointer to the process entry with given ID. If it does not
	exist, return a null pointer.
	<<XXX Processes: procedures>>=
	function process_store_get_entry_ptr (process_id) result (entry)
	type(process_entry_t), pointer :: entry
	type(string_t), intent(in) :: process_id
	entry => store%first
	do while (associated (entry))
	if (entry%process%id == process_id) exit
	entry => entry%next
	end do
	end function process_store_get_entry_ptr

	@ %def process_store_get_entry_ptr
	@ Return the index of the process entry with given ID within the
	process store. If it does not exist, return zero.
	<<XXX Processes: procedures>>=
	function process_store_get_process_index (process_id) result (process_index)
	integer :: process_index
	type(string_t), intent(in) :: process_id
	type(process_entry_t), pointer :: entry
	entry => process_store_get_entry_ptr (process_id)
	if (associated (entry)) then
	process_index = entry%process%store_index
	else
	process_index = 0
	end if
	end function process_store_get_process_index

	@ %def process_store_get_process_index
	@ Return a pointer to the process with index [[i]] or alphanumeric ID.
	<<XXX Processes: public>>=
	public :: process_store_get_process_ptr
	<<XXX Processes: interfaces>>=
	interface process_store_get_process_ptr
	module procedure process_store_get_process_ptr_int
	module procedure process_store_get_process_ptr_id
	end interface

	<<XXX Processes: procedures>>=
	function process_store_get_process_ptr_int (i) result (process)
	type(process_t), pointer :: process
	integer, intent(in) :: i
	if (i > 0 .and. i <= size (store%proc)) then
	process => store%proc(i)%ptr
	else
	process => null ()
	end if
	end function process_store_get_process_ptr_int

	function process_store_get_process_ptr_id (id) result (process)
	type(process_t), pointer :: process
	type(string_t), intent(in) :: id
	integer :: i
	do i = 1, store%n
	process => store%proc(i)%ptr
	if (process%id == id) return
	end do
	process => null ()
	end function process_store_get_process_ptr_id

	@ %def process_store_get_process_ptr
	@
	\subsubsection{Filling the process store}
	Append a new process entry and return a pointer to it, unless the
	process already exists. If the process exists, finalize it and return
	the pointer for fresh initialization. If it does not exist, allocate
	a new entry and update the shortcut array. If the latter is full,
	expand by a fixed block size.
	<<XXX Processes: procedures>>=
	function process_store_get_fresh_process_ptr (process_id) result (process)
	type(process_t), pointer :: process
	type(string_t), intent(in) :: process_id
	type(process_entry_t), pointer :: current, entry
	integer :: i
	integer, parameter :: BLOCK_SIZE = 10
	current => process_store_get_entry_ptr (process_id)
	if (associated (current)) then
	call process_final (current%process)
	else
	allocate (current)
	if (store%n == 0) then
	allocate (store%proc (BLOCK_SIZE))
	store%first => current
	else
	store%last%next => current
	end if
	store%last => current
	store%n = store%n + 1
	if (store%n <= size (store%proc)) then
	store%proc(store%n)%ptr => current%process
	else
	deallocate (store%proc)
	allocate (store%proc (store%n + BLOCK_SIZE))
	i = 1
	entry => store%first
	do while (associated (entry))
	store%proc(i)%ptr => entry%process; i = i + 1
	entry => entry%next
	end do
	end if
	end if
	process => current%process
	end function process_store_get_fresh_process_ptr

	@ %def process_store_get_fresh_process_ptr
	@ Append a new process entry (or find an existing one) and initialize
	it with a particular hard process, model pointer and total energy.
	Return a pointer to the process object, so further process preparation
	can be done by the caller. Allocate or expand the array as needed.
	<<XXX Processes: public>>=
	public :: process_store_init_process
	<<XXX Processes: procedures>>=
	subroutine process_store_init_process (process, &
	prc_lib, process_id, model, var_list, &
	use_beams)
	type(process_t), pointer :: process
	type(process_library_t), intent(inout), target :: prc_lib
	type(string_t), intent(in) :: process_id
	type(model_t), intent(in), target :: model
	type(pdf_builtin_status_t) :: pdf_builtin_status
	type(var_list_t), intent(in), target :: var_list
	logical, intent(in) :: use_beams
	integer :: process_lib_index, process_store_index
	procedure(prclib_unload_hook), pointer :: unload_hook
	procedure(prclib_reload_hook), pointer :: reload_hook
	process_lib_index = process_library_get_process_index (prc_lib, process_id)
	if (process_lib_index == 0) then
	call msg_fatal ("Process '" // char (process_id) &
	// "' is not available.")
	end if
	process_store_index = process_store_get_process_index (process_id)
	process => process_store_get_fresh_process_ptr (process_id)
	if (process_store_index == 0) then
	process_store_index = process_store_get_n_processes ()
	end if
	unload_hook => process_store_unload
	reload_hook => process_store_reload
	call process_library_set_unload_hook (prc_lib, unload_hook)
	call process_library_set_reload_hook (prc_lib, reload_hook)
	call process_init &
	(process, prc_lib, process_lib_index, process_store_index, &
	process_id, model, var_list, use_beams)
	end subroutine process_store_init_process

	@ %def process_store_init_process
	@
	\subsection{Sampling function}
	This is the function that computes the squared matrix element in the
	form needed for VAMP integration. It computes and multiplies the flux
	factor for the incoming particles, the phase-space factors of the
	integration channels combined with the VAMP grid jacobians to a common
	phase-space factor, the phase-space volume, and the squared matrix
	element of the hard interaction. The latter is only evaluated if the
	event passes cuts.

	There are time-critical operations involved here, so we set breakpoints.

	When doing a mere matrix-element test, after evaluating kinematics we
	do not stop if we encounter an unphysical configuration. This use
	case is characterized by the absence of the [[grids]] argument.
	<<XXX Processes: procedures>>=
	function sample_function (xi, prc_index, weights, channel, grids) result (f)
	real(default) :: f
	real(default), dimension(:), intent(in) :: xi
	integer, intent(in) :: prc_index
	real(default), dimension(:), intent(in), optional :: weights
	integer, intent(in), optional :: channel
	type(vamp_grid), dimension(:), intent(in), optional :: grids
	type(process_t), pointer :: process
	logical :: ok
	integer :: i
	call terminate_now_if_signal ()
	process => process_get_working_copy_ptr (store%proc(prc_index)%ptr)
	process%sample_function_value = 0
	call process_status_reset_flags (process%status)
	call process_status_called (process%status)
	call core_interaction_set_state (process%ci, CI_STATE_CLEAR)
	call process_set_kinematics (process, xi, channel, ok)
	if (ok) then
	call process_fill_subevt (process, transform=process%is_cascade_decay)
	ok = process_passes_cuts (process)
	if (ok) call process_status_passed_cuts (process%status)
	end if
	call terminate_now_if_signal ()
	if (ok) then
	call process_compute_scale (process)
	call process_update_alpha_s (process)
	call core_interaction_set_state (process%ci, CI_STATE_EVALUATE)
	call process_evaluate (process)
	do i = 1, process%n_kinematics_in
	if (.not. process%kinematics_in(i)%passed) cycle
	process%kinematics_in(i)%passed = core_interaction_needs_weight ( &
	process%ci, i)
	end do
	call process_complete_kinematics (process, channel)
	if (present (grids)) then
	call process_compute_vamp_phs_factor (process, weights)
	else
	process%kinematics_in(:)%vamp_phs_factor = 1
	end if
	do i = 1, process%n_kinematics_in
	if (.not. process%kinematics_in(i)%passed) cycle
	call core_interaction_set_weight (process%ci, &
	process%kinematics_in(i)%phs_volume * &
	process%kinematics_in(i)%vamp_phs_factor, &
	i)
	end do
	call core_interaction_set_state (process%ci, CI_STATE_WEIGHTS_SET)
	call process_compute_reweighting_factor (process)
	do i = 1, process%n_kinematics_out
	if (.not. process%kinematics_out(i)%passed) cycle
	process%sample_function_value = process%sample_function_value + &
	process%kinematics_out(i)%sqme * &
	process%kinematics_out(i)%reweighting_factor * &
	core_interaction_get_weight (process%ci, i)
	end do
	process%sample_function_value = process%sample_function_value * &
	process%flux_factor * process%sf_mapping_factor
	call process_status_passed_evaluation (process%status)
	end if
	f = process%sample_function_value
	call terminate_now_if_signal ()
	end function sample_function

	@ %def sample_function
	@
	\subsection{Old Tests}
	<<XXX Processes: public>>=
	public :: process_test
	<<XXX Processes: procedures>>=
	subroutine process_test ()
	type(os_data_t), pointer :: os_data => null ()
	type(process_library_t), pointer :: prc_lib => null ()
	type(model_t), pointer :: model => null ()
	type(var_list_t), pointer :: var_list => null ()
	allocate (os_data)
	allocate (prc_lib)
	allocate (var_list)
	call process_library_store_final
	call os_data_init (os_data)
	print , "** Read model file"
	call syntax_model_file_init ()
	call model_list_read_model &
	(var_str("SM"), var_str("SM.mdl"), os_data, model)
	var_list => model_get_var_list_ptr (model)
	call syntax_pexpr_init ()
	call syntax_phs_forest_init ()
	print *
	print , "** Create process library"
	call var_list_append_string (var_list, name = "$library_name", sval = "prc_proc") ! $
	call var_list_append_log (var_list, name = "?read_color_factors", lval = .true.)
	call var_list_append_log (var_list, name = "?alpha_s_is_fixed", lval = .true.)
	call process_library_store_append (var_str ("prc_proc"), os_data, prc_lib)
	call process_library_init (prc_lib, var_str("prc_proc"), os_data)
	print *
	call process_test1 (prc_lib, os_data, model, var_list)
	print *
	call process_test2 (prc_lib, os_data, model, var_list)
	print *
	call process_test3 (prc_lib, os_data, model, var_list)
	print *
	call process_test4 (prc_lib, os_data, model, var_list)
	print *
	print , " Cleanup"
	call process_store_final ()
	call syntax_pexpr_final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()
	call process_library_final (prc_lib)
	deallocate (prc_lib)
	deallocate (os_data)
	end subroutine process_test

	@ %def process_test
	@ Test decay process: $Z\to e^+e^-$ (colorless); polarized and unpolarized
	<<XXX Processes: procedures>>=
	subroutine process_test1 (prc_lib, os_data, model, var_list)
	type(process_library_t), intent(inout) :: prc_lib
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(inout), target :: var_list
	type(process_t), pointer :: process
	type(string_t) :: objlist
	type(string_t), dimension(:), allocatable :: prt_in, prt_out
	type(os_data_t), intent(inout) :: os_data
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(1) :: flv
	type(polarization_t), dimension(1) :: pol
	type(beam_data_t) :: beam_data
	type(grid_parameters_t) :: grid_parameters
	type(tao_random_state) :: rng
	integer :: i
	logical :: rebuild_phs = .true.
	logical :: discard_integrals, adapt_grids, adapt_weights, print_current
	logical :: time_estimate = .true.
	print , " Test decay process Z -> e+ e- *"
	print *
	print , " Initialization"
	call tao_random_create (rng, 0)
	allocate (prt_in (1), prt_out (2))
	print *, "setting particles for Z -> e+ e-"
	prt_in(1) = "Z"
	prt_out(1) = "e1"
	prt_out(2) = "E1"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("zff"), model, prt_in, prt_out, method = PRC_TEST, &
	message = .true. )
	deallocate (prt_in, prt_out)
	allocate (prt_in (1), prt_out (2))
	print *, "setting particles for Z -> u ubar"
	prt_in(1) = "Z"
	prt_out(1) = "u"
	prt_out(2) = "U"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("zqq"), model, prt_in, prt_out, method = PRC_TEST, &
	message = .true. )
	deallocate (prt_in, prt_out)
	allocate (prt_in (2), prt_out (3))
	print *, "setting particles for e+ e- -> nu nubar H"
	prt_in(1) = "e1"
	prt_in(2) = "E1"
	prt_out(1) = "nue"
	prt_out(2) = "nuebar"
	prt_out(3) = "H"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("nnh"), model, prt_in, prt_out, method = PRC_TEST, &
	message = .true. )
	deallocate (prt_in, prt_out)
	allocate (prt_in (2), prt_out (2))
	print *, "setting particles for g g -> u ubar"
	prt_in(1) = "g"
	prt_in(2) = "g"
	prt_out(1) = "u"
	prt_out(2) = "U"
	call process_library_append &
	(prc_lib, CI_OMEGA, var_str ("gguu"), model, prt_in, prt_out, method = PRC_TEST, &
	message = .true. )
	deallocate (prt_in, prt_out)
	print *
	print , " Generate code"
	call process_library_generate_code (prc_lib, os_data)
	print *
	print , " Write driver file 'prc_proc_interface.f90'"
	call process_library_write_driver (prc_lib)
	print *
	print , " Compile and link as 'libprc_proc.so'"
	call process_library_compile (prc_lib, os_data, .false., objlist)
	call process_library_link (prc_lib, os_data, objlist)
	print *
	print , " Load shared libraries"
	call process_library_load (prc_lib, os_data, var_list = var_list)
	print *
	call process_store_init_process &
	(process, prc_lib, var_str ("zff"), model, &
	var_list, use_beams = .true.)
	print *
	print , "** Beam/strfun setup (unpolarized)"
	print *
	call flavor_init (flv, (/ 23 /), model)
	call polarization_init_unpolarized (pol(1), flv(1))
	call beam_data_init_decay (beam_data, flv, pol)
	call process_setup_beams (process, beam_data, 0)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("zff.phs"), &
	vis_channels = .false.)
	call process_init_vamp_history (process, 1)
	print *
	print , "** Test integration"
	print , " Grids setup"
	grid_parameters%stratified = .false.
	call process_setup_grids (process, grid_parameters, calls=9)
	print *
	print , " 1 iteration with minimal number of calls"
	call process_results_write_header (process)
	do i = 1, 1
	discard_integrals = i==1
	adapt_grids = .true.
	adapt_weights = .true.
	print_current = .true.
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 9, &
	discard_integrals, adapt_grids, adapt_weights, print_current, &
	time_estimate)
	end do
	call process_results_write_footer (process)
	print *
	print , " Process written to 'fort.60'"
	call process_write (process, 60)
	print *
	print , "** Beam/strfun setup (polarized)"
	call process_store_init_process &
	(process, prc_lib, var_str ("zff"), model, &
	var_list, use_beams = .true.)
	call flavor_init (flv, (/ 23 /), model)
	call polarization_init_axis &
	(pol(1), flv(1), (/ 0._default, 0._default, 1._default/))
	call beam_data_init_decay (beam_data, flv, pol)
	call process_setup_beams (process, beam_data, 0)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("zff.phs"), &
	vis_channels = .false.)
	call process_init_vamp_history (process, 6)
	print *
	print , "** Test integration"
	print , " Grids setup"
	grid_parameters%stratified = .false.
	call process_setup_grids (process, grid_parameters, calls=10000)
	print *
	print , " 3 + 3 iterations"
	call process_results_write_header (process)
	do i = 1, 3
	discard_integrals = i==1
	adapt_grids = .true.
	adapt_weights = .true.
	print_current = .true.
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 10000, &
	discard_integrals, adapt_grids, adapt_weights, print_current, &
	time_estimate)
	end do
	call process_results_write_current_average (process)
	call process_integrate (process, rng, grid_parameters, &
	2, 1, 3, 10000, &
	.true., .true., .false., .true., .true.)
	call process_results_write_footer (process)
	call process_write_time_estimate (process)
	print *
	print , " Process written to 'fort.61'"
	call process_write (process, 61)
	end subroutine process_test1

	@ %def process_test1
	@ Test decay process: $Z\to uu$.
	<<XXX Processes: procedures>>=
	subroutine process_test2 (prc_lib, os_data, model, var_list)
	type(process_library_t), intent(inout) :: prc_lib
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(in), target :: var_list
	type(string_t) :: objlist
	type(process_t), pointer :: process
	type(os_data_t), intent(inout) :: os_data
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(1) :: flv
	type(polarization_t), dimension(1) :: pol
	type(beam_data_t) :: beam_data
	type(grid_parameters_t) :: grid_parameters
	type(tao_random_state) :: rng
	real(default) :: weight
	logical :: time_estimate = .true.
	integer :: i
	logical :: rebuild_phs = .true.
	logical :: discard_integrals, adapt_grids, adapt_weights, print_current
	print , " Test decay process Z -> u ubar *"
	print *
	print , " Initialization"
	call tao_random_create (rng, 0)
	call process_store_init_process &
	(process, prc_lib, var_str ("zqq"), model, &
	var_list, use_beams=.false.)
	print *, " Process ID = ", char (process%id)
	print *
	print , "** Beam/strfun setup (unpolarized)"
	print *
	call flavor_init (flv, (/ 23 /), model)
	call polarization_init_unpolarized (pol(1), flv(1))
	call beam_data_init_decay (beam_data, flv, pol)
	call process_setup_beams (process, beam_data, 0)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("zqq.phs"), &
	vis_channels = .false.)
	call process_init_vamp_history (process, 1)
	print *
	print , "** Test integration"
	print , " Grids setup"
	grid_parameters%stratified = .false.
	call process_setup_grids (process, grid_parameters, calls=9)
	print *
	print , " 1 iteration with minimal number of calls"
	call process_results_write_header (process)
	do i = 1, 1
	discard_integrals = i==1
	adapt_grids = .true.
	adapt_weights = .true.
	print_current = .true.
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 9, &
	discard_integrals, adapt_grids, adapt_weights, print_current, &
	time_estimate)
	end do
	call process_results_write_footer (process)
	call process_write_time_estimate (process)
	print *
	print , " Process written to 'fort.62'"
	call process_write (process, 62)
	print *
	print , "** Event generation"
	call process_setup_event_generation (process)
	print *
	print , " Generate weighted event"
	call process_generate_weighted_event (process, rng, weight)
	print *
	print , " Process written to 'fort.63'"
	call process_write (process, 63)
	print *, "weight =", weight
	print *
	print , " Generate unweighted event"
	call process_generate_unweighted_event (process, rng, weight)
	print *
	print , " Process written to 'fort.64'"
	call process_write (process, 64)
	print *, "excess weight =", weight
	end subroutine process_test2

	@ %def process_test2
	@ Test scattering process: ee->nnh (colorless)
	<<XXX Processes: procedures>>=
	subroutine process_test3 (prc_lib, os_data, model, var_list)
	type(process_library_t), intent(inout) :: prc_lib
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(in), target :: var_list
	type(process_t), pointer :: process
	type(os_data_t), intent(inout) :: os_data
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(2) :: flv
	type(polarization_t), dimension(2) :: pol
	type(beam_data_t) :: beam_data
	type(grid_parameters_t) :: grid_parameters
	real(default), dimension(:), allocatable :: x
	logical :: time_estimate = .true.
	integer :: channel
	logical :: ok
	integer :: i
	type(tao_random_state) :: rng
	logical :: rebuild_phs = .true.
	logical :: discard_integrals, adapt_grids, adapt_weights, print_current
	print , " Test scattering process e+ e- -> nu nubar H *"
	print *
	print , " Initialization"
	call tao_random_create (rng, 0)
	call process_store_init_process &
	(process, prc_lib, var_str ("nnh"), model, &
	var_list, use_beams = .true.)
	print *, " Process ID = ", char (process%id)
	print *
	print , " Beam/strfun setup"
	print *
	call flavor_init (flv, (/ 11, -11 /), model)
	call polarization_init_unpolarized (pol(1), flv(1))
	call polarization_init_unpolarized (pol(2), flv(2))
	call beam_data_init_sqrts (beam_data, 500._default, flv, pol)
	call process_setup_beams (process, beam_data, 0)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("nnh.phs"), &
	vis_channels = .false.)
	call process_init_vamp_history (process, 8)
	print *
	print , " Kinematics setup"
	allocate (x (process_get_n_parameters (process)))
	do i = 1, size (x)
	x(i) = (i - 0.5_default) * (1._default / size (x))
	end do
	channel = 1
	call process_set_kinematics (process, x, channel, ok)
	print *
	print , " Process written to 'fort.70'"
	call process_write (process, 70)
	print *
	print , "** Test process evaluation"
	call core_interaction_set_cut_status (process%ci, .true., 1)
	call core_interaction_set_state (process%ci, CI_STATE_EVALUATE)
	call process_evaluate (process)
	print *
	print , " Process written to 'fort.71'"
	call process_write (process, 71)
	print *
	print , "** Test integration"
	print , " Grids setup"
	call process_setup_grids (process, grid_parameters, calls=20000)
	print *
	print , " 5 + 3 iterations"
	call process_results_write_header (process)
	do i = 1, 5
	discard_integrals = i==1
	adapt_grids = .true.
	adapt_weights = .true.
	print_current = .true.
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 10000, &
	discard_integrals, adapt_grids, adapt_weights, print_current, &
	time_estimate)
	end do
	call process_results_write_current_average (process)
	call process_integrate (process, rng, grid_parameters, &
	2, 1, 3, 20000, .true., .false., .false., .true., .true.)
	call process_results_write_footer (process)
	call process_write_time_estimate (process)
	print *
	print , " Process written to 'fort.72'"
	call process_write (process, 72)
	end subroutine process_test3

	@ %def process_test3
	@ Test scattering process: $gg \to uu$.
	<<XXX Processes: procedures>>=
	subroutine process_test4 (prc_lib, os_data, model, var_list)
	type(process_library_t), intent(inout) :: prc_lib
	type(model_t), intent(in), target :: model
	type(var_list_t), intent(in), target :: var_list
	type(process_t), pointer :: process
	type(os_data_t), intent(inout) :: os_data
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(2) :: flv
	type(polarization_t), dimension(2) :: pol
	type(beam_data_t) :: beam_data
	type(pdf_builtin_status_t) :: pdf_builtin_status
	type(pdf_builtin_data_t), dimension(2) :: data
	type(stream_t), target :: stream
	type(parse_tree_t) :: parse_tree
	type(grid_parameters_t) :: grid_parameters
	logical :: time_estimate = .true.
	integer :: i
	type(tao_random_state) :: rng
	logical :: rebuild_phs = .true.
	print , " Test process setup for g g -> u ubar *"
	print *
	print , " Initialization"
	call tao_random_create (rng, 0)
	call process_store_init_process &
	(process, prc_lib, var_str ("gguu"), model, &
	var_list, use_beams = .true.)
	print *, " Process ID = ", char (process%id)
	print *
	print , " Beam/strfun setup"
	print *
	! call flavor_init (flv, (/ 21, 21 /), model)
	call flavor_init (flv, (/ PROTON, PROTON /), model)
	call polarization_init_unpolarized (pol(1), flv(1))
	call polarization_init_unpolarized (pol(2), flv(2))
	call beam_data_init_sqrts (beam_data, 14000._default, flv, pol)
	! call process_setup_beams (process, beam_data, 0, 0)
	call process_setup_beams (process, beam_data, 2)
	call pdf_builtin_init (data(1), pdf_builtin_status, model, flv(1), name = &
	var_str("cteq6l"), path = os_data%pdf_builtin_datapath)
	call pdf_builtin_init (data(2), pdf_builtin_status, model, flv(2), name = &
	var_str("cteq6l"), path = os_data%pdf_builtin_datapath)
	call process_set_strfun (process, 1, 1, data(1), 1)
	call process_set_strfun (process, 2, 2, data(2), 1)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("gguu.phs"), &
	vis_channels = .false.)
	call process_init_vamp_history (process, 18)
	print *
	print , " Cuts setup"
	call stream_init (stream, var_str ("all Pt > 50 GeV [u:d:U:D]"))
	call parse_tree_init_lexpr (parse_tree, stream, .true.)
	call process_setup_cuts (process, parse_tree_get_root_ptr (parse_tree))
	call parse_tree_final (parse_tree)
	call stream_final (stream)
	print *
	print , " Scale setup"
	call stream_init (stream, var_str ("1 TeV"))
	call parse_tree_init_expr (parse_tree, stream, .true.)
	call process_setup_fac_scale (process, parse_tree_get_root_ptr (parse_tree))
	call parse_tree_final (parse_tree)
	call stream_final (stream)
	print *
	print , "** Test integration"
	print , " Grids setup"
	call process_setup_grids (process, grid_parameters, calls=10000)
	print *
	print , " 5 + 3 iterations"
	call process_results_write_header (process)
	do i = 1, 5
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 50000, i==1, .true., i>2, .true., .true.)
	end do
	call process_results_write_current_average (process)
	call process_integrate (process, rng, grid_parameters, &
	2, 1, 3, 50000, .true., .false., .true., .true., .true.)
	call process_results_write_footer (process)
	call process_write_time_estimate (process)
	print *
	print , " Process written to 'fort.90'"
	call process_write (process, 90)
	end subroutine process_test4

	@ %def process_test4
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Decays}

	Particles can be marked as unstable, so during event generation
	(cascade) decays are applied to them. For each decay mode, we
	temporarily use the corresponding process entry in the process store,
	which is filled and evaluated and connected to the mother process.
	<<[[decays.f90]]>>=
	<<File header>>

	module decays

	<<Use kinds>>
	use kinds, only: double !NODEP!
	<<Use strings>>
	use limits, only: MAX_TRIES_FOR_DECAY_CHAIN !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use lorentz !NODEP!
	use tao_random_numbers !NODEP!
	use md5
	use models
	use flavors
	use quantum_numbers
	use processes
	use interactions
	use evaluators

	<<Standard module head>>

	<<Decays: public>>

	<<Decays: types>>

	<<Decays: variables>>

	contains

	<<Decays: procedures>>

	end module decays
	@ %def decays
	@
	\subsection{Decay configuration}
	We store the decay properties of a particular particle. First, we
	need an array of process pointers. For the final-state particles, we need to
	store the fact whether they are stable themselves and, if not, their decay
	properties. This is necessary because it determines the quantum numbers we
	need to keep for the decay products in event generation.
	<<Decays: types>>=
	type :: decay_channel_t
	private
	type(process_t), pointer :: process => null ()
	real(default) :: br = 0
	type(flavor_t), dimension(:), allocatable :: unstable_products
	logical, dimension(:), allocatable :: isotropic
	logical, dimension(:), allocatable :: diagonal
	end type decay_channel_t

	@ %def process_ptr_t
	@ Decay configurations are stored in a list:
	<<Decays: public>>=
	public :: decay_configuration_t
	<<Decays: types>>=
	type :: decay_configuration_t
	private
	type(flavor_t) :: flv
	type(model_t), pointer :: model => null ()
	real(default) :: width = 0
	logical :: isotropic = .false.
	logical :: diagonal = .false.
	type(decay_channel_t), dimension(:), allocatable :: channel
	type(string_t), dimension(:), allocatable :: process_id
	type(decay_configuration_t), pointer :: next => null ()
	end type decay_configuration_t

	@ %def decay_configuration_t
	@ Allocate the array for a known number of decay channels.
	<<Decays: procedures>>=
	subroutine decay_configuration_init &
	(conf, flv, model, width, n_channels, isotropic, diagonal)
	type(decay_configuration_t), intent(out) :: conf
	type(flavor_t), intent(in) :: flv
	type(model_t), intent(in), target :: model
	real(default), intent(in) :: width
	integer, intent(in) :: n_channels
	logical, intent(in) :: isotropic, diagonal
	conf%flv = flv
	conf%model => model
	conf%width = width
	conf%isotropic = isotropic
	conf%diagonal = diagonal
	allocate (conf%channel (n_channels))
	allocate (conf%process_id (n_channels))
	end subroutine decay_configuration_init

	@ %def decay_configuration_init
	@ Set/retrieve the pointer to the next configuration in list:
	<<Decays: procedures>>=
	function decay_configuration_get_next_ptr (conf) result (ptr)
	type(decay_configuration_t), pointer :: ptr
	type(decay_configuration_t), intent(in) :: conf
	ptr => conf%next
	end function decay_configuration_get_next_ptr

	subroutine decay_configuration_set_next_ptr (conf, ptr)
	type(decay_configuration_t), intent(inout) :: conf
	type(decay_configuration_t), pointer :: ptr
	conf%next => ptr
	end subroutine decay_configuration_set_next_ptr

	@ %def decay_configuration_get_next_ptr
	@ %def decay_configuration_set_next_ptr
	@ Set a single decay channel:
	<<Decays: public>>=
	public :: decay_configuration_set_channel
	<<Decays: procedures>>=
	subroutine decay_configuration_set_channel (conf, i, process, br)
	type(decay_configuration_t), intent(inout) :: conf
	integer, intent(in) :: i
	type(process_t), intent(in), target :: process
	real(default), intent(in) :: br
	integer :: n_unstable_products
	conf%channel(i)%process => process
	conf%channel(i)%br = br
	conf%process_id(i) = process_get_id (process)
	call process_get_unstable_products &
	(conf%channel(i)%process, conf%channel(i)%unstable_products)
	n_unstable_products = size (conf%channel(i)%unstable_products)
	if (allocated (conf%channel(i)%isotropic)) &
	deallocate (conf%channel(i)%isotropic)
	if (allocated (conf%channel(i)%diagonal)) &
	deallocate (conf%channel(i)%diagonal)
	allocate (conf%channel(i)%isotropic (n_unstable_products))
	allocate (conf%channel(i)%diagonal (n_unstable_products))
	if (n_unstable_products /= 0) then
	conf%channel(i)%isotropic = &
	flavor_decays_isotropically (conf%channel(i)%unstable_products)
	conf%channel(i)%diagonal = &
	flavor_decays_diagonal (conf%channel(i)%unstable_products)
	end if
	end subroutine decay_configuration_set_channel

	@ %def decay_configuration_set_channel
	@ Check an existing decay configuration whether the stability of the decay
	products has changed. If yes, re-initialize event generation for the
	corresponding channel.

	Do the check only if the configuration corresponds to a particle that is
	currently known as unstable.
	<<Decays: procedures>>=
	subroutine decay_configuration_recheck_final_state (conf, verbose)
	type(decay_configuration_t), intent(inout) :: conf
	logical, intent(in), optional :: verbose
	type(flavor_t), dimension(:), allocatable :: flv_unstable
	logical, dimension(:), allocatable :: isotropic, diagonal
	logical :: modified, verb
	integer :: u, i, n_unstable_products
	u = logfile_unit ()
	verb = .false.; if (present (verbose)) verb = verbose
	if (flavor_is_stable (conf%flv)) return
	do i = 1, size (conf%channel)
	call process_get_unstable_products &
	(conf%channel(i)%process, flv_unstable)
	n_unstable_products = size (flv_unstable)
	allocate (isotropic (n_unstable_products))
	allocate (diagonal (n_unstable_products))
	isotropic = flavor_decays_isotropically (flv_unstable)
	diagonal = flavor_decays_diagonal (flv_unstable)
	if (n_unstable_products == size (conf%channel(i)%unstable_products)) &
	then
	modified = &
	any (flv_unstable /= conf%channel(i)%unstable_products) &
	.or. &
	any (isotropic .neqv. conf%channel(i)%isotropic) &
	.or. &
	any (diagonal .neqv. conf%channel(i)%diagonal)
	else
	modified = .true.
	deallocate (conf%channel(i)%unstable_products)
	deallocate (conf%channel(i)%isotropic)
	deallocate (conf%channel(i)%diagonal)
	allocate (conf%channel(i)%unstable_products (n_unstable_products))
	allocate (conf%channel(i)%isotropic (n_unstable_products))
	allocate (conf%channel(i)%diagonal (n_unstable_products))
	end if
	if (modified) then
	conf%channel(i)%unstable_products = flv_unstable
	conf%channel(i)%isotropic = isotropic
	conf%channel(i)%diagonal = diagonal
	call process_setup_event_generation (conf%channel(i)%process, &
	qn_mask_in = new_quantum_numbers_mask (.false., .false., &
	mask_h = conf%isotropic, mask_hd = conf%diagonal))
	if (verb) then
	call msg_message ("Further modified decay configuration:")
	call decay_configuration_write (conf)
	call decay_configuration_write (conf, u)
	end if
	end if
	deallocate (flv_unstable, isotropic, diagonal)
	end do
	end subroutine decay_configuration_recheck_final_state

	@ %def decay_configuration_recheck_final_state
	@ Check an existing decay configuration whether it contains any of a
	given list of processes, which have been updated since the decay
	configuration was stored. If yes, re-initialize event generation for
	the updated processes, recalculate the branching ratios and report the
	updated decay configuration.

	We assume that the record has been initialized before.
	<<Decays: procedures>>=
	subroutine decay_configuration_update (conf, process_id, verbose)
	type(decay_configuration_t), intent(inout) :: conf
	type(string_t), dimension(:), intent(in) :: process_id
	logical, intent(in), optional :: verbose
	logical, dimension(:), allocatable :: updated
	real(default), dimension(:), allocatable :: integral, br
	real(default) :: integral_sum
	integer :: u, i, j, n_channels
	type(process_t), pointer :: process
	logical :: verb
	u = logfile_unit ()
	verb = .false.; if (present (verbose)) verb = verbose
	if (flavor_is_stable (conf%flv)) return
	n_channels = size (conf%channel)
	allocate (updated (n_channels))
	allocate (integral (n_channels), br (n_channels))
	updated = .false.
	do j = 1, n_channels
	do i = 1, size (process_id)
	if (process_id(i) == conf%process_id(j)) then
	updated(j) = .true.
	end if
	end do
	end do
	if (any (updated)) then
	do j = 1, n_channels
	process => conf%channel(j)%process
	integral(j) = process_get_integral (process)
	if (integral(j) < 0) then
	call msg_fatal ("Integral of process '" &
	// char (process_get_id (process)) // "' is negative")
	end if
	if (updated(j)) then
	call process_setup_event_generation (process, &
	qn_mask_in = new_quantum_numbers_mask (.false., .false., &
	mask_h = conf%isotropic, mask_hd = conf%diagonal))
	end if
	end do
	integral_sum = sum (integral)
	if (integral_sum /= 0) then
	br = integral / integral_sum
	else
	call msg_fatal ("Unstable particle: Computed total width vanishes")
	br = 0
	end if
	conf%width = integral_sum
	conf%channel%br = br
	if (verb) then
	call msg_message ("Updated decay configuration:")
	call decay_configuration_write (conf)
	call decay_configuration_write (conf, u)
	end if
	end if
	end subroutine decay_configuration_update

	@ %def decay_configuration_update
	@ Output. Note that either no channel or all channels have to be defined.
	<<Decays: public>>=
	public :: decay_configuration_write
	<<Decays: procedures>>=
	subroutine decay_configuration_write (conf, unit)
	type(decay_configuration_t), intent(in) :: conf
	integer, intent(in), optional :: unit
	character(12) :: fmt
	integer :: n_channels, proc_id_len
	integer :: u, i, j
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)") "Decay configuration of particle '" &
	// char (flavor_get_name (conf%flv)) // "' in model '" &
	// char (model_get_name (conf%model)) // "':"
	write (u, *) " Computed total width = ", conf%width, " GeV"
	if (conf%isotropic) then
	write (u, *) " Isotropic decays requested for simulation."
	end if
	if (conf%diagonal) then
	write (u, *) " Diagonal density matrix in decays " &
	// "requested for simulation."
	end if
	write (u, *) " Branching ratios:"
	n_channels = decay_configuration_get_n_channels (conf)
	if (n_channels /= 0) then
	proc_id_len = maxval (len (conf%process_id))
	do i = 1, n_channels
	write (u, "(F12.7,1x,A)", advance="no") 100 * conf%channel(i)%br, "%"
	write (fmt, "(2x,A,I0,A)") "(4x,A", proc_id_len + 1, ")"
	write (u, fmt, advance="no") char (conf%process_id(i))
	if (allocated (conf%channel(i)%unstable_products)) then
	if (size (conf%channel(i)%unstable_products) /= 0) then
	write (u, "(1x,A)", advance="no") " -> unstable:"
	do j = 1, size (conf%channel(i)%unstable_products)
	write (u, "(1x,A)", advance="no") char (flavor_get_name &
	(conf%channel(i)%unstable_products(j)))
	if (conf%channel(i)%isotropic(j)) then
	write (u, "(A)", advance="no") "[I]"
	else if (conf%channel(i)%diagonal(j)) then
	write (u, "(A)", advance="no") "[D]"
	end if
	end do
	end if
	end if
	write (u, *)
	end do
	else
	write (u, *) " [undefined]"
	end if
	end subroutine decay_configuration_write

	@ %def decay_configuration_write
	@ Return the number of decay channels:
	<<Decays: public>>=
	public :: decay_configuration_get_n_channels
	<<Decays: procedures>>=
	function decay_configuration_get_n_channels (conf) result (n)
	integer :: n
	type(decay_configuration_t), intent(in) :: conf
	if (allocated (conf%channel)) then
	n = size (conf%channel)
	else
	n = 0
	end if
	end function decay_configuration_get_n_channels

	@ %def decay_configuration_get_n_channels
	@ Select a decay channel, using the random-number generator. Return
	the process pointer. Note that the sum of branching ratios must be
	unity. (As a fallback, the last channel is selected if the sum of
	ratios is less than unity.)
	<<Decays: procedures>>=
	function decay_configuration_select_channel (conf, rng) result (channel)
	integer :: channel
	type(decay_configuration_t), intent(in) :: conf
	type(tao_random_state), intent(inout) :: rng
	real(default) :: x
	real(default) :: x_sum
	call tao_random_number (rng, x)
	x_sum = 0
	do channel = 1, size (conf%channel)
	x_sum = x_sum + conf%channel(channel)%br
	if (x < x_sum) return
	end do
	channel = size (conf%channel)
	end function decay_configuration_select_channel

	@ %def decay_configuration_select_channel
	@ Return a pointer to a specified decay process.
	<<Decays: procedures>>=
	function decay_configuration_get_process_ptr (conf, channel) &
	result (process)
	type(process_t), pointer :: process
	type(decay_configuration_t), intent(in) :: conf
	integer, intent(in) :: channel
	process => conf%channel(channel)%process
	end function decay_configuration_get_process_ptr

	@ %def decay_configuration_get_process_ptr
	@
	\subsection{List of decay configurations}
	Similar to the list of active processes ([[process_store]]), we
	maintain a list of unstable particles and their decay properties.
	<<Decays: types>>=
	type :: decay_store_t
	private
	integer :: n = 0
	type(decay_configuration_t), pointer :: first => null ()
	type(decay_configuration_t), pointer :: last => null ()
	end type decay_store_t

	@ %def decay_store_t
	<<Decays: variables>>=
	type(decay_store_t), save :: store

	@ %def decay_store
	@ Finalize.
	<<Decays: public>>=
	public :: decay_store_final
	<<Decays: procedures>>=
	subroutine decay_store_final ()
	type(decay_configuration_t), pointer :: current
	store%last => null ()
	do while (associated (store%first))
	current => store%first
	store%first => current%next
	deallocate (current)
	end do
	store%n = 0
	end subroutine decay_store_final

	@ %def decay_store_final
	@ Output.
	<<Decays: public>>=
	public :: decay_store_write
	<<Decays: procedures>>=
	subroutine decay_store_write (unit)
	integer, intent(in), optional :: unit
	type(decay_configuration_t), pointer :: decay
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)") "Decay configuration for unstable particles:"
	decay => store%first
	do while (associated (decay))
	if (.not. flavor_is_stable (decay%flv)) &
	call decay_configuration_write (decay, unit)
	decay => decay%next
	end do
	end subroutine decay_store_write

	@ %def decay_store_write
	@ Retrieve the MD5 sum of the decay store, if there is any decay assigned.
	<<Decays: public>>=
	public :: decay_store_get_md5sum
	<<Decays: procedures>>=
	function decay_store_get_md5sum () result (md5sum_decays)
	character(32) :: md5sum_decays
	integer :: u
	if (associated (store%first)) then
	u = free_unit ()
	open (u, status="scratch")
	call decay_store_write (u)
	rewind (u)
	md5sum_decays = md5sum (u)
	else
	md5sum_decays = ""
	end if
	end function decay_store_get_md5sum

	@ %def decay_store_get_md5sum
	@ Append a new entry for an unstable particle. If a decay exists
	already, it is overwritten. Return a pointer to the new decay
	configuration.
	<<Decays: public>>=
	public :: decay_store_append_decay
	<<Decays: procedures>>=
	subroutine decay_store_append_decay &
	(flv, model, width, n_channels, isotropic, diagonal, decay)
	type(flavor_t), intent(in) :: flv
	type(model_t), intent(in), target :: model
	real(default), intent(in) :: width
	integer, intent(in) :: n_channels
	logical, intent(in) :: isotropic, diagonal
	type(decay_configuration_t), pointer :: decay
	type(decay_configuration_t), pointer :: next_decay
	decay => store%first
	do while (associated (decay))
	if (decay%flv == flv) then
	next_decay => decay_configuration_get_next_ptr (decay)
	call decay_configuration_init &
	(decay, flv, model, width, n_channels, isotropic, diagonal)
	call decay_configuration_set_next_ptr (decay, next_decay)
	return
	end if
	decay => decay%next
	end do
	allocate (decay)
	call decay_configuration_init &
	(decay, flv, model, width, n_channels, isotropic, diagonal)
	if (associated (store%first)) then
	store%last%next => decay
	else
	store%first => decay
	end if
	store%last => decay
	end subroutine decay_store_append_decay

	@ %def decay_store_append_decay
	@ Return a pointer to the decay configuration for a particular
	unstable particle.
	<<Decays: procedures>>=
	function decay_store_get_decay_configuration_ptr (flv) result (config)
	type(decay_configuration_t), pointer :: config
	type(flavor_t), intent(in) :: flv
	config => store%first
	SCAN_PARTICLES: do while (associated (config))
	if (config%flv == flv) exit SCAN_PARTICLES
	config => config%next
	end do SCAN_PARTICLES
	end function decay_store_get_decay_configuration_ptr

	@ %def decay_store_get_decay_configuration_ptr
	@ Recheck all decay configurations whether the stability of the final state
	has changed. If yes, re-initialize event generation for the corresponding
	decay process.

	This should be executed anytime the stablity of a particle has changed.
	<<Decays: public>>=
	public :: decay_store_recheck_final_state
	<<Decays: procedures>>=
	subroutine decay_store_recheck_final_state (verbose)
	logical, intent(in), optional :: verbose
	logical :: modified
	type(decay_configuration_t), pointer :: config
	config => store%first
	do while (associated (config))
	call decay_configuration_recheck_final_state (config, verbose)
	config => config%next
	end do
	end subroutine decay_store_recheck_final_state

	@ %def decay_store_recheck_final_state
	@ Update all entries in the decay store which contain a process that
	is in the specified list (of processes that have been recalculated).
	<<Decays: public>>=
	public :: decay_store_update
	<<Decays: procedures>>=
	subroutine decay_store_update (process_id, verbose)
	type(string_t), dimension(:), intent(in) :: process_id
	logical, intent(in), optional :: verbose
	type(decay_configuration_t), pointer :: conf
	conf => store%first
	do while (associated (conf))
	call decay_configuration_update (conf, process_id, verbose)
	conf => conf%next
	end do
	end subroutine decay_store_update

	@ %def decay_store_update
	@
	\subsection{Decays}
	The decay object contains a pointer to the decay process, evaluators
	that hold the product of production and decay, and a pointer to the
	next decay node (which holds all possible subsequent decays).
	<<Decays: types>>=
	type :: decay_t
	private
	logical :: initialized = .false.
	type(process_t), pointer :: process => null ()
	type(evaluator_t) :: eval_sqme
	type(evaluator_t) :: eval_flows
	type(decay_node_t), pointer :: next_node => null ()
	end type decay_t

	@ %def decay_t
	@ Initialize the decay with a certain process, and use this together
	with the production evaluators to initialize product evaluators.
	<<Decays: procedures>>=
	subroutine decay_init (decay, process, eval_sqme, eval_flows, i)
	type(decay_t), intent(out), target :: decay
	type(process_t), intent(inout), target :: process
	type(evaluator_t), intent(in), target :: eval_sqme, eval_flows
	integer, intent(in) :: i
	type(interaction_t), pointer :: prc_int
	type(evaluator_t), pointer :: prc_eval_sqme, prc_eval_flows
	integer :: n_tot
	logical, dimension(:), allocatable :: ignore_hel
	type(quantum_numbers_mask_t), dimension(:), allocatable :: &
	mask_hel, mask_sqme, mask_flows
	type(quantum_numbers_mask_t) :: mask_conn
	if (.not. process_has_trivial_kinematics (process)) call msg_bug ( &
	"decays@NLO not yet implemented")
	call process_request_copy (process, decay%process)
	call process_mark_as_cascade_decay (decay%process)
	call process_setup_cuts (decay%process)
	call process_setup_weight (decay%process)
	call process_setup_scale (decay%process)
	call process_setup_fac_scale (decay%process)
	call process_setup_ren_scale (decay%process)
	prc_int => process_get_ci_int_ptr (decay%process)
	prc_eval_sqme => process_get_ci_eval_sqme_ptr (decay%process)
	prc_eval_flows => process_get_ci_eval_flows_ptr (decay%process)
	n_tot = evaluator_get_n_tot (prc_eval_sqme)
	if (n_tot < 3) then
	call msg_bug (arr = &
	(/"Initialization fails for decay '" &
	// process_get_id (decay%process) // "':", &
	var_str ("Event generation not set up properly.") &
	! var_str ("(Missing 'unstable' command after integration?)") &
	/))
	end if
	allocate (ignore_hel (n_tot))
	ignore_hel(1) = .true.
	ignore_hel(2:) = .false.
	allocate (mask_hel (n_tot), mask_sqme (n_tot), mask_flows (n_tot))
	call quantum_numbers_mask_set_helicity (mask_hel, ignore_hel)
	mask_sqme = evaluator_get_mask (prc_eval_sqme) .or. mask_hel
	mask_flows = evaluator_get_mask (prc_eval_flows) .or. mask_hel
	mask_conn = new_quantum_numbers_mask (.false., .false., .true.)
	call evaluator_set_source_link (prc_eval_sqme, 1, eval_sqme, i)
	call evaluator_set_source_link (prc_eval_flows, 1, eval_flows, i)
	call evaluator_init_product (decay%eval_sqme, &
	eval_sqme, prc_eval_sqme, mask_conn, &
	connections_are_resonant=.true.)
	call evaluator_init_product (decay%eval_flows, &
	eval_flows, prc_eval_flows, mask_conn, &
	connections_are_resonant=.true.)
	call evaluator_set_source_link (prc_eval_sqme, 1, prc_int, 1)
	call evaluator_set_source_link (prc_eval_flows, 1, prc_int, 1)
	allocate (decay%next_node)
	decay%initialized = .true.
	end subroutine decay_init

	@ %def decay_init
	@ Finalizer: Delete the evaluators. Do not delete the process copy yet.
	<<Decays: procedures>>=
	recursive subroutine decay_final (decay)
	type(decay_t), intent(inout) :: decay
	if (decay%initialized) then
	if (associated (decay%next_node)) &
	call decay_node_final (decay%next_node)
	call evaluator_final (decay%eval_sqme)
	call evaluator_final (decay%eval_flows)
	end if
	end subroutine decay_final

	@ %def decay_final
	@ Output.
	<<Decays: procedures>>=
	subroutine decay_write (decay, unit)
	type(decay_t), intent(in) :: decay
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)") repeat ("=", 72)
	write (u, "(A)") "Decay process:"
	call process_write (decay%process, unit)
	write (u, "(A)") repeat ("=", 72)
	write (u, "(A)") "Combined sqme including color factors " &
	// "(process + decay):"
	call evaluator_write (decay%eval_sqme, unit)
	write (u, "(A)") repeat ("-", 72)
	write (u, "(A)") "Combined color flow coefficients " &
	// "(process + decay):"
	call evaluator_write (decay%eval_flows, unit)
	end subroutine decay_write

	@ %def decay_write
	@ Given preconfigured evaluators, generate an event.

	We generate an unweighted event for the decay process. This is isotropic in
	the decaying particle rest frame. To prepare spin correlation selection, we
	renormalize the squared matrix element by the trace. (Thus, the sum of the
	matrix element values is unity.)

	We must tag the current process as the working copy if there is more than
	one. This occurs if the same decay appears more than once in a decay tree.

	TODO: Any excess weight is collected (to avoid VAMP warnings) but not
	recorded anywhere.
	<<Decays: procedures>>=
	subroutine decay_generate (decay, rng, flv, p)
	type(decay_t), intent(inout) :: decay
	type(tao_random_state), intent(inout) :: rng
	type(flavor_t), intent(in) :: flv
	type(vector4_t), intent(in) :: p
	real(default) :: excess
	type(evaluator_t), pointer :: process_eval_sqme
	call process_set_beam_momenta (decay%process, (/ p /))
	call process_tag_as_working_copy (decay%process)
	call process_generate_unweighted_event (decay%process, rng, excess=excess)
	process_eval_sqme => process_get_eval_sqme_ptr (decay%process)
	call evaluator_normalize_by_trace (process_eval_sqme)
	call evaluator_receive_momenta (decay%eval_sqme)
	call evaluator_receive_momenta (decay%eval_flows)
	call evaluator_evaluate (decay%eval_sqme)
	call evaluator_evaluate (decay%eval_flows)
	end subroutine decay_generate

	@ %def decay_generate
	@
	\subsection{Decay trees}
	A decay tree is created during event generation. Each node holds the
	possible decays as branches, together with the decay configuration
	which is used to select a branch for a particular event. Whenever a
	branch is selected for the first time, it is initialized with the
	appropriate evaluators, which are then kept for later use.
	<<Decays: types>>=
	type :: decay_node_t
	private
	type(decay_configuration_t), pointer :: configuration => null ()
	integer :: current_channel = 0
	type(decay_t), dimension(:), allocatable :: decay
	end type decay_node_t

	@ %def decay_branch_t decay_node_t decay_tree_t
	@ Initializer:
	<<Decays: procedures>>=
	subroutine decay_node_init (node, flv)
	type(decay_node_t), intent(out) :: node
	type(flavor_t), intent(in) :: flv
	node%configuration => decay_store_get_decay_configuration_ptr (flv)
	if (associated (node%configuration)) then
	allocate (node%decay &
	(decay_configuration_get_n_channels (node%configuration)))
	else
	call msg_bug ("Particle '" // char (flavor_get_name (flv)) &
	// "': Missing decay configuration")
	end if
	end subroutine decay_node_init

	@ %def decay_node_init
	@ Recursive finalizer:
	<<Decays: procedures>>=
	recursive subroutine decay_node_final (node)
	type(decay_node_t), intent(inout) :: node
	integer :: i
	if (allocated (node%decay)) then
	do i = 1, size (node%decay)
	call decay_final (node%decay(i))
	end do
	deallocate (node%decay)
	end if
	end subroutine decay_node_final

	@ %def decay_branch_final decay_node_final decay_tree_final
	@ Write the currently selected decay:
	<<Decays: procedures>>=
	subroutine decay_node_write (node, unit)
	type(decay_node_t), intent(in) :: node
	integer, intent(in), optional :: unit
	integer :: channel, u
	u = output_unit (unit)
	write (u, "(A)") "\|" // repeat ("=", 79)
	if (associated (node%configuration)) then
	call decay_configuration_write (node%configuration, unit)
	channel = node%current_channel
	if (channel /= 0) then
	write (u, "(1x,A)", advance="no") "Decay node: "
	write (u, *) "current channel = ", channel
	call decay_write (node%decay(channel), unit)
	else
	write (u, *) "Decay node: [no channel selected]"
	end if
	else
	write (u, *) "Decay configuration: [undefined]"
	end if
	end subroutine decay_node_write

	@ %def decay_node_write
	@ Return a pointer to the currently selected decay, or null if absent:
	<<Decays: procedures>>=
	function decay_node_get_next_ptr (node) result (ptr)
	type(decay_node_t), pointer :: ptr
	type(decay_node_t), intent(in) :: node
	if (node%current_channel /= 0) then
	ptr => node%decay(node%current_channel)%next_node
	else
	ptr => null ()
	end if
	end function decay_node_get_next_ptr

	@ %def decay_node_get_next_ptr
	@ The decay tree holds references to the production process as well as
	pointers to the final evaluators.
	<<Decays: public>>=
	public :: decay_tree_t
	<<Decays: types>>=
	type :: decay_tree_t
	private
	integer :: tries = 0
	real(default) :: acceptance_probability = 0
	type(process_t), pointer :: hard_process => null ()
	type(evaluator_t), pointer :: eval_sqme_in => null ()
	type(evaluator_t), pointer :: eval_flows_in => null ()
	type(decay_node_t), pointer :: root => null ()
	type(evaluator_t), pointer :: eval_sqme => null ()
	type(evaluator_t), pointer :: eval_flows => null ()
	end type decay_tree_t

	@ %def decay_tree_t
	@ Initialize the decay tree with a particular process and allocate the
	root node.
	<<Decays: public>>=
	public :: decay_tree_init
	<<Decays: procedures>>=
	subroutine decay_tree_init (decay_tree, process)
	type(decay_tree_t), intent(out) :: decay_tree
	type(process_t), intent(in), target :: process
	decay_tree%hard_process => process
	decay_tree%eval_sqme_in => process_get_eval_sqme_ptr (process)
	decay_tree%eval_flows_in => process_get_eval_flows_ptr (process)
	allocate (decay_tree%root)
	end subroutine decay_tree_init

	@ %def decay_tree_init
	<<Decays: public>>=
	public :: decay_tree_final
	<<Decays: procedures>>=
	subroutine decay_tree_final (decay_tree)
	type(decay_tree_t), intent(inout) :: decay_tree
	if (associated (decay_tree%root)) then
	call decay_node_final (decay_tree%root)
	deallocate (decay_tree%root)
	end if
	end subroutine decay_tree_final

	@ %def decay_branch_final decay_node_final decay_tree_final
	@ Output.
	<<Decays: public>>=
	public :: decay_tree_write
	<<Decays: procedures>>=
	subroutine decay_tree_write (decay_tree, unit)
	type(decay_tree_t), intent(in) :: decay_tree
	integer, intent(in), optional :: unit
	type(decay_node_t), pointer :: decay_node
	integer :: u
	u = output_unit (unit)
	write (u, "(A)") "\|" // repeat ("=", 79)
	write (u, *) "Decay tree:"
	write (u, *) " tries = ", decay_tree%tries
	write (u, *) " acceptance probability = ", &
	decay_tree%acceptance_probability
	write (u, "(A)") "\|" // repeat ("=", 79)
	write (u, "(1x,A)", advance="no") "Mother process = "
	if (associated (decay_tree%hard_process)) then
	write (u, "(A)") "'" &
	// char (process_get_id (decay_tree%hard_process)) &
	// "'"
	else
	write (u, "(A)") "[undefined]"
	end if
	write (u, "(A)") "\|" // repeat ("=", 79)
	decay_node => decay_tree%root
	if (associated (decay_node)) then
	write (u, *) "Decay chain:"
	do while (associated (decay_node))
	call decay_node_write (decay_node, unit)
	decay_node => decay_node_get_next_ptr (decay_node)
	end do
	else
	write (u, *) "[No decays]"
	end if
	write (u, "(A)") "\|" // repeat ("=", 79)
	write (u, "(1x,A)") "Evaluator: " &
	// "Color-summed including all decays"
	if (associated (decay_tree%eval_sqme)) then
	call evaluator_write (decay_tree%eval_sqme, unit)
	else
	write (u, "(A)") "[undefined]"
	end if
	write (u, "(A)") "\|" // repeat ("=", 79)
	write (u, "(1x,A)") "Evaluator: " &
	// "Color flow components including all decays"
	if (associated (decay_tree%eval_flows)) then
	call evaluator_write (decay_tree%eval_flows, unit)
	else
	write (u, "(A)") "[undefined]"
	end if
	write (u, "(A)") "\|" // repeat ("=", 79)
	end subroutine decay_tree_write

	@ %def decay_tree_write
	@ Generate a decay chain; construct the decay tree as far as
	necessary, otherwise reuse it.

	To prepare for spin correlation selection, we renormalize the matrix elements
	of the parent interaction by the entry with maximum value. Normalizing all
	decay process appropriately (by the trace of their respective matrix
	elements), the (trace of the) product of the evaluators should result in a
	single value between zero and one. This is used as the probability for
	accepting the decay chain. If the chain is rejected, a new one is generated.
	<<Limits: public parameters>>=
	integer, parameter, public :: MAX_TRIES_FOR_DECAY_CHAIN = 100000
	@ %def MAX_TRIES_FOR_DECAY_CHAIN
	<<Decays: public>>=
	public :: decay_tree_generate_event
	<<Decays: procedures>>=
	subroutine decay_tree_generate_event (decay_tree, rng)
	type(decay_tree_t), intent(inout) :: decay_tree
	type(tao_random_state), intent(inout) :: rng
	real(default) :: x_decay
	real(default) :: x
	integer :: i
	logical :: decay_occurs
	call evaluator_normalize_by_max (decay_tree%eval_sqme_in)
	decay_occurs = .false.
	REJECTION: do i = 1, MAX_TRIES_FOR_DECAY_CHAIN
	decay_tree%tries = i
	decay_tree%eval_sqme => decay_tree%eval_sqme_in
	decay_tree%eval_flows => decay_tree%eval_flows_in
	call decay_node_generate_event (decay_tree%root, decay_occurs)
	if (decay_occurs) then
	x_decay = evaluator_sum (decay_tree%eval_sqme)
	decay_tree%acceptance_probability = x_decay
	call tao_random_number (rng, x)
	if (x <= x_decay) return
	else
	return
	end if
	end do REJECTION
	write (msg_buffer, "(A,I0,A)") "Failed to generate a decay chain " &
	// "after ", MAX_TRIES_FOR_DECAY_CHAIN, " tries"
	call msg_fatal ()
	contains
	recursive subroutine decay_node_generate_event (node, decay_occurs)
	type(decay_node_t), intent(inout), target :: node
	logical, intent(inout) :: decay_occurs
	type(flavor_t) :: flv
	type(vector4_t) :: p
	integer :: i, channel
	type(process_t), pointer :: process
	call evaluator_get_unstable_particle (decay_tree%eval_sqme, flv, p, i)
	if (flavor_is_defined (flv)) then
	decay_occurs = .true.
	if (.not. associated (node%configuration)) &
	call decay_node_init (node, flv)
	channel = decay_configuration_select_channel (node%configuration, rng)
	node%current_channel = channel
	if (.not. node%decay(channel)%initialized) then
	process => decay_configuration_get_process_ptr &
	(node%configuration, channel)
	call decay_init (node%decay(channel), &
	process, decay_tree%eval_sqme, decay_tree%eval_flows, i)
	end if
	call decay_generate (node%decay(channel), rng, flv, p)
	decay_tree%eval_sqme => node%decay(channel)%eval_sqme
	decay_tree%eval_flows => node%decay(channel)%eval_flows
	call decay_node_generate_event &
	(node%decay(channel)%next_node, decay_occurs)
	end if
	end subroutine decay_node_generate_event
	end subroutine decay_tree_generate_event

	@ %def decay_tree_generate_event
	@ Return pointers to the final evaluators:
	<<Decays: public>>=
	public :: decay_tree_get_eval_sqme_ptr
	public :: decay_tree_get_eval_flows_ptr
	<<Decays: procedures>>=
	function decay_tree_get_eval_sqme_ptr (decay_tree) result (eval)
	type(evaluator_t), pointer :: eval
	type(decay_tree_t), intent(in), target :: decay_tree
	eval => decay_tree%eval_sqme
	end function decay_tree_get_eval_sqme_ptr

	function decay_tree_get_eval_flows_ptr (decay_tree) result (eval)
	type(evaluator_t), pointer :: eval
	type(decay_tree_t), intent(in), target :: decay_tree
	eval => decay_tree%eval_flows
	end function decay_tree_get_eval_flows_ptr

	@ %def decay_tree_get_eval_sqme_ptr decay_tree_get_eval_flows_ptr
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Events}

	The event record becomes relevant only after cross sections have been
	integrated. It gets filled by some signal process (including
	beam/structure functions) if an event has been successfully been
	generated (passing rejection).

	If requested, particles in the event are subject to decay and/or
	showering. This is not implemented yet.
	<<[[events.f90]]>>=
	<<File header>>

	module events

	<<Use kinds>>
	<<Use strings>>
	use limits, only: RAW_EVENT_FILE_ID_STRING !NODEP!
	<<Use file utils>>
	use diagnostics !NODEP!
	use tao_random_numbers !NODEP!
	use pdf_builtin !NODEP!
	use os_interface
	use lexers
	use parser
	use subevents
	use variables
	use expressions
	use models
	use flavors
	use state_matrices
	use polarizations
	use event_formats
	use hepmc_interface
	use particles
	use interactions
	use evaluators
	use process_libraries
	use beams
	use sf_lhapdf
	use mappings
	use phs_forests
	use cascades
	use processes
	use decays
	use lorentz !NODEP!
	use shower_interface
	use lorentz !NODEP!
	use ckkw_pseudo_weights_module !NODEP!
	use ckkw_matching_module !NODEP!

	<<Standard module head>>

	<<Events: public>>

	<<Events: types>>

	contains

	<<Events: procedures>>

	end module events
	@ %def events
	@
	\subsection{The event type}
	<<Events: public>>=
	public :: event_t
	<<Events: types>>=
	type :: event_t
	private
	integer :: num_proc_id = 0
	type(process_t), pointer :: process => null ()
	type(event_vars_t), pointer :: vars => null ()
	type(decay_tree_t), pointer :: decay_tree => null ()
	logical :: particle_set_exists = .false.
	logical :: is_valid = .false.
	logical :: is_vetoed = .false.
	type(particle_set_t) :: particle_set
	real(default) :: excess = 0
	end type event_t

	@ %def event_t
	@ The event record is initialized with a pointer to a specific
	``signal'' process. The particle set is not (yet) initialized, this
	is done for each event. The event weight and squared matrix element are
	presented as a target, so the
	event record acquires a pointer to this target. The same target is available
	to the analysis evaluation tree.
	<<Events: public>>=
	public :: event_init
	<<Events: procedures>>=
	subroutine event_init (event, process, event_vars, decay_tree)
	type(event_t), intent(out) :: event
	type(process_t), intent(in), target :: process
	type(event_vars_t), intent(in), target :: event_vars
	type(decay_tree_t), intent(in), optional, target :: decay_tree
	event%process => process
	event%vars => event_vars
	if (present (decay_tree)) event%decay_tree => decay_tree
	end subroutine event_init

	@ %def event_init
	@ Finalize the event: delete the particle set.
	<<Events: public>>=
	public :: event_final
	<<Events: procedures>>=
	subroutine event_final (event)
	type(event_t), intent(inout) :: event
	call particle_set_final (event%particle_set)
	event%is_valid = .false.
	end subroutine event_final

	@ %def event_final
	@ Output: Only the particle set is printed explicitly, unless verbose
	format is selected.
	<<Events: public>>=
	public :: event_write
	<<Events: procedures>>=
	subroutine event_write (event, analysis_expr, unit, verbose)
	type(event_t), intent(in) :: event
	type(eval_tree_t), intent(in), optional :: analysis_expr
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, *) repeat ("=", 72)
	write (u, *) "Event record:"
	if (.not. event%is_valid) write (u, *) " [invalid event record]"
	if (associated (event%vars)) then
	call event_vars_write (event%vars, unit)
	end if
	if (associated (event%process)) then
	if (present (verbose)) then
	if (verbose) then
	call process_write (event%process, unit)
	if (present (analysis_expr)) then
	write (u, "(A)") "Analysis expression:"
	call eval_tree_write (analysis_expr, unit)
	write (u, "(A)") repeat ("#", 79)
	end if
	write (u, *)
	end if
	end if
	else
	write (u, *) " [empty]"
	end if
	write (u, *) repeat ("=", 72)
	if (associated (event%decay_tree)) then
	write (u, *) repeat ("=", 72)
	call decay_tree_write (event%decay_tree, unit)
	end if
	write (u, *) " [Process: ", char (process_get_id (event%process)), "]"
	write (u, *)
	call particle_set_write (event%particle_set, unit)
	end subroutine event_write

	@ %def event_write
	@
	\subsection{Event generation}
	Generate a new event and transfer the resulting data to the event
	record.

	The call to [[event_factorize_process]] determines whether the event is
	valid.
	<<Events: public>>=
	public :: event_generate
	<<Events: procedures>>=
	subroutine event_generate (event, rng, unweighted, &
	factorization_mode, keep_correlations, keep_virtual, os_data, &
	shower_settings)
	type(event_t), intent(inout), target :: event
	type(tao_random_state), intent(inout) :: rng
	logical, intent(in) :: unweighted
	integer, intent(in) :: factorization_mode
	logical, intent(in) :: keep_correlations, keep_virtual
	type(os_data_t), intent(in) :: os_data
	!!! shower_settings should be intent(in), but the calls to ckkw_pseudo_shower_weights_init
	!!! and ckkw_fake_pseudo_shower_weights force it to be declared as intent(inout)
	! type(shower_settings_t), intent(in), optional :: shower_settings
	type(shower_settings_t), intent(inout), optional :: shower_settings
	integer :: u

	event%is_vetoed = .false.
	if (unweighted) then
	call process_generate_unweighted_event &
	(event%process, rng, event%vars%excess)
	event%vars%weight = 1
	else
	call process_generate_weighted_event &
	(event%process, rng, event%vars%weight)
	event%vars%excess = 0
	end if
	event%vars%n_in = process_get_n_in (event%process)
	event%vars%n_out = process_get_n_out_real (event%process) ! or _eff?
	event%vars%n_tot = process_get_n_tot_real (event%process) ! or _eff?
	event%vars%sqrts = process_get_sqrts (event%process)
	event%vars%sqrts_hat = process_get_sqrts_hat (event%process)
	event%vars%sqme = process_get_sqme (event%process)
	event%vars%sqme_ref = event%vars%sqme
	if (associated (event%decay_tree)) then
	call decay_tree_generate_event (event%decay_tree, rng)
	end if
	call event_factorize_process (event, rng, &
	factorization_mode, keep_correlations, keep_virtual)
	if(event%particle_set_exists.and.present (shower_settings)) then
	call event_assure_heprup(event)

	if(shower_settings%ckkw_matching) then
	call ckkw_pseudo_shower_weights_init(shower_settings%ckkw_weights)
	call ckkw_fake_pseudo_shower_weights(shower_settings%ckkw_settings, &
	shower_settings%ckkw_weights, event%particle_set)
	end if

	call apply_shower_particle_set(event%particle_set, &
	shower_settings, &
	process_get_model_ptr(event%process), &
	os_data, &
	process_get_strfun_type(event%process), &
	process_get_strfun_set(event%process), &
	event%is_valid, event%is_vetoed)
	end if
	end subroutine event_generate

	@ %def event_generate
	@ Generate fake ckkw weights. This can be dropped, once information from the matrix element
	generation is available.
	<<Events: public>>=
	public :: ckkw_fake_pseudo_shower_weights
	<<Events: procedures>>=
	subroutine ckkw_fake_pseudo_shower_weights(ckkw_pseudo_shower_settings, &
	ckkw_pseudo_shower_weights, particle_set)
	type(ckkw_matching_settings_t), intent(inout) :: ckkw_pseudo_shower_settings
	type(ckkw_pseudo_shower_weights_t), intent(inout) :: ckkw_pseudo_shower_weights
	type(particle_set_t), intent(in) :: particle_set
	integer :: i, j, k
	integer :: n
	type(vector4_t) :: momentum

	ckkw_pseudo_shower_settings%alphaS = 1.0_default
	ckkw_pseudo_shower_settings%Qmin = 1.0_default
	ckkw_pseudo_shower_settings%n_max_jets = 3

	n = 2**particle_set_get_n_tot(particle_set)
	if(allocated(ckkw_pseudo_shower_weights%weights)) then
	deallocate(ckkw_pseudo_shower_weights%weights)
	end if
	allocate(ckkw_pseudo_shower_weights%weights(1:n))
	do i=1,n
	momentum = vector4_null
	do j=1, particle_set_get_n_tot(particle_set)
	if(btest(i,j-1)) then
	momentum = momentum + particle_get_momentum(particle_set_get_particle(particle_set, j))
	end if
	end do
	if(momentum**1 > 0.0) then
	ckkw_pseudo_shower_weights%weights(i) = 1.0 / (momentum**2)
	end if
	end do

	! equally distribute the weights by type
	if(allocated(ckkw_pseudo_shower_weights%weights_by_type)) then
	deallocate(ckkw_pseudo_shower_weights%weights_by_type)
	end if
	allocate(ckkw_pseudo_shower_weights%weights_by_type(1:n, 0:4))
	do i=1,n
	do j=0,4
	ckkw_pseudo_shower_weights%weights_by_type(i,j) = 0.2 * ckkw_pseudo_shower_weights%weights(i)
	end do
	end do
	end subroutine ckkw_fake_pseudo_shower_weights
	@ %def ckkw_fake_pseudo_shower_weights
	@ Apply decay to an existing event:
	<<Events: public>>=
	public :: event_decay
	<<Events: procedures>>=
	subroutine event_decay (event, rng, decay_tree)
	type(event_t), intent(inout) :: event
	type(tao_random_state), intent(inout) :: rng
	type(decay_tree_t), intent(in), target :: decay_tree
	if (event%is_valid) then
	call process_complete_evaluators (event%process)
	event%decay_tree => decay_tree
	call decay_tree_generate_event (event%decay_tree, rng)
	end if
	end subroutine event_decay

	@ %def event_decay
	@ Transfer event data from the process record (if a decay has
	happened: the decay chain) to the event record, factorizing the
	correlated quantum-number state. We use both the colorless and the
	colored evaluators to determine the particle set. The factorization
	of the correlated state is done in one of three modes (unpolarized,
	definite helicity, generic one-particle density matrices); optionally,
	the fully correlated density matrix can also be transferred to the
	particle set.

	The [[is_valid]] flag is set unless factorization fails, e.g., if the matrix
	element squared vanishes.
	<<Events: public>>=
	public :: event_factorize_process
	<<Events: procedures>>=
	subroutine event_factorize_process (event, rng, &
	factorization_mode, keep_correlations, keep_virtual)
	type(event_t), intent(inout), target :: event
	type(tao_random_state), intent(inout) :: rng
	integer, intent(in) :: factorization_mode
	logical, intent(in) :: keep_correlations, keep_virtual
	type(interaction_t), pointer :: int_sqme, int_flows
	real(default), dimension(2) :: r
	integer, dimension(:), allocatable :: beam_index
	integer, dimension(:), allocatable :: incoming_parton_index
	if (associated (event%decay_tree)) then
	int_sqme => evaluator_get_int_ptr &
	(decay_tree_get_eval_sqme_ptr (event%decay_tree))
	int_flows => evaluator_get_int_ptr &
	(decay_tree_get_eval_flows_ptr (event%decay_tree))
	else
	int_sqme => evaluator_get_int_ptr &
	(process_get_eval_sqme_ptr (event%process))
	int_flows => evaluator_get_int_ptr &
	(process_get_eval_flows_ptr (event%process))
	end if
	call tao_random_number (rng, r)
	if (interaction_get_n_in (int_sqme) /= 0) then
	call particle_set_init (event%particle_set, event%is_valid, &
	int_sqme, int_flows, factorization_mode, r, &
	keep_correlations, keep_virtual)
	else
	call particle_set_init (event%particle_set, event%is_valid, &
	int_sqme, int_flows, factorization_mode, r, &
	keep_correlations, keep_virtual, &
	n_incoming = process_get_n_in (event%process))
	end if
	call process_get_beam_index (event%process, beam_index)
	if (allocated (beam_index)) then
	call particle_set_reset_status (event%particle_set, &
	beam_index, PRT_BEAM)
	end if
	call process_get_incoming_parton_index (event%process, &
	incoming_parton_index)
	if (allocated (incoming_parton_index)) then
	call particle_set_reset_status (event%particle_set, &
	incoming_parton_index, PRT_INCOMING)
	end if
	event%particle_set_exists = .true.
	end subroutine event_factorize_process

	@ %def event_factorize_process
	@ Do the reverse operation, as far as possible: Given a complete event, try to
	recover the process kinematics. Assume that the process has been initialized
	correctly.
	<<Events: public>>=
	public :: event_recover_process
	<<Events: procedures>>=
	subroutine event_recover_process (event)
	type(event_t), intent(inout) :: event
	call process_recover_kinematics (event%process, event%particle_set)
	call process_fill_subevt (event%process)
	end subroutine event_recover_process

	@ %def event_recover_process
	@ (Re)compute the event scale, model parameters, $\alpha_s$, matrix element,
	event weight, and user reweighting factor.
	<<Events: public>>=
	public :: event_compute_scale
	public :: event_update_parameters
	public :: event_update_alpha_s
	public :: event_compute_sqme
	public :: event_update_weight
	<<Events: procedures>>=
	subroutine event_compute_scale (event)
	type(event_t), intent(inout) :: event
	call process_compute_scale (event%process)
	end subroutine event_compute_scale

	subroutine event_update_parameters (event)
	type(event_t), intent(inout) :: event
	call process_update_parameters (event%process)
	end subroutine event_update_parameters

	subroutine event_update_alpha_s (event)
	type(event_t), intent(inout) :: event
	call process_update_alpha_s (event%process)
	end subroutine event_update_alpha_s

	subroutine event_compute_sqme (event)
	type(event_t), intent(inout) :: event
	call process_evaluate (event%process)
	event%vars%sqme = process_get_sqme (event%process)
	end subroutine event_compute_sqme

	subroutine event_update_weight (event)
	type(event_t), intent(inout) :: event
	if (event%vars%sqme_ref /= 0) then
	call event_renormalize_weight &
	(event, event%vars%sqme / event%vars%sqme_ref)
	end if
	end subroutine event_update_weight

	@ %def event_compute_scale event_update_parameters event_update_alpha_s
	@ %def event_compute_sqme event_update_weight
	@ Determine whether an event passes selection cuts, if a selection expression
	is defined.
	<<Events: public>>=
	public :: event_passes_selection
	<<Events: procedures>>=
	function event_passes_selection (event, subevt, selection_expr) result (flag)
	logical :: flag
	type(event_t), intent(inout), target :: event
	type(subevt_t), intent(inout), target :: subevt
	type(eval_tree_t), intent(inout), target :: selection_expr
	real(default) :: factor
	if (event%is_valid .and. eval_tree_is_defined (selection_expr)) then
	call particle_set_to_subevt (event%particle_set, subevt)
	call eval_tree_evaluate (selection_expr)
	flag = eval_tree_get_log (selection_expr)
	else
	flag = .true.
	end if
	end function event_passes_selection

	@ %def event_passes_selection
	@ Renormalize the event weight by some factor
	<<Events: public>>=
	public :: event_renormalize_weight
	<<Events: procedures>>=
	subroutine event_renormalize_weight (event, factor)
	type(event_t), intent(inout) :: event
	real(default), intent(in) :: factor
	event%vars%weight = event%vars%weight * factor
	end subroutine event_renormalize_weight

	@ %def event_renormalize_weight
	@ Reweight the event, if a reweighting expression is defined.
	<<Events: public>>=
	public :: event_reweight
	<<Events: procedures>>=
	subroutine event_reweight (event, subevt, reweight_expr)
	type(event_t), intent(inout), target :: event
	type(subevt_t), intent(inout), target :: subevt
	type(eval_tree_t), intent(inout), target :: reweight_expr
	real(default) :: factor
	if (event%is_valid .and. eval_tree_is_defined (reweight_expr)) then
	call particle_set_to_subevt (event%particle_set, subevt)
	call eval_tree_evaluate (reweight_expr)
	factor = eval_tree_get_real (reweight_expr)
	call event_renormalize_weight (event, factor)
	end if
	end subroutine event_reweight

	@ %def event_reweight
	@ Analyze an event. The [[subevt]] object is used as a messenger object to
	store the event particle data; the analysis expression has to be initialized
	before with reference to this object. The analysis results are
	stored as side-effect operations.
	<<Events: public>>=
	public :: event_do_analysis
	<<Events: procedures>>=
	subroutine event_do_analysis (event, subevt, analysis_expr)
	type(event_t), intent(inout), target :: event
	type(subevt_t), intent(inout), target :: subevt
	type(eval_tree_t), intent(inout), target :: analysis_expr
	if (event%is_valid .and. eval_tree_is_defined (analysis_expr)) then
	call particle_set_to_subevt (event%particle_set, subevt)
	call eval_tree_evaluate (analysis_expr)
	end if
	end subroutine event_do_analysis

	@ %def event_do_analysis
	@ Delete any previous contents of the particle set.
	<<Events: procedures>>=
	subroutine event_discard_particle_set (event)
	type(event_t), intent(inout), target :: event
	if (event%particle_set_exists) then
	call particle_set_final (event%particle_set)
	event%particle_set_exists = .false.
	end if
	end subroutine event_discard_particle_set

	@ %def event_discard_particle_set
	@
	\subsection{Contents}
	<<Events: public>>=
	public :: event_is_valid
	<<Events: procedures>>=
	function event_is_valid (event) result (flag)
	logical :: flag
	type(event_t), intent(in) :: event
	flag = event%is_valid
	end function event_is_valid

	@ %def event_is_valid
	@
	<<Events: public>>=
	public :: event_is_vetoed
	<<Events: procedures>>=
	function event_is_vetoed (event) result (flag)
	logical :: flag
	type(event_t), intent(in) :: event
	flag = event%is_vetoed
	end function event_is_vetoed

	@ %def event_is_valid
	\subsection{Binary I/O}
	Read/write the particle set including the associated state matrix
	from/to an unformatted file. This can be used to re-read events
	generated in a previous run.

	Version 2 contains a WHIZARD ID string as header.

	Version 3 contains [[sqrts_hat]] in the event-vars record.
	<<Limits: public parameters>>=
	character(*), parameter, public :: &
	RAW_EVENT_FILE_ID_STRING = "WHIZARD raw event file"
	@ %def RAW_EVENT_FILE_ID_STRING
	@ Collect the MD5 sums in a transparent container:
	<<Events: public>>=
	public :: md5sum_events_t
	<<Events: types>>=
	type :: md5sum_events_t
	character(32), dimension(:), allocatable :: process
	character(32), dimension(:), allocatable :: parameters
	character(32), dimension(:), allocatable :: results
	character(32), dimension(:), allocatable :: polarized
	character(32) :: decays = ""
	character(32) :: simulation = ""
	end type md5sum_events_t

	@ %def md5sum_events_t
	@ Check just the event-file format. Return true if the ID string matches,
	otherwise return false.
	<<Events: public>>=
	public :: is_raw_event_file
	<<Events: procedures>>=
	function is_raw_event_file (unit) result (flag)
	logical :: flag
	integer, intent(in) :: unit
	character(len=len(RAW_EVENT_FILE_ID_STRING)) :: id_string
	integer :: iostat
	read (unit, iostat=iostat) id_string
	if (iostat /= 0) then
	flag = .false.
	else if (id_string /= RAW_EVENT_FILE_ID_STRING) then
	flag = .false.
	else
	flag = .true.
	end if
	end function is_raw_event_file

	@ %def is_raw_event_file
	@ Write and read the header including the MD5 sum info.
	<<Events: public>>=
	public :: raw_event_file_write_header
	public :: raw_event_file_read_header
	<<Events: procedures>>=
	subroutine raw_event_file_write_header (unit, md5sum, version)
	integer, intent(in) :: unit
	type(md5sum_events_t), intent(in) :: md5sum
	integer, intent(in) :: version
	write (unit) RAW_EVENT_FILE_ID_STRING
	write (unit) version
	write (unit) size (md5sum%process)
	write (unit) md5sum%process
	write (unit) md5sum%parameters
	write (unit) md5sum%results
	write (unit) md5sum%polarized
	write (unit) md5sum%decays
	write (unit) md5sum%simulation
	end subroutine raw_event_file_write_header

	subroutine raw_event_file_read_header &
	(unit, rescan, check, md5sum, version, ok, iostat)
	integer, intent(in) :: unit
	logical, intent(in) :: rescan, check
	type(md5sum_events_t), intent(in) :: md5sum
	integer, intent(in) :: version
	logical, intent(out) :: ok
	integer, intent(out), optional :: iostat
	character(len=len(RAW_EVENT_FILE_ID_STRING)) :: id_string
	integer :: file_version, n
	character(32), dimension(:), allocatable :: md5sum_array
	character(32) :: md5sum_single
	logical :: unweighted
	ok = .false.
	read (unit, iostat=iostat) id_string
	if (check .and. id_string /= RAW_EVENT_FILE_ID_STRING) then
	call msg_fatal &
	("File doesn't appear to be a WHIZARD raw event file")
	return
	end if
	read (unit, iostat=iostat) file_version
	if (check .and. file_version /= version) then
	call msg_fatal &
	("Event-file format version mismatch")
	return
	end if
	read (unit, iostat=iostat) n
	if (check .and. n /= size (md5sum%process)) then
	call msg_message &
	("Process number has changed, discarding old event file")
	return
	end if
	allocate (md5sum_array (n))
	read (unit, iostat=iostat) md5sum_array
	if (check .and. any (md5sum%process /= md5sum_array)) then
	call msg_message &
	("Process configuration has changed, discarding old event file")
	return
	end if
	read (unit, iostat=iostat) md5sum_array
	if (check .and. .not. rescan &
	.and. any (md5sum%parameters /= md5sum_array)) then
	call msg_message &
	("Model parameters have changed, discarding old event file")
	return
	end if
	read (unit, iostat=iostat) md5sum_array
	if (check .and. .not. rescan &
	.and. any (md5sum%results /= md5sum_array)) then
	call msg_message &
	("Integration results have changed, skipping event file")
	return
	end if
	read (unit, iostat=iostat) md5sum_array
	if (check .and. any (md5sum%polarized /= md5sum_array)) then
	call msg_message &
	("Polarization setup has changed, discarding old event file")
	return
	end if
	read (unit, iostat=iostat) md5sum_single
	if (check .and. .not. rescan .and. md5sum%decays /= md5sum_single) then
	call msg_message &
	("Decay configuration has changed, skipping event file")
	return
	end if
	read (unit, iostat=iostat) md5sum_single
	if (check .and. md5sum%simulation /= md5sum_single) then
	call msg_message &
	("Simulation parameters have changed, skipping event file")
	return
	end if
	ok = .true.
	end subroutine raw_event_file_read_header

	@ %def raw_event_file_write_header
	@ %def raw_event_file_read_header
	@ Write only valid events; an event read from file is valid by definition.
	<<Events: public>>=
	public :: event_write_raw
	public :: event_read_raw
	<<Events: procedures>>=
	subroutine event_write_raw (event, unit, version)
	type(event_t), intent(in) :: event
	integer, intent(in) :: unit
	integer, intent(in) :: version
	if (event%is_valid) then
	if (.not. associated (event%process)) &
	call msg_bug ("Writing event: process not associated")
	if (.not. associated (event%vars)) &
	call msg_bug ("Writing event: event variables not associated")
	call event_vars_write_raw (event%vars, unit, version)
	write (unit) process_get_scale (event%process)
	write (unit) process_get_fac_scale (event%process)
	write (unit) process_get_ren_scale (event%process)
	write (unit) process_get_alpha_s (event%process)
	call particle_set_write_raw (event%particle_set, unit)
	end if
	end subroutine event_write_raw

	subroutine event_read_raw &
	(event, unit, event_vars, prc_array, num_id_array, iostat, version)
	type(event_t), intent(out) :: event
	integer, intent(in) :: unit
	type(event_vars_t), intent(inout), target :: event_vars
	type(process_p), dimension(:), intent(in) :: prc_array
	integer, dimension(:), intent(in), optional :: num_id_array
	integer, intent(out) :: iostat
	integer, intent(in) :: version
	integer :: proc
	type(process_t), pointer :: process
	real(default) :: scale, ren_scale, fac_scale, alpha_s, sqme
	call event_vars_read_raw (event_vars, unit, iostat, version)
	if (iostat /= 0) return
	proc = event_vars%process_index
	if (proc > 0 .and. proc <= size (prc_array)) then
	process => prc_array(proc)%ptr
	event_vars%process_id = process_get_id (process)
	if (present (num_id_array)) then
	event_vars%process_num_id = num_id_array(proc)
	else
	event_vars%process_num_id = proc
	end if
	else
	call msg_fatal ("Invalid process index encountered in raw event file")
	return
	end if
	call event_init (event, process, event_vars)
	event%is_valid = .true.
	read (unit, iostat=iostat) scale
	if (iostat /= 0) return
	read (unit, iostat=iostat) fac_scale
	if (iostat /= 0) return
	read (unit, iostat=iostat) ren_scale
	if (iostat /= 0) return
	read (unit, iostat=iostat) alpha_s
	if (iostat /= 0) return
	call particle_set_read_raw (event%particle_set, unit, iostat=iostat)
	if (iostat /= 0) return
	event%particle_set_exists = .true.
	if (associated (event%process)) then
	call process_set_particles (event%process, event%particle_set)
	call process_set_scale (event%process, scale)
	call process_set_fac_scale (event%process, fac_scale)
	call process_set_ren_scale (event%process, ren_scale)
	call process_set_alpha_s (event%process, alpha_s)
	call process_set_sqme (event%process, event%vars%sqme)
	end if
	end subroutine event_read_raw

	@ %def event_write_raw
	@ %def event_read_raw
	@
	\subsection{HepMC interface}
	Check whether a file is a HepMC event file. The HepMC format is characterized
	by a version ID string, which apparently follows an empty line. Discard the
	empty line, then check the ID string (but not the version).
	<<Events: public>>=
	public :: is_hepmc_event_file
	<<Events: procedures>>=
	function is_hepmc_event_file (u) result (flag)
	logical :: flag
	integer, intent(in) :: u
	integer :: iostat
	character(*), parameter :: HEPMC_ID_STRING = "HepMC::Version"
	character(len=len(HEPMC_ID_STRING)) :: id_string
	id_string = ""
	do while (id_string == "")
	read (u, "(A)", iostat=iostat) id_string
	if (iostat /= 0) exit
	end do
	if (iostat == 0) then
	flag = id_string == HEPMC_ID_STRING
	else
	flag = .false.
	end if
	end function is_hepmc_event_file

	@ %def is_hepmc_event_file
	@ Read/write the particle set as far as possible from/to a HepMC event record.

	The default weight is unity. The further weights are understood as excess
	weight, squared matrix element, and reference value for the latter, in that
	order. We rely on the HepMC interface routine to return zero for a weight
	that does not exist. When writing to the HepMC event, we rely on the weight
	container to be empty initially.

	The polarization mode must be known when reading from HepMC because
	the HepMC event record does not specify it.

	Write only valid events; an event read from file is valid by definition.
	<<Events: public>>=
	public :: event_read_from_hepmc
	public :: event_write_to_hepmc
	<<Events: procedures>>=
	subroutine event_read_from_hepmc (event, hepmc_event, polarization_mode, &
	event_vars, prc_array, num_id_array)
	type(event_t), intent(out) :: event
	type(hepmc_event_t), intent(in) :: hepmc_event
	integer, intent(in) :: polarization_mode
	type(event_vars_t), intent(inout), target :: event_vars
	type(process_p), dimension(:), intent(in) :: prc_array
	integer, dimension(:), intent(in), optional :: num_id_array
	real(default) :: scale, alpha_s
	integer :: num_id, proc, n_weights
	type(process_t), pointer :: process
	num_id = hepmc_event_get_process_id (hepmc_event)
	proc = get_process_index (num_id, num_id_array)
	if (proc > 0 .and. proc <= size (prc_array)) then
	process => prc_array(proc)%ptr
	call event_init (event, process, event_vars)
	event%is_valid = .true.
	scale = hepmc_event_get_scale (hepmc_event)
	if (scale > 0) call process_set_fac_scale (process, scale)
	alpha_s = hepmc_event_get_alpha_qcd (hepmc_event)
	if (alpha_s > 0) call process_set_alpha_s (process, alpha_s)
	event_vars%event_index = hepmc_event_get_event_index (hepmc_event)
	event_vars%process_index = proc
	event_vars%process_id = process_get_id (process)
	event_vars%process_num_id = num_id
	event_vars%sqrts_hat = 0
	n_weights = hepmc_event_get_weights_size (hepmc_event)
	if (n_weights > 0) then
	event_vars%weight = hepmc_event_get_weight (hepmc_event, 1)
	else
	event_vars%weight = 1
	end if
	event_vars%excess = hepmc_event_get_weight (hepmc_event, 2)
	event_vars%sqme = hepmc_event_get_weight (hepmc_event, 3)
	event_vars%sqme_ref = hepmc_event_get_weight (hepmc_event, 4)
	call particle_set_init (event%particle_set, hepmc_event, &
	process_get_model_ptr (event%process), polarization_mode)
	event%particle_set_exists = .true.
	else
	call hepmc_event_print (hepmc_event)
	write (msg_buffer, "(A,I0,A)") "HepMC event: process ID ", &
	proc, " is invalid in the current context"
	call msg_fatal ()
	end if
	end subroutine event_read_from_hepmc

	subroutine event_write_to_hepmc (event, hepmc_event)
	type(event_t), intent(in) :: event
	type(hepmc_event_t), intent(inout) :: hepmc_event
	if (event%is_valid) then
	call hepmc_event_set_process_id (hepmc_event, event%vars%process_num_id)
	call hepmc_event_clear_weights (hepmc_event)
	call hepmc_event_add_weight (hepmc_event, event%vars%weight)
	call hepmc_event_add_weight (hepmc_event, event%vars%excess)
	call hepmc_event_add_weight (hepmc_event, event%vars%sqme)
	call hepmc_event_add_weight (hepmc_event, event%vars%sqme_ref)
	call hepmc_event_set_scale (hepmc_event, &
	process_get_fac_scale (event%process))
	call hepmc_event_set_alpha_qcd (hepmc_event, &
	process_get_alpha_s (event%process))
	! call hepmc_event_set_cross_section (hepmc_event, &
	! process_get_integral (event%process), &
	! process_get_error (event%process))
	call particle_set_fill_hepmc_event (event%particle_set, hepmc_event)
	end if
	end subroutine event_write_to_hepmc

	@ %def event_read_from_hepmc event_write_to_hepmc
	@
	\subsection{LHEF and HEPEVT interface}
	@ The HEPRUP (event) common block is needed for the interface
	to the shower. Filling of it is triggered by some output file formats.
	If these are not present, the common block is filled with some dummy information.
	Be generous with the number of processes in HEPRUP so that PYTHIA only rarely needs to be
	reinitialized in case events with higher process ids are generated.
	<<Events: public>>=
	public :: event_assure_heprup
	<<Events: procedures>>=
	subroutine event_assure_heprup (event)
	type(event_t), intent(in) :: event
	integer :: i
	integer, parameter :: min_processes = 10

	<<Event formats: parameters>>
	<<Event formats: variables>>
	<<Event formats: common blocks>>

	if (.not.event%is_valid) return
	if(LPRUP(event%vars%process_num_id).ne.0) return

	call heprup_init( &
	(/particle_get_pdg(particle_set_get_particle(event%particle_set, 1)), &
	particle_get_pdg(particle_set_get_particle(event%particle_set, 2)) /) , &
	(/vector4_get_component(particle_get_momentum(particle_set_get_particle(event%particle_set, 1)), 0),&
	vector4_get_component(particle_get_momentum(particle_set_get_particle(event%particle_set, 1)), 0) /), &
	event%vars%process_num_id, .false., .false. )
	do i=1, (event%vars%process_num_id/min_processes+1)*min_processes
	call heprup_set_process_parameters (i = i, process_id = &
	i, cross_section = 1._default, error = 1._default)
	end do
	end subroutine event_assure_heprup

	@ %def event_assure_heprup
	@
	\subsection{Recovering events}
	Recover the process index for this event. If the optional array
	[[num_id_array]] is present, select the entry which matches the given ID,
	otherwise just return the input ID.
	<<Events: procedures>>=
	function get_process_index (num_id, num_id_array) result (proc)
	integer :: proc
	integer, intent(in) :: num_id
	integer, dimension(:), intent(in), optional :: num_id_array
	if (present (num_id_array)) then
	do proc = 1, size (num_id_array)
	if (num_id_array(proc) == num_id) return
	end do
	write (msg_buffer, "(A,I0,A)") "Reading events: numeric process ID ", &
	num_id, " does not match any process"
	call msg_fatal
	proc = 0
	else
	proc = num_id
	end if
	end function get_process_index

	@ %def get_process_index
	@
	Given an event, recover process data.
	<<Events: public>>=
	public :: event_get_process_ptr
	<<Events: procedures>>=
	function event_get_process_ptr (event) result (process)
	type(process_t), pointer :: process
	type(event_t), intent(in) :: event
	process => event%process
	end function event_get_process_ptr

	@ %def event_get_process_ptr
	@
	\subsection{Factorization modes}
	We re-export them here from the [[state_matrices]] module:
	<<Events: public>>=
	public :: FM_IGNORE_HELICITY
	public :: FM_SELECT_HELICITY
	public :: FM_FACTOR_HELICITY
	@ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY
	@
	\subsection{Test}
	<<Events: public>>=
	public :: event_test
	<<Events: procedures>>=
	subroutine event_test ()
	type(os_data_t), pointer :: os_data => null ()
	type(process_library_t), pointer :: prc_lib => null ()
	type(event_t), target :: event
	type(model_t), pointer :: model
	type(var_list_t), pointer :: var_list => null ()
	print , "** Read model file"
	allocate (os_data)
	allocate (prc_lib)
	allocate (var_list)
	call os_data_init (os_data)
	call syntax_model_file_init ()
	call model_list_read_model &
	(var_str("SM"), var_str("SM.mdl"), os_data, model)
	var_list => model_get_var_list_ptr (model)
	call syntax_pexpr_init ()
	call syntax_phs_forest_init ()
	print *
	print , "** Load process library"
	call var_list_append_string (var_list, name = "$library_name", sval = "test_me") ! $
	call var_list_append_log (var_list, name = "?read_color_factors", lval = .true.)
	call var_list_append_log (var_list, name = "?alpha_s_is_fixed", lval = .true.)
	call process_library_init (prc_lib, var_str("test_me"), os_data)
	call process_library_load (prc_lib, os_data, var_list = var_list)
	print *
	call event_test1 (prc_lib, model, os_data, var_list)
	print *
	print , " Cleanup"
	call event_final (event)
	call process_store_final ()
	call syntax_pexpr_final ()
	call syntax_phs_forest_final ()
	call syntax_model_file_final ()
	call process_library_final (prc_lib)
	deallocate (os_data)
	deallocate (prc_lib)
	end subroutine event_test

	@ %def event_test
	<<Events: procedures>>=
	subroutine event_test1 (prc_lib, model, os_data, var_list)
	type(process_library_t), intent(inout) :: prc_lib
	type(model_t), intent(in), target :: model
	type(os_data_t), intent(in) :: os_data
	type(var_list_t), target :: var_list
	type(process_t), pointer :: process
	type(phs_parameters_t) :: phs_par
	type(mapping_defaults_t) :: mapping_defaults
	type(flavor_t), dimension(2) :: flv
	type(polarization_t), dimension(2) :: pol
	type(beam_data_t) :: beam_data
	type(stream_t), target :: stream
	type(parse_tree_t) :: parse_tree
	type(grid_parameters_t) :: grid_parameters
	integer :: i
	type(tao_random_state) :: rng
	type(event_vars_t), target :: event_vars
	type(event_t), target :: event
	type(decay_tree_t), target :: decay_tree
	logical :: rebuild_phs = .true.
	print , "** Test process setup"
	print *
	print , " Initialization"
	call tao_random_create (rng, 0)
	call process_store_init_process &
	(process, prc_lib, var_str ("test_me_unit_col"), model, &
	var_list, use_beams = .false.)
	print *, " Process ID = ", char (process_get_id (process))
	print *
	print , " Beam setup"
	print *
	call flavor_init (flv, (/ 2, -2 /), model)
	call polarization_init_unpolarized (pol(1), flv(1))
	call polarization_init_unpolarized (pol(2), flv(2))
	call process_setup_beams (process, beam_data, 0, sqrts = 1000._default)
	call process_connect_strfun (process)
	call process_setup_subevt (process)
	print *
	print , " Phase space setup"
	call openmp_set_num_threads_verbose (1)
	call process_setup_phase_space (process, rebuild_phs, &
	os_data, phs_par, mapping_defaults, filename_out=var_str("test_me_unit_col.phs"), &
	vis_channels = .false.)
	print *
	print , " Cuts setup"
	call stream_init (stream, var_str ("all Pt > 200 GeV [g]"))
	call parse_tree_init_lexpr (parse_tree, stream, .true.)
	call process_setup_cuts (process, parse_tree_get_root_ptr (parse_tree))
	call parse_tree_final (parse_tree)
	call stream_final (stream)
	print *
	print , "** Integration"
	print , " Grids setup"
	call process_setup_grids (process, grid_parameters, calls=10000)
	print *
	print , " 5 + 3 iterations"
	call process_results_write_header (process)
	call process_init_vamp_history (process, 8)
	call openmp_set_num_threads_verbose (1)
	do i = 1, 5
	call process_integrate (process, rng, grid_parameters, &
	1, 1, 1, 5000, i==1, .true., i>2, .true., .true.)
	end do
	call process_results_write_current_average (process)
	call process_integrate (process, rng, grid_parameters, &
	2, 1, 3, 5000, .true., .false., .true., .true., .true.)
	call process_results_write_footer (process)
	call process_write_time_estimate (process)
	print *
	print , "** Event generation"
	call process_setup_event_generation (process)
	call decay_tree_init (decay_tree, process)
	call event_init (event, process, event_vars, decay_tree=decay_tree)
	print *
	print , " Weighted event"
	call event_generate &
	(event, rng, .false., FM_IGNORE_HELICITY, .false., .false., os_data)
	call event_write (event)
	print *
	print , " Unweighted event"
	call event_generate &
	(event, rng, .true., FM_SELECT_HELICITY, .false., .true., os_data)
	call event_write (event)
	print *, " Process data written to fort.81"
	call process_write (process, 81)
	call event_final (event)
	end subroutine event_test1

	@ %def event_test1
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Event files configuration}
	This module manages the file formats and the file list for reading and writing
	events.
	<<[[event_files.f90]]>>=
	<<File header>>

	module event_files

	<<Use kinds>>
	use kinds, only: i64 !NODEP!
	<<Use strings>>
	<<Use file utils>>
	use diagnostics !NODEP!
	use variables
	use expressions
	use flavors
	use event_formats
	use processes
	use stdhep_interface
	use hepmc_interface
	use events
	use decays

	<<Standard module head>>

	<<Event files: public>>

	<<Event files: parameters>>

	<<Event files: types>>

	contains

	<<Event files: procedures>>

	end module event_files
	@ %def event_files
	@
	\subsection{Available formats}
	Files have a name and a format; we need lists of file specifications.
	Writing LHEF files, we need beam information and overall process data.
	<<Event files: public>>=
	<<Event files: parameters>>=
	integer, parameter, public :: FMT_NONE = 0
	integer, parameter, public :: FMT_RAW = -1
	integer, parameter, public :: FMT_DEFAULT = 1
	integer, parameter, public :: FMT_DEBUG = 2
	integer, parameter, public :: FMT_HEPMC = 10
	integer, parameter, public :: FMT_LHEF = 20
	integer, parameter, public :: FMT_LHA = 21
	integer, parameter, public :: FMT_LHA_VERB = 29
	integer, parameter, public :: FMT_HEPEVT = 30
	integer, parameter, public :: FMT_ASCII_SHORT = 31
	integer, parameter, public :: FMT_ASCII_LONG = 32
	integer, parameter, public :: FMT_ATHENA = 33
	integer, parameter, public :: FMT_MOKKA = 34
	integer, parameter, public :: FMT_HEPEVT_VERB = 39
	integer, parameter, public :: FMT_STDHEP = 40
	integer, parameter, public :: FMT_STDHEP_UP = 41

	@ %def FMT_NONE FMT_RAW
	@ %def FMT_DEFAULT FMT_DEBUG
	@ %def FMT_HEPMC FMT_LHEF FMT_LHA
	@ %def FMT_HEPEVT FMT_ASCII_SHORT FMT_ASCII_LONG
	@ %def FMT_MOKKA FMT_ATHENA FMT_STDHEP FMT_STDHEP_UP
	@ %def FMT_HEPEVT_VERB FMT_LHA_VERB
	@ Determine the format of an event file. Check first if it is raw format, then
	HepMC. Other formats are not (yet) recognized.
	<<Event files: public>>=
	public :: event_file_get_format
	<<Event files: procedures>>=
	function event_file_get_format (file) result (fmt)
	integer :: fmt
	type(string_t), intent(in) :: file
	if (is_raw_fmt (file)) then
	fmt = FMT_RAW
	else if (is_hepmc_fmt (file)) then
	fmt = FMT_HEPMC
	else
	fmt = FMT_NONE
	end if
	end function event_file_get_format

	@ %def event_file_get_format
	@ The raw format is actually unformatted.
	<<Event files: procedures>>=
	function is_raw_fmt (file) result (flag)
	logical :: flag
	type(string_t), intent(in) :: file
	integer :: u, iostat
	u = free_unit ()
	open (unit=u, file=char(file), action="read", status="old", &
	form="unformatted", iostat=iostat)
	if (iostat == 0) then
	flag = is_raw_event_file (u)
	close (u)
	else
	flag = .false.
	end if
	end function is_raw_fmt

	@ %def is_raw_fmt
	@ The HepMC format is characterized by an ID string, which apparently follows
	an empty line. Discard empty lines when checking the ID.
	<<Event files: procedures>>=
	function is_hepmc_fmt (file) result (flag)
	logical :: flag
	type(string_t), intent(in) :: file
	integer :: u, iostat
	open (unit=u, file=char(file), action="read", status="old", iostat=iostat)
	if (iostat == 0) then
	flag = is_hepmc_event_file (u)
	close (u)
	else
	flag = .false.
	end if
	end function is_hepmc_fmt

	@ %def is_hepmc_fmt
	@
	\subsection{Reading event files}
	Apart from the raw event format which is handled in the [[events]] module, we
	currently support reading only for HepMC.
	<<Event files: public>>=
	public :: input_event_stream_t
	<<Event files: types>>=
	type :: input_event_stream_t
	integer :: fmt = FMT_NONE
	integer :: polarization_mode = FM_IGNORE_HELICITY
	type(hepmc_iostream_t), pointer :: iostream => null ()
	end type input_event_stream_t

	@ %def input_event_stream_t
	<<Event files: public>>=
	public :: input_event_stream_init
	<<Event files: procedures>>=
	subroutine input_event_stream_init (input_stream, file, fmt)
	type(input_event_stream_t), intent(out) :: input_stream
	type(string_t), intent(in) :: file
	integer, intent(in) :: fmt
	input_stream%fmt = fmt
	select case (input_stream%fmt)
	case (FMT_HEPMC)
	if (hepmc_is_available ()) then
	allocate (input_stream%iostream)
	call hepmc_iostream_open_in (input_stream%iostream, file)
	else
	call msg_fatal ("HepMC event reading is disabled " &
	// "because HepMC library is not linked.")
	input_stream%fmt = FMT_NONE
	end if
	case default
	call msg_bug ("Unsupported file format selected for reading events.")
	end select
	end subroutine input_event_stream_init

	@ %def input_event_stream_init
	<<Event files: public>>=
	public :: input_event_stream_read_event
	<<Event files: procedures>>=
	subroutine input_event_stream_read_event (input_stream, event, &
	event_vars, prc_array, ok, num_id_array)
	type(input_event_stream_t), intent(inout) :: input_stream
	type(event_t), intent(out) :: event
	type(event_vars_t), intent(inout), target :: event_vars
	type(process_p), dimension(:), intent(in) :: prc_array
	logical, intent(out) :: ok
	integer, dimension(:), intent(in), optional :: num_id_array
	type(hepmc_event_t) :: hepmc_event
	select case (input_stream%fmt)
	case (FMT_HEPMC)
	call hepmc_event_init (hepmc_event)
	call hepmc_iostream_read_event (input_stream%iostream, hepmc_event, ok)
	if (ok) then
	call event_read_from_hepmc &
	(event, hepmc_event, input_stream%polarization_mode, &
	event_vars, prc_array, num_id_array)
	! call hepmc_event_print (hepmc_event)
	end if
	call hepmc_event_final (hepmc_event)
	end select
	end subroutine input_event_stream_read_event

	@ %def input_event_stream_read
	<<Event files: public>>=
	public :: input_event_stream_final
	<<Event files: procedures>>=
	subroutine input_event_stream_final (input_stream)
	type(input_event_stream_t), intent(inout) :: input_stream
	select case (input_stream%fmt)
	case (FMT_HEPMC)
	call hepmc_iostream_close (input_stream%iostream)
	deallocate (input_stream%iostream)
	end select
	input_stream%fmt = FMT_NONE
	end subroutine input_event_stream_final

	@ %def input_event_stream_final
	@
	\subsection{Output file specification and file list}
	<<Event files: types>>=
	type :: file_spec_t
	private
	type(string_t) :: name
	integer :: format = FMT_NONE
	type(hepmc_iostream_t), pointer :: iostream => null ()
	integer :: unit = 0
	type(flavor_t), dimension(:), allocatable :: beam_flv
	real(default), dimension(:), allocatable :: beam_energy
	real(default), dimension(:), allocatable :: integral
	real(default), dimension(:), allocatable :: error
	integer :: n_processes = 0
	logical :: unweighted = .true.
	logical :: negative_weights = .false.
	logical :: keep_beams = .false.
	type(file_spec_t), pointer :: next => null ()
	end type file_spec_t

	@ %def file_spec_t
	@ File lists.
	<<Event files: public>>=
	public :: event_file_list_t
	<<Event files: types>>=
	type :: event_file_list_t
	private
	type(file_spec_t), pointer :: first => null ()
	type(file_spec_t), pointer :: last => null ()
	end type event_file_list_t

	@ %def event_file_list_t
	<<Event files: public>>=
	public :: event_file_list_append_file_spec
	<<Event files: procedures>>=
	subroutine event_file_list_append_file_spec &
	(event_file_list, basename, var_list, format, beam_flv, beam_energy, &
	n_processes)
	! unweighted, negative_weights, &
	type(event_file_list_t), intent(inout) :: event_file_list
	type(string_t), intent(in) :: basename
	type(var_list_t), intent(in) :: var_list
	integer, intent(in) :: format
	type(flavor_t), dimension(:), intent(in) :: beam_flv
	real(default), dimension(:), intent(in) :: beam_energy
	integer, intent(in) :: n_processes
	! logical, intent(in) :: unweighted, negative_weights
	type(file_spec_t), pointer :: current
	allocate (current)
	select case (format)
	case (FMT_DEFAULT); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_default"))
	case (FMT_DEBUG); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_debug"))
	case (FMT_HEPMC); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_hepmc"))
	case (FMT_LHEF); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_lhef"))
	case (FMT_LHA); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_lha"))
	case (FMT_HEPEVT); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_hepevt"))
	case (FMT_ASCII_SHORT); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_ascii_short"))
	case (FMT_ASCII_LONG); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_ascii_long"))
	case (FMT_ATHENA); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_athena"))
	case (FMT_MOKKA); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_mokka"))
	case (FMT_STDHEP); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_stdhep"))
	case (FMT_STDHEP_UP); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_stdhep_up"))
	case (FMT_HEPEVT_VERB); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_hepevt_verbose"))
	case (FMT_LHA_VERB); current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_lha_verbose"))
	case default; current%name = basename // "." // var_list_get_sval &
	(var_list, var_str ("$extension_default"))
	end select
	current%format = format
	allocate (current%beam_flv (size (beam_flv)))
	current%beam_flv = beam_flv
	allocate (current%beam_energy (size (beam_energy)))
	current%beam_energy = beam_energy
	current%n_processes = n_processes
	current%keep_beams = var_list_get_lval (var_list, var_str ("?keep_beams"))
	if (associated (event_file_list%last)) then
	event_file_list%last%next => current
	else
	event_file_list%first => current
	end if
	event_file_list%last => current
	end subroutine event_file_list_append_file_spec

	@ %def event_file_list_append_file_spec
	<<Event files: procedures>>=
	subroutine event_file_list_final (event_file_list)
	type(event_file_list_t), intent(inout) :: event_file_list
	type(file_spec_t), pointer :: current
	do while (associated (event_file_list%first))
	current => event_file_list%first
	event_file_list%first => current%next
	deallocate (current)
	end do
	event_file_list%last => null ()
	end subroutine event_file_list_final

	@ %def event_file_list_final
	@
	\subsection{Checking filenames}
	Check if a filename is reserved as an output filename.
	<<Event files: public>>=
	public :: event_file_list_is_filename
	<<Event files: procedures>>=
	function event_file_list_is_filename (event_file_list, filename) result (flag)
	logical :: flag
	type(event_file_list_t), intent(in) :: event_file_list
	type(string_t), intent(in) :: filename
	type(file_spec_t), pointer :: current
	current => event_file_list%first
	do while (associated (current))
	if (current%name == filename) then
	flag = .true.
	return
	end if
	current => current%next
	end do
	flag = .false.
	end function event_file_list_is_filename

	@ %def event_file_list_is_filename
	@
	\subsection{Handling output event files}
	LHEF: Initialize run data with beam and simulation parameters.
	<<Event files: public>>=
	public :: event_file_list_open
	<<Event files: procedures>>=
	subroutine event_file_list_open (event_file_list, process_id, n_events, var_list)
	type(event_file_list_t), intent(inout), target :: event_file_list
	type(string_t), dimension(:), intent(in) :: process_id
	integer, intent(in) :: n_events
	real(default), dimension(:), allocatable :: integral, error
	type(var_list_t), intent(in) :: var_list
	type(process_t), pointer :: process
	type(file_spec_t), pointer :: current
	integer :: i, n_proc
	integer(i64) :: n_events_expected
	n_proc = size (process_id)
	current => event_file_list%first
	allocate (integral (n_proc), error (n_proc))
	do i = 1, n_proc
	process => process_store_get_process_ptr (process_id(i))
	if (associated (process)) then
	integral(i) = process_get_integral (process)
	error(i) = process_get_error (process)
	else
	integral(i) = 0
	error(i) = 0
	end if
	end do
	n_events_expected = n_events
	do while (associated (current))
	select case (current%format)
	case (FMT_DEFAULT)
	call msg_message ("Writing events in human-readable format " &
	// "to file '" // char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_DEBUG)
	call msg_message ("Writing events in verbose format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_HEPMC)
	call msg_message ("Writing events in HepMC format to file '" &
	// char (current%name) // "'")
	if (hepmc_is_available ()) then
	allocate (current%iostream)
	call hepmc_iostream_open_out (current%iostream, current%name)
	else
	call msg_error ("HepMC event writing is disabled " &
	// "because HepMC library is not linked.")
	end if
	case (FMT_HEPEVT)
	call msg_message ("Writing events in HEPEVT format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_ASCII_SHORT)
	call msg_message ("Writing events in short ASCII format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_ASCII_LONG)
	call msg_message ("Writing events in long ASCII format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_ATHENA)
	call msg_message ("Writing events in ATHENA format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_MOKKA)
	call msg_message ("Writing events in MOKKA format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_LHEF)
	call msg_message ("Writing events in LHEF format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	call les_houches_events_write_header (current%unit)
	call heprup_init &
	(flavor_get_pdg (current%beam_flv), &
	current%beam_energy, &
	n_processes = current%n_processes, &
	unweighted = current%unweighted, &
	negative_weights = current%negative_weights)
	do i = 1, n_proc
	call heprup_set_process_parameters (i = i, process_id = &
	i, cross_section = integral(i), error = error(i))
	end do
	call heprup_write_lhef (current%unit)
	case (FMT_LHA)
	call msg_message ("Writing events in (old) LHA format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	call heprup_init &
	(flavor_get_pdg (current%beam_flv), &
	current%beam_energy, &
	n_processes = current%n_processes, &
	unweighted = current%unweighted, &
	negative_weights = current%negative_weights)
	do i = 1, n_proc
	call heprup_set_process_parameters (i = i, process_id = &
	i, cross_section = integral(i), error = error(i))
	end do
	case (FMT_STDHEP)
	call msg_message ("Writing events in binary STDHEP/HEPEVT format to file '" &
	// char (current%name) // "'")
	call stdhep_init (char(current%name), "WHIZARD event sample", &
	n_events_expected)
	case (FMT_STDHEP_UP)
	call msg_message ("Writing events in binary STDHEP/HEPRUP/HEPEUP format to file '" &
	// char (current%name) // "'")
	call heprup_init &
	(flavor_get_pdg (current%beam_flv), &
	current%beam_energy, &
	n_processes = current%n_processes, &
	unweighted = current%unweighted, &
	negative_weights = current%negative_weights)
	do i = 1, n_proc
	call heprup_set_process_parameters (i = i, process_id = &
	i, cross_section = integral(i), error = error(i))
	end do
	call stdhep_init (char(current%name), "WHIZARD event sample", &
	n_events_expected)
	call stdhep_write (STDHEP_HEPRUP)
	case (FMT_HEPEVT_VERB)
	call msg_message ("Writing events in verbose HEPEVT format to file '" &
	// char (current%name) // "'")
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	case (FMT_LHA_VERB)
	call msg_message ("Writing events in verbose HEPRUP/HEPEUP format to file '" &
	// char (current%name) // "'")
	call heprup_init &
	(flavor_get_pdg (current%beam_flv), &
	current%beam_energy, &
	n_processes = current%n_processes, &
	unweighted = current%unweighted, &
	negative_weights = current%negative_weights)
	do i = 1, n_proc
	call heprup_set_process_parameters (i = i, process_id = &
	i, cross_section = integral(i), error = error(i))
	end do
	current%unit = free_unit ()
	open (unit=current%unit, file=char(current%name), &
	action="write", status="replace")
	call heprup_write_verbose (current%unit)
	end select
	current => current%next
	end do
	end subroutine event_file_list_open

	@ %def event_file_list_open
	@ Scan the file list and write the event in the selected formats.
	<<Event files: public>>=
	public :: event_file_list_write_event
	<<Event files: procedures>>=
	subroutine event_file_list_write_event &
	(event_file_list, event, integral_sum, error_sum, analysis_expr, i_evt)
	type(event_file_list_t), intent(in), target :: event_file_list
	type(event_t), intent(in), target :: event
	real(default), intent(in) :: integral_sum, error_sum
	type(eval_tree_t), intent(in) :: analysis_expr
	integer, intent(in) :: i_evt
	type(file_spec_t), pointer :: current
	type(hepmc_event_t) :: hepmc_event
	current => event_file_list%first
	do while (associated (current))
	select case (current%format)
	case (FMT_DEFAULT)
	call event_write (event, unit=current%unit, verbose=.false.)
	case (FMT_DEBUG)
	call event_write (event, analysis_expr=analysis_expr, &
	unit=current%unit, verbose=.true.)
	case (FMT_HEPMC)
	if (hepmc_is_available ()) then
	call hepmc_event_init (hepmc_event, event_id=i_evt)
	call hepmc_event_set_cross_section (hepmc_event, &
	integral_sum, error_sum)
	call event_write_to_hepmc (event, hepmc_event)
	! call hepmc_event_print (hepmc_event)
	call hepmc_iostream_write_event (current%iostream, hepmc_event)
	call hepmc_event_final (hepmc_event)
	end if
	case (FMT_HEPEVT)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_hepevt (current%unit)
	case (FMT_ASCII_SHORT)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_ascii (current%unit, .false.)
	case (FMT_ASCII_LONG)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_ascii (current%unit, .true.)
	case (FMT_ATHENA)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_athena (unit=current%unit, i_evt=i_evt)
	case (FMT_MOKKA)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_mokka (unit=current%unit)
	case (FMT_LHEF)
	call event_write_to_hepeup (event, current%keep_beams)
	call hepeup_write_lhef (current%unit)
	case (FMT_LHA)
	call event_write_to_hepeup (event, current%keep_beams)
	call hepeup_write_lha (current%unit)
	case (FMT_STDHEP)
	call event_write_to_hepevt (event, current%keep_beams)
	call stdhep_write (STDHEP_HEPEVT)
	case (FMT_STDHEP_UP)
	call event_write_to_hepeup (event, current%keep_beams)
	call stdhep_write (STDHEP_HEPEUP)
	case (FMT_HEPEVT_VERB)
	call event_write_to_hepevt (event, current%keep_beams)
	call hepevt_write_verbose (current%unit)
	case (FMT_LHA_VERB)
	call event_write_to_hepeup (event, current%keep_beams)
	call hepeup_write_verbose (current%unit)
	end select
	current => current%next
	end do
	end subroutine event_file_list_write_event

	@ %def event_file_list_write_event
	@ Close streams.
	<<Event files: public>>=
	public :: event_file_list_close
	<<Event files: procedures>>=
	subroutine event_file_list_close (event_file_list)
	type(event_file_list_t), intent(inout), target :: event_file_list
	type(file_spec_t), pointer :: current
	current => event_file_list%first
	do while (associated (current))
	select case (current%format)
	case (FMT_HEPMC)
	if (hepmc_is_available ()) then
	call hepmc_iostream_close (current%iostream)
	deallocate (current%iostream)
	end if
	case (FMT_LHEF)
	call les_houches_events_write_footer (current%unit)
	close (current%unit)
	case (FMT_STDHEP)
	call stdhep_end
	case (FMT_STDHEP_UP)
	call stdhep_end
	case default
	close (current%unit)
	end select
	current => current%next
	end do
	end subroutine event_file_list_close

	@ %def event_file_list_close
	@
	\subsection{Additional tools}
	<<Event files: public>>=
	public :: event_format_code
	<<Event files: procedures>>=
	elemental function event_format_code (format) result (fmt)
	integer :: fmt
	type(string_t), intent(in) :: format
	select case (char (format))
	case ("ascii")
	fmt = FMT_DEFAULT
	case ("debug")
	fmt = FMT_DEBUG
	case ("hepmc")
	fmt = FMT_HEPMC
	case ("hepevt")
	fmt = FMT_HEPEVT
	case ("short")
	fmt = FMT_ASCII_SHORT
	case ("long")
	fmt = FMT_ASCII_LONG
	case ("athena")
	fmt = FMT_ATHENA
	case ("mokka")
	fmt = FMT_MOKKA
	case ("lhef")
	fmt = FMT_LHEF
	case ("lha")
	fmt = FMT_LHA
	case ("stdhep")
	fmt = FMT_STDHEP
	case ("stdhep_up")
	fmt = FMT_STDHEP_UP
	case ("hepevt_verbose")
	fmt = FMT_HEPEVT_VERB
	case ("lha_verbose")
	fmt = FMT_LHA_VERB
	case default
	fmt = FMT_NONE
	end select
	end function event_format_code

	@ %def event_format_code
	@
	\subsection{Simulation parameters}
	This transparent container holds the parameters that control event
	generation.

	\emph{This and the following section (simulation object) should end up in a
	separate module. We defer this until it is clear whether we need anything
	from the [[integrate]] command to be complete.}
	<<XXX Simulations: parameters>>=
	integer, parameter :: NORM_UNDEFINED = 0
	integer, parameter :: NORM_UNIT = 1
	integer, parameter :: NORM_N_EVT = 2
	integer, parameter :: NORM_SIGMA = 3
	integer, parameter :: NORM_SIGMA_N_EVT = 4

	@ %def NORM_AUTO NORM_UNIT NORM_N_EVT NORM_SIGMA NORM_SIGMA_N_EVT
	<<XXX Simulations: types>>=
	type :: simulation_parameters_t
	logical :: unweighted = .true.
	logical :: use_best_grid = .true.
	integer :: normalization_mode = NORM_UNDEFINED
	logical :: negative_weights = .false.
	logical :: polarized = .false.
	type(shower_settings_t) :: shower_settings
	end type simulation_parameters_t

	@ %def simulation_parameters_t
	@ Initialize the generic simulation parameters.
	<<XXX Simulations: procedures>>=
	recursive subroutine simulation_parameters_init &
	(sim, unweighted, use_best_grid, event_normalization, negative_weights, &
	polarized)
	type(simulation_parameters_t), intent(out) :: sim
	logical, intent(in) :: unweighted
	logical, intent(in) :: use_best_grid
	type(string_t), intent(in) :: event_normalization
	logical, intent(in) :: negative_weights, polarized
	sim%unweighted = unweighted
	sim%use_best_grid = use_best_grid
	sim%negative_weights = negative_weights
	sim%polarized = polarized
	select case (char (event_normalization))
	case ("auto", "Auto", "AUTO", "automatic", "Automatic", "AUTOMATIC")
	if (unweighted) then
	sim%normalization_mode = NORM_UNIT
	else
	sim%normalization_mode = NORM_SIGMA
	end if
	case ("1", "unity", "Unity", "UNITY")
	sim%normalization_mode = NORM_UNIT
	case ("1/n", "1/N")
	sim%normalization_mode = NORM_N_EVT
	case ("sigma", "Sigma", "SIGMA")
	sim%normalization_mode = NORM_SIGMA
	case ("sigma/n", "Sigma/n", "Sigma/N", "SIGMA/N")
	sim%normalization_mode = NORM_SIGMA_N_EVT
	case default
	call msg_error ("Unknown value '" // char (event_normalization) &
	// "for $event_normalization. I'll assume 'auto'")
	call simulation_parameters_init &
	(sim, unweighted, use_best_grid, var_str ("auto"), &
	negative_weights, polarized)
	end select
	end subroutine simulation_parameters_init

	@ %def simulation_parameters_init
	@ Initialize the shower parameters.
	<<XXX Simulations: procedures>>=
	subroutine simulation_parameters_init_shower (sim, var_list)
	type(simulation_parameters_t), intent(inout) :: sim
	type(var_list_t), intent(in) :: var_list
	call shower_settings_init (sim%shower_settings, var_list)
	end subroutine simulation_parameters_init_shower

	@ %def simulation_parameters_init_shower
	<<XXX Simulations: procedures>>=
	subroutine simulation_parameters_write_message (sim, unit)
	type(simulation_parameters_t), intent(in) :: sim
	integer, intent(in), optional :: unit
	type(string_t) :: weight_str, grid_str, norm_str, neg_str, polarized_str
	if (sim%unweighted) then
	weight_str = "unweighted"
	else
	weight_str = "weighted"
	end if
	if (sim%use_best_grid) then
	grid_str = ", best grid"
	else
	grid_str = ", last grid"
	end if
	if (sim%polarized) then
	polarized_str = ", polarized events"
	else
	polarized_str = ", unpolarized_events"
	end if
	select case (sim%normalization_mode)
	case (NORM_UNIT)
	norm_str = "1"
	case (NORM_N_EVT)
	norm_str = "1/n"
	case (NORM_SIGMA)
	norm_str = "sigma"
	case (NORM_SIGMA_N_EVT)
	norm_str = "sigma/n"
	case default
	norm_str = "unknown"
	end select
	if (sim%negative_weights) then
	neg_str = ", allow negative weights"
	else
	neg_str = ""
	end if
	call msg_message ("Simulation mode = " &
	// char (weight_str) // char (grid_str), &
	unit)
	call msg_message (" " &
	// "event_normalization = '" // char (norm_str) &
	// "'" // char (neg_str) // char (polarized_str), &
	unit)
	end subroutine simulation_parameters_write_message

	@ %def simulation_parameters_write
	<<XXX Simulations: procedures>>=
	subroutine simulation_parameters_write (sim, unit)
	type(simulation_parameters_t), intent(in) :: sim
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit)
	write (u, *) "Simulation parameters:"
	write (u, *) " unweighted = ", sim%unweighted
	write (u, *) " use best grid = ", sim%use_best_grid
	write (u, *) " normalization_mode = ", sim%normalization_mode
	write (u, *) " negative_weights = ", sim%negative_weights
	write (u, *) " polarized = ", sim%polarized
	call shower_settings_write (sim%shower_settings, unit)
	end subroutine simulation_parameters_write

	@ %def simulation_parameters_write
	<<XXX Simulations: procedures>>=
	function simulation_parameters_get_norm (sim, sigma, n) result (norm)
	real(default) :: norm
	type(simulation_parameters_t), intent(in) :: sim
	real(default), intent(in) :: sigma
	integer, intent(in) :: n
	select case (sim%normalization_mode)
	case (NORM_UNIT)
	norm = 1
	case (NORM_N_EVT)
	if (n /= 0) then
	norm = 1._default / n
	else
	norm = 1
	end if
	case (NORM_SIGMA)
	norm = sigma
	case (NORM_SIGMA_N_EVT)
	if (n /= 0) then
	norm = sigma / n
	else
	norm = sigma
	end if
	case default
	norm = 1
	end select
	if ((.not. sim%unweighted) .and. sigma /= 0) norm = norm / sigma
	end function simulation_parameters_get_norm

	@ %def simulation_parameters_get_norm
	<<XXX Simulations: procedures>>=
	function simulation_parameters_get_md5sum (sim) result (md5sum_sim)
	character(32) :: md5sum_sim
	type(simulation_parameters_t), intent(in) :: sim
	integer :: u
	u = free_unit ()
	open (u, status = "scratch")
	call simulation_parameters_write (sim, u)
	rewind (u)
	md5sum_sim = md5sum (u)
	close (u)
	end function simulation_parameters_get_md5sum

	@ %def simulation_parameters_get_md5sum
	@
	\subsection{Screen updates during simulation}
	To pacify the user during long event generation runs, we can display some data
	about the current progress on screen.
	<<XXX Simulations: parameters>>=
	character(*), parameter :: &
	checkpoint_head = &
	"\| % complete \| events generated \| events remaining \| time remaining", &
	checkpoint_bar = &
	"\|===================================================================\|", &
	checkpoint_fmt = "(' ',F5.1,T16,I9,T35,I9,T56,A)"

	@ %def checkpoint_head
	@ %def checkpoint_bar
	@ %def checkpoint_fmt
	<<XXX Simulations: types>>=
	type :: checkpointing_t
	logical :: active = .false.
	logical :: running = .false.
	integer :: val = 0
	real(default) :: tzero = 0
	end type checkpointing_t

	@ %def checkpointing_t
	<<XXX Simulations: procedures>>=
	subroutine checkpointing_init (checkpointing, var_list)
	type(checkpointing_t), intent(out) :: checkpointing
	type(var_list_t), intent(in) :: var_list
	checkpointing%active = var_list_is_known (var_list, var_str ("checkpoint"))
	if (checkpointing%active) then
	checkpointing%val = &
	var_list_get_ival (var_list, var_str("checkpoint"))
	if (checkpointing%val <= 0) then
	call msg_warning ("ignoring nonpositive value of 'checkpoint'")
	checkpointing%active = .false.
	end if
	end if
	end subroutine checkpointing_init

	@ %def checkpointing_init
	<<XXX Simulations: procedures>>=
	subroutine checkpointing_msg_start (checkpointing, n_events, i_evt)
	type(checkpointing_t), intent(inout) :: checkpointing
	integer, intent(in) :: n_events, i_evt
	if (checkpointing%active .and. n_events > i_evt) then
	call msg_message ("")
	call msg_message (checkpoint_bar)
	call msg_message (checkpoint_head)
	call msg_message (checkpoint_bar)
	write (msg_buffer, checkpoint_fmt) 0., 0, n_events - i_evt, "???"
	call msg_message ()
	checkpointing%running = .true.
	checkpointing%tzero = time_current ()
	end if
	end subroutine checkpointing_msg_start

	@ %def checkpointing_msg_start
	<<XXX Simulations: procedures>>=
	subroutine checkpointing_msg_event (checkpointing, n_events, n_read, i_evt)
	type(checkpointing_t), intent(in) :: checkpointing
	integer, intent(in) :: n_events, n_read, i_evt
	real(default) :: tcurrent
	type(string_t) :: tremain
	if (checkpointing%active .and. checkpointing%running &
	.and. mod (i_evt, checkpointing%val) == 0) then
	tcurrent = time_current ()
	tremain = time2string ( &
	int ((tcurrent - checkpointing%tzero) / (i_evt - n_read) &
	* (n_events - i_evt)))
	write (msg_buffer, checkpoint_fmt) &
	100 * (i_evt - n_read) / real (n_events - n_read), &
	i_evt - n_read, &
	n_events - i_evt, char (tremain)
	call msg_message ()
	end if
	end subroutine checkpointing_msg_event

	@ %def checkpointing_msg_event
	<<XXX Simulations: procedures>>=
	subroutine checkpointing_msg_end (checkpointing, n_read, i_evt)
	type(checkpointing_t), intent(inout) :: checkpointing
	integer, intent(in) :: n_read, i_evt
	if (checkpointing%active .and. checkpointing%running) then
	if (mod (i_evt, checkpointing%val) /= 0) then
	write (msg_buffer, checkpoint_fmt) 100., i_evt - n_read, 0, "0s"
	call msg_message ()
	end if
	call msg_message (checkpoint_bar)
	call msg_message ("")
	checkpointing%running = .false.
	end if
	end subroutine checkpointing_msg_end

	@ %def checkpointing_msg_end
	@
	\subsection{The simulation object type}
	We set up a data type which holds all information needed for simulation. This
	allows to separate initialization, event generation, and finalization of a
	simulation run. The type is public, so the object may be used as a black box
	by an external caller.

	The objects of this type must carry the [[target]] attribute, since several
	components will be pointed to.
	<<XXX Simulations: public>>=
	public :: simulation_t
	<<XXX Simulations: types>>=
	type :: simulation_t
	! not private anymore as required by the whizard-c-interface
	integer :: n_proc = 0
	type(string_t), dimension(:), allocatable :: process_id
	type(process_p), dimension(:), allocatable :: prc_array
	type(var_list_t) :: var_list
	logical :: rebuild_events = .false.
	logical :: check_grid_file = .true.
	logical :: check_event_file = .true.
	integer :: version = 0
	integer :: n_in = 0
	type(flavor_t), dimension(:), allocatable :: beam_flv
	real(default), dimension(:), allocatable :: beam_energy
	type(string_t) :: basename
	logical :: rescan = .false.
	logical :: use_num_id = .false.
	integer, dimension(:), allocatable :: num_id
	logical :: update_parameters = .true.
	logical :: update_scale = .false.
	logical :: update_alpha_s = .false.
	logical :: update_sqme = .true.
	logical :: update_weight = .true.
	logical :: read_raw = .false.
	logical :: read_hepmc = .false.
	logical :: write_raw = .false.
	type(string_t) :: file_rescan
	type(string_t) :: file_raw
	type(string_t) :: file_hepmc
	type(input_event_stream_t) :: input_stream
	type(event_file_list_t) :: event_file_list
	integer :: u_raw = -1
	type(simulation_parameters_t) :: spar
	real(default), dimension(:), allocatable :: integral
	real(default), dimension(:), allocatable :: error
	real(default) :: integral_sum = 0
	real(default) :: error_sum = 0
	real(default) :: norm_weight = 0
	logical :: helicity_selection_active = .false.
	real(default) :: helicity_selection_threshold = -1
	integer :: helicity_selection_cutoff = 1000
	type(md5sum_events_t) :: md5sum
	integer :: n_events = 0
	logical :: n_events_set = .false.
	integer :: n_read = 0
	integer :: i_evt = 0
	integer :: n_selected = 0
	real(default) :: luminosity = 0
	logical :: user_selection = .false.
	type(eval_tree_t) :: selection_expr
	type(eval_tree_t) :: reweight_expr
	type(eval_tree_t) :: analysis_expr
	type(subevt_t) :: subevt
	type(event_vars_t) :: event_vars
	logical :: allow_decays = .true.
	type(decay_tree_t), dimension(:), allocatable :: decay_tree
	type(checkpointing_t) :: checkpointing
	type(event_t) :: event
	end type simulation_t

	@ %def simulation_t
	@
	\subsubsection{Preparing event generation}
	This is the basic initializer; it specifies the processes and issues a
	message if requested. Furthermore, it initializes some important flags, and it
	makes a snapshot of the current variable list.
	<<XXX Simulations: procedures>>=
	subroutine simulation_basic_init (sim, process_id, var_list, rescan, verbose)
	type(simulation_t), intent(out) :: sim
	type(string_t), dimension(:), intent(in) :: process_id
	type(var_list_t), intent(in), target :: var_list
	logical, intent(in), optional :: rescan, verbose
	type(string_t) :: process_string, version_string
	integer :: proc
	logical :: generate, verb
	generate = .true.; if (present (rescan)) generate = .not. rescan
	verb = .true.; if (present (verbose)) verb = verbose
	sim%n_proc = size (process_id)
	allocate (sim%process_id (sim%n_proc))
	sim%process_id = process_id
	allocate (sim%prc_array (sim%n_proc))
	do proc = 1, sim%n_proc
	sim%prc_array(proc)%ptr => &
	process_store_get_process_ptr (sim%process_id(proc))
	end do
	if (verb) then
	process_string = ""
	do proc = 1, size (process_id)
	if (proc > 1) process_string = process_string // ", "
	process_string = process_string // sim%process_id (proc)
	end do
	if (generate) then
	call msg_message ("Initializing simulation for processes " &
	// char (process_string) // ":")
	else
	call msg_message ("Initializing rescanning for processes " &
	// char (process_string) // ":")
	end if
	end if
	sim%rebuild_events = &
	var_list_get_lval (var_list, var_str ("?rebuild_events"))
	sim%check_grid_file = &
	var_list_get_lval (var_list, var_str ("?check_grid_file"))
	sim%check_event_file = &
	var_list_get_lval (var_list, var_str ("?check_event_file"))
	version_string = &
	var_list_get_sval (var_list, var_str ("$event_file_version"))
	select case (char (version_string))
	case ("2.00":"2.06"); sim%version = 2
	case default; sim%version = 3
	end select
	call simulation_parameters_init (sim%spar, &
	var_list_get_lval &
	(var_list, var_str ("?unweighted")), &
	var_list_get_lval &
	(var_list, var_str ("?use_best_grid")), &
	var_list_get_sval &
	(var_list, var_str ("$event_normalization")), &
	var_list_get_lval &
	(var_list, var_str ("?negative_weights")), &
	var_list_get_lval &
	(var_list, var_str ("?polarized_events")))
	call simulation_parameters_init_shower (sim%spar, var_list)
	if (present (verbose)) then
	if (verbose) call simulation_parameters_write_message (sim%spar)
	end if
	sim%helicity_selection_active = &
	var_list_get_lval (var_list, var_str ("?helicity_selection_active"))
	if (sim%helicity_selection_active) then
	sim%helicity_selection_threshold = var_list_get_rval (var_list, &
	var_str ("helicity_selection_threshold"))
	sim%helicity_selection_cutoff = var_list_get_ival (var_list, &
	var_str ("helicity_selection_cutoff"))
	end if
	sim%use_num_id = &
	var_list_get_lval (var_list, var_str ("?use_num_id"))
	if (sim%use_num_id) then
	allocate (sim%num_id (size (process_id)))
	do proc = 1, sim%n_proc
	sim%num_id(proc) = proc_get_num_id (sim%process_id(proc), var_list)
	end do
	end if
	sim%allow_decays = &
	var_list_get_lval (var_list, var_str ("?allow_decays"))
	call var_list_init_snapshot (sim%var_list, var_list)
	end subroutine simulation_basic_init

	@ %def simulation_basic_init
	@ Get the numeric process ID for a process. If not associated, issue an
	error.
	<<XXX Simulations: procedures>>=
	function proc_get_num_id (process_id, var_list) result (num_id)
	integer :: num_id
	type(string_t), intent(in) :: process_id
	type(var_list_t), intent(in) :: var_list
	type(string_t) :: var_name
	var_name = "num_id(" // process_id // ")"
	if (var_list_is_known (var_list, var_name)) then
	num_id = var_list_get_ival (var_list, var_name)
	else
	call msg_error ("Numeric process ID '" &
	// char (var_name) // "' is undefined, inserting zero.")
	num_id = 0
	end if
	end function proc_get_num_id

	@ %def proc_get_num_id
	@ This is the initializer that applies for rescanning existing event files.
	Since the matrix element will be recalculated for each event, we redo the
	initializations of the helicity selection and the process variables.
	<<XXX Simulations: procedures>>=
	subroutine simulation_init_rescan &
	(sim, file_rescan, process_id, var_list, verbose)
	type(simulation_t), intent(out) :: sim
	type(string_t), intent(in) :: file_rescan
	type(string_t), dimension(:), intent(in) :: process_id
	type(var_list_t), intent(in), target :: var_list
	logical, intent(in), optional :: verbose
	integer :: proc
	type(process_t), pointer :: process
	logical :: verb
	verb = .true.; if (present (verbose)) verb = verbose
	call simulation_basic_init &
	(sim, process_id, var_list, rescan=.true., verbose=verbose)
	sim%rebuild_events = .false.
	sim%rescan = .true.
	sim%file_rescan = file_rescan
	sim%update_parameters = &
	var_list_get_lval (var_list, var_str ("?update_parameters"))
	sim%update_scale = &
	var_list_get_lval (var_list, var_str ("?update_scale"))
	sim%update_alpha_s = &
	var_list_get_lval (var_list, var_str ("?update_alpha_s"))
	sim%update_sqme = &
	var_list_get_lval (var_list, var_str ("?update_sqme"))
	sim%update_weight = &
	var_list_get_lval (var_list, var_str ("?update_weight"))
	if (verb) then
	call msg_message ("Reading events from file '" &
	// char (sim%file_rescan) // "'")
	if (sim%update_scale) call msg_message &
	("Recalculating event scale")
	if (sim%update_alpha_s) call msg_message &
	("Recalculating alpha_s")
	if (sim%update_sqme) then
	if (sim%update_parameters) then
	call msg_message ("Recalculating squared matrix element " &
	// "with updated parameters")
	else
	call msg_message ("Recalculating squared matrix element")
	end if
	end if
	if (sim%update_weight) call msg_message ("Updating event weight " &
	// "using matrix element ratio")
	end if
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	call process_reset_helicity_selection (process, &
	sim%helicity_selection_threshold, sim%helicity_selection_cutoff)
	end do
	end subroutine simulation_init_rescan

	@ %def simulation_init_rescan
	@ Do missing integration for processes where this is possible. The results
	are inserted into the [[global_var_list]] (the [[global]] object may in fact
	be local to the caller).

	If [[rescan]] is set, do just process initialization, no integration.
	<<XXX Simulations: procedures>>=
	subroutine simulation_compute_missing_integrals &
	(sim, global, global_var_list, rescan, verbose)
	type(simulation_t), intent(inout) :: sim
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), intent(inout) :: global_var_list
	logical, intent(in), optional :: rescan, verbose
	integer :: proc
	logical :: me_only
	me_only = .false.; if (present (rescan)) me_only = rescan
	if (me_only) then
	call prepare_me_missing_processes (sim%process_id, global, verbose)
	else
	call integrate_missing_processes &
	(sim%process_id, global, global_var_list, verbose = verbose)
	end if
	do proc = 1, sim%n_proc
	sim%prc_array(proc)%ptr => &
	process_store_get_process_ptr (sim%process_id(proc))
	end do
	end subroutine simulation_compute_missing_integrals

	@ %def simulation_compute_missing_integrals
	@ For each process that has an integral, choose the best integration
	grid for event generation.
	<<XXX Simulations: procedures>>=
	subroutine simulation_choose_best_grids (sim)
	type(simulation_t), intent(in) :: sim
	type(process_t), pointer :: process
	integer :: proc
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	if (associated (process)) then
	if (process_has_integral (process)) &
	call process_choose_best_grid (process, sim%check_grid_file)
	end if
	end do
	end subroutine simulation_choose_best_grids

	@ %def simulation_choose_best_grids
	@ Initialize processes that are not yet contained in the process store, if
	possible. This applies when rescanning files. We do not need integrals in
	that case, but the process must be initialized including beam data, if any.
	We also allow for weight and scale expressions (if absent, the values in the
	file are used), and take notice of the $\alpha_s$ scheme.
	<<XXX Simulations: procedures>>=
	subroutine simulation_init_missing_processes (sim, global, verbose)
	type(simulation_t), intent(inout) :: sim
	type(rt_data_t), intent(inout), target :: global
	logical, intent(in), optional :: verbose
	integer :: n_missing
	type(string_t), dimension(:), allocatable :: missing_process_id
	logical, dimension(:), allocatable :: missing
	integer :: proc
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	allocate (missing (sim%n_proc))
	do proc = 1, sim%n_proc
	missing(proc) = .not. associated (sim%prc_array(proc)%ptr)
	end do
	n_missing = count (missing)
	if (n_missing > 0) then
	allocate (missing_process_id (n_missing))
	missing_process_id = pack (sim%process_id, missing)
	call prepare_me_evaluation (missing_process_id, global)
	do proc = 1, sim%n_proc
	if (missing(proc)) sim%prc_array(proc)%ptr => &
	process_store_get_process_ptr (sim%process_id(proc))
	end do
	end if
	end subroutine simulation_init_missing_processes

	@ %def simulation_init_missing_processes
	@ Check whether for the selected combination of processes, simulation is
	possible at all.
	<<XXX Simulations: procedures>>=
	subroutine simulation_check (sim, ok)
	type(simulation_t), intent(inout) :: sim
	logical, intent(out) :: ok
	type(process_t), pointer :: process
	integer :: proc
	type(flavor_t), dimension(:), allocatable :: beam_flv
	real(default), dimension(:), allocatable :: beam_energy
	ok = .false.
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	if (.not. associated (process)) then
	call msg_fatal ("Process '" // char (sim%process_id(proc)) &
	// "' is not available for simulation.")
	return
	end if
	select case (proc)
	case (1)
	sim%n_in = process_get_n_in (process)
	allocate (beam_flv (sim%n_in), beam_energy (sim%n_in))
	beam_flv = process_get_beam_flv (process)
	beam_energy = process_get_beam_energy (process)
	case default
	if (.not. process_has_matrix_element (process)) cycle
	if (process_get_n_in (process) /= sim%n_in) then
	call msg_fatal ("Simulation: " &
	// "Mixture of scattering and decays")
	return
	else if (any (process_get_beam_flv (process) /= beam_flv)) then
	call msg_fatal ("Simulation: Mismatch in beam particles")
	return
	else if (any (process_get_beam_energy (process) &
	/= beam_energy))then
	call msg_fatal ("Simulation: Mismatch in beam energies")
	return
	end if
	end select
	end do
	allocate (sim%beam_flv (sim%n_in), sim%beam_energy (sim%n_in))
	sim%beam_flv = beam_flv
	sim%beam_energy = beam_energy
	ok = .true.
	end subroutine simulation_check

	@ %def simulation_check
	@ Initialize I/O files and switches. The [[event_fmt]] array may be
	unallocated, therefore we keep its [[allocatable]] attribute.
	<<XXX Simulations: procedures>>=
	subroutine simulation_setup_event_file_list (sim, event_fmt, basename_default)
	type(simulation_t), intent(inout) :: sim
	integer, dimension(:), intent(in), allocatable :: event_fmt
	type(string_t), intent(in) :: basename_default
	type(string_t) :: extension_raw
	integer :: i
	type(string_t) :: matching_basename
	sim%basename = var_list_get_sval (sim%var_list, var_str ("$sample"))
	if (sim%basename == "") sim%basename = basename_default
	if (sim%rescan) then
	select case (event_file_get_format (sim%file_rescan))
	case (FMT_RAW)
	sim%read_raw = .true.
	sim%file_raw = sim%file_rescan
	case (FMT_HEPMC)
	sim%read_hepmc = .true.
	sim%file_hepmc = sim%file_rescan
	case default
	call msg_fatal ("Rescanning event file '" // char (sim%file_rescan) &
	// "': file format not supported")
	end select
	sim%write_raw = .false.
	else
	sim%read_raw = var_list_get_lval (sim%var_list, var_str ("?read_raw")) &
	.and. .not. sim%rebuild_events
	sim%write_raw = var_list_get_lval (sim%var_list, var_str ("?write_raw"))
	extension_raw = var_list_get_sval (sim%var_list, var_str ("$extension_raw"))
	sim%file_raw = sim%basename // "." // extension_raw
	end if
	if (allocated (event_fmt)) then
	do i = 1, size (event_fmt)
	call event_file_list_append_file_spec (sim%event_file_list, &
	sim%basename, sim%var_list, event_fmt(i), &
	sim%beam_flv, sim%beam_energy, sim%n_proc)
	end do
	end if
	if (sim%rescan) then
	if (sim%read_raw) then
	if (event_file_list_is_filename (sim%event_file_list, sim%file_raw)) &
	call msg_fatal ("Output event file '" &
	// char (sim%file_raw) // "' coincides with input file")
	else if (sim%read_hepmc) then
	if (event_file_list_is_filename (sim%event_file_list, sim%file_hepmc)) &
	call msg_fatal ("Output event file '" &
	// char (sim%file_hepmc) // "' coincides with input file")
	end if
	end if
	end subroutine simulation_setup_event_file_list

	@ %def simulation_setup_event_file_list
	@ Collect and store the integrals (cross sections) for the processes to
	simulate.
	<<XXX Simulations: procedures>>=
	subroutine simulation_collect_integrals (sim, var_list, ok)
	type(simulation_t), intent(inout) :: sim
	type(var_list_t), intent(in) :: var_list
	logical, intent(out) :: ok
	integer :: proc
	type(process_t), pointer :: process
	type(string_t) :: process_id
	allocate (sim%integral (sim%n_proc))
	allocate (sim%error (sim%n_proc))
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	process_id = process_get_id (process)
	sim%integral(proc) = var_list_get_rval (var_list, &
	var_str ("integral(") // process_id // ")")
	sim%error(proc) = var_list_get_rval (var_list, &
	var_str ("error(") // process_id // ")")
	if (sim%integral(proc) < 0 .and. .not.sim%spar%negative_weights) then
	call msg_fatal ("Integral of process '" &
	// char (process_id) // "' is negative")
	end if
	end do
	sim%integral_sum = sum (sim%integral)
	sim%error_sum = sqrt (sum (sim%error ** 2))
	if (sim%integral_sum > 0) then
	ok = .true.
	else
	if (sim%spar%negative_weights) then
	ok = .false.
	else
	call msg_error ("Simulation: " &
	// "sum of process integrals must be positive; skipping")
	ok = .false.
	end if
	end if
	end subroutine simulation_collect_integrals

	@ %def simulation_collect_integrals
	@ Collect the MD5 sums that we will check when reading a raw event file.
	<<XXX Simulations: procedures>>=
	subroutine simulation_collect_md5sums (sim)
	type(simulation_t), intent(inout) :: sim
	integer :: proc
	type(process_t), pointer :: process
	allocate (sim%md5sum%process (sim%n_proc))
	allocate (sim%md5sum%parameters (sim%n_proc))
	allocate (sim%md5sum%results (sim%n_proc))
	allocate (sim%md5sum%polarized (sim%n_proc))
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	sim%md5sum%process(proc) = process_get_md5sum (process)
	sim%md5sum%parameters(proc) = process_get_md5sum_parameters (process)
	sim%md5sum%results(proc) = process_get_md5sum_results (process)
	sim%md5sum%polarized(proc) = process_get_md5sum_polarized (process)
	end do
	if (sim%allow_decays) then
	sim%md5sum%decays = decay_store_get_md5sum ()
	else
	sim%md5sum%decays = ""
	end if
	sim%md5sum%simulation = simulation_parameters_get_md5sum (sim%spar)
	end subroutine simulation_collect_md5sums

	@ %def simulation_collect_md5sums
	@ Choose the number of events to generate from either the luminosity
	or the specified [[n_events]], whatever is larger. Return revised values for
	both luminosity and number of events.

	Also determine the event weight normalization.
	<<XXX Simulations: procedures>>=
	subroutine simulation_setup_n_events (sim, verbose)
	type(simulation_t), intent(inout) :: sim
	logical, intent(in), optional :: verbose
	integer :: n_events
	real(default) :: luminosity
	logical :: verb
	verb = .true.; if (present (verbose)) verb = verbose
	n_events = var_list_get_ival (sim%var_list, var_str ("n_events"))
	if (sim%rescan) then
	if (n_events /= 0) then
	sim%n_events = n_events
	if (verb) then
	write (msg_buffer, "(A,1x,I0)") &
	"Requested number of events =", sim%n_events
	call msg_message ()
	end if
	else
	sim%n_events = huge (1)
	end if
	sim%luminosity = 0
	sim%norm_weight = 0
	else
	luminosity = var_list_get_rval (sim%var_list, var_str ("luminosity"))
	if (.not.sim%spar%unweighted) then
	if (luminosity > 0) then
	if (n_events == 0) then
	call msg_fatal ("Setting a luminosity is only allowed for " // &
	"unweighted events. Please set n_events.")
	else
	call msg_warning ("Setting a luminosity is only allowed for " // &
	"unweighted events. Luminosity will be ignored.")
	end if
	luminosity = 0
	end if
	end if
	sim%n_events = max (nint (luminosity * sim%integral_sum), n_events)
	sim%n_events_set = (sim%n_events.eq.n_events)
	sim%luminosity = max (luminosity, sim%n_events / sim%integral_sum)
	sim%norm_weight = simulation_parameters_get_norm &
	(sim%spar, sim%integral_sum, sim%n_events)
	if (verb) then
	write (msg_buffer, "(A,1x,I0)") &
	"Requested number of events =", sim%n_events
	call msg_message ()
	if (sim%spar%unweighted) then
	write (msg_buffer, "(A,1x,G11.4)") &
	"This corresponds to luminosity [fb-1] = ", &
	sim%luminosity
	call msg_message ()
	end if
	end if
	end if
	end subroutine simulation_setup_n_events

	@ %def simulation_setup_n_events
	@ Final preliminaries for event generation: Set up decay trees, prepare each
	process, and open files.
	<<XXX Simulations: procedures>>=
	subroutine simulation_prepare_event_generation (sim, verbose)
	type(simulation_t), intent(inout), target :: sim
	logical, intent(in), optional :: verbose
	integer :: proc
	logical :: ok, verb
	type(process_t), pointer :: process
	verb = .false.; if (present (verbose)) verb = verbose
	if (sim%allow_decays) allocate (sim%decay_tree (sim%n_proc))
	do proc = 1, sim%n_proc
	process => sim%prc_array(proc)%ptr
	call process_setup_event_generation (process)
	if (sim%allow_decays) &
	call decay_tree_init (sim%decay_tree(proc), process)
	end do
	call event_file_list_open (sim%event_file_list, sim%process_id, &
	sim%n_events, sim%var_list)
	if (sim%read_raw) then
	call open_raw_event_file_for_reading &
	(sim%file_raw, sim%rescan, sim%check_event_file, sim%md5sum, &
	sim%version, sim%u_raw, ok, verbose)
	if (.not. ok) sim%read_raw = .false.
	else if (sim%read_hepmc) then
	call input_event_stream_init &
	(sim%input_stream, sim%file_hepmc, FMT_HEPMC)
	else
	if (verb) then
	write (msg_buffer, "(A,I0,A)") &
	"Generating ", sim%n_events, " events ..."
	call msg_message
	end if
	end if
	if (.not. sim%read_raw) then
	if (sim%write_raw) then
	call open_raw_event_file_for_writing &
	(sim%file_raw, sim%md5sum, sim%version, sim%u_raw, verbose)
	end if
	end if
	call checkpointing_init (sim%checkpointing, sim%var_list)
	sim%n_read = 0
	sim%i_evt = 0
	sim%n_selected = 0
	end subroutine simulation_prepare_event_generation

	@ %def simulation_prepare_event_generation
	@ Initialize a selection expression. This establishes a pointer-target
	relation between the selection expression, the subevent, and certain
	variables.

	This is public, since the analysis is a separate object.
	<<XXX Simulations: public>>=
	public :: simulation_setup_selection
	<<XXX Simulations: procedures>>=
	subroutine simulation_setup_selection (sim, pn_selection_lexpr, verbose)
	type(simulation_t), intent(inout), target :: sim
	type(parse_node_t), pointer :: pn_selection_lexpr
	logical, intent(in), optional :: verbose
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	if (associated (pn_selection_lexpr)) then
	call msg_message ("Applying user-defined selection expression.")
	end if
	end if
	if (associated (pn_selection_lexpr)) then
	sim%user_selection = .true.
	call eval_tree_init_lexpr (sim%selection_expr, &
	pn_selection_lexpr, sim%var_list, sim%subevt, &
	sim%event_vars)
	else
	sim%user_selection = .false.
	end if
	end subroutine simulation_setup_selection

	@ %def simulation_setup_selection
	@ Initialize a reweighting expression. This establishes a pointer-target
	relation between the reweighting expression, the subevent, and certain
	variables.

	This is public, since the analysis is a separate object.
	<<XXX Simulations: public>>=
	public :: simulation_setup_reweight
	<<XXX Simulations: procedures>>=
	subroutine simulation_setup_reweight (sim, pn_reweight_expr, verbose)
	type(simulation_t), intent(inout), target :: sim
	type(parse_node_t), pointer :: pn_reweight_expr
	logical, intent(in), optional :: verbose
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	if (associated (pn_reweight_expr)) then
	call msg_message ("Applying user-defined reweighting expression.")
	end if
	end if
	if (associated (pn_reweight_expr)) then
	call eval_tree_init_expr (sim%reweight_expr, &
	pn_reweight_expr, sim%var_list, sim%subevt, &
	sim%event_vars)
	end if
	end subroutine simulation_setup_reweight

	@ %def simulation_setup_reweight
	@ Initialize the analysis expression. This establishes a pointer-target
	relation between the analysis expression, the subevent, and certain
	variables.

	This is public, since the analysis is a separate object.
	<<XXX Simulations: public>>=
	public :: simulation_setup_analysis
	<<XXX Simulations: procedures>>=
	subroutine simulation_setup_analysis (sim, pn_analysis_lexpr, verbose)
	type(simulation_t), intent(inout), target :: sim
	type(parse_node_t), pointer :: pn_analysis_lexpr
	logical, intent(in), optional :: verbose
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	if (associated (pn_analysis_lexpr)) then
	call msg_message ("Applying user-defined analysis setup.")
	else
	call msg_message ("No analysis setup has been provided.")
	end if
	end if
	if (associated (pn_analysis_lexpr)) then
	call eval_tree_init_lexpr (sim%analysis_expr, &
	pn_analysis_lexpr, sim%var_list, sim%subevt, &
	sim%event_vars)
	end if
	end subroutine simulation_setup_analysis

	@ %def simulation_setup_analysis
	@
	\subsubsection{Generating one event}
	Read an event from the 'raw' event file. If EOF is reached, close it, reset
	the [[read_raw]] flag, and reopen it for writing if [[write_raw]] is set.

	When reopening the raw event file, we have do re-do some process
	initialization that may got lost when reading events from file before.

	This initializes the event object, if successful.
	<<XXX Simulations: procedures>>=
	subroutine simulation_read_event_raw (sim, ok, verbose)
	type(simulation_t), intent(inout), target :: sim
	logical, intent(out) :: ok
	logical, intent(in), optional :: verbose
	logical :: verb
	integer :: iostat
	verb = .false.; if (present (verbose)) verb = verbose
	if (sim%use_num_id) then
	call event_read_raw (sim%event, sim%u_raw, &
	sim%event_vars, sim%prc_array, num_id_array=sim%num_id, &
	iostat=iostat, version=sim%version)
	else
	call event_read_raw (sim%event, sim%u_raw, &
	sim%event_vars, sim%prc_array, iostat=iostat, version=sim%version)
	end if
	if (iostat == 0) then
	sim%i_evt = sim%i_evt + 1
	sim%n_read = sim%n_read + 1
	ok = .true.
	else
	ok = .false.
	if (verb) then
	write (msg_buffer, "(A,1x,I0,1x,A)") &
	"...", sim%n_read, "events read."
	call msg_message ()
	end if
	if (.not. sim%rescan) then
	sim%read_raw = .false.
	if (verb) then
	write (msg_buffer, "(A,1x,I0,1x,A)") &
	"Generating", sim%n_events - sim%n_read, " events ..."
	call msg_message ()
	end if
	if (sim%write_raw) then
	call reopen_raw_event_file_for_writing &
	(sim%file_raw, sim%u_raw, verbose)
	else
	close (sim%u_raw)
	end if
	ok = .true.
	call reinitialize_processes (sim%prc_array)
	end if
	end if
	end subroutine simulation_read_event_raw

	@ %def simulation_read_event_raw
	@ For all processes in the current simulation, redo the initialization of the
	subevent that is used for cuts etc. This subevent may be corrupted by
	previous events read from file.
	<<XXX Simulations: procedures>>=
	subroutine reinitialize_processes (prc_array)
	type(process_p), dimension(:), intent(in) :: prc_array
	type(process_t), pointer :: process
	integer :: i
	do i = 1, size (prc_array)
	process => prc_array(i)%ptr
	call process_setup_subevt (process)
	end do
	end subroutine reinitialize_processes

	@ %def reinitialize_processes
	@ Read an event from a HepMC file.
	<<XXX Simulations: procedures>>=
	subroutine simulation_read_event_hepmc (sim, ok)
	type(simulation_t), intent(inout), target :: sim
	logical, intent(out) :: ok
	if (sim%use_num_id) then
	call input_event_stream_read_event (sim%input_stream, sim%event, &
	sim%event_vars, sim%prc_array, ok, num_id_array=sim%num_id)
	else
	call input_event_stream_read_event (sim%input_stream, sim%event, &
	sim%event_vars, sim%prc_array, ok)
	end if
	end subroutine simulation_read_event_hepmc

	@ %def simulation_read_event_hepmc
	@ Select a random process for the current event, based on the relative sizes
	of the process integrals.
	<<XXX Simulations: procedures>>=
	subroutine simulation_select_process (sim, rng, process, proc)
	type(simulation_t), intent(in) :: sim
	type(tao_random_state), intent(inout) :: rng
	type(process_t), pointer :: process
	integer, intent(out) :: proc
	real(default) :: integral_cmp, x
	call tao_random_number (rng, x)
	integral_cmp = 0
	do proc = 1, sim%n_proc
	integral_cmp = integral_cmp + sim%integral(proc)
	if (integral_cmp > x * sim%integral_sum) exit
	end do
	proc = min (proc, sim%n_proc)
	process => sim%prc_array(proc)%ptr
	end subroutine simulation_select_process

	@ %def simulation_select_process
	@ Recover the process for the current event, which should be filled already.
	<<XXX Simulations: procedures>>=
	subroutine simulation_recover_process (sim, proc)
	type(simulation_t), intent(inout) :: sim
	integer, intent(out) :: proc
	type(string_t) :: process_id
	type(process_t), pointer :: process
	process => event_get_process_ptr (sim%event)
	if (associated (process)) then
	process_id = process_get_id (process)
	do proc = 1, sim%n_proc
	if (process_id == process_get_id (sim%prc_array(proc)%ptr)) then
	call event_recover_process (sim%event)
	return
	end if
	end do
	end if
	call event_write (sim%event)
	call msg_fatal ("Simulation: recovering process data from event failed.")
	proc = 0
	end subroutine simulation_recover_process

	@ %def simulation_recover_process
	@ Recalculate the matrix element for the process, refreshing the model
	parameters and, if required, the scale and $\alpha_s$ values.
	<<XXX Simulations: procedures>>=
	subroutine simulation_recalculate (sim)
	type(simulation_t), intent(inout) :: sim
	if (sim%update_parameters) call event_update_parameters (sim%event)
	if (sim%update_scale) call event_compute_scale (sim%event)
	if (sim%update_alpha_s) call event_update_alpha_s (sim%event)
	if (sim%update_sqme) call event_compute_sqme (sim%event)
	if (sim%update_weight) call event_update_weight (sim%event)
	end subroutine simulation_recalculate

	@ %def simulation_recalculate
	@ Generate a new event for the selected process. This initializes the event
	object. We reject invalid events until a valid event could be produced.
	<<Limits: public parameters>>=
	integer, parameter, public :: MAX_TRIES_FOR_SINGLE_EVENT = 100000
	@ %def MAX_TRIES_FOR_SINGLE_EVENT
	<<XXX Simulations: procedures>>=
	subroutine simulation_generate_event (sim, rng, process, proc, os_data)
	type(simulation_t), intent(inout), target :: sim
	type(tao_random_state), intent(inout) :: rng
	type(process_t), intent(in), target :: process
	integer, intent(in) :: proc
	type(os_data_t), intent(in) :: os_data
	integer :: factorization_mode, try
	if (sim%allow_decays) then
	call event_init (sim%event, process, &
	sim%event_vars, sim%decay_tree(proc))
	else
	call event_init (sim%event, process, sim%event_vars)
	end if
	if (sim%use_num_id) then
	sim%event_vars%process_num_id = sim%num_id(proc)
	else
	sim%event_vars%process_num_id = proc
	end if
	sim%event_vars%process_id = process_get_id (process)
	if (sim%spar%polarized) then
	factorization_mode = FM_SELECT_HELICITY
	else
	factorization_mode = FM_IGNORE_HELICITY
	end if
	GENERATE: do try = 1, MAX_TRIES_FOR_SINGLE_EVENT
	call event_generate &
	(sim%event, rng, sim%spar%unweighted, &
	factorization_mode, &
	keep_correlations=.false., &
	keep_virtual=.true., os_data=os_data, &
	shower_settings = sim%spar%shower_settings)
	if(event_is_vetoed(sim%event).and. &
	(.not.sim%n_events_set)) then
	sim%n_events = sim%n_events - 1
	if(sim%i_evt .ge. sim%n_events) then
	call event_final(sim%event)
	return
	end if
	end if
	if (event_is_valid (sim%event).and. &
	(.not.event_is_vetoed(sim%event))) exit GENERATE
	end do GENERATE
	if (.not. event_is_valid (sim%event)) then
	write (msg_buffer, "(A,I0,A)") "Failed to generate a valid event " &
	// "after ", MAX_TRIES_FOR_SINGLE_EVENT, " tries"
	call msg_fatal ()
	end if
	sim%i_evt = sim%i_evt + 1
	sim%event_vars%process_index = proc
	sim%event_vars%event_index = sim%i_evt
	call event_renormalize_weight (sim%event, sim%norm_weight)
	end subroutine simulation_generate_event

	@ %def simulation_generate_event
	@ Explicitly apply decays to an existing event. (Implicitly called by the
	previous procedure.)
	<<XXX Simulations: procedures>>=
	subroutine simulation_decay (sim, rng, proc)
	type(simulation_t), intent(inout), target :: sim
	type(tao_random_state), intent(inout) :: rng
	integer, intent(in) :: proc
	if (sim%allow_decays) then
	call event_decay (sim%event, rng, sim%decay_tree(proc))
	call event_factorize_process (sim%event, rng, &
	FM_IGNORE_HELICITY, &
	keep_correlations=.false., &
	keep_virtual=.true.)
	end if
	end subroutine simulation_decay

	@ %def simulation_decay
	@ Further process an event. This implies analysis and output. Events
	which fail extra selection cuts (if any) are neither analyzed nor written
	to file, but they count for the total number of generated events. However,
	the raw event file will contain the rejected events.

	Writing to raw event file is appropriate only if reading from this file is
	disabled or has terminated.
	<<XXX Simulations: procedures>>=
	subroutine simulation_handle_event (sim)
	type(simulation_t), intent(inout), target :: sim
	if (event_passes_selection (sim%event, sim%subevt, sim%selection_expr)) &
	then
	sim%n_selected = sim%n_selected + 1
	call event_reweight (sim%event, sim%subevt, sim%reweight_expr)
	call event_do_analysis (sim%event, sim%subevt, sim%analysis_expr)
	call event_file_list_write_event &
	(sim%event_file_list, sim%event, sim%integral_sum, sim%error_sum, &
	sim%analysis_expr, i_evt=sim%i_evt)
	end if
	if (sim%write_raw .and. .not. sim%read_raw) &
	call event_write_raw (sim%event, sim%u_raw, sim%version)
	call checkpointing_msg_event &
	(sim%checkpointing, sim%n_events, sim%n_read, sim%i_evt)
	end subroutine simulation_handle_event

	@ %def simulation_handle_event
	@ Finalize the event.
	<<XXX Simulations: procedures>>=
	subroutine simulation_final_event (sim)
	type(simulation_t), intent(inout), target :: sim
	call event_final (sim%event)
	end subroutine simulation_final_event

	@ %def simulation_final_event
	@
	\subsubsection{Wrapup}
	Close open files and delete the decay tree and analysis expression:
	<<XXX Simulations: procedures>>=
	subroutine simulation_finish_event_generation (sim, verbose)
	type(simulation_t), intent(inout) :: sim
	logical, intent(in), optional :: verbose
	integer :: proc
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	call checkpointing_msg_end &
	(sim%checkpointing, sim%n_read, sim%i_evt)
	call event_file_list_close (sim%event_file_list)
	if (sim%read_raw .or. sim%write_raw) close (sim%u_raw)
	if (sim%read_hepmc) call input_event_stream_final (sim%input_stream)
	if (sim%allow_decays) then
	do proc = 1, sim%n_proc
	call decay_tree_final (sim%decay_tree(proc))
	end do
	end if
	call eval_tree_final (sim%analysis_expr)
	if (verb) then
	if (sim%rescan) then
	call msg_selection (sim%user_selection, sim%n_selected)
	call msg_message ("Rescanning finished.")
	else
	if (sim%read_raw) then
	write (msg_buffer, "(A,1x,I0,1x,A,1x,I0,1x,A)") &
	"...", sim%n_read, "events read,", sim%n_events, "total."
	call msg_message ()
	else
	write (msg_buffer, "(A,1x,I0,1x,A,1x,I0,1x,A)") &
	"...", sim%n_events - sim%n_read, "events generated.", &
	sim%n_events, "total."
	call msg_message ()
	end if
	call msg_selection (sim%user_selection, sim%n_selected)
	call msg_message ("Simulation finished.")
	end if
	end if
	contains
	subroutine msg_selection (user_selection, n_selected)
	logical, intent(in) :: user_selection
	integer, intent(in) :: n_selected
	if (user_selection) then
	write (msg_buffer, "(A,1x,I0)") &
	"Events passing selection cuts:", n_selected
	call msg_message ()
	end if
	end subroutine msg_selection
	end subroutine simulation_finish_event_generation

	@ %def subroutine simulation_finish_event_generation
	@ Deallocate extra memory where necessary
	<<XXX Simulations: procedures>>=
	subroutine simulation_basic_final (sim)
	type(simulation_t), intent(inout) :: sim
	call var_list_final (sim%var_list)
	end subroutine simulation_basic_final

	@ %def simulation_basic_final
	@
	\subsubsection{Dealing with the event file}
	Open a raw event file for reading, check the header and validity. If
	[[rescan]] is set, check only processes and simulation parameters, otherwise
	check everything.
	<<XXX Simulations: procedures>>=
	subroutine open_raw_event_file_for_reading &
	(file_raw, rescan, check, md5sum, version, u_raw, ok, verbose)
	type(string_t), intent(in) :: file_raw
	logical, intent(in) :: rescan, check
	type(md5sum_events_t), intent(in) :: md5sum
	integer, intent(in) :: version
	integer, intent(out) :: u_raw
	logical, intent(out) :: ok
	logical, intent(in), optional :: verbose
	logical :: verb
	integer :: iostat
	verb = .false.; if (present (verbose)) verb = verbose
	if (.not. check) call msg_warning &
	("Validity checks turned off for event file '" &
	// char (file_raw) // "'")
	inquire (file = char (file_raw), exist = ok)
	if (check .and. ok) then
	ok = event_file_get_format (file_raw) == FMT_RAW
	if (.not. ok) then
	call msg_warning ("File '" // char (file_raw) &
	// "' is not a WHIZARD raw event file, discarding.")
	end if
	end if
	if (ok) then
	if (verb) call msg_message ("Reading events from file '" &
	// char (file_raw) // "' ...")
	u_raw = free_unit ()
	open (file = char (file_raw), unit = u_raw, form = "unformatted", &
	action = "read", status = "old")
	call raw_event_file_read_header &
	(u_raw, rescan, check, md5sum, version, ok, iostat)
	if (iostat /= 0) then
	call msg_error ("Event file '" &
	// char (file_raw) // "' is corrupt, discarding.")
	close (u_raw)
	ok = .false.
	else if (.not. ok) then
	close (u_raw)
	ok = .false.
	else
	ok = .true.
	end if
	end if
	end subroutine open_raw_event_file_for_reading

	@ %def open_raw_event_file_for_reading
	@ Open a raw event file for writing, write header. If [[append]] is set, close
	the existing file and reopen it for appending more events.
	<<XXX Simulations: procedures>>=
	subroutine open_raw_event_file_for_writing &
	(file_raw, md5sum, version, u_raw, verbose)
	type(string_t), intent(in) :: file_raw
	type(md5sum_events_t), intent(in) :: md5sum
	integer, intent(in) :: version
	integer, intent(out) :: u_raw
	logical, intent(in), optional :: verbose
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	call msg_message ("Writing events in internal format to file '" &
	// char (file_raw) // "'")
	end if
	u_raw = free_unit ()
	open (file = char (file_raw), unit = u_raw, form = "unformatted", &
	action = "write", status = "replace")
	call raw_event_file_write_header (u_raw, md5sum, version)
	end subroutine open_raw_event_file_for_writing

	@ %def open_raw_event_file_for_writing
	@ Reopen a raw event file for writing, no header. Append new events to the
	end.
	<<XXX Simulations: procedures>>=
	subroutine reopen_raw_event_file_for_writing (file_raw, u_raw, verbose)
	type(string_t), intent(in) :: file_raw
	integer, intent(in) :: u_raw
	logical, intent(in), optional :: verbose
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	if (verb) then
	call msg_message ("Appending events in internal format to file '" &
	// char (file_raw) // "'")
	end if
	close (u_raw)
	open (file = char (file_raw), unit = u_raw, form = "unformatted", &
	action = "write", status = "old", position = "append")
	end subroutine reopen_raw_event_file_for_writing

	@ %def reopen_raw_event_file_for_writing
	@
	\subsubsection{API for simulation objects}
	This initializer does everything, except assigning the analysis expression.
	If [[ok]] is false, initialization failed and the simulation should be
	skipped.

	If [[filename]] is provided, this is not a simulation but rescanning an event
	file.

	The [[global_var_list]] is the one where missing integrals are inserted, if
	they are computed here. It is not necessarily the one within the [[global]]
	object.
	<<XXX Simulations: public>>=
	public :: simulation_init
	<<XXX Simulations: procedures>>=
	subroutine simulation_init &
	(sim, process_id, global, global_var_list, ok, filename, verbose)
	type(simulation_t), intent(out) :: sim
	type(string_t), dimension(:), intent(in) :: process_id
	type(rt_data_t), intent(inout), target :: global
	type(var_list_t), intent(inout) :: global_var_list
	logical, intent(out) :: ok
	type(string_t), intent(in), optional :: filename
	logical, intent(in), optional :: verbose
	type(string_t) :: basename_default
	logical :: rescan
	rescan = present (filename)
	if (size (process_id) /= 0) then
	basename_default = process_id(1)
	else
	basename_default = "whizard"
	end if
	if (rescan) then
	call simulation_init_rescan &
	(sim, filename, process_id, global%var_list, verbose)
	else
	call simulation_basic_init &
	(sim, process_id, global%var_list, verbose=verbose)
	end if
	call simulation_compute_missing_integrals &
	(sim, global, global_var_list, rescan, verbose)
	if (sim%spar%use_best_grid) call simulation_choose_best_grids (sim)
	call simulation_check (sim, ok)
	if (ok .and. .not. rescan) then
	call simulation_collect_integrals (sim, global%var_list, ok)
	end if
	if (ok) then
	call simulation_setup_event_file_list &
	(sim, global%event_fmt, basename_default)
	call simulation_collect_md5sums (sim)
	call simulation_setup_n_events (sim, verbose)
	call simulation_prepare_event_generation (sim, verbose)
	end if
	if (.not. ok) call simulation_basic_final (sim)
	end subroutine simulation_init

	@ %def simulation_init
	@ Return the number of events determined during initialization.
	<<XXX Simulations: public>>=
	public :: simulation_get_n_events
	<<XXX Simulations: procedures>>=
	function simulation_get_n_events (sim) result (n_events)
	integer :: n_events
	type(simulation_t), intent(in) :: sim
	n_events = sim%n_events
	end function simulation_get_n_events

	@ %def simulation_get_n_events
	@ Return the number of events simulated so far.
	<<XXX Simulations: public>>=
	public :: simulation_get_i_evt
	<<XXX Simulations: procedures>>=
	function simulation_get_i_evt (sim) result (i_evt)
	integer :: i_evt
	type(simulation_t), intent(in) :: sim
	i_evt = sim%i_evt
	end function simulation_get_i_evt

	@ %def simulation_get_n_events
	@ Get and handle a new event. Either read it from file or generate it. If
	reading fails and we are allowed to generate new events, [[read_raw]] is
	reset, so we need a separate check.
	<<XXX Simulations: public>>=
	public :: simulation_event
	<<XXX Simulations: procedures>>=
	subroutine simulation_event (sim, rng, ok, os_data, verbose)
	type(simulation_t), intent(inout), target :: sim
	type(tao_random_state), intent(inout) :: rng
	logical, intent(out) :: ok
	type(os_data_t), intent(in) :: os_data
	logical, intent(in), optional :: verbose
	type(process_t), pointer :: process
	integer :: proc
	if (sim%read_raw) then
	call simulation_read_event_raw (sim, ok, verbose)
	else if (sim%read_hepmc) then
	call simulation_read_event_hepmc (sim, ok)
	end if
	if (sim%rescan) then
	if (.not. ok) return
	call simulation_recover_process (sim, proc)
	call simulation_recalculate (sim)
	call simulation_decay (sim, rng, proc)
	else if (.not. sim%read_raw) then
	if (sim%checkpointing%active .and. (.not. sim%checkpointing%running)) &
	call checkpointing_msg_start (sim%checkpointing, sim%n_events, &
	sim%i_evt)
	call simulation_select_process (sim, rng, process, proc)
	call simulation_generate_event (sim, rng, process, proc, os_data)
	end if
	call simulation_handle_event (sim)
	call simulation_final_event (sim)
	end subroutine simulation_event

	@ %def simulation_event
	@ Finalize simulation and the simulation object.
	<<XXX Simulations: public>>=
	public :: simulation_final
	<<XXX Simulations: procedures>>=
	subroutine simulation_final (sim, verbose)
	type(simulation_t), intent(inout) :: sim
	logical, intent(in), optional :: verbose
	call simulation_finish_event_generation (sim, verbose)
	call simulation_basic_final (sim)
	end subroutine simulation_final

	@ %def simulation_final
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Structure function configuration}

	This module provides data types and methods for configuring structure
	functions and parameters. It links the user interface
	with the structure-function setup.
	<<[[strfun_config.f90]]>>=
	<<File header>>

	module strfun_config

	<<Use kinds>>
	<<Use strings>>
	<<Use file utils>>
	use diagnostics !NODEP!
	use tao_random_numbers !NODEP!
	use pdf_builtin !NODEP!
	use md5
	use models
	use flavors
	use sf_isr
	use sf_epa
	use sf_ewa
	use sf_circe1
	use sf_circe2
	use sf_escan
	use sf_beam_events
	use sf_lhapdf
	use sf_pdf_builtin
	use sf_user
	use strfun
	use processes

	<<Standard module head>>

	<<Strfun config: public>>

	<<Strfun config: types>>

	contains

	<<Strfun config: procedures>>

	end module strfun_config
	@ %def strfun_config
	@
	\subsection{Structure function codes}
	Re-export them from the lower-level module:
	<<Strfun config: public>>=
	public :: STRF_NONE
	public :: STRF_LHAPDF
	public :: STRF_ISR
	public :: STRF_EPA
	public :: STRF_EWA
	public :: STRF_CIRCE1
	public :: STRF_CIRCE2
	public :: STRF_ESCAN
	public :: STRF_BEVT
	public :: STRF_PDF_BUILTIN
	public :: STRF_USER
	@ %def STRF_NONE STRF_LHAPDF STRF_ISR STRF_EPA
	@ %def STRF_EWA STRF_CIRCE1 STRF_CIRCE2 STRF_ESCAN STRF_BEVT
	@ %def STRF_PDF_BUILTIN STRF_USER
	@
	\subsection{Mapping configuration}
	A mapping is defined for a particular set of $x$-parameters. It has a
	type and a set of real parameters whose meaning depends on the type.
	<<Strfun config: types>>=
	type :: sf_mapping_t
	private
	integer, dimension(:), allocatable :: index
	integer :: type = SFM_NONE
	real(default), dimension(:), allocatable :: par
	end type sf_mapping_t

	@ %def sf_mapping_t
	@ Output
	<<Strfun config: procedures>>=
	subroutine sf_mapping_write (sf_mapping, unit)
	type(sf_mapping_t), intent(in) :: sf_mapping
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, "(1x,A,I0,10(', #',I0))") "Mapping for parameters #", &
	sf_mapping%index
	select case (sf_mapping%type)
	case (SFM_NONE); write (u, "(3x,A)") "[none]"
	case (SFM_PAIR); write (u, "(3x,A)") "Pair mapping"
	end select
	if (allocated (sf_mapping%par)) then
	write (u, "(3x,A)", advance="no") "Parameters = "
	write (u, *) sf_mapping%par
	end if
	end subroutine sf_mapping_write

	@ %def sf_mapping_write
	@
	\subsection{Single structure function}
	This type holds the configuration of a structure function or function
	pair.
	<<Strfun config: public>>=
	public :: sf_data_t
	<<Strfun config: types>>=
	type :: sf_data_t
	private
	integer :: type = STRF_NONE
	logical, dimension(2) :: affects_beam = .false.
	integer :: n_parameters = 0
	type(lhapdf_data_t) :: lhapdf
	type(pdf_builtin_data_t) :: pdf_builtin
	type(isr_data_t) :: isr
	type(epa_data_t) :: epa
	type(ewa_data_t) :: ewa
	type(circe1_data_t) :: circe1
	type(circe2_data_t) :: circe2
	type(escan_data_t) :: escan
	type(beam_events_data_t) :: beam_events
	type(sf_user_data_t) :: user
	logical :: has_mapping = .false.
	type(sf_mapping_t) :: mapping
	type(sf_data_t), pointer :: next => null ()
	end type sf_data_t

	@ %def sf_data_t
	@ Output:
	<<Strfun config: procedures>>=
	subroutine sf_data_write (sf_data, unit, md5, beam_fmt)
	type(sf_data_t), intent(in) :: sf_data
	integer, intent(in), optional :: unit
	integer :: u
	logical, intent(in), optional :: md5
	logical, intent(in), optional :: beam_fmt
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)", advance="no") "Structure function"
	if (all (sf_data%affects_beam)) then
	write (u, "(1x,A)") "(both beams)"
	else if (sf_data%affects_beam(1)) then
	write (u, "(1x,A)") "(beam 1)"
	else if (sf_data%affects_beam(2)) then
	write (u, "(1x,A)") "(beam 2)"
	else
	write (u, "(1x,A)") "(no beams)"
	end if
	select case (sf_data%type)
	case (STRF_NONE)
	write (u, "(1x,A)") "[none]"
	case (STRF_LHAPDF)
	call lhapdf_data_write (sf_data%lhapdf, unit, md5, beam_fmt)
	case (STRF_PDF_BUILTIN)
	call pdf_builtin_data_write (sf_data%pdf_builtin, unit, md5, beam_fmt)
	case (STRF_ISR)
	call isr_data_write (sf_data%isr, unit, md5)
	case (STRF_EPA)
	call epa_data_write (sf_data%epa, unit, md5)
	case (STRF_EWA)
	call ewa_data_write (sf_data%ewa, unit, md5)
	case (STRF_CIRCE1)
	call circe1_data_write (sf_data%circe1, unit, md5)
	case (STRF_CIRCE2)
	call circe2_data_write (sf_data%circe2, unit, md5)
	case (STRF_ESCAN)
	call escan_data_write (sf_data%escan, unit, md5)
	case (STRF_BEVT)
	call beam_events_data_write (sf_data%beam_events, unit, md5)
	case (STRF_USER)
	call sf_user_data_write (sf_data%user, unit, md5)
	end select
	write (u, *) "n_parameters = ", sf_data%n_parameters
	if (sf_data%has_mapping) then
	call sf_mapping_write (sf_data%mapping, unit)
	end if
	end subroutine sf_data_write

	@ %def sf_data_write
	@ Retrieving contents:
	<<Strfun config: public>>=
	public :: sf_data_affects_beam
	public :: sf_data_get_n_parameters
	<<Strfun config: procedures>>=
	function sf_data_affects_beam (sf_data) result (affects_beam)
	logical, dimension(2) :: affects_beam
	type(sf_data_t), intent(in) :: sf_data
	affects_beam = sf_data%affects_beam
	end function sf_data_affects_beam

	function sf_data_get_n_parameters (sf_data) result (n_parameters)
	integer :: n_parameters
	type(sf_data_t), intent(in) :: sf_data
	n_parameters = sf_data%n_parameters
	end function sf_data_get_n_parameters

	@ %def sf_data_affects_beam
	@ %def sf_data_get_n_parameters
	@ Return pointers to data blocks (QCD-related only)
	<<Strfun config: procedures>>=
	function sf_data_get_lhapdf_data_ptr (sf_data) result (lhapdf_data)
	type(sf_data_t), intent(in), target :: sf_data
	type(lhapdf_data_t), pointer :: lhapdf_data
	select case (sf_data%type)
	case (STRF_LHAPDF)
	lhapdf_data => sf_data%lhapdf
	case default
	lhapdf_data => null ()
	end select
	end function sf_data_get_lhapdf_data_ptr

	function sf_data_get_pdf_builtin_data_ptr (sf_data) result (pdf_builtin_data)
	type(sf_data_t), intent(in), target :: sf_data
	type(pdf_builtin_data_t), pointer :: pdf_builtin_data
	select case (sf_data%type)
	case (STRF_PDF_BUILTIN)
	pdf_builtin_data => sf_data%pdf_builtin
	case default
	pdf_builtin_data => null ()
	end select
	end function sf_data_get_pdf_builtin_data_ptr

	@ %def sf_data_get_lhapdf_data_ptr
	@ %def sf_data_get_pdf_builtin_data_ptr
	@ Initialize the mapping block with a single parameter.
	<<Strfun config: public>>=
	public :: sf_data_setup_mapping
	<<Strfun config: procedures>>=
	subroutine sf_data_setup_mapping (sf_data, type, index, par)
	type(sf_data_t), intent(inout) :: sf_data
	integer, intent(in) :: type
	integer, dimension(:), intent(in) :: index
	real(default), intent(in) :: par
	sf_data%mapping%type = type
	allocate (sf_data%mapping%index (size (index)))
	sf_data%mapping%index = index
	allocate (sf_data%mapping%par (1))
	sf_data%mapping%par = par
	sf_data%has_mapping = .true.
	end subroutine sf_data_setup_mapping

	@ %def sf_data_setup_mapping
	@ Initialize a dataset in the list with LHAPDF-specific options.

	For the PDF pair case, we apply a mapping of the unit square which has
	a real-valued power as parameter. The default value is two.
	<<Strfun config: public>>=
	public :: sf_data_init_lhapdf
	<<Strfun config: procedures>>=
	subroutine sf_data_init_lhapdf (sf_data, i, &
	lhapdf_status, model, flv, prefix, file, member, photon_scheme)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(lhapdf_status_t), intent(inout) :: lhapdf_status
	type(model_t), intent(in), target :: model
	type(flavor_t), intent(in) :: flv
	type(string_t), intent(in), optional :: prefix, file
	integer, intent(in), optional :: member
	integer, intent(in), optional :: photon_scheme
	sf_data%type = STRF_LHAPDF
	call lhapdf_data_init (sf_data%lhapdf, lhapdf_status, &
	model, flv, prefix, file, member, photon_scheme)
	sf_data%affects_beam(i) = .true.
	sf_data%n_parameters = 1
	end subroutine sf_data_init_lhapdf

	@ %def sf_data_init_lhapdf
	<<Strfun config: public>>=
	public :: sf_data_init_pdf_builtin
	<<Strfun config: procedures>>=
	subroutine sf_data_init_pdf_builtin (sf_data, i, &
	pdf_builtin_status, model, flv, name, path)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(pdf_builtin_status_t), intent(inout) :: pdf_builtin_status
	type(model_t), intent(in), target :: model
	type(flavor_t), intent(in) :: flv
	type(string_t), intent(in), optional :: name, path
	sf_data%type = STRF_PDF_BUILTIN
	call pdf_builtin_init (sf_data%pdf_builtin, pdf_builtin_status, &
	model, flv, name, path)
	sf_data%affects_beam(i) = .true.
	sf_data%n_parameters = 1
	end subroutine sf_data_init_pdf_builtin

	@ %def sf_data_init_pdf_builtin
	<<Strfun config: public>>=
	public :: sf_data_init_isr
	<<Strfun config: procedures>>=
	subroutine sf_data_init_isr &
	(sf_data, i, model, flv, recoil, alpha, q_max, mass, order)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(model_t), intent(in), target :: model
	type(flavor_t), intent(in) :: flv
	logical, intent(in) :: recoil
	real(default), intent(in) :: alpha, q_max
	real(default), intent(in), optional :: mass
	integer, intent(in), optional :: order
	sf_data%type = STRF_ISR
	call isr_data_init (sf_data%isr, model, flv, alpha, q_max, mass)
	if (present (order)) call isr_data_set_order (sf_data%isr, order)
	call isr_data_check (sf_data%isr)
	sf_data%affects_beam(i) = .true.
	if (recoil) then
	sf_data%n_parameters = 3
	else
	sf_data%n_parameters = 1
	end if
	end subroutine sf_data_init_isr

	@ %def sf_data_init_isr
	<<Strfun config: public>>=
	public :: sf_data_init_epa
	<<Strfun config: procedures>>=
	subroutine sf_data_init_epa &
	(sf_data, i, model, flv, recoil, alpha, x_min, q_min, E_max, mass)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(model_t), intent(in), target :: model
	type(flavor_t), intent(in) :: flv
	logical, intent(in) :: recoil
	real(default), intent(in) :: alpha, x_min, q_min, E_max
	real(default), intent(in), optional :: mass
	sf_data%type = STRF_EPA
	call epa_data_init (sf_data%epa, &
	model, flv, alpha, x_min, q_min, E_max, mass)
	call epa_data_check (sf_data%epa)
	sf_data%affects_beam(i) = .true.
	if (recoil) then
	sf_data%n_parameters = 3
	else
	sf_data%n_parameters = 1
	end if
	end subroutine sf_data_init_epa

	@ %def sf_data_init_epa
	<<Strfun config: public>>=
	public :: sf_data_init_ewa
	<<Strfun config: procedures>>=
	subroutine sf_data_init_ewa &
	(sf_data, i, model, flv, x_min, q_min, pt_max, sqrts, &
	keep_momentum, keep_energy, mass)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(model_t), intent(in), target :: model
	type(flavor_t), intent(in) :: flv
	real(default), intent(in) :: x_min, q_min, pt_max, sqrts
	logical, intent(in) :: keep_momentum, keep_energy
	real(default), intent(in), optional :: mass
	sf_data%type = STRF_EWA
	call ewa_data_init (sf_data%ewa, &
	model, flv, x_min, q_min, pt_max, sqrts, &
	keep_momentum, keep_energy, mass)
	call ewa_data_check (sf_data%ewa)
	sf_data%affects_beam(i) = .true.
	if (keep_momentum .or. keep_energy) then
	sf_data%n_parameters = 3
	else
	sf_data%n_parameters = 1
	end if
	end subroutine sf_data_init_ewa

	@ %def sf_data_init_ewa
	<<Strfun config: public>>=
	public :: sf_data_init_circe1
	<<Strfun config: procedures>>=
	subroutine sf_data_init_circe1 (sf_data, &
	model, flv, sqrts, photon, generate, rng, map, ver, rev, acc, chat)
	type(sf_data_t), intent(out) :: sf_data
	type(model_t), intent(in), target :: model
	type(flavor_t), dimension(2), intent(in) :: flv
	real(default), intent(in) :: sqrts
	logical, dimension(2), intent(in) :: photon
	logical, intent(in) :: generate, map
	type(tao_random_state), intent(in), target :: rng
	integer, intent(in) :: ver, rev, acc, chat
	sf_data%type = STRF_CIRCE1
	call circe1_data_init (sf_data%circe1, &
	model, flv, sqrts, photon, generate, rng, map, ver, rev, acc, chat)
	call circe1_data_check (sf_data%circe1)
	sf_data%affects_beam = .true.
	sf_data%n_parameters = 2
	end subroutine sf_data_init_circe1

	@ %def sf_data_init_circe1
	<<Strfun config: public>>=
	public :: sf_data_init_circe2
	<<Strfun config: procedures>>=
	subroutine sf_data_init_circe2 (sf_data, &
	flv, generate, rng, map, file, design, sqrts, polarized)
	type(sf_data_t), intent(out) :: sf_data
	type(flavor_t), dimension(2), intent(in) :: flv
	logical, intent(in) :: generate
	type(tao_random_state), intent(in), target :: rng
	logical, intent(in) :: map
	type(string_t), intent(in) :: file, design
	real(default), intent(in) :: sqrts
	logical, intent(in) :: polarized
	sf_data%type = STRF_CIRCE2
	call circe2_data_init (sf_data%circe2, &
	flv, generate, rng, map, file, design, sqrts, polarized)
	sf_data%affects_beam = .true.
	sf_data%n_parameters = 2
	end subroutine sf_data_init_circe2

	@ %def sf_data_init_circe2
	<<Strfun config: public>>=
	public :: sf_data_init_escan
	<<Strfun config: procedures>>=
	subroutine sf_data_init_escan (sf_data, affects_beam, flv, sqrts)
	type(sf_data_t), intent(out) :: sf_data
	logical, dimension(2), intent(in) :: affects_beam
	type(flavor_t), dimension(2), intent(in) :: flv
	real(default), intent(in) :: sqrts
	sf_data%type = STRF_ESCAN
	call escan_data_init (sf_data%escan, affects_beam, flv, sqrts)
	sf_data%affects_beam = affects_beam
	sf_data%n_parameters = count (affects_beam)
	end subroutine sf_data_init_escan

	@ %def sf_data_init_escan
	<<Strfun config: public>>=
	public :: sf_data_init_beam_events
	<<Strfun config: procedures>>=
	subroutine sf_data_init_beam_events &
	(sf_data, affects_beam, flv, file, warn_eof)
	type(sf_data_t), intent(out) :: sf_data
	logical, dimension(2), intent(in) :: affects_beam
	type(flavor_t), dimension(2), intent(in) :: flv
	type(string_t), intent(in) :: file
	logical, intent(in) :: warn_eof
	sf_data%type = STRF_BEVT
	call beam_events_data_init (sf_data%beam_events, &
	affects_beam, flv, file, warn_eof)
	call beam_events_data_open (sf_data%beam_events)
	sf_data%affects_beam = affects_beam
	sf_data%n_parameters = 0
	end subroutine sf_data_init_beam_events

	@ %def sf_data_init_beam_events
	<<Strfun config: public>>=
	public :: sf_data_init_user
	<<Strfun config: procedures>>=
	subroutine sf_data_init_user (sf_data, i, flv, name, model)
	type(sf_data_t), intent(out) :: sf_data
	integer, intent(in) :: i
	type(flavor_t), dimension(2), intent(in) :: flv
	type(string_t), intent(in) :: name
	type(model_t), intent(in), target :: model
	sf_data%type = STRF_USER
	call sf_user_data_init (sf_data%user, name, flv, model)
	select case (sf_user_data_get_n_in (sf_data%user))
	case (1)
	sf_data%affects_beam(i) = .true.
	case (2)
	sf_data%affects_beam = .true.
	end select
	sf_data%n_parameters = sf_user_data_get_n_dim (sf_data%user)
	end subroutine sf_data_init_user

	@ %def sf_data_init_user
	@
	\subsection{Structure function list}
	A list of structure functions and associated mappings.
	<<Strfun config: public>>=
	public :: sf_list_t
	<<Strfun config: types>>=
	type :: sf_list_t
	private
	integer :: n_strfun = 0
	logical :: multichannel = .false.
	integer :: n_mapping = 0
	integer, dimension(2) :: global_mapping_index = 0
	integer :: global_mapping_type = SFM_NONE
	real(default) :: global_mapping_par = 1
	type(sf_data_t), pointer :: first => null ()
	type(sf_data_t), pointer :: last => null ()
	character(32) :: md5sum = ""
	end type sf_list_t

	@ %def sf_list_t
	@ Output
	<<Strfun config: public>>=
	public :: sf_list_write
	<<Strfun config: procedures>>=
	subroutine sf_list_write (sf_list, unit, md5, beam_fmt)
	type(sf_list_t), intent(in) :: sf_list
	integer, intent(in), optional :: unit
	integer :: u
	logical, intent(in), optional :: md5
	logical, intent(in), optional :: beam_fmt
	type(sf_data_t), pointer :: current
	u = output_unit (unit); if (u < 0) return
	write (u, "(A)") "Structure function list"
	if (sf_list%multichannel .and. sf_list%n_mapping /= 0) then
	write (u, "(2x,A,L1)") "Global structure function mapping:"
	write (u, "(4x,A,2I0)") "Index = ", sf_list%global_mapping_index
	write (u, "(4x,A,I0)") "Type = ", sf_list%global_mapping_type
	write (u, "(4x,A)", advance="no") "Parameter = "
	write (u, *) sf_list%global_mapping_par
	end if
	if (associated (sf_list%first)) then
	current => sf_list%first
	do while (associated (current))
	call sf_data_write (current, unit, md5, beam_fmt)
	current => current%next
	end do
	else
	write (u, "(1x,A)") "[empty]"
	end if
	end subroutine sf_list_write

	@ %def sf_list_write
	@ Append a data set to the list. For EPA, several data sets may be
	used in parallel. Allocate only one.
	<<Strfun config: public>>=
	public :: sf_list_append
	<<Strfun config: procedures>>=
	subroutine sf_list_append (sf_list, sf_data)
	type(sf_list_t), intent(inout) :: sf_list
	type(sf_data_t), intent(in), target :: sf_data
	if (associated (sf_list%last)) then
	sf_list%last%next => sf_data
	else
	sf_list%first => sf_data
	end if
	sf_list%last => sf_data
	sf_list%n_strfun = sf_list%n_strfun + 1
	end subroutine sf_list_append

	@ %def sf_list_append
	@ Count mappings. If the [[multichannel]] flag is set, the mappings
	that are stored in the individual structure functions are not used
	directly, but transformed into channel-individual mappings.
	<<Strfun config: public>>=
	public :: sf_list_freeze
	<<Strfun config: procedures>>=
	subroutine sf_list_freeze (sf_list, multichannel)
	type(sf_list_t), intent(inout) :: sf_list
	logical, intent(in) :: multichannel
	type(sf_data_t), pointer :: sf_data
	integer :: i_par
	sf_list%multichannel = multichannel
	if (multichannel) then
	sf_list%n_mapping = 0
	i_par = 0
	sf_data => sf_list%first
	do while (associated (sf_data))
	if (sf_data%has_mapping) then
	sf_list%n_mapping = 1
	sf_list%global_mapping_index = i_par + sf_data%mapping%index
	sf_list%global_mapping_type = sf_data%mapping%type
	select case (sf_data%mapping%type)
	case (SFM_PAIR)
	if (allocated (sf_data%mapping%par)) then
	sf_list%global_mapping_par = &
	max (sf_list%global_mapping_par, sf_data%mapping%par(1))
	end if
	end select
	end if
	i_par = i_par + sf_data%n_parameters
	sf_data => sf_data%next
	end do
	else
	sf_list%n_mapping = 0
	sf_data => sf_list%first
	do while (associated (sf_data))
	if (sf_data%has_mapping) then
	sf_list%n_mapping = sf_list%n_mapping + 1
	end if
	sf_data => sf_data%next
	end do
	end if
	end subroutine sf_list_freeze

	@ %def sf_list_freeze
	@ Finalize.
	<<Strfun config: public>>=
	public :: sf_list_final
	<<Strfun config: procedures>>=
	subroutine sf_list_final (sf_list)
	type(sf_list_t), intent(inout) :: sf_list
	type(sf_data_t), pointer :: sf_data
	do while (associated (sf_list%first))
	sf_data => sf_list%first
	sf_list%first => sf_list%first%next
	deallocate (sf_data)
	end do
	sf_list%last => null ()
	sf_list%n_strfun = 0
	end subroutine sf_list_final

	@ %def sf_list_final
	@ Return number of structure functions.
	<<Strfun config: public>>=
	public :: sf_list_get_n_strfun
	<<Strfun config: procedures>>=
	function sf_list_get_n_strfun (sf_list) result (n)
	integer :: n
	type(sf_list_t), intent(in) :: sf_list
	n = sf_list%n_strfun
	end function sf_list_get_n_strfun

	@ %def sf_list_get_n_strfun
	@ Return the MD5 checksum.
	<<Strfun config: public>>=
	public :: sf_list_get_md5sum
	<<Strfun config: procedures>>=
	function sf_list_get_md5sum (sf_list) result (sf_md5sum)
	character(32) :: sf_md5sum
	type(sf_list_t), intent(in) :: sf_list
	sf_md5sum = sf_list%md5sum
	end function sf_list_get_md5sum

	@ %def sf_list_get_md5sum
	@ Compute the MD5 checksum.
	<<Strfun config: public>>=
	public :: sf_list_compute_md5sum
	<<Strfun config: procedures>>=
	subroutine sf_list_compute_md5sum (sf_list)
	type(sf_list_t), intent(inout) :: sf_list
	integer :: unit
	unit = free_unit ()
	open (unit = unit, status = "scratch", action = "readwrite")
	call sf_list_write (sf_list, unit, md5=.true.)
	rewind (unit)
	sf_list%md5sum = md5sum (unit)
	close (unit)
	end subroutine sf_list_compute_md5sum

	@ %def sf_list_compute_md5sum
	@ Extract any PDF data from the structure function list, so they
	can be used consistently elsewhere. In case of multiple entries
	(e.g., different LHAPDF settings for both beams), the first match is returned.

	We return pointers; a null pointer indicates the absence of a matching
	data set. The implementation has to ensure the validity of the target
	for the lifetime of the pointer.
	<<Strfun config: public>>=
	public :: sf_list_get_lhapdf_data_ptr
	public :: sf_list_get_pdf_builtin_data_ptr
	<<Strfun config: procedures>>=
	function sf_list_get_lhapdf_data_ptr (sf_list) result (lhapdf_data)
	type(sf_list_t), intent(in) :: sf_list
	type(lhapdf_data_t), pointer :: lhapdf_data
	type(sf_data_t), pointer :: sf_data
	lhapdf_data => null ()
	sf_data => sf_list%first
	FIND_LHAPDF: do while (associated (sf_data))
	lhapdf_data => sf_data_get_lhapdf_data_ptr (sf_data)
	if (associated (lhapdf_data)) exit FIND_LHAPDF
	sf_data => sf_data%next
	end do FIND_LHAPDF
	end function sf_list_get_lhapdf_data_ptr

	function sf_list_get_pdf_builtin_data_ptr (sf_list) result (pdf_builtin_data)
	type(sf_list_t), intent(in) :: sf_list
	type(pdf_builtin_data_t), pointer :: pdf_builtin_data
	type(sf_data_t), pointer :: sf_data
	pdf_builtin_data => null ()
	sf_data => sf_list%first
	FIND_PDF_BUILTIN: do while (associated (sf_data))
	pdf_builtin_data => sf_data_get_pdf_builtin_data_ptr (sf_data)
	if (associated (pdf_builtin_data)) exit FIND_PDF_BUILTIN
	sf_data => sf_data%next
	end do FIND_PDF_BUILTIN
	end function sf_list_get_pdf_builtin_data_ptr

	@ %def sf_list_get_lhapdf_data_ptr
	@ %def sf_list_get_pdf_builtin_data_ptr
	@
	\subsection{Transfer to the process object}
	Initialize actual structure functions, once the [[sf_list]] is
	complete. Beam initialization has to come before this.
	<<Strfun config: public>>=
	public :: sf_list_transfer_to_process
	<<Strfun config: procedures>>=
	subroutine sf_list_transfer_to_process (sf_list, process)
	type(sf_list_t), intent(in) :: sf_list
	type(process_t), intent(inout), target :: process
	type(sf_data_t), pointer :: sf_data
	integer :: i_sf, line
	i_sf = 0
	sf_data => sf_list%first
	do while (associated (sf_data))
	if (all (sf_data%affects_beam)) then
	line = 0
	else if (sf_data%affects_beam(1)) then
	line = 1
	else if (sf_data%affects_beam(2)) then
	line = 2
	end if
	i_sf = i_sf + 1
	select case (sf_data%type)
	case (STRF_LHAPDF)
	call process_set_strfun &
	(process, i_sf, line, sf_data%lhapdf, sf_data%n_parameters)
	case (STRF_PDF_BUILTIN)
	call process_set_strfun &
	(process, i_sf, line, sf_data%pdf_builtin, sf_data%n_parameters)
	case (STRF_ISR)
	call process_set_strfun &
	(process, i_sf, line, sf_data%isr, sf_data%n_parameters)
	case (STRF_EPA)
	call process_set_strfun &
	(process, i_sf, line, sf_data%epa, sf_data%n_parameters)
	case (STRF_EWA)
	call process_set_strfun &
	(process, i_sf, line, sf_data%ewa, sf_data%n_parameters)
	case (STRF_CIRCE1)
	call process_set_strfun &
	(process, i_sf, line, sf_data%circe1, sf_data%n_parameters)
	case (STRF_CIRCE2)
	call process_set_strfun &
	(process, i_sf, line, sf_data%circe2, sf_data%n_parameters)
	case (STRF_ESCAN)
	call process_set_strfun &
	(process, i_sf, line, sf_data%escan, sf_data%n_parameters)
	case (STRF_BEVT)
	call process_set_strfun &
	(process, i_sf, line, sf_data%beam_events, sf_data%n_parameters)
	case (STRF_USER)
	call process_set_strfun &
	(process, i_sf, line, sf_data%user, sf_data%n_parameters)
	end select
	sf_data => sf_data%next
	end do
	end subroutine sf_list_transfer_to_process

	@ %def sf_list_transfer_to_process
	@ The structure-function mappings are done separately, after the phase
	space is also set up.
	<<Strfun config: public>>=
	public :: sf_list_setup_mappings
	<<Strfun config: procedures>>=
	subroutine sf_list_setup_mappings (sf_list, process)
	type(sf_list_t), intent(in) :: sf_list
	type(process_t), intent(inout), target :: process
	type(sf_data_t), pointer :: sf_data
	integer :: i_map, i_par, channel
	logical :: has_s_mapping
	real(default) :: sqrts, mass, width
	i_map = 0
	i_par = 0
	if (sf_list%multichannel) then
	call process_allocate_strfun_mappings &
	(process, sf_list%multichannel)
	if (sf_list%n_mapping /= 0) then
	select case (sf_list%global_mapping_type)
	case (SFM_PAIR)
	sqrts = process_get_sqrts (process)
	do channel = 1, process_get_n_channels (process)
	! call process_get_s_mapping &
	! (process, channel, has_s_mapping, mass, width)
	has_s_mapping = .false. ! switch off for now
	if (has_s_mapping) then
	call process_set_strfun_mapping &
	(process, 1, channel, sf_list%global_mapping_index, &
	SFM_PAIR_RESONANCE, &
	(/sqrts, mass, width/))
	else
	call process_set_strfun_mapping &
	(process, 1, channel, sf_list%global_mapping_index, &
	SFM_PAIR, &
	(/sf_list%global_mapping_par/))
	end if
	end do
	case default
	call msg_bug ("Strfun mappings: inconsistent mapping type")
	end select
	end if
	else
	call process_allocate_strfun_mappings (process, &
	sf_list%multichannel, &
	sf_list%n_mapping)
	sf_data => sf_list%first
	do while (associated (sf_data))
	if (sf_data%has_mapping) then
	i_map = i_map + 1
	call process_set_strfun_mapping &
	(process, i_map, 1, i_par + sf_data%mapping%index, &
	sf_data%mapping%type, sf_data%mapping%par)
	end if
	i_par = i_par + sf_data%n_parameters
	sf_data => sf_data%next
	end do
	end if
	end subroutine sf_list_setup_mappings

	@ %def sf_list_setup_mappings
	@
	\subsection{The LHAPDF status}
	We re-export this from the [[sf_lhapdf]] module, so this need not be
	referenced directly:
	<<Strfun config: public>>=
	public :: lhapdf_status_t
	public :: lhapdf_status_reset
	@ %def lhapdf_status_t lhapdf_status_reset
	%------------------------------------------------------------------------
	\section{Spectra and structure functions: wrapper}

	In this module, we collect, for each type of spectrum or structure
	function, the data, initialization routines, and applications.
	<<[[strfun.f90]]>>=
	<<File header>>

	module strfun

	<<Use kinds>>
	<<Use strings>>
	<<Use file utils>>
	!! !! use diagnostics !NODEP!
	!! !! use lorentz !NODEP!
	!! !! use models
	!! !! use quantum_numbers
	!! !! use interactions
	!! !! use evaluators
	!! !! use beams
	!! !! use sf_isr
	!! !! use sf_epa
	!! !! use sf_ewa
	!! !! use sf_circe1
	!! !! use sf_circe2
	!! !! use sf_escan
	!! !! use sf_beam_events
	!! !! use sf_lhapdf
	!! !! use sf_pdf_builtin
	!! !! use sf_user

	<<Standard module head>>

	<<Strfun: public>>

	<<Strfun: parameters>>

	<<Strfun: types>>

	<<Strfun: interfaces>>

	contains

	<<Strfun: procedures>>

	end module strfun
	@ %def strfun
	@
	\subsection{The structure functions type}
	\subsubsection{Definition}
	This contains the specific structure function data, much of which
	depends on the type. An extensible type would be appropriate. As
	long as this is not available in general, we emulate it by allocating
	the requested data explicitly.
	<<Strfun: types>>=
	!! !! type :: strfun_t
	!! !! private
	!! !! integer :: type = STRF_NONE
	!! !! type(string_t) :: name
	!! !! type(interaction_t) :: int
	!! !! type(lhapdf_data_t), dimension(:), allocatable :: lhapdf_data
	!! !! type(pdf_builtin_data_t), dimension(:), allocatable :: pdf_builtin_data
	!! !! type(isr_data_t), dimension(:), allocatable :: isr_data
	!! !! type(epa_data_t), dimension(:), allocatable :: epa_data
	!! !! type(ewa_data_t), dimension(:), allocatable :: ewa_data
	!! !! type(circe1_data_t), dimension(:), allocatable :: circe1_data
	!! !! type(circe2_data_t), dimension(:), allocatable :: circe2_data
	!! !! type(escan_data_t), dimension(:), allocatable :: escan_data
	!! !! type(beam_events_data_t), dimension(:), allocatable :: beam_events_data
	!! !! type(sf_user_data_t), dimension(:), allocatable :: user_data
	!! !! real(default) :: x = 0, f = 1, s = 0
	!! !! real(default), dimension(:), allocatable :: user_xval
	!! !! real(default) :: scale = 0
	!! !! end type strfun_t

	@ %def strfun_t
	The list of structure function codes:
	<<Strfun: parameters>>=
	integer, parameter, public :: STRF_NONE = 0
	integer, parameter, public :: STRF_LHAPDF = 1, STRF_ISR = 2, &
	STRF_EPA = 3, STRF_EWA = 4, STRF_CIRCE1 = 5, STRF_CIRCE2 = 6, &
	STRF_ESCAN = 7, STRF_BEVT = 8, STRF_PDF_BUILTIN = 9
	integer, parameter, public :: STRF_USER = 99

	@ %def STRF_NONE STRF_LHAPDF STRF_ISR STRF_EPA STRF_EWA
	@ %def STRF_CIRCE1 STRF_CIRCE2 STRF_ESCAN STRF_BEVT STRF_PDF_BUILTIN
	@ %def STRF_USER
	@ The initializer assigns specific data and tags the interaction. The
	data block(s) have to be known already.
	<<Strfun: interfaces>>=
	interface strfun_init
	module procedure strfun_init_lhapdf
	module procedure strfun_init_isr
	module procedure strfun_init_epa
	module procedure strfun_init_ewa
	module procedure strfun_init_circe1
	module procedure strfun_init_circe2
	module procedure strfun_init_escan
	module procedure strfun_init_beam_events
	module procedure strfun_init_pdf_builtin
	module procedure strfun_init_user
	end interface

	<<Strfun: procedures>>=
	!! !! subroutine strfun_init_lhapdf (strfun, lhapdf_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(lhapdf_data_t), intent(in) :: lhapdf_data
	!! !! strfun%type = STRF_LHAPDF
	!! !! strfun%name = "LHAPDF"
	!! !! allocate (strfun%lhapdf_data (1))
	!! !! strfun%lhapdf_data = lhapdf_data
	!! !! call interaction_init_lhapdf (strfun%int, lhapdf_data)
	!! !! end subroutine strfun_init_lhapdf
	!! !!
	!! !! subroutine strfun_init_pdf_builtin (strfun, pdf_builtin_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(pdf_builtin_data_t), intent(in) :: pdf_builtin_data
	!! !! strfun%type = STRF_PDF_BUILTIN
	!! !! strfun%name = "builtin PDF: " // pdf_builtin_get_name (pdf_builtin_data)
	!! !! allocate (strfun%pdf_builtin_data (1))
	!! !! strfun%pdf_builtin_data = pdf_builtin_data
	!! !! call interaction_init_pdf_builtin (strfun%int, pdf_builtin_data)
	!! !! end subroutine strfun_init_pdf_builtin
	!! !!
	!! !! subroutine strfun_init_isr (strfun, isr_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(isr_data_t), intent(in) :: isr_data
	!! !! strfun%type = STRF_ISR
	!! !! strfun%name = "ISR"
	!! !! allocate (strfun%isr_data (1))
	!! !! strfun%isr_data = isr_data
	!! !! call interaction_init_isr (strfun%int, isr_data)
	!! !! end subroutine strfun_init_isr
	!! !!
	!! !! subroutine strfun_init_epa (strfun, epa_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(epa_data_t), intent(in) :: epa_data
	!! !! strfun%type = STRF_EPA
	!! !! strfun%name = "EPA"
	!! !! allocate (strfun%epa_data (1))
	!! !! strfun%epa_data = epa_data
	!! !! call interaction_init_epa (strfun%int, epa_data)
	!! !! end subroutine strfun_init_epa
	!! !!
	!! !! subroutine strfun_init_ewa (strfun, ewa_data, id)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(ewa_data_t), intent(inout) :: ewa_data
	!! !! integer, intent(in) :: id
	!! !! strfun%type = STRF_EWA
	!! !! strfun%name = "EWA"
	!! !! allocate (strfun%ewa_data (1))
	!! !! call ewa_set_id (ewa_data, id)
	!! !! strfun%ewa_data = ewa_data
	!! !! call interaction_init_ewa (strfun%int, ewa_data)
	!! !! end subroutine strfun_init_ewa
	!! !!
	!! !! subroutine strfun_init_circe1 (strfun, circe1_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(circe1_data_t), intent(in) :: circe1_data
	!! !! strfun%type = STRF_CIRCE1
	!! !! strfun%name = "CIRCE1"
	!! !! allocate (strfun%circe1_data (1))
	!! !! strfun%circe1_data = circe1_data
	!! !! call interaction_init_circe1 (strfun%int, circe1_data)
	!! !! end subroutine strfun_init_circe1
	!! !!
	!! !! subroutine strfun_init_circe2 (strfun, circe2_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(circe2_data_t), intent(in) :: circe2_data
	!! !! strfun%type = STRF_CIRCE2
	!! !! strfun%name = "CIRCE2"
	!! !! allocate (strfun%circe2_data (1))
	!! !! strfun%circe2_data = circe2_data
	!! !! call interaction_init_circe2 (strfun%int, circe2_data)
	!! !! end subroutine strfun_init_circe2
	!! !!
	!! !! subroutine strfun_init_escan (strfun, escan_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(escan_data_t), intent(in) :: escan_data
	!! !! strfun%type = STRF_ESCAN
	!! !! strfun%name = "Energy scan"
	!! !! allocate (strfun%escan_data (1))
	!! !! strfun%escan_data = escan_data
	!! !! call interaction_init_escan (strfun%int, escan_data)
	!! !! end subroutine strfun_init_escan
	!! !!
	!! !! subroutine strfun_init_beam_events (strfun, beam_events_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(beam_events_data_t), intent(in) :: beam_events_data
	!! !! strfun%type = STRF_BEVT
	!! !! strfun%name = "Beam events"
	!! !! allocate (strfun%beam_events_data (1))
	!! !! strfun%beam_events_data = beam_events_data
	!! !! call interaction_init_beam_events (strfun%int, beam_events_data)
	!! !! end subroutine strfun_init_beam_events
	!! !!
	!! !! subroutine strfun_init_user (strfun, user_data)
	!! !! type(strfun_t), intent(out) :: strfun
	!! !! type(sf_user_data_t), intent(in) :: user_data
	!! !! strfun%type = STRF_USER
	!! !! strfun%name = "User structure function: " &
	!! !! // sf_user_data_get_name (user_data)
	!! !! allocate (strfun%user_data (1))
	!! !! strfun%user_data = user_data
	!! !! call interaction_init_sf_user (strfun%int, user_data)
	!! !! allocate (strfun%user_xval (sf_user_data_get_n_var (user_data)))
	!! !! end subroutine strfun_init_user
	!! !!
	@ %def strfun_init
	@ Finalizer for the contained interaction. The presence of file
	operations forbid the [[elemental]] attribute, therefore the interface.
	<<Strfun: interfaces>>=
	interface strfun_final
	module procedure strfun_final0
	module procedure strfun_final1
	end interface
	<<Strfun: procedures>>=
	subroutine strfun_final1 (strfun)
	type(strfun_t), dimension(:), intent(inout) :: strfun
	integer :: i
	do i = 1, size (strfun)
	call strfun_final0 (strfun(i))
	end do
	end subroutine strfun_final1

	subroutine strfun_final0 (strfun)
	type(strfun_t), intent(inout) :: strfun
	select case (strfun%type)
	case (STRF_ISR)
	deallocate (strfun%isr_data)
	case (STRF_EPA)
	deallocate (strfun%epa_data)
	case (STRF_EWA)
	deallocate (strfun%ewa_data)
	case (STRF_CIRCE1)
	deallocate (strfun%circe1_data)
	case (STRF_CIRCE2)
	deallocate (strfun%circe2_data)
	case (STRF_ESCAN)
	deallocate (strfun%escan_data)
	case (STRF_BEVT)
	call beam_events_data_close (strfun%beam_events_data(1))
	deallocate (strfun%beam_events_data)
	case (STRF_LHAPDF)
	deallocate (strfun%lhapdf_data)
	case (STRF_PDF_BUILTIN)
	call pdf_builtin_final (strfun%pdf_builtin_data(1))
	deallocate (strfun%pdf_builtin_data)
	case (STRF_USER)
	deallocate (strfun%user_data)
	deallocate (strfun%user_xval)
	end select
	call interaction_final (strfun%int)
	strfun%type = STRF_NONE
	end subroutine strfun_final0

	@ %def strfun_final
	@
	\subsubsection{I/O}
	<<Strfun: procedures>>=
	!!subroutine strfun_write (strfun, unit, verbose, show_momentum_sum, show_mass)
	!! type(strfun_t), intent(in) :: strfun
	!! integer, intent(in), optional :: unit
	!! logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	!! integer :: u
	!! u = output_unit (unit); if (u < 0) return
	!! if (strfun%type /= STRF_NONE) then
	!! write (u, *) char (strfun_get_name (strfun)) // " setup:"
	!! select case (strfun%type)
	!! case (STRF_LHAPDF)
	!! call lhapdf_data_write (strfun%lhapdf_data(1), u)
	!! write (u, *) "LHAPDF event data:"
	!! write (u, *) " x =", strfun%x
	!! write (u, *) " f =", strfun%f
	!! write (u, *) " scale =", strfun%scale
	!! write (u, *) " p2 =", strfun%s
	!! case (STRF_PDF_BUILTIN)
	!! call pdf_builtin_data_write (strfun%pdf_builtin_data(1), u)
	!! write (u, *) "PDF event data:"
	!! write (u, *) " x =", strfun%x
	!! write (u, *) " f =", strfun%f
	!! write (u, *) " scale =", strfun%scale
	!! write (u, *) " p2 =", strfun%s
	!! case (STRF_ISR)
	!! call isr_data_write (strfun%isr_data(1), u)
	!! case (STRF_EPA)
	!! call epa_data_write (strfun%epa_data(1), u)
	!! case (STRF_EWA)
	!! call ewa_data_write (strfun%ewa_data(1), u)
	!! case (STRF_CIRCE1)
	!! call circe1_data_write (strfun%circe1_data(1), u)
	!! case (STRF_CIRCE2)
	!! call circe2_data_write (strfun%circe2_data(1), u)
	!! case (STRF_ESCAN)
	!! call escan_data_write (strfun%escan_data(1), u)
	!! case (STRF_BEVT)
	!! call beam_events_data_write (strfun%beam_events_data(1), u)
	!! case (STRF_USER)
	!! call sf_user_data_write (strfun%user_data(1), u)
	!! write (u, *) "User event data:"
	!! if (allocated (strfun%user_xval)) then
	!! write (u, *) " x =", strfun%user_xval
	!! else
	!! write (u, *) " x = [not allocated]"
	!! end if
	!! write (u, *) " scale =", strfun%scale
	!! end select
	!! call interaction_write &
	!! (strfun%int, unit, verbose, show_momentum_sum, show_mass)
	!! else
	!! write (u, *) "Structure function setup: [empty]"
	!! end if
	!!end subroutine strfun_write

	@ %def strfun_write
	@
	\subsubsection{Retrieve data}
	<<Strfun: procedures>>=
	function strfun_get_name (strfun) result (name)
	type(string_t) :: name
	type(strfun_t), intent(in) :: strfun
	name = strfun%name
	end function strfun_get_name

	@ %def strfun_get_name
	<<Strfun: procedures>>=
	function strfun_get_type (strfun) result (type)
	integer :: type
	type(strfun_t), intent(in) :: strfun
	type = strfun%type
	end function strfun_get_type

	@ %def strfun_get_type
	@
	\subsubsection{Apply structure function}
	Set kinematics using input random numbers. For some structure
	functions, we can already compute matrix elements.

	The [[no_map]] flag implies that all preset mappings and generator modes
	should be switched off, and the structure functions should be probed
	directly.
	<<Strfun: procedures>>=
	!! !! subroutine strfun_set_kinematics (strfun, r, no_map)
	!! !! type(strfun_t), intent(inout) :: strfun
	!! !! real(default), dimension(:), intent(in) :: r
	!! !! logical, intent(in) :: no_map
	!! !! select case (strfun%type)
	!! !! case (STRF_LHAPDF)
	!! !! call interaction_set_kinematics_lhapdf (strfun%int, &
	!! !! strfun%x, strfun%f, strfun%s, r(1), strfun%lhapdf_data(1))
	!! !! case (STRF_PDF_BUILTIN)
	!! !! call interaction_set_kinematics_pdf_builtin (strfun%int, &
	!! !! strfun%x, strfun%f, strfun%s, r(1), strfun%pdf_builtin_data(1))
	!! !! case (STRF_ISR)
	!! !! call interaction_apply_isr (strfun%int, r, strfun%isr_data(1), no_map)
	!! !! case (STRF_EPA)
	!! !! call interaction_apply_epa (strfun%int, r, strfun%epa_data, no_map)
	!! !! case (STRF_EWA)
	!! !! call interaction_apply_ewa (strfun%int, r, strfun%ewa_data, no_map)
	!! !! case (STRF_CIRCE1)
	!! !! call interaction_apply_circe1 &
	!! !! (strfun%int, r, strfun%circe1_data(1), no_map)
	!! !! case (STRF_CIRCE2)
	!! !! call interaction_apply_circe2 &
	!! !! (strfun%int, r, strfun%circe2_data(1), no_map)
	!! !! case (STRF_ESCAN)
	!! !! call interaction_apply_escan &
	!! !! (strfun%int, r, strfun%escan_data(1))
	!! !! case (STRF_BEVT)
	!! !! call interaction_apply_beam_events &
	!! !! (strfun%int, strfun%beam_events_data(1))
	!! !! case (STRF_USER)
	!! !! call interaction_set_kinematics_sf_user (strfun%int, &
	!! !! strfun%user_xval, r, strfun%user_data(1))
	!! !! end select
	!! !! end subroutine strfun_set_kinematics

	@ %def strfun_set_kinematics
	@ Set values where they depend on a separate energy scale:
	<<Strfun: procedures>>=
	subroutine strfun_apply (strfun, scale)
	type(strfun_t), intent(inout) :: strfun
	real(default), intent(in) :: scale
	strfun%scale = scale
	select case (strfun%type)
	!! !! case (STRF_LHAPDF)
	!! !! call interaction_apply_lhapdf (strfun%int, scale, &
	!! !! strfun%x, strfun%f, strfun%s, strfun%lhapdf_data(1))
	!! !! case (STRF_PDF_BUILTIN)
	!! !! call interaction_apply_pdf_builtin (strfun%int, scale, &
	!! !! strfun%x, strfun%f, strfun%s, strfun%pdf_builtin_data(1))
	case (STRF_USER)
	call interaction_apply_sf_user (strfun%int, scale, &
	strfun%user_xval, strfun%user_data(1))
	end select
	end subroutine strfun_apply

	@ %def strfun_apply
	@
	\subsection{Mappings}
	\subsubsection{Definition}
	Mappings for single structure functions may be defined in the
	individual sections, but pairwise mappings belong here. We define a
	mapping type that applies to an array of $x$ parameters identified by
	their indices. The individual mapping types are identified by a
	[[type]] parameter. A mapping may depend on a set on real parameters.
	<<Strfun: parameters>>=
	integer, parameter, public :: SFM_NONE = 0
	integer, parameter, public :: SFM_PAIR = 1
	integer, parameter, public :: SFM_PAIR_RESONANCE = 2
	@ %def SFM_NONE SFM_PAIR
	<<Strfun: types>>=
	type :: strfun_mapping_t
	private
	integer, dimension(:), allocatable :: index
	integer :: type = SFM_NONE
	real(default) :: p = 0
	real(default) :: m2 = 0, mg = 0, s = 0
	real(default) :: a1 = 0, a2 = 0, a3 = 0
	end type strfun_mapping_t

	@ %def strfun_mapping_t
	@ Initialization:
	<<Strfun: procedures>>=
	subroutine strfun_mapping_init (sf_mapping, index, type, par)
	type(strfun_mapping_t), intent(out) :: sf_mapping
	integer, dimension(:), intent(in) :: index
	integer, intent(in) :: type
	real(default), dimension(:), intent(in) :: par
	real(default) :: s, m2, mg
	allocate (sf_mapping%index (size (index)))
	sf_mapping%index = index
	sf_mapping%type = type
	select case (type)
	case (SFM_PAIR)
	sf_mapping%p = par(1)
	case (SFM_PAIR_RESONANCE)
	s = par(1)**2
	m2 = par(2)**2
	mg = par(2) * par(3)
	sf_mapping%s = s
	sf_mapping%m2 = m2
	sf_mapping%mg = mg
	sf_mapping%a1 = atan (- m2 / mg)
	sf_mapping%a2 = atan ((s - m2) / mg)
	sf_mapping%a3 = (sf_mapping%a2 - sf_mapping%a1) * mg / s
	end select
	end subroutine strfun_mapping_init

	@ %def strfun_mapping_init
	@ Output
	<<Strfun: procedures>>=
	subroutine strfun_mapping_write (sf_mapping, unit)
	type(strfun_mapping_t), intent(in) :: sf_mapping
	integer, intent(in), optional :: unit
	integer :: u
	u = output_unit (unit); if (u < 0) return
	write (u, "(1x,A)", advance="no") "Strfun mapping for indices: "
	write (u, "(10(1x,I0))") sf_mapping%index
	write (u, "(1x,A,1x,I0)") "mapping type =", sf_mapping%type
	write (u, "(1x,A)", advance="no") "mapping pars ="
	select case (sf_mapping%type)
	case (SFM_NONE)
	write (u, *) "[none]"
	case (SFM_PAIR)
	write (u, *) sf_mapping%p
	case (SFM_PAIR_RESONANCE)
	write (u, *) sf_mapping%s, sf_mapping%m2, sf_mapping%mg
	end select
	end subroutine strfun_mapping_write

	@ %def strfun_mapping_write
	@
	\subsubsection{Evaluation}
	<<Strfun: procedures>>=
	subroutine strfun_mapping_apply (sf_mapping, x, factor)
	type(strfun_mapping_t), intent(in) :: sf_mapping
	real(default), dimension(:), intent(inout) :: x
	real(default), intent(out) :: factor
	real(default) :: f1, f2
	real(default), dimension(2) :: x2
	select case (sf_mapping%type)
	case (SFM_PAIR)
	x2 = x(sf_mapping%index)
	call map_unit_square (x2, factor, sf_mapping%p)
	x(sf_mapping%index) = x2
	case (SFM_PAIR_RESONANCE)
	x2 = x(sf_mapping%index)
	call map_resonance (x2(1), f2, &
	sf_mapping%s, sf_mapping%m2, sf_mapping%mg, &
	sf_mapping%a1, sf_mapping%a2, sf_mapping%a3)
	call map_unit_square (x2, f1)
	x(sf_mapping%index) = x2
	factor = f1 * f2
	case default
	factor = 1
	end select
	end subroutine strfun_mapping_apply

	subroutine strfun_mapping_apply_inverse (sf_mapping, x, factor)
	type(strfun_mapping_t), intent(in) :: sf_mapping
	real(default), dimension(:), intent(inout) :: x
	real(default), intent(out) :: factor
	real(default) :: f1, f2
	real(default), dimension(2) :: x2
	select case (sf_mapping%type)
	case (SFM_PAIR)
	x2 = x(sf_mapping%index)
	call map_unit_square_inverse (x2, factor, sf_mapping%p)
	x(sf_mapping%index) = x2
	case (SFM_PAIR_RESONANCE)
	x2 = x(sf_mapping%index)
	call map_unit_square_inverse (x2, f1)
	call map_resonance_inverse (x2(1), f2, &
	sf_mapping%s, sf_mapping%m2, sf_mapping%mg, &
	sf_mapping%a1, sf_mapping%a2, sf_mapping%a3)
	x(sf_mapping%index) = x2
	factor = f1 * f2
	case default
	factor = 1
	end select
	end subroutine strfun_mapping_apply_inverse

	@ %def strfun_mapping_apply
	@ %def strfun_mapping_apply_inverse
	@ 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.
	<<Strfun: procedures>>=
	subroutine map_unit_square (x, factor, power)
	real(kind=default), dimension(2), intent(inout) :: x
	real(kind=default), intent(out) :: factor
	real(kind=default), intent(in), optional :: power
	real(kind=default) :: xx, yy
	factor = 1
	xx = x(1)
	yy = x(2)
	if (present(power)) then
	if (x(1) > 0 .and. power > 1) then
	xx = x(1)**power
	factor = factor * power * xx / x(1)
	end if
	end if
	if (xx /= 0) then
	x(1) = xx ** yy
	x(2) = xx / x(1)
	factor = factor * abs (log (xx))
	else
	x = 0
	end if
	end subroutine map_unit_square

	@ %def map_unit_square
	@ This is the inverse mapping.
	<<Strfun: procedures>>=
	subroutine map_unit_square_inverse (x, factor, power)
	real(kind=default), dimension(2), intent(inout) :: x
	real(kind=default), intent(out) :: factor
	real(kind=default), intent(in), optional :: power
	real(kind=default) :: lg, xx, yy
	factor = 1
	xx = x(1) * x(2)
	if (xx /= 0) then
	lg = log (xx)
	yy = log (x(1)) / lg
	x(2) = yy
	factor = factor * abs (lg)
	if (present(power)) then
	x(1) = xx**(1._default/power)
	factor = factor * power * xx / x(1)
	else
	x(1) = xx
	end if
	else
	x = 0
	end if
	end subroutine map_unit_square_inverse

	@ %def map_unit_square_inverse
	@ This is the usual mapping of a Lorentz peak. Since the $x$ range
	maps the energy range $0\ldots \sqrt{s}$ to $0\ldots 1$, the position
	of the peak is $m^2/s$, the width is given by $m\Gamma/s$.
	<<Strfun: procedures>>=
	subroutine map_resonance (x, factor, s, m2, mg, a1, a2, a3)
	real(default), intent(inout) :: x
	real(default), intent(out) :: factor
	real(default), intent(in) :: s, m2, mg, a1, a2, a3
	real(default) :: t, z
	z = (1 - x) * a1 + x * a2
	t = tan (z)
	x = (m2 + t * mg) / s
	factor = a3 * (1 + t**2)
	end subroutine map_resonance

	@ %def map_resonance
	<<Strfun: procedures>>=
	subroutine map_resonance_inverse (x, factor, s, m2, mg, a1, a2, a3)
	real(default), intent(inout) :: x
	real(default), intent(out) :: factor
	real(default), intent(in) :: s, m2, mg, a1, a2, a3
	real(default) :: t
	t = (x * s - m2) / mg
	x = (atan (t) - a1) / (a2 - a1)
	factor = a3 * (1 + t**2)
	end subroutine map_resonance_inverse

	@ %def map_resonance_inverse
	@
	\subsection{Structure function chains}
	\subsubsection{Definition}
	The structure function chain contains an array of structure functions,
	where each one has one or more free parameters. For each structure
	function there is an interaction, an image of the interaction within
	the [[strfun]] object, which is needed when quantum numbers are
	reduced. Furthermore, an array of evaluators which cumulatively
	multiply the structure functions. The last evaluator is connected to
	the hard matrix element.

	The [[last_strfun]] and [[out_index]] index (pairs) identify, for each
	beam, the last structure function and the outgoing particle. The
	[[coll_index]] (pair) identifies the outgoing particles in the last
	evaluator.

	For a decay, this structure is also used, but normally there are no
	structure functions besides the ``beam'' object.
	<<Strfun: public>>=
	public :: strfun_chain_t
	<<Strfun: types>>=
	type :: strfun_chain_t
	private
	type(beam_t) :: beam
	integer :: n_strfun = 0
	logical :: multichannel = .false.
	integer :: n_mapping = 0
	type(strfun_t), dimension(:), allocatable :: strfun
	type(strfun_mapping_t), dimension(:,:), allocatable :: sf_mapping
	real(default) :: mapping_factor = 0
	integer :: n_parameters_tot = 0
	integer, dimension(:), allocatable :: n_parameters
	type(evaluator_t), dimension(:), allocatable :: eval
	integer, dimension(:), allocatable :: last_strfun
	integer, dimension(:), allocatable :: out_index
	integer, dimension(:), allocatable :: coll_index
	contains
	<<Strfun: strfun chain: TBP>>
	end type strfun_chain_t

	@ %def strfun_chain_t
	<<Strfun: public>>=
	public :: strfun_chain_init
	<<Strfun: procedures>>=
	subroutine strfun_chain_init (sfchain, beam_data, n_strfun)
	type(strfun_chain_t), intent(out) :: sfchain
	type(beam_data_t), intent(in), target :: beam_data
	integer, intent(in) :: n_strfun
	integer :: i
	sfchain%n_strfun = n_strfun
	allocate (sfchain%strfun (n_strfun))
	allocate (sfchain%n_parameters (n_strfun))
	sfchain%n_parameters = 0
	allocate (sfchain%eval (n_strfun))
	call beam_init (sfchain%beam, beam_data)
	allocate (sfchain%last_strfun (beam_data%n))
	allocate (sfchain%out_index (beam_data%n))
	allocate (sfchain%coll_index (beam_data%n))
	sfchain%last_strfun = 0
	do i = 1, size (sfchain%out_index)
	sfchain%out_index(i) = i
	sfchain%coll_index(i) = i
	end do
	end subroutine strfun_chain_init

	@ %def strfun_chain_init
	@ This is a separate initialization routine for the structure-function
	mappings.
	<<Strfun: public>>=
	public :: strfun_chain_allocate_mappings
	<<Strfun: procedures>>=
	subroutine strfun_chain_allocate_mappings &
	(sfchain, multichannel, n_mapping, n_channel)
	type(strfun_chain_t), intent(inout) :: sfchain
	logical, intent(in) :: multichannel
	integer, intent(in) :: n_mapping, n_channel
	sfchain%multichannel = multichannel
	sfchain%n_mapping = n_mapping
	allocate (sfchain%sf_mapping (n_mapping, n_channel))
	end subroutine strfun_chain_allocate_mappings

	@ %def strfun_chain_allocate_mappings
	@ Set beam momenta directly without changing anything else.
	<<Strfun: public>>=
	public :: strfun_chain_set_beam_momenta
	<<Strfun: procedures>>=
	subroutine strfun_chain_set_beam_momenta (sfchain, p)
	type(strfun_chain_t), intent(inout) :: sfchain
	type(vector4_t), dimension(:), intent(in) :: p
	call beam_set_momenta (sfchain%beam, p)
	end subroutine strfun_chain_set_beam_momenta

	@ %def strfun_chain_set_beam_momenta
	<<Strfun: public>>=
	public :: strfun_chain_final
	<<Strfun: procedures>>=
	subroutine strfun_chain_final (sfchain)
	type(strfun_chain_t), intent(inout) :: sfchain
	call beam_final (sfchain%beam)
	if (allocated (sfchain%strfun)) call strfun_final (sfchain%strfun)
	if (allocated (sfchain%eval)) call evaluator_final (sfchain%eval)
	end subroutine strfun_chain_final

	@ %def strfun_chain_final
	@
	\subsubsection{I/O}
	<<Strfun: public>>=
	public :: strfun_chain_write
	<<Strfun: strfun chain: TBP>>=
	procedure :: write => strfun_chain_write
	<<Strfun: procedures>>=
	subroutine strfun_chain_write &
	(sfchain, unit, verbose, show_momentum_sum, show_mass)
	class(strfun_chain_t), intent(in) :: sfchain
	integer, intent(in), optional :: unit
	logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
	integer :: u, i, ch
	logical :: verb
	verb = .false.; if (present (verbose)) verb = verbose
	u = output_unit (unit); if (u < 0) return
	write (u, *) "Structure function chain:"
	write (u, *)
	call beam_write (sfchain%beam, unit, verbose, show_momentum_sum, show_mass)
	if (allocated (sfchain%strfun)) then
	do i = 1, size (sfchain%strfun)
	write (u, *)
	call strfun_write &
	(sfchain%strfun(i), unit, verbose, show_momentum_sum, show_mass)
	write (u, *) "number of parameters = ", sfchain%n_parameters(i)
	end do
	end if
	if (allocated (sfchain%sf_mapping)) then
	if (sfchain%multichannel) then
	do ch = 1, size (sfchain%sf_mapping, 2)
	write (u, *)
	write (u, *) "Mappings for channel #", ch
	do i = 1, size (sfchain%sf_mapping, 1)
	call strfun_mapping_write (sfchain%sf_mapping(i, ch), unit)
	end do
	end do
	else
	do i = 1, size (sfchain%sf_mapping, 1)
	write (u, *)
	call strfun_mapping_write (sfchain%sf_mapping(i,1), unit)
	end do
	end if
	end if
	if (allocated (sfchain%eval)) then
	write (u, *)
	write (u, *) "Evaluators:"
	do i = 1, size (sfchain%eval)
	call evaluator_write &
	(sfchain%eval(i), unit, verbose, show_momentum_sum, show_mass)
	end do
	end if
	write (u, *)
	write (u, *) "Total number of parameters = ", &
	sfchain%n_parameters_tot
	write (u, "(1x,A)", advance="no") "Last structure function (index) = "
	if (allocated (sfchain%last_strfun)) then
	write (u, *) sfchain%last_strfun
	else
	write (u, *) "[not allocated]"
	end if
	write (u, "(1x,A)", advance="no") "Outgoing particles (index) = "
	if (allocated (sfchain%out_index)) then
	write (u, *) sfchain%out_index
	else
	write (u, *) "[not allocated]"
	end if
	write (u, "(1x,A)", advance="no") "Colliding particles (index) = "
	if (allocated (sfchain%coll_index)) then
	write (u, *) sfchain%coll_index
	else
	write (u, *) "[not allocated]"
	end if
	end subroutine strfun_chain_write

	@ %def strfun_chain_write
	@
	\subsubsection{Defined assignment}
	Deep copy of all components.
	<<Strfun: public>>=
	public :: assignment(=)
	<<Strfun: interfaces>>=
	interface assignment(=)
	module procedure strfun_chain_assign
	end interface

	<<Strfun: procedures>>=
	subroutine strfun_chain_assign (sfchain_out, sfchain_in)
	type(strfun_chain_t), intent(out) :: sfchain_out
	type(strfun_chain_t), intent(in) :: sfchain_in
	sfchain_out%beam = sfchain_in%beam
	sfchain_out%n_strfun = sfchain_in%n_strfun
	sfchain_out%multichannel = sfchain_in%multichannel
	sfchain_out%n_mapping = sfchain_in%n_mapping
	if (allocated (sfchain_in%strfun)) then
	allocate (sfchain_out%strfun (size (sfchain_in%strfun)))
	sfchain_out%strfun = sfchain_in%strfun
	end if
	if (allocated (sfchain_in%sf_mapping)) then
	allocate (sfchain_out%sf_mapping &
	(size (sfchain_in%sf_mapping, 1), size (sfchain_in%sf_mapping, 2)))
	sfchain_out%sf_mapping = sfchain_in%sf_mapping
	end if
	sfchain_out%mapping_factor = sfchain_in%mapping_factor
	sfchain_out%n_parameters_tot = sfchain_in%n_parameters_tot
	if (allocated (sfchain_in%n_parameters)) then
	allocate (sfchain_out%n_parameters (size (sfchain_in%n_parameters)))
	sfchain_out%n_parameters = sfchain_in%n_parameters
	end if
	if (allocated (sfchain_in%eval)) then
	allocate (sfchain_out%eval (size (sfchain_in%eval)))
	sfchain_out%eval = sfchain_in%eval
	end if
	if (allocated (sfchain_in%last_strfun)) then
	allocate (sfchain_out%last_strfun (size (sfchain_in%last_strfun)))
	sfchain_out%last_strfun = sfchain_in%last_strfun
	end if
	if (allocated (sfchain_in%out_index)) then
	allocate (sfchain_out%out_index (size (sfchain_in%out_index)))
	sfchain_out%out_index = sfchain_in%out_index
	end if
	if (allocated (sfchain_in%coll_index)) then
	allocate (sfchain_out%coll_index (size (sfchain_in%coll_index)))
	sfchain_out%coll_index = sfchain_in%coll_index
	end if
	end subroutine strfun_chain_assign

	@ %def strfun_chain_assign
	@
	\subsubsection{Accessing contents}
	Return the type of PDF used. So far, we only return a type if there
	are exactly two structure functions and they are both the same.
	<<Strfun: public>>=
	public :: strfun_chain_get_strfun_type
	<<Strfun: procedures>>=
	function strfun_chain_get_strfun_type(sfchain) result(type)
	type(strfun_chain_t), intent(in) :: sfchain
	integer :: type

	if(size(sfchain%strfun).eq.2) then
	if(sfchain%strfun(1)%type .eq. sfchain%strfun(2)%type) then
	type = sfchain%strfun(1)%type
	else
	type = STRF_NONE
	end if
	else
	type = STRF_NONE
	end if
	end function strfun_chain_get_strfun_type
	@ %def strfun_chain_get_strfun_type
	Return the number of the member of the PDF used
	<<Strfun: public>>=
	public :: strfun_chain_get_strfun_set
	<<Strfun: procedures>>=
	!! !! function strfun_chain_get_strfun_set(sfchain) result(set)
	!! !! type(strfun_chain_t), intent(in) :: sfchain
	!! !! integer :: set
	!! !!
	!! !! set = 0
	!! !! if(size(sfchain%strfun).eq.2) then
	!! !! if(sfchain%strfun(1)%type .eq. sfchain%strfun(2)%type) then
	!! !! if(sfchain%strfun(1)%type .eq. STRF_LHAPDF) then
	!! !! set = lhapdf_data_get_set(sfchain%strfun(1)%lhapdf_data(1))
	!! !! else if(sfchain%strfun(1)%type .eq. STRF_PDF_BUILTIN) then
	!! !! set = pdf_builtin_get_id(sfchain%strfun(1)%pdf_builtin_data(1))
	!! !! end if
	!! !! end if
	!! !! end if
	!! !! end function strfun_chain_get_strfun_set
	@ %def strfun_chain_get_strfun_set
	The number of active structure functions.
	<<Strfun: public>>=
	public :: strfun_chain_get_n_strfun
	<<Strfun: procedures>>=
	function strfun_chain_get_n_strfun (sfchain) result (n)
	integer :: n
	type(strfun_chain_t), intent(in) :: sfchain
	n = sfchain%n_strfun
	end function strfun_chain_get_n_strfun

	@ %def strfun_chain_get_n_strfun
	@ The number of free parameters ($x$ values) needed for
	evaluating the structure functions.
	<<Strfun: public>>=
	public :: strfun_chain_get_n_parameters_tot
	<<Strfun: procedures>>=
	function strfun_chain_get_n_parameters_tot (sfchain) result (n)
	integer :: n
	type(strfun_chain_t), intent(in) :: sfchain
	n = sfchain%n_parameters_tot
	end function strfun_chain_get_n_parameters_tot

	@ %def strfun_chain_get_n_parameters_tot
	@ The number of virtual particles in the structure function
	evaluators. These are the beam particles plus all particles that do
	not appear as outgoing.
	<<Strfun: public>>=
	public :: strfun_chain_get_n_vir
	<<Strfun: procedures>>=
	function strfun_chain_get_n_vir (sfchain) result (n)
	integer :: n
	type(strfun_chain_t), intent(in) :: sfchain
	if (sfchain%n_strfun /= 0) then
	n = evaluator_get_n_vir (sfchain%eval(sfchain%n_strfun))
	else
	n = 0
	end if
	end function strfun_chain_get_n_vir

	@ %def strfun_chain_get_n_vir
	@ Tell if the structure-function mappings should be applied to
	individual phase-space channels, or globally.
	<<Strfun: public>>=
	public :: strfun_chain_multichannel_enabled
	<<Strfun: procedures>>=
	function strfun_chain_multichannel_enabled (sfchain) result (flag)
	logical :: flag
	type(strfun_chain_t), intent(in) :: sfchain
	flag = sfchain%multichannel
	end function strfun_chain_multichannel_enabled

	@ %def strfun_chain_multichannel_enabled
	@ Return any extra factor resulting from explicit mappings of the $x$
	parameters.
	<<Strfun: public>>=
	public :: strfun_chain_get_mapping_factor
	<<Strfun: procedures>>=
	function strfun_chain_get_mapping_factor (sfchain) result (f)
	real(default) :: f
	type(strfun_chain_t), intent(in) :: sfchain
	f = sfchain%mapping_factor
	end function strfun_chain_get_mapping_factor

	@ %def strfun_chain_get_mapping_factor
	@ For pseudo-structure functions that actually are an external
	generator, the integration region must not be mapped and stay rigid.
	This function returns an array which tells, for each integration
	parameter, whether the corresponding integration dimension is rigid.
	<<Strfun: public>>=
	public :: strfun_chain_dimension_is_rigid
	<<Strfun: procedures>>=
	function strfun_chain_dimension_is_rigid (sfchain) result (rigid)
	logical, dimension(:), allocatable :: rigid
	type(strfun_chain_t), intent(in) :: sfchain
	integer :: i, j, k
	allocate (rigid (sfchain%n_parameters_tot))
	k = 0
	do i = 1, size (sfchain%n_parameters)
	do j = 1, sfchain%n_parameters(i)
	k = k + 1
	select case (sfchain%strfun(i)%type)
	case default
	rigid(k) = .false.
	end select
	end do
	end do
	end function strfun_chain_dimension_is_rigid

	@ %def strfun_chain_dimension_is_rigid
	@ Return the indices of the colliding particles.
	<<Strfun: public>>=
	public :: strfun_chain_get_colliding_particles
	<<Strfun: procedures>>=
	function strfun_chain_get_colliding_particles (sfchain) result (index)
	integer, dimension(:), allocatable :: index
	type(strfun_chain_t), intent(in) :: sfchain
	allocate (index (size (sfchain%coll_index)))
	index = sfchain%coll_index
	end function strfun_chain_get_colliding_particles

	@ %def strfun_chain_get_colliding_particles
	@ Return the quantum-numbers mask for the colliding particles. This
	is extracted from the last evaluator in the chain.
	<<Strfun: public>>=
	public :: strfun_chain_get_colliding_particles_mask
	<<Strfun: procedures>>=
	function strfun_chain_get_colliding_particles_mask (sfchain) result (mask)
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
	type(strfun_chain_t), intent(in), target :: sfchain
	integer :: n_strfun
	type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_eval
	allocate (mask (size (sfchain%coll_index)))
	n_strfun = sfchain%n_strfun
	if (n_strfun /= 0) then
	allocate (mask_eval (evaluator_get_n_tot (sfchain%eval(n_strfun))))
	mask_eval = evaluator_get_mask (sfchain%eval(n_strfun))
	mask = mask_eval(sfchain%coll_index)
	else
	mask = interaction_get_mask (beam_get_int_ptr (sfchain%beam))
	end if
	end function strfun_chain_get_colliding_particles_mask

	@ %def strfun_chain_get_colliding_particles_mask
	@ Return a pointer to the beam interaction.
	<<Strfun: public>>=
	public :: strfun_chain_get_beam_int_ptr
	<<Strfun: procedures>>=
	function strfun_chain_get_beam_int_ptr (sfchain) result (int)
	type(interaction_t), pointer :: int
	type(strfun_chain_t), intent(in), target :: sfchain
	int => beam_get_int_ptr (sfchain%beam)
	end function strfun_chain_get_beam_int_ptr

	@ %def strfun_chain_get_beam_int_ptr
	@ Return a pointer to the last evaluator, which wraps up all structure
	functions.
	<<Strfun: public>>=
	public :: strfun_chain_get_last_evaluator_ptr
	<<Strfun: procedures>>=
	function strfun_chain_get_last_evaluator_ptr (sfchain) result (eval)
	type(evaluator_t), pointer :: eval
	type(strfun_chain_t), intent(in), target :: sfchain
	if (sfchain%n_strfun /= 0) then
	eval => sfchain%eval(sfchain%n_strfun)
	else
	eval => null ()
	end if
	end function strfun_chain_get_last_evaluator_ptr

	@ %def strfun_chain_get_last_evaluator_ptr
	@
	\subsubsection{Setting up structure functions}
	The index [[i]] is the overall structure function counter. [[line]]
	indicates the beam(s) for which the structure function applies, either
	1 or 2, or 0 for both beams.
	<<Strfun: public>>=
	!! !! public :: strfun_chain_set_strfun
	<<Strfun: interfaces>>=
	!! !! interface strfun_chain_set_strfun
	!! !! module procedure strfun_chain_set_lhapdf
	!! !! module procedure strfun_chain_set_pdf_builtin
	!! !! module procedure strfun_chain_set_isr
	!! !! module procedure strfun_chain_set_epa
	!! !! module procedure strfun_chain_set_ewa
	!! !! module procedure strfun_chain_set_circe1
	!! !! module procedure strfun_chain_set_circe2
	!! !! module procedure strfun_chain_set_escan
	!! !! module procedure strfun_chain_set_beam_events
	!! !! module procedure strfun_chain_set_user
	!! !! end interface
	<<Strfun: procedures>>=
	!! !! subroutine strfun_chain_set_lhapdf &
	!! !! (sfchain, i, line, lhapdf_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(lhapdf_data_t), intent(in) :: lhapdf_data
	!! !! call strfun_init (sfchain%strfun(i), lhapdf_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/3/))
	!! !! end subroutine strfun_chain_set_lhapdf
	!! !!
	!! !! subroutine strfun_chain_set_pdf_builtin &
	!! !! (sfchain, i, line, pdf_builtin_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(pdf_builtin_data_t), intent(in) :: pdf_builtin_data
	!! !! call strfun_init (sfchain%strfun(i), pdf_builtin_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/3/))
	!! !! end subroutine strfun_chain_set_pdf_builtin
	!! !!
	!! !! subroutine strfun_chain_set_isr &
	!! !! (sfchain, i, line, isr_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(isr_data_t), intent(in) :: isr_data
	!! !! call strfun_init (sfchain%strfun(i), isr_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/3/))
	!! !! end subroutine strfun_chain_set_isr
	!! !!
	!! !! subroutine strfun_chain_set_epa &
	!! !! (sfchain, i, line, epa_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(epa_data_t), intent(in) :: epa_data
	!! !! call strfun_init (sfchain%strfun(i), epa_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/3/))
	!! !! end subroutine strfun_chain_set_epa
	!! !!
	!! !! subroutine strfun_chain_set_ewa &
	!! !! (sfchain, i, line, ewa_data, n_parameters, id)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters, id
	!! !! type(ewa_data_t), intent(inout) :: ewa_data
	!! !! call strfun_init (sfchain%strfun(i), ewa_data, id)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/3/))
	!! !! end subroutine strfun_chain_set_ewa
	!! !!
	!! !! subroutine strfun_chain_set_circe1 &
	!! !! (sfchain, i, line, circe1_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(circe1_data_t), intent(in) :: circe1_data
	!! !! call strfun_init (sfchain%strfun(i), circe1_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1, 2/), (/5, 6/))
	!! !! end subroutine strfun_chain_set_circe1
	!! !!
	!! !! subroutine strfun_chain_set_circe2 &
	!! !! (sfchain, i, line, circe2_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(circe2_data_t), intent(in) :: circe2_data
	!! !! call strfun_init (sfchain%strfun(i), circe2_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! call strfun_chain_link (sfchain, i, line, (/1, 2/), (/3, 4/))
	!! !! end subroutine strfun_chain_set_circe2
	!! !!
	!! !! subroutine strfun_chain_set_escan &
	!! !! (sfchain, i, line, escan_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(escan_data_t), intent(in) :: escan_data
	!! !! call strfun_init (sfchain%strfun(i), escan_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! if (line == 0) then
	!! !! call strfun_chain_link (sfchain, i, line, (/1, 2/), (/3, 4/))
	!! !! else
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/2/))
	!! !! end if
	!! !! end subroutine strfun_chain_set_escan
	!! !!
	!! !! subroutine strfun_chain_set_beam_events &
	!! !! (sfchain, i, line, beam_events_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(beam_events_data_t), intent(in) :: beam_events_data
	!! !! call strfun_init (sfchain%strfun(i), beam_events_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! if (line == 0) then
	!! !! call strfun_chain_link (sfchain, i, line, (/1, 2/), (/3, 4/))
	!! !! else
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/2/))
	!! !! end if
	!! !! end subroutine strfun_chain_set_beam_events
	!! !!
	!! !! subroutine strfun_chain_set_user &
	!! !! (sfchain, i, line, user_data, n_parameters)
	!! !! type(strfun_chain_t), intent(inout), target :: sfchain
	!! !! integer, intent(in) :: i, line, n_parameters
	!! !! type(sf_user_data_t), intent(in) :: user_data
	!! !! integer :: n_tot
	!! !! call strfun_init (sfchain%strfun(i), user_data)
	!! !! n_tot = sf_user_data_get_n_tot (user_data)
	!! !! sfchain%n_parameters(i) = n_parameters
	!! !! if (line == 0) then
	!! !! call strfun_chain_link (sfchain, i, line, (/1, 2/), (/n_tot-1, n_tot/))
	!! !! else
	!! !! call strfun_chain_link (sfchain, i, line, (/1/), (/n_tot/))
	!! !! end if
	!! !! end subroutine strfun_chain_set_user

	@ %def strfun_chain_set_strfun
	@ This procedure links a new structure function to the existing
	chain. [[i]] is the overall structure function counter. [[line]]
	indicates the beam(s) to which the structure function applies; 0 is
	for both beams. The last two arguments are the indices of the
	incoming and outgoing particle(s) within the current structure
	function. For a single-beam (double-beam) structure function, these
	arrays are of length 1 (2), respectively.

	The connections of outgoing/incoming particles are recorded as links
	in the new structure-function entry [[sfchain%strfun(i)]].
	<<Strfun: procedures>>=
	subroutine strfun_chain_link (sfchain, i, line, in_index, out_index)
	type(strfun_chain_t), intent(inout), target :: sfchain
	integer, intent(in) :: i, line
	integer, dimension(:), intent(in) :: in_index, out_index
	select case (line)
	case (0)
	call link_single (1, in_index(1))
	call link_single (2, in_index(2))
	sfchain%last_strfun = i
	sfchain%out_index = out_index
	case default
	call link_single (line, in_index(1))
	sfchain%last_strfun(line) = i
	sfchain%out_index(line) = out_index(1)
	end select
	contains
	subroutine link_single (line, in_index)
	integer, intent(in) :: line, in_index
	integer :: j
	j = sfchain%last_strfun(line)
	select case (j)
	case (0)
	call interaction_set_source_link &
	(sfchain%strfun(i)%int, in_index, &
	sfchain%beam, sfchain%out_index(line))
	case default
	call interaction_set_source_link &
	(sfchain%strfun(i)%int, in_index, &
	sfchain%strfun(j)%int, sfchain%out_index(line))
	end select
	end subroutine link_single
	end subroutine strfun_chain_link

	@ %def strfun_chain_link
	@
	\subsubsection{Setting up mappings}
	Set a particular mapping with a known type.
	<<Strfun: public>>=
	public :: strfun_chain_set_mapping
	<<Strfun: procedures>>=
	subroutine strfun_chain_set_mapping (sfchain, i, ch, index, type, par)
	type(strfun_chain_t), intent(inout) :: sfchain
	integer, intent(in) :: i, ch
	integer, dimension(:), intent(in) :: index
	integer, intent(in) :: type
	real(default), dimension(:), intent(in) :: par
	call strfun_mapping_init (sfchain%sf_mapping(i, ch), index, type, par)
	end subroutine strfun_chain_set_mapping

	@ %def strfun_chain_set_mapping
	@
	\subsubsection{Evaluators}
	<<Strfun: public>>=
	public :: strfun_chain_make_evaluators
	<<Strfun: procedures>>=
	subroutine strfun_chain_make_evaluators (sfchain, ok)
	type(strfun_chain_t), intent(inout), target :: sfchain
	logical, intent(out), optional :: ok
	type(interaction_t), pointer :: beam_int, eval_int, sf_int, eval_int_next
	type(quantum_numbers_mask_t) :: qn_mask_conn
	type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_beam
	integer :: i, j, last, out_index, coll_index
	sfchain%n_parameters_tot = sum (sfchain%n_parameters)
	beam_int => beam_get_int_ptr (sfchain%beam)
	if (.not. associated (beam_int)) call msg_bug &
	("strfun_chain_make_evaluators: null beam pointer")
	allocate (qn_mask_beam (interaction_get_n_out (beam_int)))
	qn_mask_beam = interaction_get_mask (beam_int)
	call interaction_exchange_mask (beam_int)
	do i = 1, size (sfchain%strfun) - 1
	call interaction_exchange_mask (sfchain%strfun(i)%int)
	end do
	do i = size (sfchain%strfun), 1, -1
	call interaction_exchange_mask (sfchain%strfun(i)%int)
	end do
	if (any (qn_mask_beam .neqv. interaction_get_mask (beam_int))) then
	call beam_write (sfchain%beam)
	call msg_fatal (" Beam polarization/color/flavor incompatible with structure functions")
	end if
	eval_int => beam_int
	do i = 1, size (sfchain%strfun)
	qn_mask_conn = new_quantum_numbers_mask (.false., .false., .true.)
	call evaluator_init_product (sfchain%eval(i), eval_int, &
	sfchain%strfun(i)%int, qn_mask_conn)
	if (evaluator_is_empty (sfchain%eval(i))) then
	call msg_fatal ("Mismatch in beam and structure-function chain")
	if (present (ok)) ok = .false.
	return
	end if
	eval_int => evaluator_get_int_ptr (sfchain%eval(i))
	end do
	if (size (sfchain%strfun) /= 0) then
	do j = 1, size (sfchain%coll_index)
	last = sfchain%last_strfun(j)
	select case (last)
	case (0)
	eval_int => beam_get_int_ptr (sfchain%beam)
	out_index = sfchain%out_index(j)
	coll_index = out_index
	case default
	sf_int => sfchain%strfun(last)%int
	eval_int => evaluator_get_int_ptr (sfchain%eval(last))
	out_index = sfchain%out_index(j)
	coll_index = interaction_find_link (eval_int, sf_int, out_index)
	end select
	if (coll_index /= 0) then
	do i = last + 1, size (sfchain%strfun)
	out_index = coll_index
	eval_int_next => evaluator_get_int_ptr (sfchain%eval(i))
	coll_index = &
	interaction_find_link (eval_int_next, eval_int, out_index)
	if (coll_index == 0) call msg_bug ("Structure functions: " &
	// "broken links in structure function chain")
	eval_int => eval_int_next
	end do
	end if
	if (coll_index /= 0) then
	sfchain%coll_index(j) = coll_index
	else
	call msg_bug ("Structure functions: " &
	// "colliding particles can't be determined")
	end if
	end do
	end if
	if (present (ok)) ok = .true.
	end subroutine strfun_chain_make_evaluators

	@ %def strfun_chain_make_evaluators
	@ Setup kinematics: use the given array of random numbers [[r]] to
	generate a chain of momenta, up to the incoming partons.
	<<Strfun: public>>=
	public :: strfun_chain_set_kinematics
	<<Strfun: procedures>>=
	subroutine strfun_chain_set_kinematics (sfchain, r, &
	channel, offset, r_all, sf_factor, ok)
	type(strfun_chain_t), intent(inout) :: sfchain
	real(default), dimension(:), intent(in) :: r
	integer, intent(in), optional :: channel, offset
	real(default), dimension(:,:), intent(inout), optional :: r_all
	real(default), dimension(:), intent(out), optional :: sf_factor
	logical, intent(out), optional :: ok
	real(default), dimension(size(r)) :: x
	integer :: n_mapping
	integer :: i, i1, i2, ch, n, n1, n_sf
	real(default) :: xprod, factor
	real(default), dimension(:), allocatable :: factor_channel
	integer, dimension(:), allocatable :: mapping_type
	n_sf = size (sfchain%strfun)
	sfchain%mapping_factor = 1
	if (size (r) == sfchain%n_parameters_tot) then
	x = r
	if (allocated (sfchain%sf_mapping)) then
	n_mapping = size (sfchain%sf_mapping, 1)
	if (present (channel)) then
	allocate (factor_channel (n_mapping))
	allocate (mapping_type (n_mapping))
	do i = 1, n_mapping
	mapping_type(i) = sfchain%sf_mapping(i,channel)%type
	call strfun_mapping_apply &
	(sfchain%sf_mapping(i, channel), x, factor_channel(i))
	end do
	sf_factor(channel) = product (factor_channel)
	else
	do i = 1, n_mapping
	call strfun_mapping_apply &
	(sfchain%sf_mapping(i, 1), x, factor)
	sfchain%mapping_factor = sfchain%mapping_factor * factor
	end do
	end if
	end if
	n = 0
	do i = 1, size (sfchain%strfun)
	call interaction_receive_momenta (sfchain%strfun(i)%int)
	n1 = sfchain%n_parameters(i)
	call strfun_set_kinematics (sfchain%strfun(i), x(n+1:n+n1), .false.)
	n = n + n1
	end do
	if (present (channel)) then
	i1 = offset
	i2 = offset + size (r)
	do ch = 1, size (r_all, 2)
	if (ch /= channel) then
	sf_factor(ch) = 1
	do i = 1, n_mapping
	if (sfchain%sf_mapping(i,ch)%type == mapping_type(i)) then
	r_all(i1+1:i2,ch) = r
	sf_factor(ch) = sf_factor(ch) * factor_channel(i)
	else
	r_all(i1+1:i2,ch) = x
	call strfun_mapping_apply_inverse &
	(sfchain%sf_mapping(1,ch), r_all(i1+1:i2,ch), &
	factor)
	sf_factor(ch) = sf_factor(ch) * factor
	end if
	end do
	end if
	end do
	end if
	do i = 1, size (sfchain%strfun)
	call evaluator_receive_momenta (sfchain%eval(i))
	end do
	if (present (ok)) ok = .true.
	else
	call msg_bug ("Structure functions: mismatch in number of parameters")
	end if
	end subroutine strfun_chain_set_kinematics

	@ %def strfun_chain_set_kinematics
	<<Strfun: public>>=
	public :: strfun_chain_evaluate
	<<Strfun: procedures>>=
	subroutine strfun_chain_evaluate (sfchain, scale)
	type(strfun_chain_t), intent(inout) :: sfchain
	real(default), intent(in) :: scale
	integer :: i
	do i = size (sfchain%strfun), 1, -1
	call strfun_apply (sfchain%strfun(i), scale)
	end do
	do i = 1, size (sfchain%eval)
	call evaluator_evaluate (sfchain%eval(i))
	end do
	end subroutine strfun_chain_evaluate

	@ %def strfun_chain_evaluate
	@
	\subsection{Test}
	<<Strfun: public>>=
	public :: strfun_test
	<<Strfun: procedures>>=
	!! !! subroutine strfun_test (lhapdf_present)
	!! !! use os_interface, only: os_data_t
	!! !! type(os_data_t) :: os_data
	!! !! type(model_t), pointer :: model
	!! !! logical, intent(in) :: lhapdf_present
	!! !! print , "** Read model file"
	!! !! call syntax_model_file_init ()
	!! !! call model_list_read_model &
	!! !! (var_str("SM"), var_str("SM.mdl"), os_data, model)
	!! !! call syntax_model_file_final ()
	!! !! print , "**********************************************************"
	!! !! call isr_test (model)
	!! !! print , "**********************************************************"
	!! !! call epa_test (model)
	!! !! if (lhapdf_present) then
	!! !! print , "**********************************************************"
	!! !! call lhapdf_test (model)
	!! !! end if
	!! !! end subroutine strfun_test

	!! !! subroutine isr_test (model)
	!! !! use flavors
	!! !! use polarizations
	!! !! type(model_t), intent(in), target :: model
	!! !! type(flavor_t), dimension(2) :: flv
	!! !! type(polarization_t), dimension(2) :: pol
	!! !! type(beam_data_t), target :: beam_data
	!! !! type(isr_data_t), dimension(2) :: isr_data
	!! !! type(strfun_chain_t), target :: sfchain
	!! !! integer :: i
	!! !! print , "** ISR test"
	!! !! call flavor_init (flv, (/11, -11/), model)
	!! !! call polarization_init_unpolarized (pol(1), flv(1))
	!! !! call polarization_init_unpolarized (pol(2), flv(2))
	!! !! call beam_data_init_sqrts (beam_data, 500._default, flv, pol)
	!! !! do i = 1, 2
	!! !! call isr_data_init (isr_data(i), &
	!! !! model, flv(i), 0.06_default, 500._default, 0.511e-3_default)
	!! !! end do
	!! !! call strfun_chain_init (sfchain, beam_data, 2)
	!! !! call strfun_chain_set_strfun (sfchain, 1, 1, isr_data(1), 1)
	!! !! call strfun_chain_set_strfun (sfchain, 2, 2, isr_data(2), 3)
	!! !! call strfun_chain_make_evaluators (sfchain)
	!! !! call strfun_chain_set_kinematics &
	!! !! (sfchain, (/0.8_default, 0.4_default, 0.5_default, 0.2_default/))
	!! !! call strfun_chain_evaluate (sfchain, 0._default)
	!! !! call strfun_chain_write (sfchain)
	!! !! call strfun_chain_final (sfchain)
	!! !! end subroutine isr_test

	subroutine epa_test (model)
	use flavors
	use polarizations
	type(model_t), intent(in), target :: model
	type(flavor_t), dimension(2) :: flv
	type(polarization_t), dimension(2) :: pol
	type(beam_data_t) :: beam_data
	type(epa_data_t) :: epa_data1
	type(epa_data_t) :: epa_data2
	type(strfun_chain_t), target :: sfchain
	print , "** EPA test"
	call flavor_init (flv, (/2, 1/), model)
	! Prepare beams
	call polarization_init_circular (pol(1), flv(1), 0.3_default)
	call polarization_init_unpolarized (pol(2), flv(2))
	call beam_data_init_sqrts (beam_data, 1000._default, flv, pol)
	call strfun_chain_init (sfchain, beam_data, 2)
	! Initialize EPA for both
	call epa_data_init (epa_data1, model, &
	flv(1), 0.06_default, 1.e-6_default, 0._default, 500._default, &
	511.e-6_default)
	call epa_data_init (epa_data2, model, &
	flv(2), 0.06_default, 1.e-6_default, 1._default, 500._default)
	call strfun_chain_set_strfun (sfchain, 1, 1, epa_data1, 1)
	call strfun_chain_set_strfun (sfchain, 2, 2, epa_data2, 3)
	! call strfun_chain_write (sfchain); stop
	call strfun_chain_make_evaluators (sfchain)
	call strfun_chain_set_kinematics &
	(sfchain, (/0.8_default, 0.4_default, 0.5_default, 0.2_default/))
	call strfun_chain_evaluate (sfchain, 0._default)
	call strfun_chain_write (sfchain)
	! Clean up
	call beam_data_final (beam_data)
	call polarization_final (pol)
	call strfun_chain_final (sfchain)
	end subroutine epa_test

	!! !! subroutine lhapdf_test (model)
	!! !! use flavors
	!! !! use polarizations
	!! !! type(model_t), intent(in), target :: model
	!! !! type(beam_data_t) :: beam_data
	!! !! type(flavor_t), dimension(2) :: flv
	!! !! type(polarization_t), dimension(2) :: pol
	!! !! type(lhapdf_data_t), dimension(2) :: data
	!! !! type(lhapdf_status_t) :: lhapdf_status
	!! !! type(strfun_chain_t), target :: sfchain
	!! !! real(default) :: scale
	!! !! print , "** LHAPDF test"
	!! !! call flavor_init (flv, (/ -PROTON, PHOTON /), model)
	!! !! call polarization_init_unpolarized (pol(1), flv(1))
	!! !! call polarization_init_unpolarized (pol(2), flv(2))
	!! !! call beam_data_init_sqrts (beam_data, 2000._default, flv, pol)
	!! !! call strfun_chain_init (sfchain, beam_data, 2)
	!! !! call lhapdf_data_init (data(1), lhapdf_status, model, flv(1), member=1)
	!! !! !!! Use the same photon PDF that is demanded by the LHAPDF tests.
	!! !! call lhapdf_data_init (data(2), lhapdf_status, model, flv(2), &
	!! !! file=var_str("GSG961.LHgrid"), photon_scheme=1)
	!! !! call lhapdf_data_set_mask (data(2), &
	!! !! (/.false.,.false.,.false., .true., .true., .true., &
	!! !! .false., &
	!! !! .true., .true., .true., .false., .false., .false. /))
	! !! !! call strfun_chain_write (sfchain); stop
	!! !! call strfun_chain_set_strfun (sfchain, 1, 1, data(1), 1)
	!! !! call strfun_chain_set_strfun (sfchain, 2, 2, data(2), 1)
	! !! !! call strfun_chain_write (sfchain); stop
	!! !! call strfun_chain_make_evaluators (sfchain)
	!! !! call strfun_chain_set_kinematics (sfchain, (/0.9_default, 0.4_default/))
	!! !! scale = 1.e3_default
	!! !! call strfun_chain_evaluate (sfchain, scale)
	!! !! call strfun_chain_write (sfchain)
	!! !! call strfun_chain_final (sfchain)
	!! !! end subroutine lhapdf_test

	@ %def strfun_test
	@
	Transform the equivalence lists into a [[vamp_equivalence_list]]
	object. The additional information that we need is: the number of
	extra integration dimensions (associated to structure functions),
	which ones of those correspond to external event generators (so that
	the binning must not be adapted), and whether there is any dependence
	on the first azimuthal angle (so its binning may be adapted or fixed).

	The permutations of masses and angles are translated into permutations
	of integration dimensions, where the correct mapping modes are
	important: [[msq]] values are always mapped 1:1 while azimuthal
	angles may need an offset by $1/2$ and polar angles may need an
	inversion. The first azimuthal angle should not be adapted to since
	the dependence of the matrix element is (usually) trivial.
	<<XXX PHS forests: public>>=
	public :: phs_forest_setup_vamp_equivalences
	<<XXX PHS forests: procedures>>=
	subroutine phs_forest_setup_vamp_equivalences &
	(forest, n_dim_extra, externally_generated, azimuthal_dependence, &
	vamp_eq)
	type(phs_forest_t), intent(in) :: forest
	integer, intent(in) :: n_dim_extra
	logical, dimension(n_dim_extra), intent(in) :: externally_generated
	logical, intent(in) :: azimuthal_dependence
	type(vamp_equivalences_t), intent(out) :: vamp_eq
	integer :: n_equivalences, n_channels, n_dim, n_masses, n_angles
	integer, dimension(forest%n_dimensions + n_dim_extra) :: perm, mode
	integer :: mode_azimuthal_angle
	type(equivalence_t), pointer :: eq
	integer :: i, j, g
	integer :: left, right
	n_equivalences = forest%n_equivalences
	n_channels = forest%n_trees
	n_dim = forest%n_dimensions
	n_masses = forest%n_masses
	n_angles = forest%n_angles
	call vamp_equivalences_init &
	(vamp_eq, n_equivalences, n_channels, n_dim + n_dim_extra)
	if (azimuthal_dependence) then
	mode_azimuthal_angle = VEQ_IDENTITY
	else
	mode_azimuthal_angle = VEQ_INVARIANT
	end if
	g = 0
	eq => null ()
	do i = 1, n_equivalences
	if (.not. associated (eq)) then
	g = g + 1
	eq => forest%grove(g)%equivalence_list%first
	end if
	do j = 1, n_masses
	perm(j) = permute (j, eq%msq_perm)
	mode(j) = VEQ_IDENTITY
	end do
	do j = 1, n_angles
	perm(n_masses+j) = n_masses + permute (j, eq%angle_perm)
	if (j == 1) then
	mode(n_masses+j) = mode_azimuthal_angle ! first azimuthal angle
	else if (mod(j,2) == 1) then
	mode(n_masses+j) = VEQ_SYMMETRIC ! other azimuthal angles
	else if (eq%angle_sig(j)) then
	mode(n_masses+j) = VEQ_IDENTITY ! polar angle +
	else
	mode(n_masses+j) = VEQ_INVERT ! polar angle -
	end if
	end do
	do j = 1, n_dim_extra
	perm(n_dim+j) = n_dim + j
	if (externally_generated(j)) then
	mode(n_dim+j) = VEQ_INVARIANT
	else
	mode(n_dim+j) = VEQ_IDENTITY
	end if
	end do
	left = eq%left + forest%grove(g)%tree_count_offset
	right = eq%right + forest%grove(g)%tree_count_offset
	call vamp_equivalence_set (vamp_eq, i, left, right, perm, mode)
	eq => eq%next
	end do
	call vamp_equivalences_complete (vamp_eq)
	end subroutine phs_forest_setup_vamp_equivalences

	@ %def phs_forest_setup_vamp_equivalences
	@
	<<CCC Commands: procedures>>=
	subroutine strfun_pair_compile (strfun_pair, pn_strfun_pair, global)
	type(strfun_pair_t), intent(out) :: strfun_pair
	type(parse_node_t), intent(in), target :: pn_strfun_pair
	type(rt_data_t), intent(in), target :: global
	type(parse_node_t), pointer :: pn_strfun_def
	integer :: i
	strfun_pair%n = parse_node_get_n_sub (pn_strfun_pair)
	pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair)
	do i = 1, strfun_pair%n
	call strfun_def_compile (strfun_pair%def(i), pn_strfun_def, global)
	pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def)
	end do
	end subroutine strfun_pair_compile

	subroutine strfun_def_compile (strfun_def, pn_strfun_def, global)
	type(strfun_def_t), intent(out) :: strfun_def
	type(parse_node_t), intent(in), target :: pn_strfun_def
	type(rt_data_t), intent(in), target :: global
	type(parse_node_t), pointer :: pn_key, pn_opt, pn_arg
	pn_key => parse_node_get_sub_ptr (pn_strfun_def)
	pn_opt => parse_node_get_next_ptr (pn_key)
	select case (char (parse_node_get_rule_key (pn_key)))
	case ("none")
	strfun_def%type = STRF_NONE
	case ("lhapdf")
	strfun_def%type = STRF_LHAPDF
	case ("pdf_builtin")
	strfun_def%type = STRF_PDF_BUILTIN
	case ("isr")
	strfun_def%type = STRF_ISR
	case ("epa")
	strfun_def%type = STRF_EPA
	case ("ewa")
	strfun_def%type = STRF_EWA
	case ("circe1")
	strfun_def%type = STRF_CIRCE1
	case ("circe2")
	strfun_def%type = STRF_CIRCE2
	case ("energy_scan")
	strfun_def%type = STRF_ESCAN
	case ("beam_events")
	strfun_def%type = STRF_BEVT
	case ("user_sf_spec")
	strfun_def%type = STRF_USER
	pn_arg => parse_node_get_sub_ptr (pn_key, 2)
	strfun_def%pn_user_name => parse_node_get_sub_ptr (pn_arg)
	end select
	call rt_data_local_init (strfun_def%local, global)
	if (associated (pn_opt)) then
	allocate (strfun_def%options)
	call command_list_compile &
	(strfun_def%options, pn_opt, strfun_def%local)
	end if
	call rt_data_local_reset (strfun_def%local)
	end subroutine strfun_def_compile

	@ %def strfun_pair_compile strfun_def_compile
	<<CCC Commands: procedures>>=
	!! !! subroutine strfun_pair_register (strfun_pair, global)
	!! !! type(strfun_pair_t), intent(inout) :: strfun_pair
	!! !! type(rt_data_t), intent(inout), target :: global
	!! !! logical, dimension(2) :: affects_beam
	!! !! select case (strfun_pair%n)
	!! !! case (1)
	!! !! affects_beam = .true.
	!! !! call strfun_def_register (strfun_pair%def(1), affects_beam, global)
	!! !! case (2)
	!! !! affects_beam = (/ .true., .false. /)
	!! !! call strfun_def_register (strfun_pair%def(1), affects_beam, global)
	!! !! affects_beam = (/ .false., .true. /)
	!! !! call strfun_def_register (strfun_pair%def(2), affects_beam, global)
	!! !! end select
	!! !! end subroutine strfun_pair_register
	!! !!
	!! !! subroutine strfun_def_register (strfun_def, affects_beam, global)
	!! !! type(strfun_def_t), intent(inout) :: strfun_def
	!! !! logical, dimension(2), intent(in) :: affects_beam
	!! !! type(rt_data_t), intent(inout), target :: global
	!! !! call rt_data_link (strfun_def%local, global)
	!! !! if (associated (strfun_def%options)) then
	!! !! call command_list_execute (strfun_def%options, strfun_def%local)
	!! !! end if
	!! !! select case (strfun_def%type)
	!! !! case (STRF_LHAPDF)
	!! !! call sf_list_register_lhapdf &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%lhapdf_status, global%model, global%beam_data%flv, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_PDF_BUILTIN)
	!! !! call sf_list_register_pdf_builtin &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%pdf_builtin_status, global%model, global%beam_data%flv, &
	!! !! strfun_def%local%os_data%pdf_builtin_datapath, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_ISR)
	!! !! call sf_list_register_isr &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%model, global%beam_data%flv, global%beam_data%sqrts, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_EPA)
	!! !! call sf_list_register_epa &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%model, global%beam_data%flv, global%beam_data%sqrts, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_EWA)
	!! !! call msg_warning ("EWA structure function not yet fully implemented")
	!! !! call sf_list_register_ewa &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%model, global%beam_data%flv, global%beam_data%sqrts, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_CIRCE1)
	!! !! call sf_list_register_circe1 &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%model, global%beam_data%flv, global%beam_data%sqrts, &
	!! !! global%rng, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_CIRCE2)
	!! !! call sf_list_register_circe2 &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%beam_data%flv, global%beam_data%sqrts, &
	!! !! global%rng, global%os_data%whizard_circe2path, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_ESCAN)
	!! !! call sf_list_register_escan &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%beam_data%flv, global%beam_data%sqrts, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_BEVT)
	!! !! call sf_list_register_beam_events &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%beam_data%flv, global%os_data%whizard_beamsimpath, &
	!! !! strfun_def%local%var_list)
	!! !! case (STRF_USER)
	!! !! call sf_list_register_user &
	!! !! (global%sf_list, affects_beam, &
	!! !! global%model, global%beam_data%flv, &
	!! !! eval_string (strfun_def%pn_user_name, strfun_def%local%var_list), &
	!! !! strfun_def%local%var_list)
	!! !! end select
	!! !! call rt_data_restore (global, strfun_def%local)
	!! !! end subroutine strfun_def_register

	@ %def strfun_pair_register strfun_def_register
	@ The individual register procedures. They unpack data from the local
	var list, allocate structure function data blocks and fill them.
	Depending on the structure function and on the beams on which
	it should apply, one or two such entries are added to the structure
	function list. For double structure functions, it is useful to add a
	pair-mapping.
	<<CCC Commands: procedures>>=
	!! !! subroutine sf_list_register_lhapdf (sf_list, affects_beam, &
	!! !! lhapdf_status, model, flv, var_list)
	!! !! type(sf_list_t), intent(inout) :: sf_list
	!! !! logical, dimension(2), intent(in) :: affects_beam
	!! !! type(lhapdf_status_t), intent(inout) :: lhapdf_status
	!! !! type(model_t), intent(in), target :: model
	!! !! type(flavor_t), dimension(2), intent(in) :: flv
	!! !! type(var_list_t), intent(in) :: var_list
	!! !! type(string_t) :: lhapdf_file, lhapdf_dir
	!! !! integer :: lhapdf_member, lhapdf_photon_scheme
	!! !! type(sf_data_t), pointer :: sf_data
	!! !! integer :: i
	!! !! lhapdf_dir = &
	!! !! var_list_get_sval (var_list, var_str ("$lhapdf_dir")) ! $
	!! !! lhapdf_file = &
	!! !! var_list_get_sval (var_list, var_str ("$lhapdf_file")) ! $
	!! !! lhapdf_member = &
	!! !! var_list_get_ival (var_list, var_str ("lhapdf_member"))
	!! !! lhapdf_photon_scheme = &
	!! !! var_list_get_ival (var_list, var_str ("lhapdf_photon_scheme"))
	!! !! do i = 1, 2
	!! !! if (affects_beam(i)) then
	!! !! allocate (sf_data)
	!! !! call sf_data_init_lhapdf (sf_data, i, lhapdf_status, &
	!! !! model, flv(i), &
	!! !! lhapdf_dir, lhapdf_file, lhapdf_member, lhapdf_photon_scheme)
	!! !! call sf_list_append (sf_list, sf_data)
	!! !! end if
	!! !! end do
	!! !! if (all (affects_beam)) then
	!! !! call sf_data_setup_mapping &
	!! !! (sf_data, SFM_PAIR, (/ 0, 1 /), 2._default)
	!! !! end if
	!! !! end subroutine sf_list_register_lhapdf

	@ %def sf_list_register_lhapdf
	<<CCC Commands: procedures>>=
	!! subroutine sf_list_register_pdf_builtin (sf_list, affects_beam, &
	!! pdf_status, model, flv, datapath, var_list)
	!! type(sf_list_t), intent(inout) :: sf_list
	!! logical, dimension(2), intent(in) :: affects_beam
	!! type(pdf_builtin_status_t), intent(inout) :: pdf_status
	!! type(model_t), intent(in), target :: model
	!! type(flavor_t), dimension(2), intent(in) :: flv
	!! type(string_t), intent(in) :: datapath
	!! type(var_list_t), intent(in) :: var_list
	!! logical :: pdf_builtin_have_name
	!! type(string_t) :: pdf_builtin_prefix, pdf_builtin_name
	!! type(sf_data_t), pointer :: sf_data
	!! integer :: i
	!! pdf_builtin_have_name = &
	!! var_list_is_known (var_list, var_str ("$pdf_builtin_set"))
	!! if (pdf_builtin_have_name) &
	!! pdf_builtin_name = &
	!! var_list_get_sval (var_list, var_str ("$pdf_builtin_set"))
	!! pdf_builtin_have_name = trim (pdf_builtin_name) /= ""
	!! pdf_builtin_prefix = ""
	!! if (var_list_is_known (var_list, var_str ("$pdf_builtin_path"))) &
	!! pdf_builtin_prefix = &
	!! var_list_get_sval (var_list, var_str ("$pdf_builtin_path"))
	!! if (trim (pdf_builtin_prefix) == "") pdf_builtin_prefix = datapath
	!! do i = 1, 2
	!! if (affects_beam(i)) then
	!! allocate (sf_data)
	!! if (pdf_builtin_have_name) then
	!! call sf_data_init_pdf_builtin (sf_data, i, &
	!! pdf_status, model, flv(i), &
	!! name=pdf_builtin_name, path=pdf_builtin_prefix)
	!! else
	!! call sf_data_init_pdf_builtin (sf_data, i, &
	!! pdf_status, model, flv(i), &
	!! path=pdf_builtin_prefix)
	!! end if
	!! call sf_list_append (sf_list, sf_data)
	!! end if
	!! end do
	!! if (all (affects_beam)) then
	!! call sf_data_setup_mapping &
	!! (sf_data, SFM_PAIR, (/ 0, 1 /), 2._default)
	!! end if
	!! end subroutine sf_list_register_pdf_builtin

	@ %def sf_list_register_pdf_builtin
	<<CCC Commands: procedures>>=
	!! subroutine sf_list_register_isr (sf_list, affects_beam, &
	!! model, flv, sqrts, var_list)
	!! type(sf_list_t), intent(inout) :: sf_list
	!! logical, dimension(2), intent(in) :: affects_beam
	!! type(model_t), intent(in), target :: model
	!! type(flavor_t), dimension(2), intent(in) :: flv
	!! real(default), intent(in) :: sqrts
	!! type(var_list_t), intent(in) :: var_list
	!! real(default) :: isr_alpha, isr_q_max, isr_mass
	!! integer :: isr_order
	!! logical :: isr_recoil
	!! type(sf_data_t), pointer :: sf_data
	!! integer :: i
	!! isr_alpha = var_list_get_rval (var_list, var_str ("isr_alpha"))
	!! if (isr_alpha == 0) then
	!! isr_alpha = (var_list_get_rval (var_list, var_str ("ee"))) &
	!! ** 2 / (4 * pi)
	!! end if
	!! isr_q_max = var_list_get_rval (var_list, var_str ("isr_q_max"))
	!! if (isr_q_max == 0) then
	!! isr_q_max = sqrts
	!! end if
	!! isr_mass = var_list_get_rval (var_list, var_str ("isr_mass"))
	!! isr_order = var_list_get_ival (var_list, var_str ("isr_order"))
	!! isr_recoil = var_list_get_lval (var_list, var_str ("?isr_recoil"))
	!! do i = 1, 2
	!! if (affects_beam(i)) then
	!! allocate (sf_data)
	!! if (isr_mass /= 0) then
	!! call sf_data_init_isr (sf_data, i, &
	!! model, flv(i), isr_recoil, isr_alpha, isr_q_max, isr_mass, &
	!! order=isr_order)
	!! else
	!! call sf_data_init_isr (sf_data, i, &
	!! model, flv(i), isr_recoil, isr_alpha, isr_q_max, &
	!! order=isr_order)
	!! end if
	!! call sf_list_append (sf_list, sf_data)
	!! end if
	!! end do
	!! ! No pair mapping
	!! end subroutine sf_list_register_isr

	@ %def sf_list_register_isr
	<<CCC Commands: procedures>>=
	!! !! subroutine sf_list_register_epa (sf_list, affects_beam, &
	!! !! model, flv, sqrts, var_list)
	!! !! type(sf_list_t), intent(inout) :: sf_list
	!! !! logical, dimension(2), intent(in) :: affects_beam
	!! !! type(model_t), intent(in), target :: model
	!! !! type(flavor_t), dimension(2), intent(in) :: flv
	!! !! real(default), intent(in) :: sqrts
	!! !! type(var_list_t), intent(in) :: var_list
	!! !! real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_e_max, epa_mass
	!! !! logical :: epa_recoil
	!! !! type(sf_data_t), pointer :: sf_data
	!! !! integer :: i
	!! !! epa_alpha = var_list_get_rval (var_list, var_str ("epa_alpha"))
	!! !! if (epa_alpha == 0) then
	!! !! epa_alpha = (var_list_get_rval (var_list, var_str ("ee"))) &
	!! !! ** 2 / (4 * pi)
	!! !! end if
	!! !! epa_x_min = var_list_get_rval (var_list, var_str ("epa_x_min"))
	!! !! epa_q_min = var_list_get_rval (var_list, var_str ("epa_q_min"))
	!! !! epa_e_max = var_list_get_rval (var_list, var_str ("epa_e_max"))
	!! !! if (epa_e_max == 0) then
	!! !! epa_e_max = sqrts
	!! !! end if
	!! !! epa_mass = var_list_get_rval (var_list, var_str ("epa_mass"))
	!! !! epa_recoil = var_list_get_lval (var_list, var_str ("?epa_recoil"))
	!! !! do i = 1, 2
	!! !! if (affects_beam(i)) then
	!! !! allocate (sf_data)
	!! !! if (epa_mass /= 0) then
	!! !! call sf_data_init_epa (sf_data, i, &
	!! !! model, flv(i), epa_recoil, &
	!! !! epa_alpha, epa_x_min, epa_q_min, epa_e_max, epa_mass)
	!! !! else
	!! !! call sf_data_init_epa (sf_data, i, &
	!! !! model, flv(i), epa_recoil, &
	!! !! epa_alpha, epa_x_min, epa_q_min, epa_e_max)
	!! !! end if
	!! !! call sf_list_append (sf_list, sf_data)
	!! !! end if
	!! !! end do
	!! !! if (all (affects_beam)) then
	!! !! if (epa_recoil) then
	!! !! call sf_data_setup_mapping &
	!! !! (sf_data, SFM_PAIR, (/-2, 1 /), 1._default)
	!! !! else
	!! !! call sf_data_setup_mapping &
	!! !! (sf_data, SFM_PAIR, (/ 0, 1 /), 1._default)
	!! !! end if
	!! !! end if
	!! !! end subroutine sf_list_register_epa

	@ %def sf_list_register_epa
	<<CCC Commands: procedures>>=
	!! !! subroutine sf_list_register_ewa (sf_list, affects_beam, &
	!! !! model, flv, sqrts, var_list)
	!! !! type(sf_list_t), intent(inout) :: sf_list
	!! !! logical, dimension(2), intent(in) :: affects_beam
	!! !! type(model_t), intent(in), target :: model
	!! !! type(flavor_t), dimension(2), intent(in) :: flv
	!! !! real(default), intent(in) :: sqrts
	!! !! type(var_list_t), intent(in) :: var_list
	!! !! real(default) :: ewa_x_min, ewa_q_min, ewa_pt_max, ewa_mass, ewa_sqrts
	!! !! logical :: ewa_keep_momentum, ewa_keep_energy
	!! !! type(sf_data_t), pointer :: sf_data
	!! !! integer :: i
	!! !! do i = 1, 2
	!! !! if (affects_beam(i)) then
	!! !! allocate (sf_data)
	!! !! ewa_x_min = var_list_get_rval (var_list, var_str ("ewa_x_min"))
	!! !! ewa_q_min = var_list_get_rval (var_list, var_str ("ewa_q_min"))
	!! !! ewa_pt_max = var_list_get_rval (var_list, var_str ("ewa_pt_max"))
	!! !! if (ewa_pt_max == 0) then
	!! !! ewa_pt_max = sqrts
	!! !! end if
	!! !! ewa_mass = var_list_get_rval (var_list, var_str ("ewa_mass"))
	!! !! ewa_sqrts = sqrts
	!! !! ewa_keep_momentum = var_list_get_lval (var_list, &
	!! !! var_str ("?ewa_keep_momentum"))
	!! !! ewa_keep_energy = var_list_get_lval (var_list, &
	!! !! var_str ("?ewa_keep_energy"))
	!! !! if (ewa_keep_momentum .and. ewa_keep_energy) &
	!! !! call msg_fatal (" EWA cannot violate both energy " &
	!! !! // "and momentum conservation.")
	!! !! if (ewa_mass /= 0) then
	!! !! call sf_data_init_ewa (sf_data, i, &
	!! !! model, flv(i), &
	!! !! ewa_x_min, ewa_q_min, ewa_pt_max, ewa_sqrts, &
	!! !! ewa_keep_momentum, ewa_keep_energy, ewa_mass)
	!! !! else
	!! !! call sf_data_init_ewa (sf_data, i, &
	!! !! model, flv(i), &
	!! !! ewa_x_min, ewa_q_min, ewa_pt_max, ewa_sqrts, &
	!! !! ewa_keep_momentum, ewa_keep_energy)
	!! !! end if
	!! !! call sf_list_append (sf_list, sf_data)
	!! !! end if
	!! !! end do
	!! !! if (all (affects_beam)) then
	!! !! call sf_data_setup_mapping &
	!! !! (sf_data, SFM_PAIR, (/ 0, 1 /), 1._default)
	!! !! end if
	!! !! end subroutine sf_list_register_ewa

	@ %def sf_list_register_ewa
	<<CCC Commands: procedures>>=
	subroutine sf_list_register_circe1 (sf_list, affects_beam, &
	model, flv, sqrts, rng, var_list)
	type(sf_list_t), intent(inout) :: sf_list
	logical, dimension(2), intent(in) :: affects_beam
	type(model_t), intent(in), target :: model
	type(flavor_t), dimension(2), intent(in) :: flv
	real(default), intent(in) :: sqrts
	type(tao_random_state), intent(in), target :: rng
	type(var_list_t), intent(in) :: var_list
	real(default) :: circe1_sqrts
	logical, dimension(2) :: circe1_photon
	logical :: circe1_generate, circe1_map
	integer :: circe1_ver, circe1_rev, circe1_acc, circe1_chat
	type(sf_data_t), pointer :: sf_data
	if (all (affects_beam)) then
	allocate (sf_data)
	if (var_list_is_known (var_list, var_str ("circe1_sqrts"))) then
	circe1_sqrts = var_list_get_rval (var_list, var_str ("circe1_sqrts"))
	else
	circe1_sqrts = sqrts
	end if
	circe1_photon(1) = &
	var_list_get_lval (var_list, var_str ("?circe1_photon1"))
	circe1_photon(2) = &
	var_list_get_lval (var_list, var_str ("?circe1_photon2"))
	circe1_generate = &
	var_list_get_lval (var_list, var_str ("?circe1_generate"))
	circe1_map = &
	var_list_get_lval (var_list, var_str ("?circe1_map"))
	circe1_ver = &
	var_list_get_ival (var_list, var_str ("circe1_ver"))
	circe1_rev = &
	var_list_get_ival (var_list, var_str ("circe1_rev"))
	circe1_acc = &
	var_list_get_ival (var_list, var_str ("circe1_acc"))
	circe1_chat = &
	var_list_get_ival (var_list, var_str ("circe1_chat"))
	call sf_data_init_circe1 (sf_data, &
	model, flv, circe1_sqrts, circe1_photon, &
	circe1_generate, rng, circe1_map, &
	circe1_ver, circe1_rev, circe1_acc, circe1_chat)
	call sf_list_append (sf_list, sf_data)
	else
	call msg_fatal ("CIRCE1 beamstrahlung spectrum must apply to both beams")
	end if
	! No pair mapping
	end subroutine sf_list_register_circe1

	@ %def sf_list_register_circe1
	<<CCC Commands: procedures>>=
	subroutine sf_list_register_circe2 (sf_list, affects_beam, &
	flv, sqrts, rng, path, var_list)
	type(sf_list_t), intent(inout) :: sf_list
	logical, dimension(2), intent(in) :: affects_beam
	type(flavor_t), dimension(2), intent(in) :: flv
	real(default), intent(in) :: sqrts
	type(tao_random_state), intent(in), target :: rng
	type(string_t), intent(in) :: path
	type(var_list_t), intent(in) :: var_list
	real(default) :: circe2_sqrts
	logical :: circe2_generate, circe2_map, circe2_polarized
	type(string_t) :: circe2_file, circe2_design
	type(sf_data_t), pointer :: sf_data
	if (all (affects_beam)) then
	allocate (sf_data)
	if (var_list_is_known (var_list, var_str ("circe2_sqrts"))) then
	circe2_sqrts = var_list_get_rval (var_list, var_str ("circe2_sqrts"))
	else
	circe2_sqrts = sqrts
	end if
	circe2_generate = &
	var_list_get_lval (var_list, var_str ("?circe2_generate"))
	circe2_map = &
	var_list_get_lval (var_list, var_str ("?circe2_map"))
	circe2_polarized = &
	var_list_get_lval (var_list, var_str ("?circe2_polarized"))
	circe2_file = &
	var_list_get_sval (var_list, var_str ("$circe2_file")) ! $
	if (circe2_file == "") call msg_fatal &
	("CIRCE2: Data file $circe2_file must be specified") ! $
	circe2_file = path // "/" // circe2_file
	circe2_design = &
	var_list_get_sval (var_list, var_str ("$circe2_design")) ! $
	call sf_data_init_circe2 (sf_data, &
	flv, circe2_generate, rng, &
	circe2_map, circe2_file, circe2_design, circe2_sqrts, &
	circe2_polarized)
	call sf_list_append (sf_list, sf_data)
	else
	call msg_fatal ("CIRCE2 spectrum must apply to both beams")
	end if
	! No pair mapping
	end subroutine sf_list_register_circe2

	@ %def sf_list_register_circe2
	<<CCC Commands: procedures>>=
	subroutine sf_list_register_escan (sf_list, affects_beam, &
	flv, sqrts, var_list)
	type(sf_list_t), intent(inout) :: sf_list
	logical, dimension(2), intent(in) :: affects_beam
	type(flavor_t), dimension(2), intent(in) :: flv
	real(default), intent(in) :: sqrts
	type(var_list_t), intent(in) :: var_list
	real(default) :: escan_sqrts
	type(sf_data_t), pointer :: sf_data
	escan_sqrts = sqrts
	allocate (sf_data)
	call sf_data_init_escan (sf_data, affects_beam, flv, escan_sqrts)
	call sf_list_append (sf_list, sf_data)
	! No pair mapping
	end subroutine sf_list_register_escan

	@ %def sf_list_register_escan
	<<CCC Commands: procedures>>=
	subroutine sf_list_register_beam_events (sf_list, affects_beam, &
	flv, path, var_list)
	type(sf_list_t), intent(inout) :: sf_list
	logical, dimension(2), intent(in) :: affects_beam
	type(flavor_t), dimension(2), intent(in) :: flv
	type(string_t), intent(in) :: path
	type(var_list_t), intent(in) :: var_list
	type(sf_data_t), pointer :: sf_data
	type(string_t) :: beam_events_file
	logical :: beam_events_warn_eof
	logical :: exist
	if (all (affects_beam)) then
	allocate (sf_data)
	beam_events_file = &
	var_list_get_sval (var_list, var_str ("$beam_events_file")) ! $
	beam_events_warn_eof = &
	var_list_get_lval (var_list, var_str ("?beam_events_warn_eof"))
	inquire (file = char (beam_events_file), exist = exist)
	if (.not. exist) then
	beam_events_file = path // "/" // beam_events_file
	inquire (file = char (beam_events_file), exist = exist)
	if (.not. exist) then
	call msg_fatal ("Beam simulation data file '" &
	// char (beam_events_file) // "' not found.")
	end if
	end if
	call sf_data_init_beam_events &
	(sf_data, affects_beam, flv, beam_events_file, beam_events_warn_eof)
	call sf_list_append (sf_list, sf_data)
	else
	call msg_fatal ("Beam events simulation must apply to both beams")
	end if
	! No pair mapping
	end subroutine sf_list_register_beam_events

	@ %def sf_list_register_beam_events
	@ For user structure functions, it is not evident whether they apply
	to single beams or to the beam pair, before the data set has been
	initialized. Therefore, we have to shortcut the scan over the two
	beams if we encounter a structure function that applies to the beam
	pair.
	<<CCC Commands: procedures>>=
	subroutine sf_list_register_user (sf_list, affects_beam, &
	model, flv, user_name, var_list)
	type(sf_list_t), intent(inout) :: sf_list
	logical, dimension(2), intent(in) :: affects_beam
	type(model_t), intent(in), target :: model
	type(flavor_t), dimension(2), intent(in) :: flv
	type(string_t), intent(in) :: user_name
	type(var_list_t), intent(in) :: var_list
	type(sf_data_t), pointer :: sf_data
	logical :: user_strfun_mapping
	real(default) :: user_strfun_mapping_power
	integer :: i
	do i = 1, 2
	if (affects_beam(i)) then
	allocate (sf_data)
	call sf_data_init_user (sf_data, i, flv, user_name, model)
	call sf_list_append (sf_list, sf_data)
	if (all (sf_data_affects_beam (sf_data))) then
	if (.not. all (affects_beam)) call msg_fatal &
	("User spectrum/structure function inconsistently applied")
	exit
	end if
	end if
	end do
	user_strfun_mapping = &
	var_list_get_lval (var_list, var_str ("?user_strfun_mapping"))
	user_strfun_mapping_power = &
	var_list_get_rval (var_list, var_str ("user_strfun_mapping_power"))
	if (all (affects_beam) .and. user_strfun_mapping) then
	if (all (sf_data_affects_beam (sf_data))) then
	call sf_data_setup_mapping &
	(sf_data, SFM_PAIR, &
	(/ sf_data_get_n_parameters (sf_data) - 1, &
	sf_data_get_n_parameters (sf_data) /), &
	user_strfun_mapping_power)
	else
	call sf_data_setup_mapping &
	(sf_data, SFM_PAIR, &
	(/ 0, sf_data_get_n_parameters (sf_data) /), &
	user_strfun_mapping_power)
	end if
	end if
	! No pair mapping
	end subroutine sf_list_register_user

	@ %def sf_list_register_beam_events
	@
	<<CCC SF lhapdf: procedures>>=
	!! !! subroutine interaction_apply_lhapdf (int, scale, x, f, s, lhapdf_data)
	!! !! type(interaction_t), intent(inout) :: int
	!! !! real(default), intent(in) :: scale, x, f, s
	!! !! type(lhapdf_data_t), intent(in) :: lhapdf_data
	!! !! double precision :: xx, qq, ss
	!! !! double precision, dimension(-6:6) :: ff
	!! !! double precision :: fphot
	!! !! complex(default), dimension(:), allocatable :: fc
	!! !! external :: evolvePDFM, evolvePDFpM
	!! !! xx = x
	!! !! qq = min (lhapdf_data% qmax, scale)
	!! !! qq = max (lhapdf_data% qmin, qq)
	!! !! if (.not. lhapdf_data% photon) then
	!! !! if (lhapdf_data% invert) then
	!! !! if (lhapdf_data%has_photon) then
	!! !! call evolvePDFphotonM (lhapdf_data% set, xx, qq, ff(6:-6:-1), fphot)
	!! !! else
	!! !! call evolvePDFM (lhapdf_data% set, xx, qq, ff(6:-6:-1))
	!! !! end if
	!! !! else
	!! !! if (lhapdf_data%has_photon) then
	!! !! call evolvePDFphotonM (lhapdf_data% set, xx, qq, ff, fphot)
	!! !! else
	!! !! call evolvePDFM (lhapdf_data% set, xx, qq, ff)
	!! !! end if
	!! !! end if
	!! !! else
	!! !! ss = s
	!! !! call evolvePDFpM (lhapdf_data% set, xx, qq, &
	!! !! ss, lhapdf_data% photon_scheme, ff)
	!! !! end if
	!! !! if (lhapdf_data%has_photon) then
	!! !! allocate (fc (count ((/lhapdf_data%mask, lhapdf_data%mask_photon/))))
	!! !! fc = max (pack ((/ff, fphot/) / x, &
	!! !! (/lhapdf_data% mask, lhapdf_data%mask_photon/)) * f, 0._default)
	!! !! else
	!! !! allocate (fc (count (lhapdf_data%mask)))
	!! !! fc = max (pack (ff / x, lhapdf_data%mask) * f, 0._default)
	!! !! end if
	!! !! call interaction_set_matrix_element (int, fc)
	!! !! end subroutine interaction_apply_lhapdf

	@ %def interaction_apply_lhapdf

	\subsubsection{Beam polarization}
	We define an assortment of containers for the options of the different beam
	polarization constructors.
	<<CCC Commands: types>>=
	type :: bp_circ_data_t
	private
	type(parse_node_t), pointer :: pn_fraction => null ()
	real(default) :: fraction
	end type bp_circ_data_t

	type :: bp_trans_data_t
	private
	type(parse_node_t), pointer :: pn_fraction => null ()
	type(parse_node_t), pointer :: pn_phi => null ()
	real(default) :: fraction, phi
	end type bp_trans_data_t

	type :: bp_long_data_t
	private
	type(parse_node_t), pointer :: pn_fraction => null ()
	real(default) :: fraction
	end type bp_long_data_t

	type :: bp_axis_data_t
	private
	type(parse_node_t), pointer :: pn_fraction => null ()
	type(parse_node_t), pointer :: pn_theta => null ()
	type(parse_node_t), pointer :: pn_phi => null ()
	real(default) :: fraction, theta, phi
	end type bp_axis_data_t

	type :: bp_diag_data_t
	private
	type(parse_node_p), dimension(:), allocatable :: pn_hel
	type(parse_node_p), dimension(:), allocatable :: pn_fraction
	integer, dimension(:), allocatable :: hel
	real(default), dimension(:), allocatable :: fraction
	end type bp_diag_data_t

	type :: bp_density_data_t
	private
	type(parse_node_t), pointer :: pn_d => null ()
	type(parse_node_t), pointer :: pn_nd => null ()
	real(default) :: d
	complex(default) :: nd
	end type bp_density_data_t

	@ %def bp_circ_data_t
	@ %def bp_trans_data_t
	@ %def bp_long_data_t
	@ %def bp_axis_data_t
	@ %def bp_diag_data_t
	@ %def bp_density_data_t
	@ The actual scratch container for the command. A negative [[n]] means the
	structure is invalid, and a negative [[type]] tells the execution subprogram to
	disable beam polarization altogether.
	<<CCC Commands: types>>=
	type :: cmd_beam_polarization_t
	private
	integer :: n = -1
	integer, dimension(2) :: type = -1
	type(bp_circ_data_t), dimension(:), pointer :: circ_data => null ()
	type(bp_trans_data_t), dimension(:), pointer :: trans_data => null ()
	type(bp_long_data_t), dimension(:), pointer :: long_data => null ()
	type(bp_axis_data_t), dimension(:), pointer :: axis_data => null ()
	type(bp_diag_data_t), dimension(:), pointer :: diag_data => null ()
	type(bp_density_data_t), dimension(:), pointer :: &
	density_data => null ()
	type(command_list_t), pointer :: options => null ()
	type(rt_data_t) :: local
	type(beam_polarization_t), dimension(:), pointer :: &
	beam_polarization => null ()
	end type cmd_beam_polarization_t

	@ %def cmd_beam_polarization_t
	@ Finalize the container. We define a separate finalizer for each subcontainer.
	<<CCC Commands: procedures>>=
	elemental subroutine bp_circ_data_final (d)
	type(bp_circ_data_t), intent(inout) :: d
	end subroutine bp_circ_data_final

	elemental subroutine bp_trans_data_final (d)
	type(bp_trans_data_t), intent(inout) :: d
	end subroutine bp_trans_data_final

	elemental subroutine bp_long_data_final (d)
	type(bp_long_data_t), intent(inout) :: d
	end subroutine bp_long_data_final

	elemental subroutine bp_axis_data_final (d)
	type(bp_axis_data_t), intent(inout) :: d
	end subroutine bp_axis_data_final

	elemental subroutine bp_diag_data_final (d)
	type(bp_diag_data_t), intent(inout) :: d
	deallocate (d%pn_hel)
	deallocate (d%pn_fraction)
	if (allocated (d%hel)) deallocate (d%hel)
	if (allocated (d%fraction)) deallocate (d%fraction)
	end subroutine bp_diag_data_final

	elemental subroutine bp_density_data_final (d)
	type(bp_density_data_t), intent(inout) :: d
	end subroutine bp_density_data_final

	subroutine cmd_beam_polarization_final (bp)
	type(cmd_beam_polarization_t), intent(inout) :: bp
	if (associated (bp%circ_data)) then
	call bp_circ_data_final (bp%circ_data)
	deallocate (bp%circ_data)
	end if
	if (associated (bp%trans_data)) then
	call bp_trans_data_final (bp%trans_data)
	deallocate (bp%trans_data)
	end if
	if (associated (bp%long_data)) then
	call bp_long_data_final (bp%long_data)
	deallocate (bp%long_data)
	end if
	if (associated (bp%axis_data)) then
	call bp_axis_data_final (bp%axis_data)
	deallocate (bp%axis_data)
	end if
	if (associated (bp%diag_data)) then
	call bp_diag_data_final (bp%diag_data)
	deallocate (bp%diag_data)
	end if
	if (associated (bp%density_data)) then
	call bp_density_data_final (bp%density_data)
	deallocate (bp%density_data)
	end if
	if (associated (bp%options)) then
	call command_list_final (bp%options)
	deallocate (bp%options)
	end if
	if (associated (bp%beam_polarization)) deallocate (bp%beam_polarization)
	bp%type = -1
	bp%n = -1
	end subroutine cmd_beam_polarization_final

	@ %def bp_circ_data_final
	@ %def bp_trans_data_final
	@ %def bp_long_data_final
	@ %def bp_axis_data_final
	@ %def bp_diag_data_final
	@ %def bp_density_data_final
	@ %def cmd_beam_polarization_final
	@ Compile.
	<<CCC Commands: procedures>>=
	subroutine cmd_beam_polarization_compile (bp, pn, global)
	type(cmd_beam_polarization_t), pointer, intent(inout) :: bp
	type(parse_node_t), intent(in), target :: pn
	type(rt_data_t), intent(in), target :: global
	type(parse_node_t), pointer :: pn_list, pn_opts, pn_args, pn_entry
	integer :: i, n
	pn_list => parse_node_get_sub_ptr (pn, 3)
	pn_opts => parse_node_get_sub_ptr (pn, 4)
	allocate (bp)
	call rt_data_local_init (bp%local, global)
	if (associated (pn_opts)) then
	allocate (bp%options)
	call command_list_compile (bp%options, pn_opts, bp%local)
	end if
	if (parse_node_get_rule_key (pn_list) == "off") then
	bp%n = 0
	bp%type = -1
	return
	end if
	bp%n = parse_node_get_n_sub (pn_list)
	pn_list => parse_node_get_sub_ptr (pn_list)
	do i = 1, bp%n
	pn_args => parse_node_get_sub_ptr (pn_list, 2)
	select case (char (parse_node_get_rule_key (pn_list)))
	case ("none")
	bp%type(i) = BP_NONE
	case ("bp_circ")
	if (parse_node_get_n_sub (pn_args) /= 1) then
	call cmd_beam_polarization_final (bp)
	call msg_fatal &
	("syntax error: expecting 'circular (fraction)'")
	return
	end if
	bp%type(i) = BP_CIRC
	if (.not. associated (bp%circ_data)) &
	allocate (bp%circ_data(2))
	bp%circ_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1)
	case ("bp_trans")
	if (parse_node_get_n_sub (pn_args) /= 2) then
	call cmd_beam_polarization_final (bp)
	call msg_fatal &
	("syntax error: expecting transverse (fraction, phi)'")
	return
	end if
	bp%type(i) = BP_TRANS
	if (.not. associated (bp%trans_data)) &
	allocate (bp%trans_data(2))
	bp%trans_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1)
	bp%trans_data(i)%pn_phi => parse_node_get_sub_ptr (pn_args, 2)
	case ("bp_axis")
	if (parse_node_get_n_sub (pn_args) /= 3) then
	call cmd_beam_polarization_final (bp)
	call msg_fatal &
	("syntax error: expecting 'axis (fraction, theta, phi)'")
	return
	end if
	bp%type(i) = BP_AXIS
	if (.not. associated (bp%axis_data)) &
	allocate (bp%axis_data(2))
	bp%axis_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1)
	bp%axis_data(i)%pn_theta => parse_node_get_sub_ptr (pn_args, 2)
	bp%axis_data(i)%pn_phi => parse_node_get_sub_ptr (pn_args, 3)
	case ("bp_long")
	if (parse_node_get_n_sub (pn_args) /= 1) then
	call cmd_beam_polarization_final (bp)
	call msg_fatal &
	("syntax error: expecting 'longitudinal (fraction)'")
	return
	end if
	bp%type(i) = BP_LONG
	if (.not. associated (bp%long_data)) &
	allocate (bp%long_data(2))
	bp%long_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1)
	case ("bp_dens")
	if (parse_node_get_n_sub (pn_args) /= 2) then
	call cmd_beam_polarization_final (bp)
	call msg_fatal &
	("syntax error: expecting 'density_matrix (a, b)'")
	return
	end if
	bp%type(i) = BP_DENSITY
	if (.not. associated (bp%density_data)) &
	allocate (bp%density_data (2))
	bp%density_data(i)%pn_d => parse_node_get_sub_ptr (pn_args, 1)
	bp%density_data(i)%pn_nd => parse_node_get_sub_ptr (pn_args, 2)
	case ("bp_diag")
	bp%type(i) = BP_DIAG
	n = parse_node_get_n_sub (pn_args)
	if (.not. associated (bp%diag_data)) &
	allocate (bp%diag_data(2))
	allocate (bp%diag_data(i)%pn_hel (n))
	allocate (bp%diag_data(i)%pn_fraction (n))
	allocate (bp%diag_data(i)%hel (n))
	allocate (bp%diag_data(i)%fraction (n))
	pn_entry => parse_node_get_sub_ptr (pn_args)
	n = 1
	do while (associated (pn_entry))
	bp%diag_data(i)%pn_hel(n)%ptr &
	=> parse_node_get_sub_ptr (pn_entry, 1)
	bp%diag_data(i)%pn_fraction(n)%ptr &
	=> parse_node_get_sub_ptr (pn_entry, 3)
	pn_entry => parse_node_get_next_ptr (pn_entry)
	n = n + 1
	end do
	case default
	call msg_bug ("cmd_beam_polarization_compile: invalid " &
	// "polarization type")
	end select
	pn_list => parse_node_get_next_ptr (pn_list)
	end do

	call rt_data_local_reset (bp%local)
	end subroutine cmd_beam_polarization_compile

	@ %def cmd_beam_polarization_compile
	@ Execute.
	<<CCC Commands: procedures>>=
	subroutine cmd_beam_polarization_execute (bp, global)
	type(cmd_beam_polarization_t), pointer, intent(inout) :: bp
	type(rt_data_t), intent(inout), target :: global
	type(polarization_t), dimension(:), allocatable :: pol
	integer :: i, j, k, ulog
	ulog = logfile_unit ()
	call rt_data_link (bp%local, global)
	if (associated (bp%options)) &
	call command_list_execute (bp%options, bp%local)
	if (bp%n < 0) then
	call rt_data_restore (global, bp%local)
	return
	end if
	if (bp%type(1) < 0) then
	call rt_data_restore (global, bp%local)
	global%beam_polarization => null ()
	if (beam_data_are_valid (global%beam_data)) &
	call beam_data_kill_polarization (global%beam_data)
	if (global%environment /= CMD_BEAMS) call msg_message &
	("beam polarization disabled")
	return
	end if
	if (.not. associated (bp%beam_polarization)) then
	allocate (bp%beam_polarization(bp%n))
	else
	do i = 1, bp%n
	call beam_polarization_final (bp%beam_polarization(i))
	end do
	end if
	do i = 1, bp%n
	select case (bp%type(i))
	case (BP_NONE, BP_TRIVIAL)
	if (bp%n == 2) then
	call beam_polarization_init_none (bp%beam_polarization(i))
	else
	call beam_polarization_init_trivial (bp%beam_polarization(i))
	end if
	case (BP_CIRC)
	bp%circ_data(i)%fraction = &
	eval_real (bp%circ_data(i)%pn_fraction, bp%local%var_list)
	call beam_polarization_init_circ (bp%beam_polarization(i), &
	bp%circ_data(i)%fraction)
	case (BP_TRANS)
	bp%trans_data(i)%fraction = &
	eval_real (bp%trans_data(i)%pn_fraction, bp%local%var_list)
	bp%trans_data(i)%phi = &
	eval_real (bp%trans_data(i)%pn_phi, bp%local%var_list)
	call beam_polarization_init_trans (bp%beam_polarization(i), &
	bp%trans_data(i)%fraction, bp%trans_data(i)%phi)
	case (BP_LONG)
	bp%long_data(i)%fraction = &
	eval_real (bp%long_data(i)%pn_fraction, bp%local%var_list)
	call beam_polarization_init_long (bp%beam_polarization(i), &
	bp%long_data(i)%fraction)
	case (BP_AXIS)
	bp%axis_data(i)%fraction = &
	eval_real (bp%axis_data(i)%pn_fraction, bp%local%var_list)
	bp%axis_data(i)%theta = &
	eval_real (bp%axis_data(i)%pn_theta, bp%local%var_list)
	bp%axis_data(i)%phi = &
	eval_real (bp%axis_data(i)%pn_phi, bp%local%var_list)
	call beam_polarization_init_axis (bp%beam_polarization(i), &
	bp%axis_data(i)%fraction, bp%axis_data(i)%theta, &
	bp%axis_data(i)%phi)
	case (BP_DENSITY)
	bp%density_data(i)%d = &
	eval_real (bp%density_data(i)%pn_d, bp%local%var_list)
	bp%density_data(i)%nd = &
	eval_cmplx (bp%density_data(i)%pn_nd, bp%local%var_list)
	call beam_polarization_init_density (bp%beam_polarization (i), &
	bp%density_data(i)%d, bp%density_data(i)%nd)
	case (BP_DIAG)
	do j = 1, size (bp%diag_data(i)%hel)
	bp%diag_data(i)%hel(j) = &
	eval_int (bp%diag_data(i)%pn_hel(j)%ptr, bp%local%var_list)
	bp%diag_data(i)%fraction(j) = &
	eval_real (bp%diag_data(i)%pn_fraction(j)%ptr, &
	bp%local%var_list)
	if (j > 1) then
	do k = 1, j - 1
	if (bp%diag_data(i)%hel(j) == bp%diag_data(i)%hel(k)) then
	call msg_error ( &
	"'diagonal_density (h1:f1 [, h2:f2, ...])': " &
	// "h" // int2char(j) // " and h" // int2char (k) &
	// " must not be equal")
	call rt_data_restore (global, bp%local)
	return
	end if
	end do
	end if
	end do
	call beam_polarization_init_diag (bp%beam_polarization(i), &
	bp%diag_data(i)%hel, bp%diag_data(i)%fraction)
	case default
	call msg_bug ("cmd_beam_polarization_execute: " &
	// "unknown polarization type")
	end select
	if (global%environment /= CMD_BEAMS) then
	call msg_message &
	("polarization of incoming particle " // int2char (i) // ":")
	call beam_polarization_write (bp%beam_polarization(i))
	call beam_polarization_write (bp%beam_polarization(i), ulog)
	end if
	end do

	call rt_data_restore (global, bp%local)
	global%beam_polarization => bp%beam_polarization
	if (beam_data_are_valid (global%beam_data)) then
	if (beam_data_get_n_in (global%beam_data) /= bp%n) then
	call msg_error ("the number of incoming particles differs " &
	// "between beam and polarization setup - ignoring polarization")
	else
	allocate (pol (bp%n))
	do i = 1, bp%n
	pol(i) = beam_polarization2polarization &
	(bp%beam_polarization(i), global%beam_data%flv(i), &
	decay=(bp%n == 1))
	end do
	call beam_data_set_polarization (global%beam_data, pol)
	end if
	else
	if (global%environment /= CMD_BEAMS) call msg_warning ( &
	"beam_polarization only works with a beam setup")
	end if

	end subroutine cmd_beam_polarization_execute

	@ %def cmd_beam_polarization_execute
	@
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Beam polarization}
	Beam polarization is encapsulated in a designated type und only converted into
	a density matrix when the beams are actually initialized --- the flavor
	information necessary for initialization is not available
	earlier.
	<<[[beam_polarizations.f90]]>>=
	<<File header>>

	module beam_polarizations

	<<Use kinds>>
	<<Use strings>>
	<<Use file utils>>
	use diagnostics !NODEP!
	use flavors
	use polarizations

	<<Standard module head>>

	<<Beam polarizations: public>>

	<<Beam polarizations: parameters>>

	<<Beam polarizations: types>>

	contains

	<<Beam polarizations: procedures>>

	end module beam_polarizations
	@ %def beam_polarizations
	@
	\subsection{Parameters and type definition}
	<<Beam polarizations: public>>=
	public :: BP_NONE, BP_CIRC, BP_TRANS, BP_LONG, BP_AXIS, BP_DIAG, BP_DENSITY
	public :: BP_TRIVIAL
	public :: beam_polarization_t
	<<Beam polarizations: parameters>>=
	integer, parameter :: &
	BP_NONE = 0, BP_CIRC = 1, BP_TRANS = 2, BP_LONG = 3, BP_AXIS = 4, &
	BP_DIAG = 5, BP_DENSITY = 6, BP_TRIVIAL = 7
	<<Beam polarizations: types>>=
	type :: beam_polarization_t
	private
	integer :: type = BP_NONE
	real(default) :: fraction
	real(default) :: theta
	real(default) :: phi
	real(default) :: d
	complex(default) :: nd
	integer, dimension(:), allocatable :: hels
	real(default), dimension(:), allocatable :: fractions
	end type beam_polarization_t

	@ %def BP_NONE BP_CIRC BP_TRANS BP_LONG BP_AXIS BP_DIAG BP_DENSITY BP_TRIVIAL
	@ %def beam_polarization_t
	@
	\subsection{Constructors}
	The type is filled by dedicated constructors:
	<<Beam polarizations: public>>=
	public :: beam_polarization_init_none
	public :: beam_polarization_init_trivial
	public :: beam_polarization_init_circ
	public :: beam_polarization_init_trans
	public :: beam_polarization_init_long
	public :: beam_polarization_init_axis
	public :: beam_polarization_init_diag
	public :: beam_polarization_init_density
	public :: beam_polarization_final
	<<Beam polarizations: procedures>>=
	subroutine beam_polarization_init_none (bp)
	type(beam_polarization_t), intent(inout) :: bp
	bp%type = BP_NONE
	end subroutine beam_polarization_init_none

	subroutine beam_polarization_init_trivial (bp)
	type(beam_polarization_t), intent(inout) :: bp
	bp%type = BP_TRIVIAL
	end subroutine beam_polarization_init_trivial

	subroutine beam_polarization_init_circ (bp, fraction)
	type(beam_polarization_t), intent(inout) :: bp
	real(default), intent(in) :: fraction
	bp%type = BP_CIRC
	bp%fraction = fraction
	end subroutine beam_polarization_init_circ

	subroutine beam_polarization_init_trans (bp, fraction, phi)
	type(beam_polarization_t), intent(inout) :: bp
	real(default), intent(in) :: fraction, phi
	bp%type = BP_TRANS
	bp%fraction = fraction
	bp%phi = phi
	end subroutine beam_polarization_init_trans

	subroutine beam_polarization_init_long (bp, fraction)
	type(beam_polarization_t), intent(inout) :: bp
	real(default), intent(in) :: fraction
	bp%type = BP_LONG
	bp%fraction = fraction
	end subroutine beam_polarization_init_long

	subroutine beam_polarization_init_axis (bp, fraction, theta, phi)
	type(beam_polarization_t), intent(inout) :: bp
	real(default), intent(in) :: fraction, theta, phi
	bp%type = BP_AXIS
	bp%fraction = fraction
	bp%theta = theta
	bp%phi = phi
	end subroutine beam_polarization_init_axis

	subroutine beam_polarization_init_diag (bp, hels, fracs)
	type(beam_polarization_t), intent(inout) :: bp
	integer, dimension(:), intent(in) :: hels
	real(default), dimension(:), intent(in) :: fracs
	bp%type = BP_DIAG
	allocate (bp%hels(size (hels)))
	allocate (bp%fractions(size (fracs)))
	bp%hels = hels
	bp%fractions = fracs
	end subroutine beam_polarization_init_diag

	subroutine beam_polarization_init_density (bp, d, nd)
	type(beam_polarization_t), intent(inout) :: bp
	real(default), intent(in) :: d
	complex(default), intent(in) :: nd
	bp%type = BP_DENSITY
	bp%d = d
	bp%nd = nd
	end subroutine beam_polarization_init_density

	subroutine beam_polarization_final (bp)
	type(beam_polarization_t), intent(inout) :: bp
	if (allocated (bp%hels)) deallocate (bp%hels)
	if (allocated (bp%fractions)) deallocate (bp%fractions)
	end subroutine beam_polarization_final

	@ %def beam_polarization_init_none
	@ %def beam_polarization_init_trivial
	@ %def beam_polarization_init_circ
	@ %def beam_polarization_init_trans
	@ %def beam_polarization_init_long
	@ %def beam_polarization_init_axis
	@ %def beam_polarization_init_diag
	@ %def beam_polarization_init_density
	@ %def beam_polarization_final
	@
	\subsection{Tools}
	Together with the necessary flavor information, [[beam_polarization_t]] can
	can be promoted to [[polarization_t]]
	<<Beam polarizations: public>>=
	public :: beam_polarization2polarization
	<<Beam polarizations: procedures>>=
	function beam_polarization2polarization (bp, flv, decay) result (pol)
	type(beam_polarization_t), intent(in) :: bp
	type(flavor_t), intent(in) :: flv
	logical, optional, intent(in) :: decay
	type(polarization_t) :: pol
	logical :: fail
	real(default), dimension(:), allocatable :: frac_vector
	integer :: i, j, mult
	type(string_t) :: msg
	if (flavor_get_multiplicity (flv) == 1) then
	select case (bp%type)
	case (BP_NONE, BP_TRIVIAL)
	case default
	if (flavor_is_left_handed (flv)) then
	msg = "left-handed"
	elseif (flavor_is_right_handed (flv)) then
	msg = "right-handed"
	else
	msg = "scalar"
	end if
	call msg_error (char (msg) // " particle '" &
	// char (flavor_get_name (flv)) &
	// "' cannot be polarized - ignoring polarization")
	call emergency_unpolarized
	return
	end select
	end if
	select case (bp%type)
	case (BP_NONE)
	call polarization_init_unpolarized (pol, flv)
	case (BP_TRIVIAL)
	call polarization_init_trivial (pol, flv)
	case (BP_CIRC)
	if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then
	call polarization_init_circular (pol, flv, bp%fraction)
	else
	call msg_error ( &
	"circular polarization: 'fraction' must be within [-1; 1] - " &
	// "ignoring polarization")
	call emergency_unpolarized
	end if
	case (BP_TRANS)
	if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then
	call polarization_init_transversal (pol, flv, bp%phi, bp%fraction)
	else
	call msg_error ( &
	"transverse polarization: 'fraction' must be within [-1; 1] - " &
	// "ignoring polarization")
	call emergency_unpolarized
	end if
	case (BP_LONG)
	if ((bp%fraction > 1) .or. (bp%fraction < 0)) then
	call msg_error ( &
	"longitudinal polarization: 'fraction' must be within [0; 1]" &
	// " - ignoring polarization");
	call emergency_unpolarized
	elseif (mod (flavor_get_multiplicity (flv), 2) == 0) then
	call msg_error ( &
	"longitudinal polarization is only available for massive " &
	// " bosons - ignoring polarization")
	call emergency_unpolarized
	else
	call polarization_init_longitudinal (pol, flv, bp%fraction)
	end if
	case (BP_AXIS)
	if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then
	call polarization_init_angles (pol, flv, bp%fraction, bp%theta, &
	bp%phi)
	else
	call msg_error ( &
	"axial polarization: 'fraction' must be within [-1; 1] - " &
	// "ignoring polarization")
	call emergency_unpolarized
	end if
	case (BP_DENSITY)
	if ((bp%d <= 1) .and. (bp%d >= 0) .and. (abs (bp%nd) <= 0.5)) then
	call polarization_init_axis (pol, flv, &
	(/real (bp%nd, default), (-1.) * aimag (bp%nd), 2. * bp%d - 1./))
	else
	call msg_error ( &
	"density matrix polarization: 'a' must be within [0; 1], \|b\| " &
	// "within [0; 0.5] - ignoring polarization")
	call emergency_unpolarized
	end if
	case (BP_DIAG)
	fail = .false.
	mult = flavor_get_multiplicity (flv)
	allocate (frac_vector (mult))
	frac_vector = 0
	if (minval (bp%fractions) < 0) then
	call msg_error ( &
	"diagonal polarization: negative fractions are not allowed " &
	// "- ignoring polarization")
	fail = .true.
	else
	select case (mult)
	case (1)
	call msg_bug (&
	"beam_polarizeation2polarization: invalid multiplicity")
	case (2)
	if ((size (bp%hels) <= 2) .and. all (abs (bp%hels) == 1)) then
	frac_vector = 0
	do i = 1, size(bp%hels)
	frac_vector((bp%hels(i) + 1) / 2 + 1) = bp%fractions(i)
	end do
	else
	call msg_error ( &
	"diagonal polarization: the only admissible helicities " &
	// "for particle '" // char (flavor_get_name (flv)) &
	// "' are" // " -1 and 1 - ignoring polarization")
	fail = .true.
	end if
	case default
	if (maxval (abs (bp%hels)) <= mult / 2) then
	if (mod (mult, 2) == 0) then
	if (minval (abs (bp%hels)) == 0) then
	call msg_error ( &
	"diagonal polarization: helicity 0 not allowed " &
	// "for particle '" // char (flavor_get_name (flv)) &
	// "' - ignoring polarization")
	fail = .true.
	else
	do i = 1, size (bp%hels)
	if (bp%hels(i) < 0) then
	j = bp%hels(i) + mult / 2 + 1
	else
	j = bp%hels(i) + mult / 2
	end if
	frac_vector(j) = bp%fractions(i)
	end do
	end if
	else
	do i = 1, size (bp%hels)
	j = bp%hels(i) + mult / 2 + 1
	frac_vector(j) = bp%fractions(i)
	end do
	end if
	else
	call msg_error ( &
	"diagonal polarization: helicity exceeds admissible " &
	// "range for particle '" // char (flavor_get_name (flv)) &
	// "' - ignoring polarization")
	fail = .true.
	end if
	end select
	end if
	if (fail) then
	call emergency_unpolarized
	else
	if (sum (frac_vector) /= 1) &
	call msg_warning ( &
	"diagonal polarization: fractions will be normalized to 1")
	call polarization_init_diagonal (pol, flv, frac_vector)
	end if
	deallocate (frac_vector)
	end select

	contains

	subroutine emergency_unpolarized
	logical :: is_decay
	if (present (decay)) then
	is_decay = decay
	else
	is_decay = .false.
	end if
	if (is_decay) then
	call polarization_init_trivial (pol, flv)
	else
	call polarization_init_unpolarized (pol, flv)
	end if
	end subroutine emergency_unpolarized

	end function beam_polarization2polarization

	@ %def beam_polarization2polarization
	@ Writing.
	<<Beam polarizations: public>>=
	public :: beam_polarization_write
	<<Beam polarizations: procedures>>=
	subroutine beam_polarization_write (bp, unit, indent)
	type(beam_polarization_t), intent(in) :: bp
	integer, intent(in), optional :: unit, indent
	integer :: u, i
	type(string_t), dimension(:), allocatable :: msgs
	type(string_t) :: header, is
	u = output_unit (unit)
	if (u < 0) return
	select case (bp%type)
	case (BP_NONE, BP_TRIVIAL)
	call printer ("none")
	case (BP_CIRC)
	call printer ("circular (fraction):")
	call printer (" fraction: " // real2char (bp%fraction))
	case (BP_TRANS)
	call printer ("transverse (fraction, phi):")
	call printer (" fraction: " // real2char (bp%fraction))
	call printer (" phi : " // real2char (bp%phi))
	case (BP_AXIS)
	call printer ("axis (fraction, theta, phi):")
	call printer (" fraction: " // real2char (bp%fraction))
	call printer (" theta : " // real2char (bp%theta))
	call printer (" phi : " // real2char (bp%phi))
	case (BP_LONG)
	call printer ("longitudinal (fraction):")
	call printer (" fraction: " // real2char (bp%fraction))
	case (BP_DENSITY)
	call printer ("density_matrix (a, b):")
	call printer (" a: " // real2char (bp%d))
	call printer (" b: " // char (cmplx2string (bp%nd)))
	case (BP_DIAG)
	allocate (msgs(size (bp%fractions)))
	header = "diagonal_density ("
	do i = 1, size (msgs)
	is = int2string (i)
	if (i > 1) header = header // ", "
	header = header // "h" // is // ":f" // is
	msgs (i) = "h" // is // ": " // int2string (bp%hels(i)) &
	// " , f" // is // ": " // real2string (bp%fractions(i))
	end do
	call printer (char (header) // ")")
	do i = 1, size (msgs)
	call printer (" " // char (msgs(i)))
	end do
	deallocate (msgs)
	case default
	call msg_bug ("beam_polarization_write: illegal polarization type")
	end select
	flush (u)

	contains

	subroutine printer (s)
	character(*), intent(in) :: s
	if (present (indent)) write (u, '(A)', advance="no") &
	repeat (" ", indent)
	write (u, '(1x,A)') s
	end subroutine printer

	end subroutine beam_polarization_write

	@ %def beam_polarization_write

File Metadata

Mime Type: text/x-tex
Expires: Wed, May 14, 11:50 AM (2 h, 4 m)
Storage Engine: local-disk
Storage Format: Raw Data
Storage Handle: 46/28/745e8d6de9d6bd9f93b0679166c2
Default Alt Text: whizard.attic.nw (1 MB)

whizard.attic.nwNo OneTemporaryActions

whizard.attic.nwView Options

File Metadata

Event Timeline

whizard.attic.nw
No OneTemporary
Actions

whizard.attic.nw
View Options