No OneTemporary
Actions

Size

473 KB

Subscribers

None

View Options

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

	Index: trunk/src/whizard-core/whizard.attic.nw
	===================================================================
	--- trunk/src/whizard-core/whizard.attic.nw (revision 4080)
	+++ trunk/src/whizard-core/whizard.attic.nw (revision 4081)
	@@ -1,3372 +1,12156 @@
	% -- 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{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
	+

File Metadata

Mime Type: text/x-diff
Expires: Tue, Nov 19, 3:38 PM (1 d, 19 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 3804991
Default Alt Text: (473 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions